solve.clp

clips源代码

;;; Version 1.1
;;;
;;; Added Unique Rectangles

;;; #######################
;;; DEFTEMPLATES & DEFFACTS
;;; #######################

(deffacts techniques
   (technique (name Naked-Single) (priority 1))
   (technique (name Hidden-Single) (priority 2))
   (technique (name Locked-Candidate-Single-Line) (priority 3))
   (technique (name Locked-Candidate-Multiple-Lines) (priority 4))
   (technique (name Naked-Pairs) (priority 5))
   (technique (name Hidden-Pairs) (priority 6))
   (technique (name X-Wing) (priority 7))
   (technique (name Naked-Triples) (priority 8))
   (technique (name Hidden-Triples) (priority 9))
   (technique (name XY-Wing) (priority 10))
   (technique (name Swordfish) (priority 11))
   (technique (name Duplicate-Color) (priority 12))
   (technique (name Color-Conjugate-Pair) (priority 13))
   (technique (name Multi-Color-Type-1) (priority 14))
   (technique (name Multi-Color-Type-2) (priority 15))
   (technique (name Forced-Chain-Convergence) (priority 16))
   (technique (name Forced-Chain-XY) (priority 17))
   (technique (name Unique-Rectangle) (priority 18)))

(deffacts color-pairs
   (color-pair green magenta)
   (color-pair magenta green)
   (color-pair orange azure)
   (color-pair azure orange)
   (color-pair violet chartruese)
   (color-pair chartruese violet)
   (color-pair aquamarine fuchsia)   
   (color-pair fuchsia aquamarine)   
   (color-pair yellow blue)
   (color-pair blue yellow)
   (color-pair red cyan)
   (color-pair cyan red))

(deftemplate position-value-color
   (slot row)
   (slot column)
   (slot group)
   (slot id)
   (slot value)
   (slot color))

(deftemplate chain
   (slot start-row)
   (slot start-column)
   (slot start-value)
   (slot row)
   (slot column)
   (slot group)
   (slot id)
   (slot value))
   
;;; #################
;;; ELIMINATION RULES
;;; #################

;;; *************
;;; remove-colors
;;; *************

(defrule remove-colors

   (declare (salience 20))

   (phase elimination)
   
   ?f <- (position-value-color)

   =>
   
   (retract ?f))

;;; *************
;;; remove-chains
;;; *************

(defrule remove-chains

   (declare (salience 20))

   (phase elimination)
   
   ?f <- (chain)

   =>
   
   (retract ?f))
 
;;; *********
;;; eliminate
;;; *********

(defrule eliminate

   (declare (salience 10))

   (phase elimination)
   
   ?f1 <- (impossible (id ?id) (value ?v) (priority ?p) (reason ?r))
   
   (not (impossible (id ?id2&:(< ?id2 ?id))))
   
   (not (impossible (id ?id) (value ?v2&:(< ?v2 ?v))))
   
   (not (impossible (id ?id) (value ?v) (priority ?p2&:(< ?p2 ?p))))
   
   ?f2 <- (possible (id ?id) (value ?v))

   =>
   
   (retract ?f1 ?f2)
   
   (assert (technique-employed (priority ?p) (reason ?r))))
      
;;; ************
;;; remove-extra
;;; ************

(defrule remove-extra

   (declare (salience 10))
   
   (phase elimination)
   
   ?f <- (impossible (id ?id) (value ?v))
   
   (not (possible (id ?id) (value ?v)))
   
   =>
   
   (retract ?f))
   
;;; ****************
;;; elimination-done
;;; ****************

(defrule elimination-done

   (declare (salience 10))
   
   ?f <- (phase elimination)
   
   (not (impossible))
   
   =>
   
   (retract ?f)
   
   (assert (phase match)))

;;; ###############
;;; TECHNIQUE RULES
;;; ###############

;;; #############
;;; Naked Singles
;;; #############

;;; ******************
;;; naked-single-group
;;; ******************

(defrule naked-single-group
   
   (priority ?p)

   (technique (name Naked-Single) (priority ?p))
   
   (possible (value ?v) (group ?g) (id ?id))
   
   (not (possible (value ~?v) (group ?g) (id ?id)))
   
   (possible (value ?v) (group ?g) (id ?id2&~?id))
   
   =>
   
   (assert (impossible (id ?id2) (value ?v) (priority ?p) (reason "Naked Single"))))
   
;;; ****************
;;; naked-single-row
;;; ****************

(defrule naked-single-row
   
   (priority ?p)

   (technique (name Naked-Single) (priority ?p))
   
   (possible (value ?v) (row ?r) (id ?id))
   
   (not (possible (value ~?v) (row ?r) (id ?id)))
   
   (possible (value ?v) (row ?r) (id ?id2&~?id))
   
   =>
   
   (assert (impossible (id ?id2) (value ?v) (priority ?p) (reason "Naked Single"))))
   
