home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / xl21hos2.zip / TURTLES.LSP < prev    next >
Lisp/Scheme  |  1995-12-27  |  5KB  |  201 lines
  1. #-:classes (load "classes")
  2.  
  3. ; On an IBM PC,  ANSI escape sequences probably won't work unless you use 
  4. ; NNANSI.SYS because the buffered output used bypasses the BIOS.
  5.  
  6. ; This is a sample XLISP program
  7. ; It implements a simple form of programmable turtle for VT100 compatible
  8. ; terminals.
  9.  
  10. ; To run it:
  11.  
  12. ;    A>xlisp turtles
  13.  
  14. ; This should cause the screen to be cleared and two turtles to appear.
  15. ; They should each execute their simple programs and then the prompt
  16. ; should return.  Look at the code to see how all of this works.
  17.  
  18. ; Get some more memory
  19. (expand 1)
  20.  
  21. ; delay a while
  22. #+:times (defun pause (time) 
  23.        (let ((fintime (+ (* time internal-time-units-per-second)
  24.                  (get-internal-run-time))))
  25.         (loop (when (> (get-internal-run-time) fintime)
  26.                 (return-from pause)))))
  27. #-:times (defun pause () (dotimes (x (* time 1000))))
  28.  
  29. (defmacro delay () (pause 0.5))
  30.  
  31.  
  32. ; Clear the screen
  33. (defun clear ()
  34.     (princ "\033[H\033[2J"))
  35.  
  36. ; Move the cursor
  37. (defun setpos (x y)
  38.     (princ "\033[") (princ y) (princ ";") (princ x) (princ "H"))
  39.  
  40. ; Kill the remainder of the line
  41. (defun kill ()
  42.     (princ "\033[K"))
  43.  
  44. ; Move the cursor to the currently set bottom position and clear the line
  45. ;  under it
  46. (defun bottom ()
  47.     (setpos *bx* (+ *by* 1))
  48.     (kill)
  49.     (setpos *bx* *by*)
  50.     (kill))
  51.  
  52. ; Clear the screen and go to the bottom
  53. (defun cb ()
  54.     (clear)
  55.     (bottom))
  56.  
  57.  
  58. ; ::::::::::::
  59. ; :: Turtle ::
  60. ; ::::::::::::
  61.  
  62. ; Define "Turtle" class
  63. (defclass Turtle ((xpos (setq *newx* (+ *newx* 1))) (ypos 12) (char "*")))
  64.  
  65. ; Message ":display" prints its char at its current position
  66. (defmethod Turtle :display () 
  67.     (setpos xpos ypos)
  68.     (princ char)
  69.     (bottom)
  70.     self)
  71.  
  72. ; When the character is set, we want to redisplay
  73. (defmethod Turtle :set-char (c)
  74.     (setq char c)
  75.     (send self :display))
  76.  
  77. ; Message ":char" sets char to its arg and displays it
  78. (defmethod Turtle :set-char (c) 
  79.     (setq char c)
  80.     (send self :display))
  81.  
  82. ; Message ":goto" goes to a new place after clearing old one
  83. (defmethod Turtle :goto (x y)
  84.     (setpos xpos ypos) (princ " ")
  85.     (setq xpos x)
  86.     (setq ypos y)
  87.     (send self :display))
  88.  
  89. ; Message ":up" moves up if not at top
  90. (defmethod Turtle :up ()
  91.     (if (> ypos 0)
  92.     (send self :goto xpos (- ypos 1))
  93.     (bottom)))
  94.  
  95. ; Message ":down" moves down if not at bottom
  96. (defmethod Turtle :down ()
  97.     (if (< ypos *by*)
  98.     (send self :goto xpos (+ ypos 1))
  99.     (bottom)))
  100.  
  101. ; Message ":right" moves right if not at right
  102. (defmethod Turtle :right ()
  103.     (if (< xpos 80)
  104.     (send self :goto (+ xpos 1) ypos)
  105.     (bottom)))
  106.  
  107. ; Message ":left" moves left if not at left
  108. (defmethod Turtle :left ()
  109.     (if (> xpos 0)
  110.     (send self :goto (- xpos 1) ypos)
  111.     (bottom)))
  112.  
  113. ; :::::::::::::::::::
  114. ; :: Circular-List ::
  115. ; :::::::::::::::::::
  116.  
  117.  
  118. ; Define a class to represent a circular list
  119. (defclass Circular-List (prog pc))
  120.  
  121. ; Replace :isnew with something more appropriate
  122. (defmethod Circular-List :isnew (&optional list)
  123.     (setf prog list pc list)
  124.     self)    ; return self
  125.  
  126. ; Method to get next item in list
  127. (defmethod Circular-List :next ()
  128.     (when (null pc) (setq pc prog))
  129.     (prog1 (car pc) (setq pc (cdr pc))))
  130.  
  131.  
  132. ; :::::::::::::
  133. ; :: PTurtle ::
  134. ; :::::::::::::
  135.  
  136. ; Define "PTurtle" programable turtle class
  137. (defclass PTurtle (prog) () Turtle)
  138.  
  139. ; Message ":program" stores a program
  140. (defmethod PTurtle :program (p)
  141.     (setf prog (send Circular-List :new p))
  142.     self)
  143.  
  144. ; Message ":step" executes a single program step
  145. (defmethod PTurtle :step () 
  146.     (when prog (send self (send prog :next)))
  147.     (delay)
  148.     self)
  149.  
  150. ; Message ":step#" steps each turtle program n times
  151. (defmethod PTurtle :step# (n)
  152.     (dotimes (x n) (send self :step))
  153.     self)
  154.  
  155.  
  156. ; ::::::::::::::
  157. ; :: PTurtles ::
  158. ; ::::::::::::::
  159.  
  160. ; Define "PTurtles" class
  161. (defclass PTurtles (Turtles))
  162.  
  163. ; Message ":make" makes a programable turtle and adds it to the collection
  164. (defmethod PTurtles :make (x y &aux newturtle)
  165.     (setq newturtle (send PTurtle :new :xpos x :ypos y))
  166.     (setq Turtles (cons newturtle Turtles))
  167.     newturtle)
  168.  
  169. ; Message ":step" steps each turtle program once
  170. (defmethod PTurtles :step ()
  171.     (mapcar #'(lambda (Turtle) (send Turtle :step)) Turtles)
  172.     self)
  173.  
  174. ; Message ":step#" steps each turtle program n times
  175. (defmethod PTurtles :step# (n)
  176.     (dotimes (x n) (send self :step))
  177.     self)
  178.  
  179.  
  180. ; Initialize things and start up
  181. (defvar *bx* 0)
  182. (defvar *by* 20)
  183. (defvar *newx* 0)
  184.  
  185. ; Create some programmable turtles
  186. (cb)
  187. (definst PTurtles Turtles)
  188. (setq t1 (send Turtles :make 40 10))
  189. (setq t2 (send Turtles :make 41 10))
  190. (send t1 :program '(:left :left :right :right :up :up :down :down))
  191. (send t2 :program '(:right :right :down :down :left :left :up :up))
  192. (send t1 :set-char "+")
  193. (defun doit () 
  194.     (progn
  195.         (cb)
  196.         (send t1 :step# 8)
  197.         (send t2 :step# 8)
  198.         (send Turtles :step# 8)))
  199. (doit)
  200.  
  201.