fork(9) download
copy 
  1. ;;;; Example: "The Zebra Puzzle"
  2. ;;;;
  3. ;;;; Classic riddle popularly attributed to Lewis Carrol. (Essentially the
  4. ;;;; same as "The Einstein's Riddle".)
  5. ;;;;
  6. ;;;; This solution, contributed by Stephan Frank, uses the constraint
  7. ;;;; propagation features of Screamer.
  8. ;;;;
  9. ;;;; Five men with different nationalities live in the first five houses of a
  10. ;;;; street. They practise five distinct professions, and each of them has a
  11. ;;;; favourite animal and a favourite drink, all of them different. The five
  12. ;;;; houses are painted in different colours.
  13. ;;;;
  14. ;;;;    1. The Englishman lives in a red house.
  15. ;;;;    2. The Spaniard owns a dog.
  16. ;;;;    3. The Japanese is a painter.
  17. ;;;;    4. The Italian drinks tea.
  18. ;;;;    5. The Norwegian lives in the first house on the left.
  19. ;;;;    6. The owner of the green house drinks coffee.
  20. ;;;;    7. The green house is on the right of the white one.
  21. ;;;;    8. The sculptor breeds snails.
  22. ;;;;    9. The diplomat lives in the yellow house.
  23. ;;;;   10. Milk is drunk in the middle house.
  24. ;;;;   11. The Norwegian's house is next to the blue one.
  25. ;;;;   12. The violinist drinks fruit juice.
  26. ;;;;   13. The fox is in a house next to that of the doctor.
  27. ;;;;   14. The horse is in a house next to that of the diplomat.
  28. ;;;;
  29. ;;;; Question: Who owns a Zebra, and who drinks water?
  30.  
  31. (eval-when (:compile-toplevel :load-toplevel)
  32.   (require :screamer))
  33.  
  34. (in-package :screamer-user)
  35.  
  36. ;;;; Utility definitions
  37. ;;;;
  38. ;;;; LET-INTEGERS-BETWEENV binds names in VAR-LIST to integer
  39. ;;;; variables constrained in the range [min, max].
  40. ;;;;
  41. ;;;; ALL-DIFFERENTV returns a variable constrained to be true if variables in
  42. ;;;; the list received all have different values.
  43.  
  44. (defmacro let-integers-betweenv (((min max) var-list) body)
  45.   `(let ,(loop for i in var-list
  46.                collect (list i `(an-integer-betweenv ,min ,max)))
  47.      ,body))
  48.  
  49. (defun all-differentv (list)
  50.   ;; Functionally the same as (apply #'/=v list), but faster.
  51.   (labels ((all-different (x xs)
  52.              (if (null xs)
  53.                  t
  54.                  (andv (notv (=v x (car xs)))
  55.                        (all-different x (cdr xs))
  56.                        (all-different (car xs) (cdr xs))))))
  57.     (all-different (car list) (cdr list))))
  58.  
  59. ;;;; Constraint model
  60. ;;;;
  61. ;;;; Houses are identified by integers from 1 to 5.
  62. ;;;;
  63. ;;;; We first bind logic variables taking values in that range in
  64. ;;;; LET-INTEGERS-BETWEEN for all properties. We group them and assert that
  65. ;;;; every value is unique in its group using ALL-DIFFERENTV.
  66. ;;;;
  67. ;;;; We create three mode logic variables to represent distances between
  68. ;;;; certain houses.
  69. ;;;;
  70. ;;;; We assert the constraints stated in the riddle.
  71. ;;;;
  72. ;;;; Finally, we ask Screamer to provide a solution that satisfies
  73. ;;;; all given constraints.
  74.  
  75. (defun zebra-problem ()
  76.   (let-integers-betweenv ((1 5)
  77.                           (English Spaniard Japanese Italian Norwegian
  78.                            Red Green White Yellow Blue
  79.                            Painter Sculptor Diplomat Violinist
  80.                            Doctor Dog Snails Fox Horse Zebra
  81.                            Tea Coffee Milk Juice Water))
  82.     (let ((Nationality (list English Spaniard Japanese Italian Norwegian))
  83.           (Color       (list Red Green White Yellow Blue))
  84.           (Profession  (list Painter Sculptor Diplomat Violinist Doctor))
  85.           (Pet         (list Zebra Dog Snails Fox Horse))
  86.           (Drink       (list Water Tea Coffee Milk Juice)))
  87.       ;; The values in each list are exclusive.
  88.       (assert! (all-differentv Nationality))
  89.       (assert! (all-differentv Color))
  90.       (assert! (all-differentv Profession))
  91.       (assert! (all-differentv Pet))
  92.       (assert! (all-differentv Drink))
  93.       ;; Setup auxiliary vars needed for neigbouring relations.
  94.       (let ((distance-1 (an-integer-betweenv -1 1))
  95.             (distance-2 (an-integer-betweenv -1 1))
  96.             (distance-3 (an-integer-betweenv -1 1)))
  97.         (assert! (/=v distance-1 0))
  98.         (assert! (/=v distance-2 0))
  99.         (assert! (/=v distance-3 0))
  100.         ;; The actual constraints from the problem description.
  101.         (assert! (=v English Red))
  102.         (assert! (=v Spaniard Dog))
  103.         (assert! (=v Japanese Painter))
  104.         (assert! (=v Italian Tea))
  105.         (assert! (=v Norwegian 1))
  106.         (assert! (=v Green Coffee))
  107.         (assert! (=v Green (+v White 1)))
  108.         (assert! (=v Sculptor Snails))
  109.         (assert! (=v Diplomat Yellow))
  110.         (assert! (=v Milk 3))
  111.         (assert! (=v distance-1 (-v Norwegian Blue)))
  112.         (assert! (=v Violinist Juice))
  113.         (assert! (=v distance-2 (-v Fox Doctor)))
  114.         (assert! (=v distance-3 (-v Horse Diplomat)))
  115.         ;; Force a solution.
  116.         (let ((result
  117.                (one-value
  118.                 ;; Feed all the primary values into the solution: we don't
  119.                 ;; want any uncertainty to remain regarding these. If we
  120.                 ;; merely fed in NATIONALITY, ZEBRA, and WATER, we might
  121.                 ;; return false results where some of the constraints were
  122.                 ;; not fully checked because eg. PROFESSION wasn't solved.
  123.                 ;;
  124.                 ;; We're using STATIC-ORDERING here for simplicity. REORDER
  125.                 ;; using DOMAIN-SIZE would be faster.
  126.                 (solution (list Nationality Pet Drink Color Profession)
  127.                           (static-ordering #'linear-force)))))
  128.           ;; Human-readable labels: results we have back are integers identifying
  129.           ;; the houses. Map back to nationalities.
  130.           (destructuring-bind (Nationality Pet Drink &rest rest) result
  131.             (declare (ignore rest))
  132.             (let ((names (vector "Brit" "Spaniard" "Japanese" "Italian" "Norwegian")))
  133.               (format t "The ~A owns the zebra.~%"
  134.                       (aref names (position (first Pet) Nationality)))
  135.               (format t "The ~A drinks water.~%"
  136.                       (aref names (position (first Drink) Nationality))))))))))
  137.  
  138. #+nil
  139. (time (screamer-user::zebra-problem))
  140.  
Runtime error #stdin #stdout 0.03s 10832KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
Standard output is empty
https://ideone.com/b20Qh
language:
Common Lisp (clisp 2.49.92)
created:
14 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!