(in-package :cl-user) ;;;Einsteins Riddle, see generic.lisp ;;;There are five houses in five different colours starting from left to right. ;;;In each house lives a person of a different nationality. ;;;These owners all drink a certain type of beverage, ;;;smoke a certain brand of cigarette and keep a certain type of pet. ;;;No two owners have the same pet, smoke the same brand or drink the same beverage. ;;;The question is: WHO OWNS THE FISH??? Hints: ;;; ;;;The Brit lives in the red house ;;;The Swede keeps dogs as pets ;;;The Dane drinks tea ;;;The green house is on the left of the white house ;;;The green house's owner drinks coffee ;;;The person who smokes Pall Mall rears birds ;;;The owner of the yellow house smokes Dunhill ;;;The man living in the centre house drinks milk ;;;The Norwegian lives in the first house ;;;The person who smokes Marlboro lives next to the one who keeps cats ;;;The person who keeps horses lives next to the person who smokes Dunhill ;;;The person who smokes Winfield drinks beer ;;;The German smokes Rothmans ;;;The Norwegian lives next to the blue house ;;;The person who smokes Marlboro has a neigbor who drinks water ;;;To get a solution, try (test-einstein) ;;;Run tests at least twice to get clos prepared (eval-when (:compile-toplevel :execute :load-toplevel) (proclaim '(optimize (speed 0) (safety 3) (space 0)(debug 3)(compilation-speed 0))) ) (defclass einstein-riddle-solver (riddle-solver) () ) (defmethod initialize-instance :after ((me einstein-riddle-solver) &rest initargs) (declare (ignore initargs)) (setf (my-constraints me) (list (make-instance 'COLOR-LEFT-CONSTRAINT :riddle-left :green :riddle-right :white ) (make-instance 'NATION-POSITION-CONSTRAINT :riddle-position 0 :riddle-value :norwegian) (make-instance 'drink-position-constraint :riddle-position 2 :riddle-value :milk) (make-instance 'TWO-VALUES-IN-HOUSE-CONSTRAINT :SELECTOR-ONE :CIGARETTE :value-one :WINFIELD :SELECTOR-two :DRINK :value-two :beer) (make-instance 'TWO-VALUES-IN-HOUSE-CONSTRAINT :SELECTOR-ONE :animal :value-one :bird :SELECTOR-two :cigarette :value-two :pallmall) (make-instance 'TWO-VALUES-IN-HOUSE-CONSTRAINT :SELECTOR-ONE :nation :value-one :danish :SELECTOR-two :drink :value-two :tea) (make-instance 'TWO-VALUES-IN-HOUSE-CONSTRAINT :SELECTOR-ONE :color :value-one :green :SELECTOR-two :drink :value-two :coffee) (make-instance 'TWO-VALUES-IN-HOUSE-CONSTRAINT :SELECTOR-ONE :color :value-one :yellow :SELECTOR-two :CIGARETTE :value-two :dunhill) (make-instance 'TWO-VALUES-IN-HOUSE-CONSTRAINT :SELECTOR-ONE :nation :value-one :german :SELECTOR-two :CIGARETTE :value-two :ROTHMANS) (make-instance 'TWO-VALUES-IN-HOUSE-CONSTRAINT :SELECTOR-ONE :nation :value-one :SWEDISH :SELECTOR-two :animal :value-two :dog) (make-instance 'TWO-VALUES-IN-HOUSE-CONSTRAINT :SELECTOR-ONE :nation :value-one :BRITISH :SELECTOR-two :color :value-two :red) (make-instance 'NEIGHBOUR-CONSTRAINT :SELECTOR-ONE :CIGARETTE :value-one :MARLBORO :SELECTOR-two :DRINK :value-two :WATER) (make-instance 'NEIGHBOUR-CONSTRAINT :SELECTOR-ONE :ANIMAL :value-one :HORSE :SELECTOR-two :CIGARETTE :value-two :DUNHILL) (make-instance 'NEIGHBOUR-CONSTRAINT :SELECTOR-ONE :ANIMAL :value-one :CAT :SELECTOR-two :CIGARETTE :value-two :MARLBORO) (make-instance 'NEIGHBOUR-CONSTRAINT :SELECTOR-ONE :nation :value-one :NORWEGIAN :SELECTOR-two :color :value-two :blue) ))) (defmethod all-domains-extended ((me einstein-riddle-solver)) '((:nation (:british :swedish :norwegian :german :danish)) (:color (:red :green :yellow :blue :white)) (:animal (:dog :horse :cat :bird :fish)) (:cigarette (:marlboro :winfield :rothmans :pallmall :dunhill)) (:drink (:tea :coffee :milk :beer :water)) ) ) (defclass Einstein-Riddle-House () ( (nation :accessor riddle-house-nation :initform nil) (color :accessor riddle-house-color :initform nil) (animal :accessor riddle-house-animal :initform nil) (cigarette :accessor riddle-house-cigarette :initform nil) (drink :accessor riddle-house-drink :initform nil) ) ) (defclass einstein-partial-solution (riddle-partial-solution) ( ) ) (defmethod partial-solution-class ((me EINSTEIN-RIDDLE-SOLVER)) (find-class 'einstein-partial-solution)) (defmethod solution-element-class ((me EINSTEIN-RIDDLE-SOLVER)) (find-class 'Einstein-Riddle-House)) (defmethod show-result ((me Einstein-Riddle-House) tries) (declare (ignore tries)) (format t "A house with ") (format t "Nation ~10a " (riddle-house-nation me)) (format t "Color ~10a " (riddle-house-color me)) (format t "Animal ~10a "(riddle-house-animal me)) (format t "Cigarette ~10a "(riddle-house-cigarette me)) (format t "Drink ~10a~%" (riddle-house-drink me)) ) (defconstant +einstein-setf-mapper+ (list 0 #'(setf riddle-house-nation) 1 #'(setf riddle-house-color) 2 #'(setf riddle-house-animal) 3 #'(setf riddle-house-cigarette) 4 #'(setf riddle-house-drink) )) (defmethod element-mapper ((me einstein-partial-solution)) +einstein-setf-mapper+) ;;; todo. rewrite these with the generic constraints (defclass einstein-constraints (RIDDLE-CONSTRAINTS) () ) (defclass color-left-constraint (einstein-constraints) ( (left :accessor riddle-left :initarg :riddle-left) (right :accessor riddle-right :initarg :riddle-right) ) ) (defmethod constraint-holds ((constraint color-left-constraint) (EINSTEIN-PARTIAL-SOLUTION partial-solution)) (let ((house-list (riddle-elements EINSTEIN-PARTIAL-SOLUTION))) (if (null (riddle-house-color (first house-list))) t (let ((index 0) (pos-a nil) (pos-b nil) (left (riddle-left constraint)) (right (riddle-right constraint)) ) (dolist (house house-list nil) (cond ((eq (riddle-house-color house) left) (setq pos-a index)) ((eq (riddle-house-color house) right) (setq pos-b index)) ) #+no (print `(,pos-a ,pos-b)) (incf index) (when pos-b (if (null pos-a) (return nil) (return (= (1+ pos-a) pos-b)))) ) ) ) ) ) (defclass position-constraint (einstein-constraints) ( (position :accessor riddle-position :initarg :riddle-position) (value :accessor riddle-value :initarg :riddle-value) ) ) (defgeneric test-value (constraint house)) (defmethod constraint-holds ((constraint position-constraint) (EINSTEIN-PARTIAL-SOLUTION partial-solution)) (let ((house-list (riddle-elements EINSTEIN-PARTIAL-SOLUTION))) (if (null (test-value constraint (first house-list))) t (let ((index 0) (pos (riddle-position constraint)) (value (riddle-value constraint)) ) (dolist (house house-list nil) (when (eq value (test-value constraint house)) (return (= pos index))) (incf index)))))) (defclass nation-position-constraint (position-constraint) () ) (defmethod test-value ((me nation-position-constraint) house) (riddle-house-nation house) ) (defclass drink-position-constraint (position-constraint) () ) (defmethod test-value ((me drink-position-constraint) house) (riddle-house-drink house) ) (defconstant +einstein-property-mapper+ (list :nation #'riddle-house-nation :color #'riddle-house-color :drink #'riddle-house-drink :animal #'riddle-house-animal :cigarette #'riddle-house-cigarette)) (defmethod element-property-mapper ((me EINSTEIN-PARTIAL-SOLUTION)) +einstein-property-mapper+) ;;; Test for Einsteins Riddle (defun test-einstein (&optional (print t)) (let ((solver (make-instance 'einstein-riddle-solver)) (solution nil) ) (time (setq solution (solve-it solver))) (when print (show-result solution (solution-tried solver)) )) (values) ) #| (defparameter *solver* (make-instance 'einstein-riddle-solver)) (defparameter *test* (GENERATE-EMPTY-SOLUTION *solver*)) (EXPAND-PARTIAL-SOLUTION *test* '(:NORWEGIAN :DANISH :BRITISH :GERMAN :SWEDISH) 0) (PARTIAL-SOLUTION-CORRECT *solver* *test*) (EXPAND-PARTIAL-SOLUTION *test* '(:YELLOW :BLUE :RED :GREEN :white) 1) (PARTIAL-SOLUTION-CORRECT *solver* *test*) (EXPAND-PARTIAL-SOLUTION *test* '(:CAT :HORSE :BIRD :FISH :DOG) 2) (PARTIAL-SOLUTION-CORRECT *solver* *test*) (EXPAND-PARTIAL-SOLUTION *test* '(:DUNHILL :MARLBORO :pallmall :ROTHMANS :WINFIELD) 3) (PARTIAL-SOLUTION-CORRECT *solver* *test*) (EXPAND-PARTIAL-SOLUTION *test* '(:WATER :TEA :MILK :COFFEE :BEER) 4) (PARTIAL-SOLUTION-CORRECT *solver* *test*) (time (PARTIAL-SOLUTION-CORRECT *solver* *test*)) |# #| (defparameter *solver* (make-instance 'einstein-riddle-solver)) (defparameter *solution* nil) (time (setq *solution* (solve-it *SOLVER*))) (solution-tried *solver*) 31612 tries ; cpu time (non-gc) 440 msec user, 0 msec system ; cpu time (gc) 0 msec user, 0 msec system ; cpu time (total) 440 msec user, 0 msec system ; real time 440 msec ; space allocation: ; 8,442 cons cells, 384 other bytes, 0 static bytes |# #| Original Solution (#S(UNIT NATION NORWEGIAN HOUSE YELLOW ANIMAL CAT CIGARETTE DUNHILL DRINK WATER) #S(UNIT NATION DANISH HOUSE BLUE ANIMAL HORSE CIGARETTE MARLBORO DRINK TEA) #S(UNIT NATION BRITISH HOUSE RED ANIMAL BIRD CIGARETTE PALLMALL DRINK MILK) #S(UNIT NATION GERMAN HOUSE GREEN ANIMAL FISH CIGARETTE ROTHMANS DRINK COFFEE) #S(UNIT NATION SWEDISH HOUSE WHITE ANIMAL DOG CIGARETTE WINFIELD DRINK BEER)) ; cpu time (non-gc) 770 msec user, 0 msec system ; cpu time (gc) 220 msec user, 0 msec system ; cpu time (total) 990 msec user, 0 msec system ; real time 990 msec ; space allocation: ; 346,860 cons cells, 6,289,576 other bytes, 1136 static bytes |#