;;; ======================================================================
;;; Intermediate Example: Blocks World 8/9/94
;;; Paul McNamee

(in-package :common-lisp-user)

;;; ======================================================================
(defclass blocks-world-object ()
  ((width :initform 1 :initarg :width :accessor width)
   (weight :initform 1 :initarg :weight :accessor weight)
   (weight-limit :initform 10 :initarg :weight-limit :accessor weight-limit)
   (supported-objects :initform nil :initarg :supported-objects :accessor supported-objects) )
  (:documentation "A blocks-world top level class")
)

;;; Something big that can hold a lot.
(defclass table (blocks-world-object)
  ((width :initform 10)
   (weight :initform 0)
   (weight-limit :initform most-positive-fixnum))
)

;;; Just one table in our world 
(defparameter *table* (make-instance 'table))

(defclass blck (blocks-world-object)
  ((supporting-object :initform *table* :initarg :supporting-object :accessor supporting-object))
)

(defclass narrow-block (blck)
  ()
)

(defclass wide-block (blck)
  ((width :initform 2)
   (weight-limit :initform 20))
)  
  
(defclass pyramid (blck)
  ()
)

;;; ======================================================================
;;; I want methods for:
;;;   1. Remaining Space

(defmethod Remaining-Space ((obj blocks-world-object))
  (- (width obj) (apply #'+ (mapcar #'width (Blocks-Above obj))))
)

(defmethod Remaining-Space ((P pyramid)) 0)

;;;   2. Remaining Weight
(defmethod Remaining-Weight ((obj blocks-world-object))
  (- (weight-limit obj) (weight obj) (apply #'+ (mapcar #'weight (Blocks-Above obj))))
)

(defmethod Remaining-Weight ((P pyramid)) 0)

;;;   3. All blocks on Top (recurses all the way up)
(defmethod Blocks-Above ((obj (eql nil))) nil)
(defmethod Blocks-Above ((obj blocks-world-object))
  (append (supported-objects obj)
	  (apply #'append (mapcar #'blocks-above (supported-objects obj))) )
)  
(defmethod Blocks-Above ((P pyramid)) nil)

;;;   4. Put-On
;;; If no supporting objects on B
;;; If sufficient space and sufficient weight capacity on O

(defmethod Put-On ((B blck) (O blocks-world-object))
  (when (and (null (supported-objects B))
	     (>= (Remaining-Space O) (width B))
	     (>= (Remaining-Weight O) (weight B)) )
    ;; Remove B from parent
    (setf (supported-objects (supporting-object B))
	  (delete B (supported-objects (supporting-object B))) )
    ;; Add B to O
    (pushnew B (supported-objects O))
    ;; Change parent of B
    (setf (supporting-object B) O)
    )
)

(defmethod Put-On ((B blck) (P pyramid))
  (format t "Pyramids can not support other objects~%")
)

;;;   5. Take-Off.
(defmethod Take-Off ((B blck) (parent blck))
  (unless (Put-On B *table*)
    (format t "Couldn't Move ~S from ~S to ~S.~%" B parent *table*)
    )
)  

(defmethod Take-Off ((B blck) (P pyramid))
  (format t "~tThere is no object on pyramid: ~S.~%" P)
  (format t "~tObject: ~S is on ~S.~%" blck (supporting-object blck))
)

;;; ======================================================================
;;; Initialize World.


(defun Make-Blocks-World (&optional (num-blocks 5))
  (loop repeat num-blocks
	do (Put-On (Make-Random-Block) *table*)
	finally (Print-Blocks-World)
	)
)

(defun Make-Random-Block ()
  (make-instance
   (case (random 3)
     (0 'narrow-block)
     (1 'wide-block)
     (2 'pyramid)) )
)

;;; ======================================================================
(defmethod Print-Object ((obj blocks-world-object) stream)
  (format stream "#<~A (~D/~D)>" (type-of obj) (Remaining-Space obj) (Remaining-Weight obj))
)  

(defmethod Fancy-Print ((obj blocks-world-object) &optional (num-spaces 0))
  (format t (make-string num-spaces :initial-element #\space))
  (format t "~S which is holding:~%" obj)
  (loop for block in (supported-objects obj)
	do (Fancy-Print block (+ 3 num-spaces)) )
)  

(defmethod Fancy-Print ((obj table) &optional (num-spaces 3))
  (format t "~A is holding:~%" obj)
  (loop for block in (supported-objects obj)
	do (Fancy-Print block num-spaces))
)
	
(defun Print-Blocks-World ()
  (Fancy-Print *table*)
)


;;; dribbling to file "/home/paulmac/jhu/ai-prog/lisp/clos-course/blocks.txt"
;;;  
;;; NIL
;;; USER(2): (load "blocks.lisp")
;;; ; Loading /home/paulmac/jhu/ai-prog/lisp/clos-course/blocks.lisp.
;;; ; Autoloading for EXCL::COMPLEX-LOOP-EXPANDER:
;;; ;   Fast loading from bundle code/loop.fasl.
;;; T
;;; USER(3): (make-blocks-world)
;;; #<TABLE (2/536870906)> is holding:
;;;    #<WIDE-BLOCK (2/19)> which is holding:
;;;    #<NARROW-BLOCK (1/9)> which is holding:
;;;    #<WIDE-BLOCK (2/19)> which is holding:
;;;    #<WIDE-BLOCK (2/19)> which is holding:
;;;    #<PYRAMID (0/0)> which is holding:
;;; NIL
;;; USER(4): (print-blocks-world)
;;; #<TABLE (2/536870906)> is holding:
;;;    #<WIDE-BLOCK (2/19)> which is holding:
;;;    #<NARROW-BLOCK (1/9)> which is holding:
;;;    #<WIDE-BLOCK (2/19)> which is holding:
;;;    #<WIDE-BLOCK (2/19)> which is holding:
;;;    #<PYRAMID (0/0)> which is holding:
;;; NIL
;;; USER(5): (setf wide (first (supported-objects *table*)))
;;; #<WIDE-BLOCK (2/19)>
;;; USER(6): (setf pyr (fifth (supported-objects *table*)))
;;; #<PYRAMID (0/0)>
;;; USER(7): (Put-On wide pyr)
;;; Pyramids can not support other objects
;;; NIL
;;; USER(8): (Put-On pyr wide)
;;; #<WIDE-BLOCK (1/18)>
;;; USER(9): (print-blocks-world)
;;; #<TABLE (2/536870906)> is holding:
;;;    #<WIDE-BLOCK (1/18)> which is holding:
;;;       #<PYRAMID (0/0)> which is holding:
;;;    #<NARROW-BLOCK (1/9)> which is holding:
;;;    #<WIDE-BLOCK (2/19)> which is holding:
;;;    #<WIDE-BLOCK (2/19)> which is holding:
;;; NIL
;;; USER(10): (Take-Off pyr wide)
;;; NIL
;;; USER(11): (print-blocks-world)
;;; #<TABLE (2/536870906)> is holding:
;;;    #<PYRAMID (0/0)> which is holding:
;;;    #<WIDE-BLOCK (2/19)> which is holding:
;;;    #<NARROW-BLOCK (1/9)> which is holding:
;;;    #<WIDE-BLOCK (2/19)> which is holding:
;;;    #<WIDE-BLOCK (2/19)> which is holding:
;;; NIL
;;; USER(12): (dribble)
;;;