;;; *******************
;;; naked-single-column
;;; *******************

(defrule naked-single-column
   
   (priority ?p)

   (technique (name Naked-Single) (priority ?p))
   
   (possible (value ?v) (column ?c) (id ?id))
   
   (not (possible (value ~?v) (column ?c) (id ?id)))
   
   (possible (value ?v) (column ?c) (id ?id2&~?id))
   
   =>
   
   (assert (impossible (id ?id2) (value ?v) (priority ?p) (reason "Naked Single"))))

;;; ##############
;;; Hidden Singles
;;; ##############
   
;;; *******************
;;; hidden-single-group
;;; *******************

(defrule hidden-single-group
   
   (priority ?p)

   (technique (name Hidden-Single) (priority ?p))
   
   (possible (value ?v) (group ?g) (id ?id))
   
   (not (possible (value ?v) (group ?g) (id ~?id)))
   
   (possible (value ?v2&~?v) (group ?g) (id ?id))
   
   =>
   
   (assert (impossible (id ?id) (value ?v2) (priority ?p) (reason "Hidden Single"))))
   
;;; *****************
;;; hidden-single-row
;;; *****************

(defrule hidden-single-row
   
   (priority ?p)

   (technique (name Hidden-Single) (priority ?p))
   
   (possible (value ?v) (row ?r) (id ?id))
   
   (not (possible (value ?v) (row ?r) (id ~?id)))
   
   (possible (value ?v2&~?v) (row ?r) (id ?id))
   
   =>
   
   (assert (impossible (id ?id) (value ?v2) (priority ?p) (reason "Hidden Single"))))
   
;;; ********************
;;; hidden-single-column
;;; ********************

(defrule hidden-single-column
   
   (priority ?p)

   (technique (name Hidden-Single) (priority ?p))
   
   (possible (value ?v) (column ?c) (id ?id))
   
   (not (possible (value ?v) (column ?c) (id ~?id)))
   
   (possible (value ?v2&~?v) (column ?c) (id ?id))
   
   =>
   
   (assert (impossible (id ?id) (value ?v2) (priority ?p) (reason "Hidden Single"))))

;;; ############################
;;; Locked Candidate Single Line
;;; ############################

;;; ********************************
;;; locked-candidate-single-line-row
;;; ********************************

(defrule locked-candidate-single-line-row
   
   (priority ?p)

   (technique (name Locked-Candidate-Single-Line) (priority ?p))
   
   (possible (value ?v) (row ?r) (group ?g))
   
   (not (possible (value ?v) (row ~?r) (group ?g)))
   
   (possible (value ?v) (row ?r) (group ~?g) (id ?id))
   
   =>
   
   (assert (impossible (id ?id) (value ?v) (priority ?p) (reason "Locked Candidate Single Line"))))

;;; ***********************************
;;; locked-candidate-single-line-column
;;; ***********************************

(defrule locked-candidate-single-line-column
   
   (priority ?p)

   (technique (name Locked-Candidate-Single-Line) (priority ?p))
   
   (possible (value ?v) (column ?c) (group ?g))
   
   (not (possible (value ?v) (column ~?c) (group ?g)))
   
   (possible (value ?v) (column ?c) (group ~?g) (id ?id))
   
   =>
   
   (assert (impossible (id ?id) (value ?v) (priority ?p) (reason "Locked Candidate Single Line"))))

;;; ###############################
;;; Locked Candidate Multiple Lines
;;; ###############################

;;; ***********************************
;;; locked-candidate-multiple-lines-row
;;; ***********************************

(defrule locked-candidates-multiple-lines-row

   (priority ?p)

   (technique (name Locked-Candidate-Multiple-Lines) (priority ?p))
   
   (possible (value ?v) (row ?r) (group ?g))
   
   (not (possible (value ?v) (row ?r) (group ~?g)))
   
   (possible (value ?v) (row ~?r) (group ?g) (id ?id))
   
   =>
   
   (assert (impossible (id ?id) (value ?v) (priority ?p) (reason "Locked Candidate Multiple Lines"))))

;;; **************************************
;;; locked-candidate-multiple-lines-column
;;; **************************************

(defrule locked-candidate-multiple-lines-column

   (priority ?p)

   (technique (name Locked-Candidate-Multiple-Lines) (priority ?p))
   
   (possible (value ?v) (column ?c) (group ?g))
   
   (not (possible (value ?v) (column ?c) (group ~?g)))
   
   (possible (value ?v) (column ~?c) (group ?g) (id ?id))
   
   =>
   
   (assert (impossible (id ?id) (value ?v) (priority ?p) (reason "Locked Candidate Multiple Lines"))))


