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