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