home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / xl21hos2.zip / GBLOCKS.LSP < prev    next >
Lisp/Scheme  |  1995-12-27  |  12KB  |  387 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. (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)
  387.