solve.clp

clips源代码

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

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

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


;;; ######
;;; X Wing
;;; ######

;;; **********
;;; X-Wing-Row
;;; **********

(defrule X-Wing-Row
   
   (priority ?p)

   (technique (name X-Wing) (priority ?p))
   
   (possible (value ?v) (row ?r1) (column ?c1))
   
   (possible (value ?v) (row ?r1) (column ?c2&~?c1))
   
   (not (possible (value ?v) (row ?r1) (column ~?c1&~?c2)))
   
   (possible (value ?v) (row ?r2&~?r1) (column ?c1))
   
   (possible (value ?v) (row ?r2) (column ?c2))
   
   (not (possible (value ?v) (row ?r2) (column ~?c1&~?c2)))
   
   (possible (value ?v) (row ~?r1&~?r2) (column ?c1 | ?c2) (id ?id))
   
   =>
   
   (assert (impossible (id ?id) (value ?v) (priority ?p) (reason "X Wing"))))

;;; *************
;;; X-Wing-Column
;;; *************

(defrule X-Wing-Column
   
   (priority ?p)

   (technique (name X-Wing) (priority ?p))
   
   (possible (value ?v) (row ?r1) (column ?c1))
   
   (possible (value ?v) (row ?r2&~?r1) (column ?c1))
   
   (not (possible (value ?v) (row ~?r1&~?r2) (column ?c1)))
   
   (possible (value ?v) (row ?r1) (column ?c2&~?c1))
   
   (possible (value ?v) (row ?r2) (column ?c2))
   
   (not (possible (value ?v) (row ~?r1&~?r2) (column ?c2)))
   
   (possible (value ?v) (row ?r1 | ?r2) (column ~?c1&~?c2) (id ?id))
   
   =>
   
   (assert (impossible (id ?id) (value ?v) (priority ?p) (reason "X Wing"))))

;;; #############
;;; Naked Triples
;;; #############

;;; ****************
;;; generate-triples
;;; ****************

(defrule generate-triples
   
   (declare (salience 10))
   
   (priority ?p)

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

   (size ?s)
   
   (size-value (size ?sv1&:(<= ?sv1 ?s)) (value ?v1))
 
   (size-value (size ?sv2&:(<= ?sv2 ?s)) (value ?v2&:(> ?v2 ?v1)))

   (size-value (size ?sv3&:(<= ?sv3 ?s)) (value ?v3&:(> ?v3 ?v2)))

   =>
   
   (assert (triple ?v1 ?v2 ?v3)))

;;; *****************
;;; naked-triples-row
;;; *****************

