;; ==================================
;; Grundlagen der KI
;;
;; Loesung zum Uebungsblatt 1
;;
;; Aufgabe 2: Missionare- und Kannibalen- Problem
;; ==================================
;;

(in-package "USER")
;;;======================================================================
;;; GENERIC SEARCH FUNCTION
;;;======================================================================


(defvar *operators*)
(defvar *op-application-test*)
(defvar *op-application-fun*)


;; a node of the search graph consists of:
;;   state   (contents of recipients)
;;   gen-by  (generated-by: Operator that has generated this node)
;;   next-nodes (next nodes / children in the graph)
;;   prev-node  (previous node, ancestor in the graph)

(defstruct node
  state
  gen-by
  prev-node
  next-nodes)



;;; GENERAL REMARK regarding application of operators:
;; The applicability of an operator is tested by looking at the state
;; of a node, not at the whole state itself
;; Similarly, an operator is applied by computing a new state from its old
;; state. In general, no global information (previous nodes etc) is taken
;; into account.

;; tests whether operator op is applicable to node
(defun operator-applicable-p (op node)
  (let ((application-test (second (find op *op-application-test*
                                        :key #'first))))
    (funcall application-test (node-state node))))


;; INPUT:
;; op: operator
;; node: node of search graph
;; OUTPUT:
;; new node, with all necessary entries made

(defun apply-operator (op node)
  (let* ((old-state (node-state node))
         (application-fun (second (find op *op-application-fun*
                                        :key #'first)))
         (new-state (funcall application-fun old-state)))
    (make-node :state new-state
               :gen-by op
               :prev-node node
               :next-nodes nil)))

;;;----------------------------------------------------------------------

(defun occurs-in-ancestors (state node)
  (cond ((equal-state state (node-state node))  T)
        ((node-prev-node node)
         (occurs-in-ancestors state (node-prev-node node)))
        (T nil)))

(defun redundant (node)
  (if (node-prev-node node)
      (occurs-in-ancestors (node-state node) (node-prev-node node))
    nil))

;; expand-node is an improved version of expansion that only expands
;; a node if it is not one of the ancester nodes
(defun expand-node (node)
  (if (redundant node)
      nil
    (really-expand-node node)))

;;;----------------------------------------------------------------------

;; expand the node and return the list of nodes generated by application of
;; all applicable operators
(defun really-expand-node (node)
  (let* ((applicable-operators
          (remove-if-not #'(lambda (op) (operator-applicable-p op node))
                         *operators*))
         (new-nodes (mapcar #'(lambda (op) (apply-operator op node))
                            applicable-operators)))
    (setf (node-next-nodes node) new-nodes)
    new-nodes))


;; find a solution in a node-list; if no solution exists, return nil
(defun find-solution (node-list)
  (find-if #'(lambda (node) (success-state-p (node-state node))) node-list))


;;;----------------------------------------------------------------------
;; INPUT:
;; node-list:  list of open nodes
;; OUTPUT:
;; nil, if no solution is found; a success node otherwise

(defun breadth-first-search (node-list)

  (if (null node-list)
      ;; node-list is empty
      ;; --> no more nodes to expand 
      ;; --> return nil to indicate failure
      nil
    
    ;; expand first node of node-list,
    ;; look for a solution in the resulting node-list
    (let* ((new-nodes (expand-node (first node-list)))
           (solution (find-solution new-nodes)))
      (if solution
          ;; if a solution is found in the new nodes, return it
          solution
        ;; otherwise continue search, with the first node removed
        ;; and the new-nodes added to the node-list
        (breadth-first-search (append (rest node-list) new-nodes))))))


(defun start-search ()
  (let* ((initial-node (make-node :state (start-state)
                                  :gen-by NIL
                                  :prev-node NIL
                                  :next-nodes NIL))
         (result (breadth-first-search (list initial-node))))
    (if result
        ;; search successful
        (output-result result)
      nil)))


(defun output-result (node)
  (if (node-prev-node node)
      (progn
        (output-result (node-prev-node node))
        (format T "Application of ~A yields state~% ~A~%"
                (node-gen-by node)
                (format-state (node-state node))))
    (format T "Starting with state~% ~A~%" (format-state (node-state node)))))





;;;======================================================================
;;; DOMAIN-SPECIFIC INFORMATION
;;;======================================================================


;;;----------------------------------------------------------------------
;; assuming that the river has to be crossed from the left bank of the
;; river to the right bank

;; a state is a triple consisting of:
;; - the number of missionaries on the left bank (0 .. 3)
;; - the number of cannibals on the left bank (0 .. 3)
;; - the position of the boat (L, R)

(defun make-state (m c pos)
  (list m c pos))

(defun m-in-state (state)
  (first state))

(defun c-in-state (state)
  (second state))

(defun pos-in-state (state)
  (third state))

(defun equal-state (state1 state2) (equal state1 state2))

;;;----------------------------------------------------------------------

(defun m-on-left (state)
  (m-in-state state))

(defun c-on-left (state)
  (c-in-state state))

(defun boat-on-left-p (state)
  (eq (pos-in-state state) 'L))

(defun m-on-right (state)
  (- 3 (m-in-state state)))

(defun c-on-right (state)
  (- 3 (c-in-state state)))

(defun boat-on-right-p (state)
  (eq (pos-in-state state) 'R))

;;;----------------------------------------------------------------------

(defun start-state ()
  (make-state 3 3 'L))

(defun success-state-p (state)
 (equal-state state (make-state 0 0 'R)))

;; for output:
(defun format-state (state)
  (with-output-to-string
   (str)
   (format str "~6<~{~S ~}~>" (make-list (m-in-state state) :initial-element 'm))
   (format str "~6<~{~S ~}~>" (make-list (c-in-state state) :initial-element 'c))
   (if (eql (pos-in-state state) 'L)
       (format str "  | |__|       |  ")
     (format str "  |       |__| |  "))
   (format str "~6<~{~S ~}~>" (make-list (- 3 (m-in-state state)) :initial-element 'm))
   (format str "~6<~{~S ~}~>" (make-list (- 3 (c-in-state state)) :initial-element 'c))))

;;;----------------------------------------------------------------------

(defun consistent-state (state)
  (or (eql (m-in-state state) (c-in-state state))
      (eql (m-in-state state) 0)
      (eql (m-in-state state) 3)))

(defun row-left (m c state)
  (make-state (+ (m-in-state state) m)
              (+ (c-in-state state) c)
              'L))

(defun row-right (m c state)
  (make-state (- (m-in-state state) m)
              (- (c-in-state state) c)
              'R))


;;;----------------------------------------------------------------------

(setf *operators* '(row-left-m row-left-c row-left-mc row-left-mm row-left-cc
                               row-right-m row-right-c row-right-mc row-right-mm row-right-cc))

;; an application test is a unary predicate taking a state as argument
(setf *op-application-test*
      (list 
       (list 'row-left-m #'(lambda (state)
                             (and (boat-on-right-p state)
                                  (>= (m-on-right state) 1)
                                  (consistent-state (row-left 1 0 state)))))
       (list 'row-left-c #'(lambda (state)
                             (and (boat-on-right-p state)
                                  (>= (c-on-right state) 1)
                                  (consistent-state (row-left 0 1 state)))))
       (list 'row-left-mc #'(lambda (state)
                              (and (boat-on-right-p state)
                                   (>= (m-on-right state) 1)
                                   (>= (c-on-right state) 1)
                                   (consistent-state (row-left 1 1 state)))))
       (list 'row-left-mm #'(lambda (state)
                              (and (boat-on-right-p state)
                                   (>= (m-on-right state) 2)
                                   (consistent-state (row-left 2 0 state)))))
       (list 'row-left-cc #'(lambda (state)
                              (and (boat-on-right-p state)
                                   (>= (c-on-right state) 2)
                                   (consistent-state (row-left 0 2 state)))))
       (list 'row-right-m #'(lambda (state)
                             (and (boat-on-left-p state)
                                  (>= (m-on-left state) 1)
                                  (consistent-state (row-right 1 0 state)))))
       (list 'row-right-c #'(lambda (state)
                             (and (boat-on-left-p state)
                                  (>= (c-on-left state) 1)
                                  (consistent-state (row-right 0 1 state)))))
       (list 'row-right-mc #'(lambda (state)
                              (and (boat-on-left-p state)
                                   (>= (m-on-left state) 1)
                                   (>= (c-on-left state) 1)
                                   (consistent-state (row-right 1 1 state)))))
       (list 'row-right-mm #'(lambda (state)
                              (and (boat-on-left-p state)
                                   (>= (m-on-left state) 2)
                                   (consistent-state (row-right 2 0 state)))))
       (list 'row-right-cc #'(lambda (state)
                              (and (boat-on-left-p state)
                                   (>= (c-on-left state) 2)
                                   (consistent-state (row-right 0 2 state)))))))
;; an application test is a unary function taking a state and returning a state
(setf *op-application-fun*
      (list 
       (list 'row-left-m #'(lambda (state) (row-left 1 0 state)))
       (list 'row-left-c #'(lambda (state) (row-left 0 1 state)))
       (list 'row-left-mc #'(lambda (state) (row-left 1 1 state)))
       (list 'row-left-mm #'(lambda (state) (row-left 2 0 state)))
       (list 'row-left-cc #'(lambda (state) (row-left 0 2 state)))
       (list 'row-right-m #'(lambda (state) (row-right 1 0 state)))
       (list 'row-right-c #'(lambda (state) (row-right 0 1 state)))
       (list 'row-right-mc #'(lambda (state) (row-right 1 1 state)))
       (list 'row-right-mm #'(lambda (state) (row-right 2 0 state)))
       (list 'row-right-cc #'(lambda (state) (row-right 0 2 state)))))


;;;----------------------------------------------------------------------