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