1 ;;; -*- Mode: LISP; Package: (SCREAMS :USE CL :COLON-MODE :EXTERNAL); Base: 10; Syntax: Ansi-common-lisp -*-
3 ;;; LaHaShem HaAretz U'Mloah
5 (in-package :screamer-user
)
7 (screamer:define-screamer-package
:screams
(:use
:iterate
))
11 (defun pythagorean-triples (n)
13 (let ((a (an-integer-between 1 n
))
14 (b (an-integer-between 1 n
))
15 (c (an-integer-between 1 n
)))
16 (unless (= (+ (* a a
) (* b b
)) (* c c
)) (fail))
19 (defun pythagorean-triplesv (n)
22 (let ((a (an-integer-betweenv 1 n
))
23 (b (an-integer-betweenv 1 n
))
24 (c (an-integer-betweenv 1 n
)))
25 (assert! (=v
(+v
(*v a a
) (*v b b
)) (*v c c
)))
28 #'(lambda (x) (< x
1e-6))
30 #'divide-and-conquer-force
))))
32 (defun attacks?
(qi qj distance
)
33 (or (= qi qj
) (= (abs (- qi qj
)) distance
)))
35 (defun check-queens (queen queens
&optional
(distance 1))
37 (if (attacks? queen
(first queens
) distance
) (fail))
38 (check-queens queen
(rest queens
) (1+ distance
))))
40 (defun n-queens (n &optional queens
)
41 (if (= (length queens
) n
)
43 (let ((queen (an-integer-between 1 n
)))
44 (check-queens queen queens
)
45 (n-queens n
(cons queen queens
)))))
49 (let ((q (make-array n
)))
50 (dotimes (i n
) (setf (aref q i
) (an-integer-betweenv 1 n
)))
55 (notv (funcallv #'attacks?
(aref q i
) (aref q j
) (- j i
)))))))
57 (reorder #'domain-size
58 #'(lambda (x) (declare (ignore x
)) nil
)
62 (defun a-subset-of (x)
65 (let ((y (a-subset-of (rest x
)))) (either (cons (first x
) y
) y
))))
67 (defun a-partition-of (x)
70 (let ((y (a-partition-of (rest x
))))
71 (either (cons (list (first x
)) y
)
72 (let ((z (a-member-of y
)))
73 (cons (cons (first x
) z
) (remove z y
:test
#'eq
:count
1)))))))
75 (defstruct (node (:conc-name nil
) (:print-function print-node
))
76 name next-nodes
(visited? nil
) (visits 0))
78 (defun print-node (node stream print-level
)
79 (declare (ignore print-level
))
80 (princ (name node
) stream
))
82 (defun simple-path (u v
)
83 (if (visited? u
) (fail))
84 (local (setf (visited? u
) t
))
85 (either (progn (unless (eq u v
) (fail)) (list u
))
86 (cons u
(simple-path (a-member-of (next-nodes u
)) v
))))
88 (defun k-simple-path (u v k
)
89 (if (= (visits u
) k
) (fail))
90 ;; This can't be (LOCAL (INCF (VISITS U))) since Lucid screws up here.
91 (local (setf (visits u
) (1+ (visits u
))))
92 (either (progn (unless (eq u v
) (fail)) (list u
))
93 (cons u
(k-simple-path (a-member-of (next-nodes u
)) v k
))))
96 (let ((a (make-node :name
'a
))
97 (b (make-node :name
'b
))
98 (c (make-node :name
'c
))
99 (d (make-node :name
'd
))
100 (e (make-node :name
'e
))
101 (f (make-node :name
'f
)))
102 (setf (next-nodes a
) (list b c
))
103 (setf (next-nodes b
) (list a d e
))
104 (setf (next-nodes c
) (list a d e
))
105 (setf (next-nodes d
) (list b c f
))
106 (setf (next-nodes e
) (list b c f
))
107 (setf (next-nodes f
) (list d e
))
108 (list (all-values (simple-path a f
))
109 (all-values (k-simple-path a f
2)))))
111 (defstruct (boolean-variable (:conc-name nil
)) (value :unassigned
) noticers
)
114 (let ((z (make-boolean-variable)))
115 (local (push #'(lambda () (set-value x
(not (value z
)))) (noticers z
))
116 (push #'(lambda () (set-value z
(not (value x
)))) (noticers x
)))
120 (let ((z (make-boolean-variable)))
124 (unless (eq (value y
) :unassigned
) (set-value z
(value y
)))
125 (unless (eq (value z
) :unassigned
) (set-value y
(value z
))))
126 (t (set-value z nil
))))
130 (unless (eq (value x
) :unassigned
) (set-value z
(value x
)))
131 (unless (eq (value z
) :unassigned
) (set-value x
(value z
))))
132 (t (set-value z nil
))))
135 (cond ((value z
) (set-value x t
) (set-value y t
))
136 (t (if (eq (value x
) t
) (set-value y nil
))
137 (if (eq (value y
) t
) (set-value x nil
)))))
141 (defun orb (x y
) (notb (andb (notb x
) (notb y
))))
143 (defun set-value (variable value
)
144 (cond ((eq (value variable
) :unassigned
)
145 (local (setf (value variable
) value
))
146 (dolist (noticer (noticers variable
)) (funcall noticer
)))
147 (t (unless (eq (value variable
) value
) (fail)))))
149 (defun boolean-solution (variables)
152 (let ((variable (first variables
)))
153 (when (eq (value variable
) :unassigned
)
154 (set-value variable
(either t nil
)))
155 (cons (value variable
) (boolean-solution (rest variables
))))))
157 (defun sat-problem ()
159 (let ((x (make-boolean-variable))
160 (y (make-boolean-variable))
161 (z (make-boolean-variable)))
162 (set-value (andb (orb x
(notb y
)) (orb y
(notb z
))) t
)
163 (boolean-solution (list x y z
)))))
165 (defvar *grammar
* '((s np vp
)
175 (defun lhs (rule) (car rule
))
177 (defun rhs (rule) (cdr rule
))
179 (defun categories (grammar)
181 (set-difference (reduce #'append grammar
) (mapcar #'first grammar
)
185 (defun parse-categories (categories words1
&optional words2
)
186 (if (null categories
)
187 (if (and (null words1
) (null words2
)) t
(fail))
188 (either (progn (parse (first categories
) words1
)
189 (parse-categories (rest categories
) words2
))
194 (reverse (rest (reverse words1
)))
195 (append (last words1
) words2
))))))
197 (defun parse-rule (category words rules
)
200 (either (if (eq (lhs (first rules
)) category
)
201 (parse-categories (rhs (first rules
)) words
)
203 (parse-rule category words
(rest rules
)))))
205 (defun parse (category words
)
206 (if (null (rest words
))
207 (if (eq category
(category (first words
))) t
(fail))
208 (parse-rule category words
*grammar
*)))
210 (defun category (word)
211 (declare (special lexicon
))
212 (let ((category (gethash word lexicon
)))
215 (local (setf (gethash word lexicon
)
216 (a-member-of (categories *grammar
*)))))))
220 (let ((lexicon (make-hash-table :test
#'eq
)))
221 (declare (special lexicon
))
222 (progn (parse 's
'(the cup slid from john to mary
))
223 (parse 's
'(john walked to the table
)))
224 (maphash (lambda (word category
)
225 (format t
"~%~S: ~S" word category
))
228 (defun parse-categoriesv (categories words1
&optional words2
)
229 (if (null categories
)
230 (if (and (null words1
) (null words2
)) t NIL
)
231 (ORV (progn (parsev (first categories
) words1
)
232 (parse-categoriesv (rest categories
) words2
))
237 (reverse (rest (reverse words1
)))
238 (append (last words1
) words2
))))))
240 (defun parse-rulev (category words rules
)
243 (ORV (if (eq (lhs (first rules
)) category
)
244 (parse-categoriesv (rhs (first rules
)) words
)
246 (parse-rulev category words
(rest rules
)))))
248 (defun parsev (category words
)
249 (if (null (rest words
))
250 (EQUALV CATEGORY
(CATEGORYV (FIRST WORDS
)))
251 (parse-rulev category words
*grammar
*)))
253 (defun categoryv (word)
254 (declare (special lexicon
))
255 (let ((category (gethash word lexicon
)))
258 (setf (gethash word lexicon
) (A-MEMBER-OFV (categories *grammar
*))))))
261 (let ((lexicon (make-hash-table :test
#'eq
)))
262 (declare (special lexicon
))
263 (ASSERT! (ANDV (parsev 's
'(the cup slid from john to mary
))
264 (parsev 's
'(john walked to the table
))))
266 (FUNCALL (REORDER #'DOMAIN-SIZE
267 #'(LAMBDA (X) (DECLARE (IGNORE X
)) NIL
)
271 (maphash (lambda (word category
)
272 (declare (ignore word
))
273 (push category categories
))
276 (maphash (lambda (word category
)
277 (format t
"~%~S: ~S" word category
))
280 (defvar *puzzle1
* '((1 1 across
5)
327 (defvar *words1
* '("ache"
373 (defvar *puzzle2
* '((1 1 across
3)
468 (defvar *words2
* '("ad"
563 (defun row (placement) (first placement
))
565 (defun column (placement) (second placement
))
567 (defun direction (placement) (third placement
))
569 (defun placement-length (placement) (fourth placement
))
571 (defun intersect?
(placement1 placement2
)
573 (not (eq (direction placement1
) (direction placement2
)))
574 (if (eq (direction placement1
) 'across
)
575 (and (>= (row placement1
) (row placement2
))
577 (+ (row placement2
) (placement-length placement2
) -
1))
578 (>= (column placement2
) (column placement1
))
579 (<= (column placement2
)
580 (+ (column placement1
) (placement-length placement1
) -
1)))
581 (and (>= (row placement2
) (row placement1
))
583 (+ (row placement1
) (placement-length placement1
) -
1))
584 (>= (column placement1
) (column placement2
))
585 (<= (column placement1
)
586 (+ (column placement2
) (placement-length placement2
) -
1))))))
588 (defun consistent-placements?
589 (placement1 placement2 placement1-word placement2-word
)
590 (or (not (intersect? placement1 placement2
))
591 (if (eq (direction placement1
) 'across
)
592 (char= (aref placement1-word
593 (- (column placement2
) (column placement1
)))
594 (aref placement2-word
595 (- (row placement1
) (row placement2
))))
596 (char= (aref placement2-word
597 (- (column placement1
) (column placement2
)))
598 (aref placement1-word
599 (- (row placement2
) (row placement1
)))))))
601 (defun word-of-length (n dictionary
)
602 (if (null dictionary
)
604 (if (= (length (first dictionary
)) n
)
605 (either (first dictionary
) (word-of-length n
(rest dictionary
)))
606 (word-of-length n
(rest dictionary
)))))
608 (defun check-placement (placement word solution
)
609 (dolist (placement-word solution
)
610 (if (not (consistent-placements?
611 (first placement-word
) placement
(second placement-word
) word
))
614 (defun choose-placement (placements solution
)
616 (dolist (placement placements
)
617 (if (some #'(lambda (placement-word)
618 (intersect?
(first placement-word
) placement
))
620 (return-from exit placement
)))
621 (return-from exit
(first placements
))))
623 (defun crossword (placements dictionary
&optional solution
)
624 (if (null placements
)
626 (let* ((placement (choose-placement placements solution
))
627 (word (word-of-length (placement-length placement
) dictionary
)))
628 (check-placement placement word solution
)
629 (crossword (remove placement placements
)
631 (cons (list placement word
) solution
)))))
633 (defun crossword-variables (placements dictionary
)
637 (for placement in placements
)
641 (let ((word (a-member-of dictionary
)))
642 (unless (= (length word
)
643 (placement-length placement
))
646 (for (variable1 . remaining-variables
) on variables
)
647 (for (placement1 . remaining-placements
) on placements
)
649 (for variable2 in remaining-variables
)
650 (for placement2 in remaining-placements
)
651 (if (intersect? placement1 placement2
)
652 (let ((placement1 placement1
)
653 (placement2 placement2
))
655 (funcallv #'(lambda (word1 word2
)
656 (consistent-placements?
657 placement1 placement2 word1 word2
))
660 (finally (return variables
))))
662 (defun crosswordv (placements dictionary
)
665 (solution (crossword-variables placements dictionary
)
666 (reorder #'domain-size
667 #'(lambda (x) (declare (ignore x
)) nil
)
675 (let ((x (a-real-betweenv -
1e38
1e38
))
676 (y (a-real-betweenv -
1e38
1e38
))
677 (z (a-real-betweenv -
1e38
1e38
)))
679 (andv (orv (=v
(+v
(*v
4 x x y
) (*v
7 y z z
) (*v
6 x x z z
)) 2)
680 (=v
(+v
(*v
3 x y
) (*v
2 y y
) (*v
5 x y z
)) -
4))
681 (>=v
(*v
(+v x y
) (+v y z
)) -
5)))
683 (reorder #'range-size
684 #'(lambda (x) (< x
1e-6))
686 #'divide-and-conquer-force
)))))
688 (defun prolog-append (x y z
)
689 (either (progn (assert! (equalv x nil
))
690 (assert! (equalv y z
)))
691 (let ((x1 (make-variable))
695 (assert! (equalv x
(cons a x1
)))
696 (assert! (equalv y y1
))
697 (assert! (equalv z
(cons a z1
)))
698 (prolog-append x1 y1 z1
))))
702 (let ((x (make-variable))
704 (prolog-append x y
'(a b c d
))
705 ;; Note how lists with variables in their CDR print out as dotted pairs
706 ;; since the Common Lisp printer for cons cells won't dereference bound
707 ;; variables to determine that a cons cell can be printed in list notation.
708 ;; Also note that the value returned by SPLIT-LIST contains variables which
709 ;; are unbound outside the context of ALL-VALUES.
710 (print (list x y
)))))
712 ;;; Tam V'Nishlam Shevah L'El Borei Olam