screams.lisp

   1 ;;; -*- Mode: LISP; Package: (SCREAMS :USE CL :COLON-MODE :EXTERNAL); Base: 10; Syntax: Ansi-common-lisp -*-
   2
   3 ;;; LaHaShem HaAretz U'Mloah
   4
   5 (in-package :screamer-user)
   6
   7 (screamer:define-screamer-package :screams (:use :iterate))
   8
   9 (in-package :screams)
  10
  11 (defun pythagorean-triples (n)
  12   (all-values
  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))
  17       (list a b c))))
  18
  19 (defun pythagorean-triplesv (n)
  20   (all-values
  21     (solution
  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)))
  26        (list a b c))
  27      (reorder #'range-size
  28               #'(lambda (x) (< x 1e-6))
  29               #'>
  30               #'divide-and-conquer-force))))
  31
  32 (defun attacks? (qi qj distance)
  33   (or (= qi qj) (= (abs (- qi qj)) distance)))
  34
  35 (defun check-queens (queen queens &optional (distance 1))
  36   (unless (null queens)
  37     (if (attacks? queen (first queens) distance) (fail))
  38     (check-queens queen (rest queens) (1+ distance))))
  39
  40 (defun n-queens (n &optional queens)
  41   (if (= (length queens) n)
  42       queens
  43       (let ((queen (an-integer-between 1 n)))
  44         (check-queens queen queens)
  45         (n-queens n (cons queen queens)))))
  46
  47 (defun n-queensv (n)
  48   (solution
  49    (let ((q (make-array n)))
  50      (dotimes (i n) (setf (aref q i) (an-integer-betweenv 1 n)))
  51      (dotimes (i n)
  52        (dotimes (j n)
  53          (if (> j i)
  54              (assert!
  55               (notv (funcallv #'attacks? (aref q i) (aref q j) (- j i)))))))
  56      (coerce q 'list))
  57    (reorder #'domain-size
  58             #'(lambda (x) (declare (ignore x)) nil)
  59             #'<
  60             #'linear-force)))
  61
  62 (defun a-subset-of (x)
  63   (if (null x)
  64       nil
  65       (let ((y (a-subset-of (rest x)))) (either (cons (first x) y) y))))
  66
  67 (defun a-partition-of (x)
  68   (if (null x)
  69       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)))))))
  74
  75 (defstruct (node (:conc-name nil) (:print-function print-node))
  76   name next-nodes (visited? nil) (visits 0))
  77
  78 (defun print-node (node stream print-level)
  79   (declare (ignore print-level))
  80   (princ (name node) stream))
  81
  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))))
  87
  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))))
  94
  95 (defun graph ()
  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)))))
 110
 111 (defstruct (boolean-variable (:conc-name nil)) (value :unassigned) noticers)
 112
 113 (defun notb (x)
 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)))
 117     z))
 118
 119 (defun andb (x y)
 120   (let ((z (make-boolean-variable)))
 121     (local
 122       (push #'(lambda ()
 123                 (cond ((value x)
 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))))
 127             (noticers x))
 128       (push #'(lambda ()
 129                 (cond ((value y)
 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))))
 133             (noticers y))
 134       (push #'(lambda ()
 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)))))
 138             (noticers z))
 139       z)))
 140
 141 (defun orb (x y) (notb (andb (notb x) (notb y))))
 142
 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)))))
 148
 149 (defun boolean-solution (variables)
 150   (if (null variables)
 151       '()
 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))))))
 156
 157 (defun sat-problem ()
 158   (all-values
 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)))))
 164
 165 (defvar *grammar* '((s np vp)
 166                     (np det n)
 167                     (np n)
 168                     (vp v)
 169                     (vp v np)
 170                     (vp v np np)
 171                     (vp v pp)
 172                     (vp v np pp)
 173                     (pp p np)))
 174
 175 (defun lhs (rule) (car rule))
 176
 177 (defun rhs (rule) (cdr rule))
 178
 179 (defun categories (grammar)
 180   (remove-duplicates
 181    (set-difference (reduce #'append grammar) (mapcar #'first grammar)
 182                    :test #'eq)
 183    :test #'eq))
 184
 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))
 190               (if (null words1)
 191                   (fail)
 192                   (parse-categories
 193                    categories
 194                    (reverse (rest (reverse words1)))
 195                    (append (last words1) words2))))))
 196
 197 (defun parse-rule (category words rules)
 198   (if (null rules)
 199       (fail)
 200       (either (if (eq (lhs (first rules)) category)
 201                   (parse-categories (rhs (first rules)) words)
 202                   (fail))
 203               (parse-rule category words (rest rules)))))
 204
 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*)))
 209
 210 (defun category (word)
 211   (declare (special lexicon))
 212   (let ((category (gethash word lexicon)))
 213     (if category
 214         category
 215         (local (setf (gethash word lexicon)
 216                      (a-member-of (categories *grammar*)))))))
 217
 218 (defun grow-up ()
 219   (all-values
 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))
 226                lexicon))))
 227
 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))
 233            (if (null words1)
 234                NIL
 235                (parse-categoriesv
 236                 categories
 237                 (reverse (rest (reverse words1)))
 238                 (append (last words1) words2))))))
 239
 240 (defun parse-rulev (category words rules)
 241   (if (null rules)
 242       NIL
 243       (ORV (if (eq (lhs (first rules)) category)
 244                (parse-categoriesv (rhs (first rules)) words)
 245                NIL)
 246            (parse-rulev category words (rest rules)))))
 247
 248 (defun parsev (category words)
 249   (if (null (rest words))
 250       (EQUALV CATEGORY (CATEGORYV (FIRST WORDS)))
 251       (parse-rulev category words *grammar*)))
 252
 253 (defun categoryv (word)
 254   (declare (special lexicon))
 255   (let ((category (gethash word lexicon)))
 256     (if category
 257         category
 258         (setf (gethash word lexicon) (A-MEMBER-OFV (categories *grammar*))))))
 259
 260 (defun grow-upv ()
 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))))
 265     (all-values
 266       (FUNCALL (REORDER #'DOMAIN-SIZE
 267                         #'(LAMBDA (X) (DECLARE (IGNORE X)) NIL)
 268                         #'<
 269                         #'LINEAR-FORCE)
 270                (let (categories)
 271                  (maphash (lambda (word category)
 272                             (declare (ignore word))
 273                             (push category categories))
 274                           lexicon)
 275                  categories))
 276       (maphash (lambda (word category)
 277                  (format t "~%~S: ~S" word category))
 278                lexicon))))
 279
 280 (defvar *puzzle1* '((1 1 across 5)
 281                     (1 12 across 2)
 282                     (2 4 across 4)
 283                     (2 10 across 6)
 284                     (3 1 across 4)
 285                     (3 12 across 2)
 286                     (4 1 across 2)
 287                     (4 4 across 2)
 288                     (4 8 across 4)
 289                     (5 8 across 5)
 290                     (6 1 across 3)
 291                     (6 10 across 4)
 292                     (7 7 across 4)
 293                     (7 13 across 3)
 294                     (8 1 across 2)
 295                     (8 5 across 4)
 296                     (10 6 across 2)
 297                     (10 14 across 2)
 298                     (11 3 across 4)
 299                     (12 6 across 3)
 300                     (12 10 across 5)
 301                     (13 1 across 6)
 302                     (14 1 across 4)
 303                     (3 1 down 6)
 304                     (12 1 down 4)
 305                     (3 2 down 2)
 306                     (13 2 down 2)
 307                     (13 3 down 2)
 308                     (1 4 down 4)
 309                     (10 4 down 5)
 310                     (1 5 down 2)
 311                     (4 5 down 5)
 312                     (8 6 down 6)
 313                     (7 7 down 2)
 314                     (4 8 down 2)
 315                     (7 8 down 2)
 316                     (4 9 down 2)
 317                     (2 10 down 6)
 318                     (12 10 down 3)
 319                     (4 11 down 3)
 320                     (1 12 down 3)
 321                     (5 12 down 2)
 322                     (1 13 down 3)
 323                     (6 13 down 2)
 324                     (10 14 down 3)
 325                     (6 15 down 5)))
 326
 327 (defvar *words1* '("ache"
 328                    "adults"
 329                    "am"
 330                    "an"
 331                    "ax"
 332                    "bandit"
 333                    "bath"
 334                    "below"
 335                    "cave"
 336                    "dean"
 337                    "dig"
 338                    "do"
 339                    "dots"
 340                    "ef"
 341                    "eh"
 342                    "enjoys"
 343                    "era"
 344                    "es"
 345                    "fade"
 346                    "fee"
 347                    "him"
 348                    "incur"
 349                    "jo"
 350                    "knee"
 351                    "la"
 352                    "large"
 353                    "lie"
 354                    "ma"
 355                    "mops"
 356                    "on"
 357                    "ow"
 358                    "owe"
 359                    "pair"
 360                    "pi"
 361                    "re"
 362                    "royal"
 363                    "run"
 364                    "squad"
 365                    "sticks"
 366                    "string"
 367                    "ti"
 368                    "ut"
 369                    "veils"
 370                    "you"
 371                    "zero"))
 372
 373 (defvar *puzzle2* '((1 1 across 3)
 374                     (1 5 across 5)
 375                     (1 11 across 4)
 376                     (2 1 across 3)
 377                     (2 5 across 5)
 378                     (2 11 across 5)
 379                     (3 1 across 7)
 380                     (3 9 across 4)
 381                     (3 14 across 2)
 382                     (4 4 across 3)
 383                     (4 8 across 4)
 384                     (4 13 across 3)
 385                     (5 1 across 5)
 386                     (5 7 across 4)
 387                     (5 12 across 4)
 388                     (6 1 across 4)
 389                     (6 6 across 4)
 390                     (6 11 across 3)
 391                     (7 1 across 3)
 392                     (7 5 across 4)
 393                     (7 10 across 6)
 394                     (8 1 across 2)
 395                     (8 4 across 4)
 396                     (8 9 across 4)
 397                     (8 14 across 2)
 398                     (9 1 across 6)
 399                     (9 8 across 4)
 400                     (9 13 across 3)
 401                     (10 3 across 3)
 402                     (10 7 across 4)
 403                     (10 12 across 4)
 404                     (11 1 across 4)
 405                     (11 6 across 4)
 406                     (11 11 across 5)
 407                     (12 1 across 3)
 408                     (12 5 across 4)
 409                     (12 10 across 3)
 410                     (13 1 across 2)
 411                     (13 4 across 4)
 412                     (13 9 across 7)
 413                     (14 1 across 5)
 414                     (14 7 across 5)
 415                     (14 13 across 3)
 416                     (15 2 across 4)
 417                     (15 7 across 5)
 418                     (15 13 across 3)
 419                     (1 1 down 3)
 420                     (5 1 down 5)
 421                     (11 1 down 4)
 422                     (1 2 down 3)
 423                     (5 2 down 5)
 424                     (11 2 down 5)
 425                     (1 3 down 3)
 426                     (5 3 down 3)
 427                     (9 3 down 4)
 428                     (14 3 down 2)
 429                     (3 4 down 4)
 430                     (8 4 down 4)
 431                     (13 4 down 3)
 432                     (1 5 down 5)
 433                     (7 5 down 4)
 434                     (12 5 down 4)
 435                     (1 6 down 4)
 436                     (6 6 down 4)
 437                     (11 6 down 3)
 438                     (1 7 down 3)
 439                     (5 7 down 4)
 440                     (10 7 down 6)
 441                     (1 8 down 2)
 442                     (4 8 down 4)
 443                     (9 8 down 4)
 444                     (14 8 down 2)
 445                     (1 9 down 6)
 446                     (8 9 down 4)
 447                     (13 9 down 3)
 448                     (3 10 down 3)
 449                     (7 10 down 4)
 450                     (12 10 down 4)
 451                     (1 11 down 4)
 452                     (6 11 down 4)
 453                     (11 11 down 5)
 454                     (1 12 down 3)
 455                     (5 12 down 4)
 456                     (10 12 down 4)
 457                     (1 13 down 2)
 458                     (4 13 down 4)
 459                     (9 13 down 3)
 460                     (13 13 down 3)
 461                     (1 14 down 5)
 462                     (7 14 down 5)
 463                     (13 14 down 3)
 464                     (2 15 down 4)
 465                     (7 15 down 5)
 466                     (13 15 down 3)))
 467
 468 (defvar *words2* '("ad"
 469                    "al"
 470                    "alas"
 471                    "aloha"
 472                    "art"
 473                    "at"
 474                    "atl"
 475                    "bags"
 476                    "bang"
 477                    "base"
 478                    "bore"
 479                    "coat"
 480                    "dad"
 481                    "dart"
 482                    "dime"
 483                    "dine"
 484                    "dive"
 485                    "do"
 486                    "eh"
 487                    "elf"
 488                    "er"
 489                    "evade"
 490                    "even"
 491                    "fan"
 492                    "fee"
 493                    "fine"
 494                    "gate"
 495                    "goat"
 496                    "happy"
 497                    "hares"
 498                    "hem"
 499                    "hide"
 500                    "hire"
 501                    "hive"
 502                    "hoe"
 503                    "hone"
 504                    "inn"
 505                    "largest"
 506                    "learned"
 507                    "lee"
 508                    "lemons"
 509                    "lid"
 510                    "lilac"
 511                    "lip"
 512                    "lo"
 513                    "load"
 514                    "mates"
 515                    "mile"
 516                    "mirror"
 517                    "mist"
 518                    "moon"
 519                    "more"
 520                    "oak"
 521                    "olive"
 522                    "ore"
 523                    "pans"
 524                    "paris"
 525                    "pay"
 526                    "pea"
 527                    "pedal"
 528                    "penny"
 529                    "pier"
 530                    "pile"
 531                    "pins"
 532                    "pits"
 533                    "raise"
 534                    "rips"
 535                    "roe"
 536                    "ropes"
 537                    "roy"
 538                    "salads"
 539                    "see"
 540                    "slam"
 541                    "slat"
 542                    "some"
 543                    "spot"
 544                    "steer"
 545                    "stew"
 546                    "tag"
 547                    "tame"
 548                    "tan"
 549                    "tank"
 550                    "tea"
 551                    "tee"
 552                    "tie"
 553                    "tigers"
 554                    "tire"
 555                    "to"
 556                    "toe"
 557                    "wager"
 558                    "wave"
 559                    "wider"
 560                    "win"
 561                    "wires"))
 562
 563 (defun row (placement) (first placement))
 564
 565 (defun column (placement) (second placement))
 566
 567 (defun direction (placement) (third placement))
 568
 569 (defun placement-length (placement) (fourth placement))
 570
 571 (defun intersect? (placement1 placement2)
 572   (and
 573    (not (eq (direction placement1) (direction placement2)))
 574    (if (eq (direction placement1) 'across)
 575        (and (>= (row placement1) (row placement2))
 576             (<= (row placement1)
 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))
 582             (<= (row placement2)
 583                 (+ (row placement1) (placement-length placement1) -1))
 584             (>= (column placement1) (column placement2))
 585             (<= (column placement1)
 586                 (+ (column placement2) (placement-length placement2) -1))))))
 587
 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)))))))
 600
 601 (defun word-of-length (n dictionary)
 602   (if (null dictionary)
 603       (fail)
 604       (if (= (length (first dictionary)) n)
 605           (either (first dictionary) (word-of-length n (rest dictionary)))
 606           (word-of-length n (rest dictionary)))))
 607
 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))
 612         (fail))))
 613
 614 (defun choose-placement (placements solution)
 615   (block exit
 616     (dolist (placement placements)
 617       (if (some #'(lambda (placement-word)
 618                     (intersect? (first placement-word) placement))
 619                 solution)
 620           (return-from exit placement)))
 621     (return-from exit (first placements))))
 622
 623 (defun crossword (placements dictionary &optional solution)
 624   (if (null placements)
 625       solution
 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)
 630                    dictionary
 631                    (cons (list placement word) solution)))))
 632
 633 (defun crossword-variables (placements dictionary)
 634   (iterate
 635     (with variables =
 636           (iterate
 637             (for placement in placements)
 638             (collect
 639                 (a-member-ofv
 640                  (all-values
 641                    (let ((word (a-member-of dictionary)))
 642                      (unless (= (length word)
 643                                 (placement-length placement))
 644                        (fail))
 645                      word))))))
 646     (for (variable1 . remaining-variables) on variables)
 647     (for (placement1 . remaining-placements) on placements)
 648     (iterate
 649       (for variable2 in remaining-variables)
 650       (for placement2 in remaining-placements)
 651       (if (intersect? placement1 placement2)
 652           (let ((placement1 placement1)
 653                 (placement2 placement2))
 654             (assert!
 655              (funcallv #'(lambda (word1 word2)
 656                            (consistent-placements?
 657                             placement1 placement2 word1 word2))
 658                        variable1
 659                        variable2)))))
 660     (finally (return variables))))
 661
 662 (defun crosswordv (placements dictionary)
 663   (mapcar #'list
 664           placements
 665           (solution (crossword-variables placements dictionary)
 666                     (reorder #'domain-size
 667                              #'(lambda (x) (declare (ignore x)) nil)
 668                              #'<
 669                              #'linear-force))))
 670
 671 (defun nonlinear ()
 672   (for-effects
 673     (print
 674      (solution
 675       (let ((x (a-real-betweenv -1e38 1e38))
 676             (y (a-real-betweenv -1e38 1e38))
 677             (z (a-real-betweenv -1e38 1e38)))
 678         (assert!
 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)))
 682         (list x y z))
 683       (reorder #'range-size
 684                #'(lambda (x) (< x 1e-6))
 685                #'>
 686                #'divide-and-conquer-force)))))
 687
 688 (defun prolog-append (x y z)
 689   (either (progn (assert! (equalv x nil))
 690                  (assert! (equalv y z)))
 691           (let ((x1 (make-variable))
 692                 (y1 (make-variable))
 693                 (z1 (make-variable))
 694                 (a (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))))
 699
 700 (defun split-list ()
 701   (all-values
 702     (let ((x (make-variable))
 703           (y (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)))))
 711
 712 ;;; Tam V'Nishlam Shevah L'El Borei Olam