xlisponly/lsp/blocks.lsp

   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