home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / xl21hos2.zip / BLOCKS.LSP < prev    next >
Text File  |  1995-12-27  |  6KB  |  196 lines
  1. ; Blocks World from Winston&Horn
  2.  
  3. #-:classes (load "classes")
  4.  
  5. ; abstract classes for ball types
  6.  
  7. ; basic blocks support nothing
  8. (defclass basic-block (name width height position supported-by))
  9.  
  10. (defmethod basic-block :support-for () nil)
  11.  
  12. (defmethod basic-block :top-location  () 
  13.     (list (+ (first position) (/ width 2))
  14.           (+ (second position) height)))
  15.  
  16. ; movable-blocks can be moved
  17. (defclass movable-block () () basic-block)
  18.  
  19. ; load-bearing blocks can support other blocks, and can be moved
  20. (defclass load-bearing-block (support-for) () movable-block)
  21.  
  22. ; we can't have multiple inheritance, so we need a separate class for table
  23. ; table blocks can support other blocks but cannot be moved.
  24.  
  25. (defclass table-block (support-for) () basic-block)
  26.  
  27. ; Specific classes for table brick wedge and ball
  28.  
  29. (defclass brick () () load-bearing-block)
  30.  
  31. (defclass wedge () () movable-block)
  32.  
  33. (defclass ball  () () movable-block)
  34.  
  35. (defclass hand  (name position grasping))
  36.  
  37.  
  38. ; define all the individual blocks
  39.  
  40. (setf *blocks*
  41.       (list
  42.         (send table-block :new :name 'table :width 20 :height 0 :position '(0 0))
  43.     (send brick :new :name 'b1 :width 2 :height 2 :position '(0 0))
  44.     (send brick :new :name 'b2 :width 2 :height 2 :position '(2 0))
  45.     (send brick :new :name 'b3 :width 4 :height 4 :position '(4 0))
  46.     (send brick :new :name 'b4 :width 2 :height 2 :position '(8 0))
  47.     (send wedge :new :name 'w5 :width 2 :height 4 :position '(10 0))
  48.     (send brick :new :name 'b6 :width 4 :height 2 :position '(12 0))
  49.     (send wedge :new :name 'w7 :width 2 :height 2 :position '(16 0))
  50.     (send ball  :new :name 'l8 :width 2 :height 2 :position '(18 0))
  51.        ))
  52.  
  53. (dolist (l *blocks*) (set (send l :name) l))
  54.  
  55.  
  56. (dolist (l (cdr *blocks*)) ; all but table block
  57.     (setf (send table :support-for) 
  58.           (cons l (send table :support-for))
  59.           (send l :supported-by)
  60.           table))
  61.  
  62. (definst hand *hand* :name '*hand* :position '(0 6))
  63.  
  64. (defmethod movable-block :put-on (support)
  65.     (if (send self :get-space support)
  66.         (and (send *hand* :grasp self)
  67.              (send *hand* :move  self support)
  68.          (send *hand* :ungrasp self))
  69.         (format t 
  70.                 "Sorry, there is no room for ~a on ~a.~%"
  71.             name
  72.             (send support :name))))
  73.  
  74. (defmethod movable-block :get-space (support)
  75.     (or (send self :find-space support)
  76.         (send self :make-space support)))
  77.  
  78. (defmethod hand :grasp (obj)
  79.     (unless (eq grasping obj)
  80.         (when (send obj :support-for)
  81.               (send obj :clear-top))
  82.         (when grasping
  83.               (send grasping :rid-of))
  84.         (setf position (send obj :top-location))
  85.         (format t
  86.             "Move hand to pick up ~a at location ~a.~%"
  87.             (send obj :name)
  88.             position)
  89.         (format t
  90.             "Grasp ~a.~%"
  91.             (send obj :name))
  92.         (setf grasping obj))
  93.     t)
  94.  
  95. (defmethod hand :ungrasp (obj)
  96.     (when (send obj :supported-by)
  97.           (format t
  98.                     "Ungrasp ~a~%"
  99.               (send obj :name))
  100.           (setf grasping nil)
  101.           t))
  102.  
  103. (defmethod movable-block :rid-of ()
  104.     (send self :put-on table))
  105.  
  106. (defmethod movable-block :make-space (support)
  107.     (dolist (obstruction (send support :support-for))
  108.         (send obstruction :rid-of)
  109.         (let ((space (send self :find-space support)))
  110.              (when space (return space)))))
  111.  
  112. (defmethod  load-bearing-block :clear-top ()
  113.     (dolist (obstacle support-for) (send obstacle :rid-of))
  114.     t)
  115.  
  116.  
  117. (defmethod hand :move (obj support)
  118.     (send obj :remove-support)
  119.     (let ((newplace (send obj :get-space support)))
  120.          (format t
  121.                   "Move ~a to top of ~a at location ~a.~%"
  122.              (send obj :name)
  123.              (send support :name)
  124.              newplace)
  125.          (setf (send obj :position) newplace)
  126.          (setf position (send obj :top-location)))
  127.     (send support :add-support obj)
  128.     t)
  129.  
  130.  
  131. ; remove-support-for is defined twice, for each load bearing class
  132.  
  133. (defmethod load-bearing-block :remove-support-for (obj)
  134.     (setf support-for (remove obj support-for))
  135.     t)
  136.  
  137. (defmethod table-block :remove-support-for (obj)
  138.     (setf support-for (remove obj support-for))
  139.     t)
  140.  
  141. (defmethod movable-block :remove-support ()
  142.     (when supported-by
  143.           (format t
  144.               "Removing support relations between ~a and ~a.~%"
  145.               (send supported-by :name)
  146.               name)
  147.           (send supported-by :remove-support-for self)
  148.           (setf supported-by nil))
  149.     t)
  150.  
  151. (defmethod load-bearing-block :add-support (obj)
  152.     (format t
  153.         "Adding support relations between ~a and ~a.~%"
  154.         (send obj :name)
  155.         name)
  156.     (setf support-for 
  157.           (cons obj support-for)
  158.           (send obj :supported-by) 
  159.           self)
  160.     t)
  161.  
  162. (defmethod table-block :add-support (obj)
  163.     (format t
  164.         "Adding support relations between ~a and ~a.~%"
  165.         (send obj :name)
  166.         name)
  167.     (setf support-for 
  168.           (cons obj support-for)
  169.           (send obj :supported-by) 
  170.           self)
  171.     t)
  172.  
  173. (defmethod basic-block :add-support (obj)
  174.     t)
  175.  
  176. (defmethod movable-block :find-space (support)
  177.     (dotimes (offset (1+ (- (send support :width) width)))
  178.          (unless (intersections-p self offset
  179.                        (first (send support :position))
  180.                       (send support :support-for))
  181.              (return (list (+ offset (first (send support 
  182.                                    :position)))
  183.                        (+ (second (send support :position))
  184.                           (send support :height)))))))
  185.  
  186. (defun intersections-p (obj offset base obstacles)
  187.     (dolist (obstacle obstacles)
  188.         (let* ((ls-proposed (+ offset base))
  189.             (rs-proposed (+ ls-proposed (send obj :width)))
  190.             (ls-obstacle (first (send obstacle :position)))
  191.             (rs-obstacle (+ ls-obstacle (send obstacle :width))))
  192.               (unless (or (>= ls-proposed rs-obstacle)
  193.                         (<= rs-proposed ls-obstacle))
  194.                   (return t)))))
  195.  
  196.