(in-package :cl-user)

;;; Solution to Einstein Riddle by Dr. Karsten Poeck
;;; inspired by Dr. Edmund Weitz solution
;;; But, no macros, no function generation, CLOS only
;;; In Allegro 6.0 about twice as fast as the original
;;; But more important consumes a lot less memory
;;; Original 445,402 cons cells, 8,186,528 other bytes, 1328 static bytes
;;; This version  8,443 cons cells, 384 other bytes, 0 static bytes
;;; The Backtracking is essentially the same (but no nested dolist)
;;; but it stops after the first solution (return-from)
;;; The Code for the conditions is a bit optimised

;;; Permutation is borrowed from Dr. Edmund Weitz
;;; Works in ACL 6.0, LW 4.1.20, Corman 1.42 and clisp 2.27

;;; Einstein specific code in einstein.lisp
;;; Simpler mickey test in mickey.lisp

(eval-when
    (:compile-toplevel :execute :load-toplevel)
  (proclaim '(optimize (speed 0) (safety 3) (space 0)(debug 3)(compilation-speed 0)))
  )

(defun permutation (list)
  (if (null list)
      (list nil)
    (mapcan #'(lambda (first) 
                (mapcar #'(lambda (rest)
                            (cons first rest))
                  (permutation (remove first list :count 1 :test #'eq))))
      list)))

(defclass combine-root ()
  ()
  )

(defclass partial-solution (combine-root)
  ()
  )

(defclass testable-constraint (combine-root)
  ()
  )

(defmethod constraint-holds ((constraint testable-constraint) (solution partial-solution))
  t)

(defclass combinatoric-solver (combine-root)
  (
   (my-constraints :accessor my-constraints :initarg :my-constraints :initform nil)
   (solution-tried :accessor solution-tried)
   )
  )

(defgeneric SOLVE-IT (solver))

(defmethod get-my-constraints ((me combinatoric-solver))
  (my-constraints me)
  )

(defmethod partial-solution-correct ((me combinatoric-solver) (solution partial-solution))
  (dolist (constraint (get-my-constraints me) t)
    (unless (constraint-holds constraint solution)
      (return nil))))

(defgeneric ALL-DOMAINS-EXTENDED (solver))

(defmethod all-domains ((me COMBINATORIC-SOLVER))
  (mapcar #'second (all-domains-extended me)))

(defmethod problem-size ((me COMBINATORIC-SOLVER))
  (length (all-domains-extended me)))

(defclass backtracking-solver (combinatoric-solver)
  ()
  )

(defgeneric generate-empty-solution (solver))

(defgeneric EXPAND-PARTIAL-SOLUTION (solver permutation index))

(defgeneric CHANGE-PARTIAL-SOLUTION (solver permutation index))

(defmethod solve-it ((solver BACKTRACKING-SOLVER))
  (let ((perm-array (generate-perm-array solver))
        (index -1)
        (limit (problem-size solver))
        (stack-array (make-array (problem-size solver)))
        (partial (generate-empty-solution solver))
        )
    (setf (solution-tried solver) 0)
    (unless (PARTIAL-SOLUTION-CORRECT solver partial)
      (error "Empty solution not valid"))
    (loop
      (incf (solution-tried solver))
      (cond ((PARTIAL-SOLUTION-CORRECT solver partial)
             (incf index)
             (when (= index limit)
               ;hurra
               (return-from solve-it partial)
               )
             ;extend the solution
             
             (setf (svref stack-array index)(svref perm-array index))
             (expand-partial-solution partial (first (svref stack-array index)) index))
            (t
             (loop
               #+no (break "Backtracking")
               (cond ((svref stack-array index)
                      (let ((new (pop (svref stack-array index))))
                        (change-partial-solution partial new index)
                        (return)))
                     (t
                      ; no alternatives in current level, backtrack
                      (forget-partial-solution partial index)
                      (decf index)
                      (when (minusp index)
                        (break "Failed")))))
             )))   
    )
  )

(defmethod generate-perm-array ((solver BACKTRACKING-SOLVER))
  (let ((array (make-array (problem-size solver)))
        (index 0)
        )
    (dolist (domain (all-domains solver))
      (setf (aref array index) (permutation domain))
      (incf index))
    array))


;;; Specific to Riddle
(defclass riddle-solver (backtracking-solver)
  ()
  )

(defclass riddle-partial-solution (partial-solution)
  (
   (riddle-elements :accessor riddle-elements :initarg :riddle-elements)
   )
  )

(defmethod show-result ((me riddle-partial-solution) tries)
  (format t "~%The solution in ~a tries is:~%" tries)
  (dolist (house (riddle-elements me))
    (show-result house tries)))

(defgeneric partial-solution-class (solver))

(defgeneric solution-element-class (solver))

(defmethod generate-empty-solution ((me riddle-solver))
  (let ((elements nil)
        (class (solution-element-class me)))
    (dotimes (x (problem-size me))
      (push (make-instance class) elements))
    (make-instance (partial-solution-class me)
      :riddle-elements elements   
      )
    )
  )

(defgeneric element-mapper (partial-solution))

(defmethod EXPAND-PARTIAL-SOLUTION ((me RIDDLE-PARTIAL-SOLUTION)
                                    permutation index)
  (let ((setter (getf (element-mapper me) index)))
    (dolist (house (riddle-elements me))
      (funcall setter (pop permutation)  house)
      )
    )
  )

(defmethod CHANGE-PARTIAL-SOLUTION ((me RIDDLE-PARTIAL-SOLUTION)
                                    permutation index)
  (EXPAND-PARTIAL-SOLUTION me permutation index)
  )

(defmethod FORGET-PARTIAL-SOLUTION ((me RIDDLE-PARTIAL-SOLUTION)
                                    index)
  (let ((setter (getf (element-mapper me) index)))
    (dolist (house (riddle-elements me))
      (funcall setter nil  house)
      )
    )
  )

(defclass riddle-constraints (testable-constraint)
  ()
  )

(defgeneric element-property-mapper (riddle-partial-solution))

(defclass position-and-property-constraint (RIDDLE-CONSTRAINTS)
  (
   (selector-one :initarg :selector-one :accessor riddle-selector-one)
   (value-one :initarg :value-one :accessor riddle-value-one)
   (position :initarg :position :accessor riddle-position)
   )
  )

(defmethod constraint-holds ((constraint position-and-property-constraint) (RIDDLE-PARTIAL-SOLUTION partial-solution))
  (let ((sel-1 (getf (element-property-mapper RIDDLE-PARTIAL-SOLUTION)  
                     (riddle-selector-one constraint)))
        (value-1 (riddle-value-one constraint))
        (position (riddle-position constraint))
        (house-list (riddle-elements riddle-partial-solution))
        )
    (if (null (funcall sel-1 (first house-list)))
        t
      (let ((index 0))
        (dolist (house house-list)
          
          (when (eq value-1 (funcall sel-1 house))
            (let ((result (= index POSITION)))
              (return result)))
          )
        )
      )
    )
  )

(defclass TWO-VALUES-IN-HOUSE-constraint (riddle-constraints)
  (
   (selector-one :initarg :selector-one :accessor riddle-selector-one)
   (value-one :initarg :value-one :accessor riddle-value-one)
   (selector-two :initarg :selector-two :accessor riddle-selector-two)
   (value-two :initarg :value-two :accessor riddle-value-two)
   )
  )

(defmethod constraint-holds ((constraint TWO-VALUES-IN-HOUSE-constraint) (RIDDLE-PARTIAL-SOLUTION partial-solution))
  (let ((sel-1 (getf (element-property-mapper RIDDLE-PARTIAL-SOLUTION)  (riddle-selector-one constraint)))
        (sel-2 (getf (element-property-mapper RIDDLE-PARTIAL-SOLUTION) (riddle-selector-two constraint)))
        (value-1 (riddle-value-one constraint))
        (value-2 (riddle-value-two constraint))
        (house-list (riddle-elements riddle-partial-solution))
        )
    (if (or (null (funcall sel-1 (first house-list)))
            (null (funcall sel-2 (first house-list)))
            )
        t
      (dolist (house house-list)
        
        (when (eq value-1 (funcall sel-1 house))
          (let ((result (eq value-2 (funcall sel-2 house))))
            (return result)))
        )
      )
    )
  )

(defclass generic-neighbour-constraint (riddle-constraints)
  (
   (selector-one :initarg :selector-one :accessor riddle-selector-one)
   (value-one :initarg :value-one :accessor riddle-value-one)
   (selector-two :initarg :selector-two :accessor riddle-selector-two)
   (value-two :initarg :value-two :accessor riddle-value-two)
   )
  )

(defclass NEIGHBOUR-CONSTRAINT (generic-neighbour-constraint)
  ()
  )

(defclass abs-distance-neighbour-constraint (GENERIC-NEIGHBOUR-CONSTRAINT)
  (
    (distance :initarg :distance :accessor riddle-distance :initform nil)
   )
  )

(defclass directed-distance-neighbour-constraint (GENERIC-NEIGHBOUR-CONSTRAINT)
  (
   (distance :initarg :distance :accessor riddle-distance :initform nil)
   )
  )

(defclass negated-directed-distance-neighbour-constraint (GENERIC-NEIGHBOUR-CONSTRAINT)
  (
   (distance :initarg :distance :accessor riddle-distance :initform nil)
   )
  )

(defgeneric evaluate-distance (NEIGHBOUR-CONSTRAINT pos-a pos-b))

(defmethod constraint-holds ((constraint generic-neighbour-constraint) (RIDDLE-PARTIAL-SOLUTION partial-solution))
  (let ((sel-1 (getf (element-property-mapper RIDDLE-PARTIAL-SOLUTION) (riddle-selector-one constraint)))
        (sel-2 (getf (element-property-mapper RIDDLE-PARTIAL-SOLUTION) (riddle-selector-two constraint)))
        (value-1 (riddle-value-one constraint))
        (value-2 (riddle-value-two constraint))
        (house-list (riddle-elements riddle-partial-solution))
        )
    (if (or (null (funcall sel-1 (first house-list)))
            (null (funcall sel-2 (first house-list)))
            )
        t
      (let ((index 0)
            (pos-a nil)
            (pos-b nil)
            )
        (dolist (house house-list nil)
          
          (when (eq value-1 (funcall sel-1 house))
            (setq pos-a index))
          (when (eq value-2 (funcall sel-2 house))
            (setq pos-b index))
          (when (and pos-a pos-b)
            (return
              (EVALUATE-DISTANCE CONSTRAINT pos-a pos-b)))
          (incf index)
          )
        )
      )
    )
  )

(defmethod evaluate-distance ((CONSTRAINT NEIGHBOUR-CONSTRAINT) pos-a pos-b)
  (or (= pos-a (1- pos-b))
      (= pos-a (1+ pos-b)))
  )

(defmethod evaluate-distance ((CONSTRAINT abs-distance-neighbour-constraint) pos-a pos-b)
  (= (riddle-distance constraint)
     (abs (- pos-a pos-b)))
  )

(defmethod evaluate-distance ((CONSTRAINT directed-distance-neighbour-constraint) pos-a pos-b)
  (= (riddle-distance constraint)
     (- pos-b POS-A))
  )

(defmethod evaluate-distance ((CONSTRAINT NEGATED-DIRECTED-DISTANCE-NEIGHBOUR-CONSTRAINT) pos-a pos-b)
  (not (= (riddle-distance constraint)
          (- pos-b pos-a)))
  )