some

csp/aima.rkt

@@ -0,0 +1,171 @@
+#lang debug racket
+
+(struct $csp (variables domains neighbors constraints initial curr_domains nassigns) #:transparent #:mutable)
+
+(define/contract (make-csp variables domains neighbors constraints)
+  ((listof symbol?) hash? hash? procedure? . -> . $csp?)
+  ($csp
+   variables
+   domains
+   neighbors
+   constraints
+   null
+   #f
+   0))
+
+(define/contract (assign csp var val assignment)
+  ($csp? symbol? any/c hash? . -> . void?)
+  ;; Add {var: val} to assignment; Discard the old value if any.
+  (hash-set! assignment var val)
+  (set-$csp-nassigns! csp (add1 ($csp-nassigns csp))))
+
+(define/contract (unassign csp var assignment)
+  ($csp? symbol? hash? . -> . void?)
+  ;; Remove {var: val} from assignment.
+  ;; DO NOT call this if you are changing a variable to a new value;
+  ;; just call assign for that.
+  (hash-remove! assignment var))
+
+(define/contract (nconflicts csp var val assignment)
+  ($csp? symbol? any/c hash? . -> . number?)
+  ;; Return the number of conflicts var=val has with other variables."""
+  ;; Subclasses may implement this more efficiently
+  (define (conflict var2)
+    (and (hash-has-key? assignment var2)
+         (not (($csp-constraints csp) var val var2 (hash-ref assignment var2)))))
+  (for/sum ([v (hash-ref ($csp-neighbors csp) var)]
+            #:when (conflict v))
+    1))
+
+(define (display csp assignment)
+  (displayln "todo"))
+
+(define/contract (support_pruning csp)
+  ($csp? . -> . void?)
+  ;; Make sure we can prune values from domains. (We want to pay
+  ;; for this only if we use it.)
+  (when (false? ($csp-curr_domains csp))
+    (set-$csp-curr_domains!
+     csp
+     (let ([h (make-hash)])
+       (for ([v ($csp-variables csp)])
+         (hash-set! h v (hash-ref ($csp-domains csp) v)))
+       h))))
+      
+(define/contract (suppose csp var value)
+  ($csp? symbol? any/c . -> . (listof (cons/c symbol? any/c)))
+  ;; Start accumulating inferences from assuming var=value
+  (support_pruning csp)
+  (define removals
+    (for/list ([a (hash-ref ($csp-curr_domains csp) var)]
+               #:when (not (equal? a value)))
+      (cons var a)))
+  (hash-set! ($csp-curr_domains csp) var (list value))
+  removals)
+
+
+(define/contract (prune csp var value removals)
+  ($csp? symbol? any/c (or/c #f (listof (cons/c symbol? any/c))) . -> . (listof (cons/c symbol? any/c)))
+  ;; Rule out var=value
+  (hash-update! ($csp-curr_domains csp) var
+                (λ (vals) (remove value vals)))
+  (and removals
+       (append removals (list (cons var value)))))
+
+(define/contract (choices csp var)
+  ($csp? symbol? . -> . (listof any/c))
+  ;; Return all values for var that aren't currently ruled out.
+  (hash-ref (or ($csp-curr_domains csp) ($csp-domains csp)) var))
+
+(define/contract (infer_assignment csp)
+  ($csp? . -> . hash?)
+  ;; Return the partial assignment implied by the current inferences.
+  (support_pruning csp)
+  (let ([a (make-hash)])
+    (for ([v ($csp-variables csp)]
+          #:when (= 1 (length (hash-ref ($csp-curr_domains csp) v))))
+      (hash-set! a v (first (hash-ref ($csp-curr_domains csp) v))))
+    a))
+
+(define/contract (restore csp removals)
+  ($csp? (listof (cons/c symbol? any/c)) . -> . void?)
+  ;; Undo a supposition and all inferences from it.
+  (for ([removal removals])
+    (match-define (cons B b) removal)
+    (hash-update! ($csp-curr_domains csp) B
+                  (λ (vals) (append vals (list b))))))
+
+
+;; ______________________________________________________________________________
+;; CSP Backtracking Search
+
+;; Variable ordering
+
+(define/contract (first_unassigned_variable assignment csp)
+  (hash? $csp? . -> . symbol?)
+  ;; The default variable order.
+  (for/first ([var ($csp-variables csp)]
+              #:when (not (hash-has-key? assignment var)))
+    var))
+
+;; Value ordering
+
+(define/contract (unordered_domain_values var assignment csp)
+  (symbol? hash? $csp? . -> . (listof any/c))
+  ;; The default value order.
+  (choices csp var))
+
+;; Inference
+
+(define/contract (no_inference csp var value assignment removals)
+  ($csp? symbol? any/c hash? (listof (cons/c symbol? any/c)) . -> . boolean?)
+  #true)
+
+(define/contract (backtracking_search csp
+                                      [select_unassigned_variable first_unassigned_variable]
+                                      [order_domain_values unordered_domain_values]
+                                      [inference no_inference])
+  (($csp?) (procedure? procedure? procedure?) . ->* . (or/c #f hash?))
+  #f)
+
+(require rackunit)
+(define vs '(wa nsw t q nt v sa))
+(define ds (for/hash ([k vs])
+             (values k '(red green blue))))
+(define ns (for*/hash ([k vs]
+                       [k2 (cdr vs)])
+             (values k (list k2))))
+(define csp (make-csp vs ds ns void))
+(check-true ($csp? csp))
+(define a (make-hash))
+(assign csp 'key 42 a)
+(check-equal? (hash-ref a 'key) 42)
+(unassign csp 'key a)
+(check-exn exn:fail? (λ () (hash-ref a 'key)))
+(check-equal? 0 (nconflicts csp 'wa 'red (hasheq 'wa 42)))
+(support_pruning csp)
+(check-true (hash? ($csp-curr_domains csp)))
+
+(check-equal?
+ (suppose csp 'wa 'red)
+ '((wa . green) (wa . blue)))
+(check-equal?
+ (hash-ref ($csp-curr_domains csp) 'wa) '(red))
+
+(check-equal? (prune csp 'v 'red empty) '((v . red)))
+
+(check-equal? (choices csp 'v) '(green blue))
+(check-equal? (choices csp 'wa) '(red))
+(check-equal? (infer_assignment csp)
+              (make-hash '((wa . red))))
+(check-equal? (suppose csp 'v 'blue) '((v . green)))
+(check-equal? (infer_assignment csp)
+              (make-hash '((v . blue) (wa . red))))
+(restore csp '((wa . green)))
+(check-equal? (infer_assignment csp)
+              (make-hash '((v . blue))))
+
+(check-equal? (first_unassigned_variable (hash) csp) 'wa)
+(check-equal? (unordered_domain_values 'wa (hash) csp) '(red green))
+
+(backtracking_search csp)