(defrule naked-triples-row

   (priority ?p)

   (technique (name Naked-Triples) (priority ?p))
   
   (triple ?v1 ?v2 ?v3)
   
   (possible (value ?v1) (row ?r) (id ?id1))
   
   (not (possible (value ~?v1&~?v2&~?v3) (id ?id1)))
   
   (possible (value ?v2) (row ?r) (id ?id2&~?id1))

   (not (possible (value ~?v1&~?v2&~?v3) (id ?id2)))
   
   (possible (value ?v3) (row ?r) (id ?id3&~?id2&~?id1))
   
   (not (possible (value ~?v1&~?v2&~?v3) (id ?id3)))
   
   (possible (value ?v& ?v1 | ?v2 | ?v3) (row ?r) (id ?id&~?id1&~?id2&~?id3))

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

;;; ********************
;;; naked-triples-column
;;; ********************

(defrule naked-triples-column

   (priority ?p)

   (technique (name Naked-Triples) (priority ?p))
   
   (triple ?v1 ?v2 ?v3)
   
   (possible (value ?v1) (column ?c) (id ?id1))
   
   (not (possible (value ~?v1&~?v2&~?v3) (id ?id1)))
   
   (possible (value ?v2) (column ?c) (id ?id2&~?id1))

   (not (possible (value ~?v1&~?v2&~?v3) (id ?id2)))
   
   (possible (value ?v3) (column ?c) (id ?id3&~?id2&~?id1))
   
   (not (possible (value ~?v1&~?v2&~?v3) (id ?id3)))
   
   (possible (value ?v& ?v1 | ?v2 | ?v3) (column ?c) (id ?id&~?id1&~?id2&~?id3))

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

;;; *******************
;;; naked-triples-group
;;; *******************

(defrule naked-triples-group

   (priority ?p)

   (technique (name Naked-Triples) (priority ?p))
   
   (triple ?v1 ?v2 ?v3)
   
   (possible (value ?v1) (group ?g) (id ?id1))
   
   (not (possible (value ~?v1&~?v2&~?v3) (id ?id1)))
   
   (possible (value ?v2) (group ?g) (id ?id2&~?id1))

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

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

;;; ##############
;;; Hidden Triples
;;; ##############

;;; ******************
;;; hidden-triples-row
;;; ******************

(defrule hidden-triples-row

   (priority ?p)

   (technique (name Hidden-Triples) (priority ?p))
   
   (triple ?v1 ?v2 ?v3)
   
   (possible (value ?v1) (row ?r) (column ?c1))
   
   (possible (value ?v2) (row ?r) (column ?c2&~?c1))
   
   (possible (value ?v3) (row ?r) (column ?c3&~?c2&~?c1))
   
   (not (possible (value ?v1 | ?v2 | ?v3) (row ?r) (column ~?c3&~?c2&~?c1)))
   
   (possible (value ?v&~?v1&~?v2&~?v3) (row ?r) (column ?c1 | ?c2 | ?c3) (id ?id))

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

;;; *********************
;;; hidden-triples-column
;;; *********************

(defrule hidden-triples-column

   (priority ?p)

   (technique (name Hidden-Triples) (priority ?p))
   
   (triple ?v1 ?v2 ?v3)
   
   (possible (value ?v1) (row ?r1) (column ?c))
   
   (possible (value ?v2) (row ?r2&~?r1) (column ?c))
   
   (possible (value ?v3) (row ?r3&~?r2&~?r1) (column ?c))
   
   (not (possible (value ?v1 | ?v2 | ?v3) (row ~?r3&~?r2&~?r1) (column ?c)))
   
   (possible (value ?v&~?v1&~?v2&~?v3) (row ?r1 | ?r2 | ?r3) (column ?c) (id ?id))

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

;;; ********************
;;; hidden-triples-group
;;; ********************

(defrule hidden-triples-group

   (priority ?p)

   (technique (name Hidden-Triples) (priority ?p))
   
   (triple ?v1 ?v2 ?v3)
   
   (possible (value ?v1) (id ?id1) (group ?g))
   
   (possible (value ?v2) (id ?id2&~?id1) (group ?g))
   
   (possible (value ?v3) (id ?id3&~?id2&~?id1) (group ?g))
   
   (not (possible (value ?v1 | ?v2 | ?v3) (id ~?id3&~?id2&~?id1) (group ?g)))
   
   (possible (value ?v&~?v1&~?v2&~?v3) (id ?id& ?id1 | ?id2 | ?id3))

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

;;; #########
;;; Swordfish
;;; #########

;;; *************
;;; swordfish-row
;;; *************

(defrule swordfish-row

   (priority ?p)

   (technique (name Swordfish) (priority ?p))
   
   (triple ?c1 ?c2 ?c3)
   
   (possible (value ?v) (row ?r1) (column ?c1))
   
   (not (possible (value ?v) (row ?r1) (column ~?c1&~?c2&~?c3)))
   
   (possible (value ?v) (row ?r2&~?r1) (column ?c2))

   (not (possible (value ?v) (row ?r2) (column ~?c1&~?c2&~?c3)))
   
   (possible (value ?v) (row ?r3&~?r2&~?r1) (column ?c3))

   (not (possible (value ?v) (row ?r3) (column ~?c1&~?c2&~?c3)))
   
   (possible (value ?v) (row ~?r1&~?r2&~?r3) (column ?c1 | ?c2 | ?c3) (id ?id))

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

;;; ****************
;;; swordfish-column
;;; ****************

(defrule swordfish-column

   (priority ?p)

   (technique (name Swordfish) (priority ?p))
   
   (triple ?r1 ?r2 ?r3)
   
   (possible (value ?v) (row ?r1) (column ?c1))
   
   (not (possible (value ?v) (row ~?r1&~?r2&~?r3) (column ?c1)))
   
   (possible (value ?v) (row ?r2) (column ?c2&~?c1))

   (not (possible (value ?v) (row ~?r1&~?r2&~?r3) (column ?c2)))
   
   (possible (value ?v) (row ?r3) (column ?c3&~?c2&~?c1))

   (not (possible (value ?v) (row ~?r1&~?r2&~?r3) (column ?c3)))
   
   (possible (value ?v) (row ?r1 | ?r2 | ?r3) (column ~?c1&~?c2&~?c3) (id ?id))

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

;;; #######
;;; XY-Wing
;;; #######

;;; *******
;;; XY-Wing
;;; *******
 
(defrule XY-Wing

   (priority ?p)

   (technique (name XY-Wing) (priority ?p))
   
   (possible (value ?x) (row ?r1) (column ?c1) (group ?g1) (id ?id1))
   
   (possible (value ?y&~?x) (id ?id1))
   
   (not (possible (value ~?y&~?x) (id ?id1)))
   
   (possible (value ?x) (row ?r2) (column ?c2) (group ?g2) (id ?id2&~?id1))
   
   (possible (value ?z&~?x) (id ?id2))
   
   (not (possible (value ~?z&~?x) (id ?id2)))
               
   (test (or (= ?r1 ?r2) (= ?c1 ?c2) (= ?g1 ?g2)))

   (possible (value ?y) (row ?r3) (column ?c3) (group ?g3) (id ?id3&~?id2&~?id1))
   
   (possible (value ?z&~?y) (id ?id3))
   
   (not (possible (value ~?z&~?y) (id ?id3)))
             
   (test (or (= ?r1 ?r3) (= ?c1 ?c3) (= ?g1 ?g3)))
                            
   (possible (value ?z) (row ?r4) (column ?c4) (group ?g4) (id ?id&~?id3&~?id2&~?id1))

   (test (and (or (= ?r2 ?r4) (= ?c2 ?c4) (= ?g2 ?g4))
              (or (= ?r3 ?r4) (= ?c3 ?c4) (= ?g3 ?g4))))
   =>
   
   (assert (impossible (id ?id) (value ?z) (priority ?p) (reason "XY-Wing"))))

;;; ######
;;; Colors
;;; ######

;;; *********
;;; color-row
;;; *********

(defrule color-row

   (declare (salience -10))
   
   (phase match)
   
   (priority ?p)

   (technique (name Duplicate-Color | Color-Conjugate-Pair | Multi-Color-Type-1  | Multi-Color-Type-2) 
              (priority ?p))

   (possible (row ?r) (column ?c1) (group ?g1) (id ?id1) (value ?v))

   (possible (row ?r) (column ?c2&~?c1) (group ?g2) (id ?id2) (value ?v))
   
   (not (possible (row ?r) (column ?c3&~?c2&~?c1) (value ?v)))
                     
   (color-pair ?color1 ?color2)
   
   ;; Don't use a color previously used for this value.

   (not (position-value-color (value ?v)
                              (color ?color1 | color2)))
   
   ;; Don't try to color the position if it's already colored. 
   
   (not (position-value-color (row ?r)
                              (column ?c1 | ?c2)
                              (value ?v)))

   =>
   
   (assert (position-value-color (row ?r)
                                 (column ?c1)
                                 (group ?g1)
                                 (id ?id1)
                                 (value ?v)
                                 (color ?color1)))
                  
   (assert (position-value-color (row ?r)
                                 (column ?c2)
                                 (group ?g2)
                                 (id ?id2)
                                 (value ?v)
                                 (color ?color2))))

;;; ************
;;; color-column
;;; ************

(defrule color-column

   (declare (salience -10))
   
   (phase match)
   
   (priority ?p)

   (technique (name Duplicate-Color | Color-Conjugate-Pair | Multi-Color-Type-1 | Multi-Color-Type-2) 
              (priority ?p))

   (possible (row ?r1) (column ?c) (group ?g1) (id ?id1) (value ?v))

   (possible (row ?r2&~?r1) (column ?c) (group ?g2) (id ?id2) (value ?v))
   
   (not (possible (row ?r3&~?r2&~?r1) (column ?c) (value ?v)))
                     
   (color-pair ?color1 ?color2)
   
   ;; Don't use a color previously used for this value.

   (not (position-value-color (value ?v)
                              (color ?color1 | color2)))
   
   ;; Don't try to color the position if it's already colored. 
   
   (not (position-value-color (row ?r1 | ?r2)
                              (column ?c)
                              (value ?v)))

   =>
   
   (assert (position-value-color (row ?r1)
                                 (column ?c)
                                 (group ?g1)
                                 (id ?id1)
                                 (value ?v)
                                 (color ?color1)))
                  
   (assert (position-value-color (row ?r2)
                                 (column ?c)
                                 (group ?g2)
                                 (id ?id2)
                                 (value ?v)
                                 (color ?color2))))

;;; *******************
;;; propagate-color-row
;;; *******************

(defrule propagate-color-row

   (phase match)

   (priority ?p)

   (technique (name Duplicate-Color | Color-Conjugate-Pair | Multi-Color-Type-1 | Multi-Color-Type-2) 
              (priority ?p))

   (position-value-color (row ?r) (column ?c1) (value ?v) (color ?color1))
                                    
   (possible (row ?r) (column ?c2&~?c1) (group ?g) (id ?id) (value ?v))
      
   (not (position-value-color (row ?r) (column ?c2) (value ?v)))
                              
   (not (possible (row ?r) (column ?c3&~?c2&~?c1) (value ?v)))
                               
   (color-pair ?color1 ?color2)
   
   =>

   (assert (position-value-color (row ?r)
                                 (column ?c2)
                                 (group ?g)
                                 (id ?id)
                                 (value ?v)
                                 (color ?color2))))

;;; **********************
;;; propagate-color-column
;;; **********************

(defrule propagate-color-column

   (phase match)

   (priority ?p)

   (technique (name Duplicate-Color | Color-Conjugate-Pair | Multi-Color-Type-1 | Multi-Color-Type-2) 
              (priority ?p))

   (position-value-color (row ?r1) (column ?c) (value ?v) (color ?color1))
                                    
   (possible (row ?r2&~?r1) (column ?c) (group ?g) (id ?id) (value ?v))
      
   (not (position-value-color (row ?r2) (column ?c) (value ?v)))
                              
   (not (possible (row ?r3&~?r2&~?r1) (column ?c) (value ?v)))