;;; ###########
;;; Naked Pairs
;;; ###########

;;; ***************
;;; naked-pairs-row
;;; ***************

(defrule naked-pairs-row

   (priority ?p)

   (technique (name Naked-Pairs) (priority ?p))
   
   (possible (value ?v1) (row ?r) (column ?c1))
   
   (possible (value ?v2&~?v1) (row ?r) (column ?c1))
   
   (not (possible (value ~?v2&~?v1) (row ?r) (column ?c1)))
   
   (possible (value ?v1) (row ?r) (column ?c2&~?c1))
   
   (possible (value ?v2) (row ?r) (column ?c2))
   
   (not (possible (value ~?v2&~?v1) (row ?r) (column ?c2)))

   (possible (value ?v& ?v1 | ?v2) (row ?r) (column ~?c1&~?c2) (id ?id))

   =>
   
   (assert (impossible (id ?id) (value ?v) (priority ?p) (reason "Naked Pairs"))))

;;; ******************
;;; naked-pairs-column
;;; ******************

(defrule naked-pairs-column

   (priority ?p)

   (technique (name Naked-Pairs) (priority ?p))

   (possible (value ?v1) (row ?r1) (column ?c))
   
   (possible (value ?v2&~?v1) (row ?r1) (column ?c))
   
   (not (possible (value ~?v2&~?v1) (row ?r1) (column ?c)))
   
   (possible (value ?v1) (row ?r2&~?r1) (column ?c))
   
   (possible (value ?v2) (row ?r2) (column ?c))
   
   (not (possible (value ~?v2&~?v1) (row ?r2) (column ?c)))

   (possible (value ?v& ?v1 | ?v2) (row ~?r1&~?r2) (column ?c) (id ?id))

   =>
   
   (assert (impossible (id ?id) (value ?v) (priority ?p) (reason "Naked Pairs"))))

;;; *****************
;;; naked-pairs-group
;;; *****************

(defrule naked-pairs-group

   (priority ?p)

   (technique (name Naked-Pairs) (priority ?p))

   (possible (value ?v1) (group ?g) (id ?id1))
   
   (possible (value ?v2&~?v1) (id ?id1))
   
   (not (possible (value ~?v2&~?v1) (id ?id1)))
   
   (possible (value ?v1) (group ?g) (id ?id2&~?id1))
   
   (possible (value ?v2) (id ?id2))
   
   (not (possible (value ~?v2&~?v1) (id ?id2)))

   (possible (value ?v& ?v1 | ?v2) (group ?g) (id ?id&~?id2&~?id1))

   =>
   
   (assert (impossible (id ?id) (value ?v) (priority ?p) (reason "Naked Pairs"))))

;;; ############
;;; Hidden Pairs
;;; ############

;;; ****************
;;; hidden-pairs-row
;;; ****************

(defrule hidden-pairs-row

   (priority ?p)

   (technique (name Hidden-Pairs) (priority ?p))
   
   (possible (value ?v1) (row ?r) (column ?c1))
   
   (possible (value ?v2&~?v1) (row ?r) (column ?c1))
      
   (possible (value ?v1) (row ?r) (column ?c2&~?c1))
   
   (possible (value ?v2) (row ?r) (column ?c2))
   
   (not (possible (value ?v1 | ?v2) (row ?r) (column ?c3&~?c2&~?c1)))

   (possible (value ?v&~?v1&~?v2) (row ?r) (column ?c1 | ?c2) (id ?id))

   =>
   
   (assert (impossible (id ?id) (value ?v) (priority ?p) (reason "Hidden Pairs"))))

;;; *******************
;;; hidden-pairs-column
;;; *******************

(defrule hidden-pairs-column

   (priority ?p)

   (technique (name Hidden-Pairs) (priority ?p))
   
   (possible (value ?v1) (row ?r1) (column ?c))
   
   (possible (value ?v2&~?v1) (row ?r1) (column ?c))
      
   (possible (value ?v1) (row ?r2&~?r1) (column ?c))
   
   (possible (value ?v2) (row ?r2) (column ?c))
   
   (not (possible (value ?v1 | ?v2) (row ?r3&~?r2&~?r1) (column ?c)))

   (possible (value ?v&~?v1&~?v2) (row ?r1 | ?r2) (column ?c) (id ?id))

   =>
   
   (assert (impossible (id ?id) (value ?v) (priority ?p) (reason "Hidden Pairs"))))


;;; ******************
;;; hidden-pairs-group
;;; ******************

(defrule hidden-pairs-group

   (priority ?p)

   (technique (name Hidden-Pairs) (priority ?p))
   
   (possible (value ?v1) (group ?g) (id ?id1))
   
   (possible (value ?v2&~?v1) (id ?id1))