;; ==================================
;; Grundlagen der KI
;;
;; Loesung zum Uebungsblatt 1
;;
;; Aufgabe 1: polya-puzzle
;; ==================================
;;


(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
;;;======================================================================


;;;----------------------------------------------------------------------
;; a state consists of the contents of recipient A and B

(defun make-state (a-cont b-cont)
  (cons a-cont b-cont))

(defun a-cont (state)
  (car state))

(defun b-cont (state)
  (cdr state))

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

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

(defun start-state ()
  (make-state 0 0))

(defun success-state-p (state)
  (eql (a-cont state) 6))

;; for output:
(defun format-state (state)
  state)

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

(defun capacity (rec)
  (case rec
        (a 9)
        (b 4)))

(defun contents (rec state)
  (case rec
        (a (a-cont state))
        (b (b-cont state))))

(defun full-p (rec state)
  (eql (contents rec state) (capacity rec)))

(defun empty-p (rec state)
  (eql (contents rec state) 0))

;; how much space is free in rec in state ?
(defun free (rec state)
  (- (capacity rec) (contents rec state)))



(defun fill-from-to (x y state)
  (let ((contents-of-x (contents x state))
        (contents-of-y (contents y state))
        (free-in-y (free y state)))
    (if (<= contents-of-x free-in-y)
        ;; x fits completely into y
        (make-state 0 (+ contents-of-x contents-of-y))
      ;; y is filled completely
      (make-state (- contents-of-x free-in-y) (capacity y)))))

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

(setf *operators* '(fill-a fill-b empty-a empty-b a-to-b b-to-a))

;; an application test is a unary predicate taking a state as argument
(setf *op-application-test*
      (list 
       (list 'fill-a #'(lambda (state) (not (full-p 'a state))))
       (list 'fill-b #'(lambda (state) (not (full-p 'b state))))
       (list 'empty-a #'(lambda (state) (not (empty-p 'a state))))
       (list 'empty-b #'(lambda (state) (not (empty-p 'b state))))
       (list 'a-to-b #'(lambda (state) (and (not (empty-p 'a state))
                                            (not (full-p 'b state)))))
       (list 'b-to-a #'(lambda (state) (and (not (empty-p 'b state))
                                            (not (full-p 'a state)))))))

;; an application test is a unary function taking a state and returning a state
(setf *op-application-fun*
      (list
       (list 'fill-a #'(lambda (state)
                         (make-state (capacity 'a) (b-cont state))))
       (list 'fill-b #'(lambda (state)
                         (make-state (a-cont state) (capacity 'b))))
       (list 'empty-a #'(lambda (state)
                          (make-state 0 (b-cont state))))
       (list 'empty-b #'(lambda (state)
                          (make-state (a-cont state) 0)))
       (list 'a-to-b #'(lambda (state) (fill-from-to 'a 'b state)))
       (list 'b-to-a #'(lambda (state) (fill-from-to 'b 'a state)))))


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