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