xlisponly/lsp/gblocks.lsp

   1 ; Blocks World from Winston&Horn
   2 ; modified for XLISP and graphics by Tom Almy
   3
   4
   5 #-:classes (load "classes")
   6
   7 ;
   8 ; Functions for graphic assistance
   9
  10 (defvar *bx* 0)         ; text communication region
  11 (defvar *by* 21)
  12 (defvar *gx* 50)        ; Graphic region origin
  13 (defvar *gy* 100)
  14 (defvar *ymax* 349)     ; height of display
  15 (defvar *char-width* 8) ; width of characters
  16 (defvar *char-height* 14)       ; height of characters
  17 (defvar *step-size* 10) ; lcd of block widths
  18 (defvar *delay-time* 0.3)       ; delay time in seconds
  19
  20
  21 ; Move the cursor to nearest position to graphic coordiates
  22 #+:math (defun setgpos (x y)
  23      (goto-xy (round (+ x *gx*) *char-width*)
  24               (round (- *ymax* y *gy*) *char-height*)))
  25 #-:math (defun setgpos (x y)
  26      (goto-xy (truncate (/ (+ x *gx*) *char-width*))
  27              (truncate (/ (+ (/ *char-height* 2) (- *ymax* y *gy*))
  28                           *char-height*))))
  29
  30 ; Move the cursor to the currently set bottom position and clear the line
  31 ;  under it
  32 (defun bottom ()
  33     (goto-xy *bx* (+ *by* 1))
  34     (cleol)
  35     (goto-xy *bx* *by*)
  36     (cleol)
  37     (goto-xy *bx* (- *by* 1))
  38     (cleol)
  39     (color 15)  ; Force color to white
  40     nil)
  41
  42 ; Clear the screen and go to the bottom
  43 (defun cb ()
  44     (cls)
  45     (bottom))
  46
  47
  48 ; Go to graphics mode
  49 (defun gmode ()
  50        (mode 16)
  51        (setq *by* 21)
  52        (setq *ymax* 349) ; reset defaults
  53        (setq *char-height* 14))
  54
  55 (defun gmode480 () ; this is for GENOA SuperEGA HiRes+
  56        (mode 115 115 640 480)
  57        (setq *ymax* 480)
  58        (setq *by* 21)
  59        (setq *char-height* 8))
  60
  61 (defun gmode600 () ; this is for GENOA SuperEGA HiRes+
  62        (mode 121 121 800 600)
  63        (setq *by* 21)
  64        (setq *ymax* 600)
  65        (setq *char-height* 8))
  66
  67 (defun gmodev () ; EVEREX 640x480 mode
  68        (setq *by* 21)
  69        (mode 112 0 640 480)
  70        (setq *ymax* 480)
  71        (setq *char-height* 14)
  72        (display-blocks))
  73
  74 (defun gmodeVGA800 () ; this is for Video 7 FastWrite/VRAM VGA
  75        (mode 28421 98 800 600)
  76        (setq *by* 21)
  77        (setq *ymax* 600)
  78        (setq *char-height* 8)
  79        (display-blocks))
  80
  81 (defun gmodeVGA (&aux dims) ; standard 640x480 VGA
  82                             ; Modified so it will work in Windows as well
  83        (setq dims (mode 18))
  84        (setq *ymax* (1+ (fourth dims)))
  85        (setq *by* 9)
  86 #+:math  (setq *char-height* (truncate (1+ (fourth dims)) (second dims)))
  87 #+:math  (setq *char-width* (truncate (1+ (third dims)) (first dims)))
  88 #-:math  (setq *char-height* (truncate (/ (1+ (fourth dims)) (second dims))))
  89 #-:math  (setq *char-width* (truncate (/ (1+ (third dims)) (first dims))))
  90        (setq *gy* (truncate (* 2.5 *char-height*)))
  91        (display-blocks))
  92
  93 ; abstract classes for ball types
  94
  95 ; basic blocks support nothing
  96 (defclass basic-block (name color width height position supported-by))
  97
  98 (defmethod basic-block :support-for () nil)
  99
 100 (defmethod basic-block :top-location  ()
 101         (list (+ (first position) (/ width 2))
 102               (+ (second position) height)))
 103
 104 (defmethod basic-block :drawname ()
 105         (setgpos (+ (first position)
 106                     (/ (- width (* *char-width* (flatc name))) 2))
 107                  (+ (second position) (/ height 2)))
 108         (color color) ; For Windows, which does color text
 109         (princ name))
 110
 111 (defmethod basic-block :undrawname ()
 112         (setgpos (+ (first position)
 113                     (/ (- width (* *char-width* (flatc name))) 2))
 114                  (+ (second position) (/ height 2)))
 115         (dotimes (i (flatc name)) (princ " ")))
 116
 117 (defmethod basic-block :draw ()
 118         (color (+ color 128))
 119         (move (+ *gx* (first position)) (+ *gy* (second position)))
 120         (drawrel (1- width) 0
 121                  0 (1- height)
 122                  (- 1 width) 0
 123                  0 (- 1 height)))
 124
 125 ; movable-blocks can be moved
 126 (defclass movable-block () () basic-block)
 127
 128 (defmethod movable-block :new-position (newpos)
 129         (send self :draw)
 130         (send self :undrawname)
 131         (setf position newpos)
 132         (send self :drawname)
 133         (send self :draw))
 134
 135 ; load-bearing blocks can support other blocks, and can be moved
 136 (defclass load-bearing-block (support-for) () movable-block)
 137
 138 ; we can't have multiple inheritance, so we need a separate class for table
 139 ; table blocks can support other blocks but cannot be moved.
 140
 141 (defclass table-block (support-for) () basic-block)
 142
 143 ; Specific classes for table brick wedge and ball
 144
 145 (defclass brick () () load-bearing-block)
 146
 147 (defclass wedge () () movable-block)
 148
 149 (defmethod wedge :draw ()
 150         (color (+ color 128))
 151         (move (+ *gx* (first position)) (+ *gy* (second position)))
 152         (drawrel (1- width) 0
 153                  (- 1 (/ width 2)) (1- height )
 154                  (- (/ width 2) width 1) (- 1 height)))
 155
 156 (defclass ball  () () movable-block)
 157
 158 (defmethod ball :draw ()
 159         (color (+ color 128))
 160         (let ((cx (+ (first position) (/ width 2) -1 *gx*))
 161               (cy (+ (second position) (/ height 2) -1 *gy*))
 162               (fstep (/ 3.14159 18))
 163               (radius (1- (/ (min width height) 2))))
 164              (move (+ cx radius) cy)
 165              (dotimes (i 36)
 166                       (draw (truncate (+ cx (* radius (cos (* (1+ i) fstep)))))
 167                             (truncate (+ cy (* radius (sin (* (1+ i) fstep)))))))))
 168
 169 (defclass hand  (name position grasping))
 170
 171 (defmethod hand :top-location  () position)
 172
 173 (defmethod hand :draw ()
 174         (color (if grasping 143 136))
 175         (move (+ *gx* -7 (first position)) (+ *gy* (second position)))
 176         (drawrel 5 0 0 10 5 0 0 -10 5 0 0 20 -15 0 0 -20))
 177
 178 (defmethod hand :new-position (newpos)
 179         (send self :draw)
 180         (setf position newpos)
 181         (send self :draw))
 182
 183 ; define all the individual blocks
 184
 185 (setf *blocks*
 186       (list
 187         (send table-block :new :name 'table :width 430 :height 10
 188                                :position '(0 0) :color 7)
 189         (send brick :new :name 'b1 :width 40 :height 40
 190                                :position '(0 10) :color 1)
 191         (send brick :new :name 'b2 :width 40 :height 40
 192                                :position '(40 10) :color 2)
 193         (send brick :new :name 'b3 :width 80 :height 80
 194                                :position '(80 10) :color 3)
 195         (send brick :new :name 'b4 :width 40 :height 40
 196                                :position '(160 10) :color 4)
 197         (send wedge :new :name 'w5 :width 40 :height 80
 198                                :position '(200 10) :color 5)
 199         (send brick :new :name 'b6 :width 80 :height 40
 200                                :position '(240 10) :color 6)
 201         (send wedge :new :name 'w7 :width 40 :height 40
 202                                :position '(320 10) :color 9)
 203         (send ball  :new :name 'l8 :width 40 :height 40
 204                                :position '(360 10) :color 10)
 205         (send brick :new :name 'b9 :width 30 :height 30
 206                                :position '(400 10) :color 12)
 207        ))
 208
 209 (dolist (l *blocks*) (set (send l :name) l))
 210
 211 (dolist (l (rest *blocks*)) ; all blocks but the table
 212         (setf (send table :support-for)
 213               (cons l (send table :support-for))
 214               (send l :supported-by)
 215               table))
 216
 217 (definst hand *hand* :name '*hand* :position '(0 120))
 218
 219 (defun display-blocks ()
 220         (cls)
 221         (dolist (l *blocks*) (send l :drawname)(send l :draw))
 222         (send *hand* :draw)
 223         (bottom)
 224         t)
 225
 226 (defmethod basic-block :put-on (support) ; default case is bad
 227         (format t
 228                 "Sorry, the ~a cannot be moved.~%"
 229                 name))
 230
 231 (defmethod movable-block :put-on (support)
 232         (if (send self :get-space support)
 233             (and (send *hand* :grasp self)
 234                  (send *hand* :move  self support)
 235                  (send *hand* :ungrasp self))
 236             (format t
 237                     "Sorry, there is no room for ~a on ~a.~%"
 238                     name
 239                     (send support :name))))
 240
 241 (defmethod movable-block :get-space (support)
 242         (or (send self :find-space support)
 243             (send self :make-space support)))
 244
 245 (defmethod hand :grasp (obj)
 246         (unless (eq grasping obj)
 247                 (when (send obj :support-for)
 248                       (send obj :clear-top))
 249                 (when grasping
 250                       (send grasping :rid-of))
 251                 (let ((lift (max-height self obj)))
 252                      (send self :new-position lift)
 253                      (pause *delay-time*)
 254                      (send self :new-position
 255                         (list (first (send obj :top-location)) (second lift)))
 256                      (pause *delay-time*)
 257                      (send self :new-position (send obj :top-location))
 258                      (pause *delay-time*))
 259                 (send self :draw)
 260                 (setf grasping obj)
 261                 (send self :draw))
 262         t)
 263
 264 (defmethod hand :ungrasp (obj)
 265         (when (send obj :supported-by)
 266               (send self :draw)
 267               (setf grasping nil)
 268               (send self :draw)
 269               t))
 270
 271
 272 (defmethod movable-block :rid-of ()
 273         (send self :put-on table))
 274
 275 (defmethod movable-block :make-space (support)
 276         (dolist (obstruction (send support :support-for))
 277                 (send obstruction :rid-of)
 278                 (let ((space (send self :find-space support)))
 279                      (when space (return space)))))
 280
 281 (defmethod  load-bearing-block :clear-top ()
 282         (dolist (obstacle support-for) (send obstacle :rid-of))
 283         t)
 284
 285
 286 (defmethod hand :move (obj support)
 287         (send obj :remove-support)
 288         (let ((newplace (send obj :get-space support)))
 289           (let ((lift (max-height obj support)))
 290              (send obj :new-position lift)
 291              (send self :new-position (send obj :top-location))
 292              (pause *delay-time*)
 293              (send obj :new-position (list (first newplace) (second lift)))
 294              (send self :new-position (send obj :top-location))
 295              (pause *delay-time*)
 296              (send obj :new-position newplace)
 297              (send self :new-position (send obj :top-location))
 298              (pause *delay-time*)))
 299         (send support :add-support obj)
 300         t)
 301
 302
 303 ; helper function to find height necessary to move object
 304
 305 (defun max-height (obj1 obj2)
 306         (let    ((source (first (send obj1 :top-location)))
 307                  (dest   (first (send obj2 :top-location))))
 308         (let    ((roof 0) (min (min source dest)) (max (max source dest)) )
 309                 (dolist (obstacle *blocks*)
 310                         (let ((x (send obstacle :top-location)))
 311                              (when (and (>= (first x) min)
 312                                         (<= (first x) max)
 313                                         (> (second x) roof))
 314                                    (setf roof (second x)))))
 315                 (list (first (send obj1 :position)) (+ 20 roof)))))
 316
 317 #+:times (defun pause (time)
 318            (let ((fintime (+ (* time internal-time-units-per-second)
 319                              (get-internal-run-time))))
 320                 (loop (when (> (get-internal-run-time) fintime)
 321                             (return-from pause)))))
 322 #-:times (defun pause () (dotimes (x (* time 1000))))
 323
 324
 325 ; remove-support-for is defined twice, for each load bearing class
 326
 327 (defmethod load-bearing-block :remove-support-for (obj)
 328         (setf support-for (remove obj support-for))
 329         t)
 330
 331 (defmethod table-block :remove-support-for (obj)
 332         (setf support-for (remove obj support-for))
 333         t)
 334
 335 (defmethod movable-block :remove-support ()
 336         (when supported-by
 337               (send supported-by :remove-support-for self)
 338               (setf supported-by nil))
 339         t)
 340
 341
 342
 343 (defmethod load-bearing-block :add-support (obj)
 344         (setf support-for
 345               (cons obj support-for)
 346               (send obj :supported-by)
 347               self)
 348         t)
 349
 350 (defmethod table-block :add-support (obj)
 351         (setf support-for
 352               (cons obj support-for)
 353               (send obj :supported-by)
 354               self)
 355         t)
 356
 357 (defmethod basic-block :add-support (obj)
 358         t)
 359
 360 (defmethod movable-block :find-space (support)
 361         (do     ((offset (- (send support :width) width)
 362                          (- offset *step-size*)))
 363                 ((< offset 0))
 364                  (unless (intersections-p self offset
 365                                           (first (send support :position))
 366                                           (send support :support-for))
 367                          (return (list (+ offset (first (send support
 368                                                               :position)))
 369                                        (+ (second (send support :position))
 370                                           (send support :height)))))))
 371
 372 (defun intersections-p (obj offset base obstacles)
 373         (dolist (obstacle obstacles)
 374                 (let* ((ls-proposed (+ offset base))
 375                         (rs-proposed (+ ls-proposed (send obj :width)))
 376                         (ls-obstacle (first (send obstacle :position)))
 377                         (rs-obstacle (+ ls-obstacle (send obstacle :width))))
 378                       (unless (or (>= ls-proposed rs-obstacle)
 379                                   (<= rs-proposed ls-obstacle))
 380                               (return t)))))
 381
 382
 383 (defun m (a b) (send a :put-on b) (bottom))
 384 (defun d () (display-blocks))
 385 (gmodeVGA)
 386 (d)