solve.clp

clips源代码

   (color-pair ?color1 ?color2)
   
   =>

   (assert (position-value-color (row ?r2)
                                 (column ?c)
                                 (group ?g)
                                 (id ?id)
                                 (value ?v)
                                 (color ?color2))))

;;; *********************
;;; propagate-color-group
;;; *********************

(defrule propagate-color-group

   (phase match)
   
   (priority ?p)

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

   (position-value-color (column ?c1) (row ?r1) (group ?g) (id ?id1) (value ?v) (color ?color1))
                                    
   (possible (column ?c2) (row ?r2) (group ?g) (id ?id2&~?id1) (value ?v))
      
   (not (position-value-color (column ?c2) (row ?r2) (value ?v)))

   (not (possible (group ?g) (id ?id3&~?id2&~?id1) (value ?v)))
   
   (color-pair ?color1 ?color2)
   
   =>

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

;;; ###############
;;; Duplicate-Color
;;; ###############

;;; **********************
;;; duplicate-color-in-row
;;; **********************

(defrule duplicate-color-in-row

   (priority ?p)

   (technique (name Duplicate-Color) (priority ?p))

   (position-value-color (row ?r)
                         (column ?c1)
                         (id ?id1)
                         (value ?v)
                         (color ?color))
                                    
   (position-value-color (row ?r)
                         (column ?c2&~?c1)
                         (id ?id2)
                         (value ?v)
                         (color ?color))

   =>
   
   (assert (impossible (id ?id1) (value ?v) (priority ?p) (reason "Duplicate Color")))
   
   (assert (impossible (id ?id2) (value ?v) (priority ?p) (reason "Duplicate Color"))))
   
;;; *************************
;;; duplicate-color-in-column
;;; *************************

(defrule duplicate-color-in-column

   (priority ?p)

   (technique (name Duplicate-Color) (priority ?p))

   (position-value-color (row ?r1)
                         (column ?c)
                         (id ?id1)
                         (value ?v)
                         (color ?color))
                                    
   (position-value-color (row ?r2&~?r1)
                         (column ?c)
                         (id ?id2)
                         (value ?v)
                         (color ?color))

   =>
   
   (assert (impossible (id ?id1) (value ?v) (priority ?p) (reason "Duplicate Color")))
   
   (assert (impossible (id ?id2) (value ?v) (priority ?p) (reason "Duplicate Color"))))
   
;;; ************************
;;; duplicate-color-in-group
;;; ************************

(defrule duplicate-color-in-group

   (priority ?p)

   (technique (name Duplicate-Color) (priority ?p))

   (position-value-color (group ?g)
                         (id ?id1)
                         (value ?v)
                         (color ?color))
                                    
   (position-value-color (group ?g)
                         (id ?id2&~?id1)
                         (value ?v)
                         (color ?color))

   =>
   
   (assert (impossible (id ?id1) (value ?v) (priority ?p) (reason "Duplicate Color")))
   
   (assert (impossible (id ?id2) (value ?v) (priority ?p) (reason "Duplicate Color"))))

;;; ####################
;;; Color-Conjugate-Pair
;;; ####################

;;; ********************
;;; color-conjugate-pair
;;; ********************

(defrule color-conjugate-pair

   (priority ?p)

   (technique (name Color-Conjugate-Pair) (priority ?p))

   (color-pair ?color1 ?color2) 

   (position-value-color (row ?r)
                         (column ?pc)
                         (value ?v)
                         (id ?id1)
                         (color ?color1))
                                    
   (position-value-color (column ?c)
                         (row ?pr)
                         (value ?v)
                         (id ?id2&~?id1)
                         (color ?color2))
                         
   (possible (row ?r) (column ?c) (id ?id&~?id2&~?id1) (value ?v))
                        
   =>
      
   (assert (impossible (id ?id) (value ?v) (priority ?p) (reason "Color Conjugate Pairs"))))
   
;;; ##################
;;; Multi-Color-Type-1
;;; ##################
   
(defrule multi-color-type-1

   (priority ?p)

   (technique (name Multi-Color-Type-1) (priority ?p))

   (color-pair ?color1 ?color2) 
   
   (position-value-color (row ?r1)
                         (column ?c1)
                         (group ?g1)
                         (id ?id1)
                         (value ?v)
                         (color ?color1))
                                    
   (position-value-color (row ?r2)
                         (column ?c2)
                         (group ?g2)
                         (id ~?id1)
                         (value ?v)
                         (color ?color2))
                         
   (color-pair ?other-color&~?color1 ~?color1) 
       
   (position-value-color (row ?r3)
                         (column ?c3)
                         (group ?g3)
                         (value ?v)
                         (color ?other-color))
   
   (test (or (= ?r1 ?r3) (= ?c1 ?c3) (= ?g1 ?g3)))
   
   (position-value-color (row ?r4)
                         (column ?c4)
                         (group ?g4)
                         (value ?v)
                         (color ?other-color))
                         
   (test (or (= ?r2 ?r4) (= ?c2 ?c4) (= ?g2 ?g4)))
   
   (position-value-color (id ?id)
                         (value ?v)
                         (color ?other-color))
   
   =>

   (assert (impossible (id ?id) (value ?v) (priority ?p) (reason "Multi Color Type 1"))))
 
;;; ##################
;;; Multi-Color-Type-2
;;; ##################
   
(defrule multi-color-type-2

   (priority ?p)

   (technique (name Multi-Color-Type-2) (priority ?p))

   (color-pair ?color1 ?color2) 
   
   (position-value-color (row ?r1)
                         (column ?c1)
                         (group ?g1)
                         (value ?v)
                         (color ?color1))

   (color-pair ?other-color1&~?color1 ?other-color2&~?color1) 
       
   (position-value-color (row ?r2)
                         (column ?c2)
                         (group ?g2)
                         (value ?v)
                         (color ?other-color1))
   
   (test (or (= ?r1 ?r2) (= ?c1 ?c2) (= ?g1 ?g2)))
   
   (position-value-color (row ?r3)
                         (column ?c3)
                         (group ?g3)
                         (id ?id3)
                         (value ?v)
                         (color ?color2))

   (position-value-color (row ?r4)
                         (column ?c4)
                         (group ?g4)
                         (id ?id4)
                         (value ?v)
                         (color ?other-color2))

   (possible (row ?r5) (column ?c5) (id ?id&~?id3&~?id4) (group ?g5) (value ?v))

   (test (and (or (= ?r3 ?r5) (= ?c3 ?c5) (= ?g3 ?g5))
              (or (= ?r4 ?r5) (= ?c4 ?c5) (= ?g4 ?g5))))
   
   =>
   
   (assert (impossible (id ?id) (value ?v) (priority ?p) (reason "Multi Color Type 2"))))

;;; #############
;;; Forced Chains
;;; #############

;;; ***********
;;; start-chain
;;; ***********

(defrule start-chain

   (declare (salience -10))

   (priority ?p)

   (technique (name Forced-Chain-Convergence | Forced-Chain-XY) (priority ?p))

   (possible (row ?r) (column ?c) (group ?g) (id ?id) (value ?v1))
   
   (possible (id ?id) (value ?v2&~?v1))
   
   (not (possible (id ?id) (value ~?v1&~?v2)))
   
   =>
   
   (assert (chain (start-row ?r)
                  (start-column ?c)
                  (start-value ?v1)
                  (row ?r)
                  (column ?c)
                  (group ?g)
                  (id ?id)
                  (value ?v1)))
                  
   (assert (chain (start-row ?r)
                  (start-column ?c)
                  (start-value ?v2)
                  (row ?r)
                  (column ?c)
                  (group ?g)
                  (id ?id)
                  (value ?v2))))  

;;; ******************
;;; continue-chain-row
;;; ******************

(defrule continue-chain-row

   (declare (salience -10))

   (priority ?p)

   (technique (name Forced-Chain-Convergence | Forced-Chain-XY) (priority ?p))

   ?f <- (chain (row ?r) (column ?c1) (value ?v1))
          
   (possible (row ?r) (column ?c2&~?c1) (value ?v1))
   
   (possible (row ?r) (column ?c2) (group ?g) (id ?id) (value ?v2&~?v1))
   
   (not (possible (row ?r) (column ?c2) (value ?v3&~?v2&~?v1)))
                 
   =>
   
   (duplicate ?f (column ?c2)
                 (group ?g)
                 (id ?id)
                 (value ?v2)))

;;; *********************
;;; continue-chain-column
;;; *********************

(defrule continue-chain-column

   (declare (salience -10))

   (priority ?p)

   (technique (name Forced-Chain-Convergence | Forced-Chain-XY) (priority ?p))

   ?f <- (chain (row ?r1) (column ?c) (value ?v1))
          
   (possible (row ?r2&~?r1) (column ?c) (value ?v1))
   
   (possible (row ?r2) (column ?c) (group ?g) (id ?id) (value ?v2&~?v1))
   
   (not (possible (row ?r2) (column ?c) (value ?v3&~?v2&~?v1)))
                 
   =>
   
   (duplicate ?f (row ?r2)
                 (group ?g)
                 (id ?id)
                 (value ?v2)))

;;; ********************
;;; continue-chain-group
;;; ********************

(defrule continue-chain-group

   (declare (salience -10))

   (priority ?p)

   (technique (name Forced-Chain-Convergence | Forced-Chain-XY) (priority ?p))

   ?f <- (chain (group ?g) (id ?id1) (value ?v1))
          
   (possible (row ?r) (column ?c) (group ?g) (id ?id2&~?id1) (value ?v1))
   
   (possible (id ?id2) (value ?v2&~?v1))
   
   (not (possible (id ?id2) (value ?v3&~?v2&~?v1)))
                 
   =>
   
   (duplicate ?f (row ?r)
                 (column ?c)
                 (id ?id2)
                 (value ?v2)))

;;; ************************
;;; forced-chain-convergence
;;; ************************

(defrule forced-chain-convergence

   (priority ?p)

   (technique (name Forced-Chain-Convergence) (priority ?p))

   (chain (start-row ?r1)
          (start-column ?c1)
          (start-value ?v1)
          (row ?r2)
          (column ?c2)
          (value ?v2))
          
   (chain (start-row ?r1)
          (start-column ?c1)
          (start-value ~?v1)
          (row ?r2)
          (column ?c2)
          (value ?v2))
                 
   (possible (row ?r2) (column ?c2) (id ?id) (value ?v3&~?v2))

   =>
   
   (assert (impossible (id ?id) (value ?v3) (priority ?p) (reason "Forced Chain Convergence"))))

;;; ***************
;;; forced-chain-XY
;;; ***************

(defrule forced-chain-XY

   (priority ?p)

   (technique (name Forced-Chain-XY) (priority ?p))

   (chain (start-row ?r1) (start-column ?c1) (start-value ?v1)
          (row ?r1) (column ?c1) (value ?v1) (id ?id1) (group ?g1))
          
   (chain (start-row ?r1) (start-column ?c1) (start-value ?v2&~?v1)
          (row ?r1) (column ?c1) (value ?v2))
          
   (chain (start-row ?r1) (start-column ?c1) (start-value ?v2)
          (row ?r2) (column ?c2) (group ?g2) (id ?id2&~?id1) (value ?v1))
       
   (possible (row ?r3)
             (column ?c3)
             (id ?id&~?id2&~?id1)
             (group ?g3)
             (value ?v1))
                   
   (test (and (or (= ?g1 ?g3) (= ?r1 ?r3) (= ?c1 ?c3))
              (or (= ?g2 ?g3) (= ?r2 ?r3) (= ?c2 ?c3))))

   =>
   
   (assert (impossible (id ?id) (value ?v1) (priority ?p) (reason "Forced Chain XY"))))
   
;;; ################
;;; Unique-Rectangle
;;; ################

;;; ********************
;;; Unique-Rectangle-Row
;;; ********************

(defrule Unique-Rectangle-Row
   
   (priority ?p)

   (technique (name Unique-Rectangle) (priority ?p))
   
   (possible (value ?v1) (group ?g1) (row ?r1) (column ?c1))

   (possible (value ?v2&~?v1) (group ?g1) (row ?r1) (column ?c1))

   (not (possible (value ~?v2&~?v1) (row ?r1) (column ?c1)))
   
   (possible (value ?v1) (group ?g1) (row ?r1) (column ?c2&~?c1))

   (possible (value ?v2&~?v1) (group ?g1) (row ?r1) (column ?c2&~?c1))

   (not (possible (value ~?v2&~?v1) (row ?r1) (column ?c2)))
   
   (possible (value ?v1) (group ?g2&~?g1) (row ?r2) (column ?c1))

   (possible (value ?v2) (group ?g2) (row ?r2) (column ?c1))
   
   (not (possible (value ~?v2&~?v1) (group ?g2) (row ?r2) (column ?c1)))  
   
   (possible (value ?v1) (id ?id1) (group ?g2) (row ?r2) (column ?c2))

   (possible (value ?v2) (id ?id2) (group ?g2) (row ?r2) (column ?c2))
   
   (possible (value ~?v2&~?v1) (group ?g2) (row ?r2) (column ?c2)) 
   
   =>
   
   (assert (impossible (id ?id1) (value ?v1) (priority ?p) (reason "Unique Rectangle")))

   (assert (impossible (id ?id2) (value ?v2) (priority ?p) (reason "Unique Rectangle"))))
   
;;; ***********************
;;; Unique-Rectangle-Column
;;; ***********************

(defrule Unique-Rectangle-Column
   
   (priority ?p)

   (technique (name Unique-Rectangle) (priority ?p))
   
   (possible (value ?v1) (group ?g1) (row ?r1) (column ?c1))

   (possible (value ?v2&~?v1) (group ?g1) (row ?r1) (column ?c1))

   (not (possible (value ~?v2&~?v1) (row ?r1) (column ?c1)))
   
   (possible (value ?v1) (group ?g1) (row ?r2&~?r1) (column ?c1))

   (possible (value ?v2&~?v1) (group ?g1) (row ?r2&~?r1) (column ?c1))

   (not (possible (value ~?v2&~?v1) (row ?r2) (column ?c1)))
   
   (possible (value ?v1) (group ?g2&~?g1) (row ?r1) (column ?c2))

   (possible (value ?v2) (group ?g2) (row ?r1) (column ?c2))
   
   (not (possible (value ~?v2&~?v1) (group ?g2) (row ?r1) (column ?c2)))  
   
   (possible (value ?v1) (id ?id1) (group ?g2) (row ?r2) (column ?c2))

   (possible (value ?v2) (id ?id2) (group ?g2) (row ?r2) (column ?c2))
   
   (possible (value ~?v2&~?v1) (group ?g2) (row ?r2) (column ?c2)) 
   
   =>
   
   (assert (impossible (id ?id1) (value ?v1) (priority ?p) (reason "Unique Rectangle")))

   (assert (impossible (id ?id2) (value ?v2) (priority ?p) (reason "Unique Rectangle"))))