home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / LSP.ZIP / PT.LSP next >
Encoding:
Text File  |  1985-08-22  |  3.9 KB  |  182 lines
  1. ; This is a sample XLISP program.
  2. ; It implements a simple form of programmable turtle for VT100 compatible
  3. ; terminals.
  4.  
  5. ; To run it:
  6.  
  7. ;    A>xlisp pt
  8.  
  9. ; This should cause the screen to be cleared and two turtles to appear.
  10. ; They should each execute their simple programs and then the prompt
  11. ; should return.  Look at the code to see how all of this works.
  12.  
  13. ; Clear the screen
  14. (defun clear ()
  15.     (princ "\e[H\e[J"))
  16.  
  17. ; Move the cursor
  18. (defun setpos (x y)
  19.     (princ "\e[" y ";" x "H"))
  20.  
  21. ; Kill the remainder of the line
  22. (defun kill ()
  23.     (princ "\e[K"))
  24.  
  25. ; Move the cursor to the currently set bottom position and clear the line
  26. ;  under it
  27. (defun bottom ()
  28.     (setpos bx (+ by 1))
  29.     (kill)
  30.     (setpos bx by)
  31.     (kill))
  32.  
  33. ; Clear the screen and go to the bottom
  34. (defun cb ()
  35.     (clear)
  36.     (bottom))
  37.  
  38.  
  39. ; ::::::::::::
  40. ; :: Turtle ::
  41. ; ::::::::::::
  42.  
  43. ; Define "Turtle" class
  44. (setq Turtle (Class 'new))
  45.  
  46. ; Define instance variables
  47. (Turtle 'ivars '(xpos ypos char))
  48.  
  49. ; Answer "isnew" by initing a position and char and displaying.
  50. (Turtle 'answer 'isnew '() '(
  51.     (setq xpos (setq newx (+ newx 1)))
  52.     (setq ypos 12)
  53.     (setq char "*")
  54.     (self 'display)
  55.     self))
  56.  
  57. ; Message "display" prints its char at its current position
  58. (Turtle 'answer 'display '() '(
  59.     (setpos xpos ypos)
  60.     (princ char)
  61.     (bottom)
  62.     self))
  63.  
  64. ; Message "char" sets char to its arg and displays it
  65. (Turtle 'answer 'char '(c) '(
  66.     (setq char c)
  67.     (self 'display)))
  68.  
  69. ; Message "goto" goes to a new place after clearing old one
  70. (Turtle 'answer 'goto '(x y) '(
  71.     (setpos xpos ypos) (princ " ")
  72.     (setq xpos x)
  73.     (setq ypos y)
  74.     (self 'display)))
  75.  
  76. ; Message "up" moves up if not at top
  77. (Turtle 'answer 'up '() '(
  78.     (if (> ypos 0) (
  79.     (self 'goto xpos (- ypos 1)))
  80.     (
  81.     (bottom)))))
  82.  
  83. ; Message "down" moves down if not at bottom
  84. (Turtle 'answer 'down '() '(
  85.     (if (< ypos by) (
  86.     (self 'goto xpos (+ ypos 1)))
  87.     (
  88.     (bottom)))))
  89.  
  90. ; Message "right" moves right if not at right
  91. (Turtle 'answer 'right '() '(
  92.     (if (< xpos 80) (
  93.     (self 'goto (+ xpos 1) ypos))
  94.     (
  95.     (bottom)))))
  96.  
  97. ; Message "left" moves left if not at left
  98. (Turtle 'answer 'left '() '(
  99.     (if (> xpos 0) (
  100.     (self 'goto (- xpos 1) ypos))
  101.     (
  102.     (bottom)))))
  103.  
  104.  
  105. ; :::::::::::::
  106. ; :: PTurtle ::
  107. ; :::::::::::::
  108.  
  109. ; Define "DPurtle" programable turtle class
  110. (setq PTurtle (Class 'new Turtle))
  111.  
  112. ; Define instance variables
  113. (PTurtle 'ivars '(prog pc))
  114.  
  115. ; Message "program" stores a program
  116. (PTurtle 'answer 'program '(p) '(
  117.     (setq prog p)
  118.     (setq pc prog)
  119.     self))
  120.  
  121. ; Message "step" executes a single program step
  122. (PTurtle 'answer 'step '() '(
  123.     (if (null pc) (
  124.     (setq pc prog)))
  125.     (if pc (
  126.     (self (head pc))
  127.     (setq pc (tail pc))))
  128.     self))
  129.  
  130.  
  131. ; ::::::::::::::
  132. ; :: PTurtles ::
  133. ; ::::::::::::::
  134.  
  135. ; Define "PTurtles" class
  136. (setq PTurtles (Class 'new))
  137.  
  138. ; Define instance variables
  139. (PTurtles 'ivars '(turtles))
  140.  
  141. ; Message "make" makes a programable turtle and adds it to the collection
  142. (PTurtles 'answer 'make '(x y / newturtle) '(
  143.     (setq newturtle (PTurtle 'new))
  144.     (newturtle 'goto x y)
  145.     (setq turtles (cons newturtle turtles))
  146.     newturtle))
  147.  
  148. ; Message "step" steps each turtle program once
  149. (PTurtles 'answer 'step '() '(
  150.     (foreach turtle turtles
  151.     (turtle 'step))
  152.     self))
  153.  
  154. ; Message "step:" steps each turtle program n times
  155. (PTurtles 'answer 'step: '(n) '(
  156.     (while n
  157.     (self 'step)
  158.     (setq n (- n 1)))
  159.     self))
  160.  
  161.  
  162. ; Initialize things and start up
  163. (setq bx 0)
  164. (setq by 20)
  165. (setq newx 0)
  166.  
  167. ; Create some programmable turtles
  168. (cb)
  169. (setq turtles (PTurtles 'new))
  170. (setq t1 (turtles 'make 40 10))
  171. (setq t2 (turtles 'make 41 10))
  172. (t1 'program '(left right up down))
  173. (t2 'program '(right left down up))
  174. elf))
  175.  
  176.  
  177. ; ::::::::::::::
  178. ; :: PTurtles ::
  179. ; ::::::::::::::
  180.  
  181. ; Define "PTurtles" class
  182. (setq PTurtles (Cla