(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
|#