home *** CD-ROM | disk | FTP | other *** search
/ The C Users' Group Library 1994 August / wc-cdrom-cusersgrouplibrary-1994-08.iso / vol_100 / 176_01 / pcturtle.lsp < prev    next >
Text File  |  1986-01-06  |  4KB  |  153 lines
  1. ; This is a sample XLISP program
  2. ; It implements a simple form of programmable turtle for IBM-PC compatible
  3. ; machines.
  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. ; Get some more memory
  14. (expand 1)
  15.  
  16. ; Move the cursor to the currently set bottom position and clear the line
  17. ;  under it
  18. (defun bottom ()
  19.     (set-cursor by bx)
  20.     (clear-eos))
  21.  
  22. ; Clear the screen and go to the bottom
  23. (defun cb ()
  24.     (clear)
  25.     (bottom))
  26.  
  27.  
  28. ; ::::::::::::
  29. ; :: Turtle ::
  30. ; ::::::::::::
  31.  
  32. ; Define "Turtle" class
  33. (setq Turtle (Class :new '(xpos ypos char)))
  34.  
  35. ; Answer ":isnew" by initing a position and char and displaying.
  36. (Turtle :answer :isnew '() '(
  37.     (setq xpos (setq newx (+ newx 1)))
  38.     (setq ypos 12)
  39.     (setq char "*")
  40.     (self :display)
  41.     self))
  42.  
  43. ; Message ":display" prints its char at its current position
  44. (Turtle :answer :display '() '(
  45.     (set-cursor ypos xpos)
  46.     (princ char)
  47.     (bottom)
  48.     self))
  49.  
  50. ; Message ":char" sets char to its arg and displays it
  51. (Turtle :answer :char '(c) '(
  52.     (setq char c)
  53.     (self :display)))
  54.  
  55. ; Message ":goto" goes to a new place after clearing old one
  56. (Turtle :answer :goto '(x y) '(
  57.     (set-cursor ypos xpos) (princ " ")
  58.     (setq xpos x)
  59.     (setq ypos y)
  60.     (self :display)))
  61.  
  62. ; Message ":up" moves up if not at top
  63. (Turtle :answer :up '() '(
  64.     (if (> ypos 1)
  65.     (self :goto xpos (- ypos 1))
  66.     (bottom))))
  67.  
  68. ; Message ":down" moves down if not at bottom
  69. (Turtle :answer :down '() '(
  70.     (if (< ypos by)
  71.     (self :goto xpos (+ ypos 1))
  72.     (bottom))))
  73.  
  74. ; Message ":right" moves right if not at right
  75. (Turtle :answer :right '() '(
  76.     (if (< xpos 80)
  77.     (self :goto (+ xpos 1) ypos)
  78.     (bottom))))
  79.  
  80. ; Message ":left" moves left if not at left
  81. (Turtle :answer :left '() '(
  82.     (if (> xpos 1)
  83.     (self :goto (- xpos 1) ypos)
  84.     (bottom))))
  85.  
  86.  
  87. ; :::::::::::::
  88. ; :: PTurtle ::
  89. ; :::::::::::::
  90.  
  91. ; Define "DPurtle" programable turtle class
  92. (setq PTurtle (Class :new '(prog pc) '() Turtle))
  93.  
  94. ; Message ":program" stores a program
  95. (PTurtle :answer :program '(p) '(
  96.     (setq prog p)
  97.     (setq pc prog)
  98.     self))
  99.  
  100. ; Message ":step" executes a single program step
  101. (PTurtle :answer :step '() '(
  102.     (if (null pc)
  103.     (setq pc prog))
  104.     (if pc
  105.     (progn (self (car pc))
  106.            (setq pc (cdr pc))))
  107.     self))
  108.  
  109. ; Message ":step#" steps each turtle program n times
  110. (PTurtle :answer :step# '(n) '(
  111.     (dotimes (x n) (self :step))
  112.     self))
  113.  
  114.  
  115. ; ::::::::::::::
  116. ; :: PTurtles ::
  117. ; ::::::::::::::
  118.  
  119. ; Define "PTurtles" class
  120. (setq PTurtles (Class :new '(turtles)))
  121.  
  122. ; Message ":make" makes a programable turtle and adds it to the collection
  123. (PTurtles :answer :make '(x y &aux newturtle) '(
  124.     (setq newturtle (PTurtle :new))
  125.     (newturtle :goto x y)
  126.     (setq turtles (cons newturtle turtles))
  127.     newturtle))
  128.  
  129. ; Message ":step" steps each turtle program once
  130. (PTurtles :answer :step '() '(
  131.     (mapcar '(lambda (turtle) (turtle :step)) turtles)
  132.     self))
  133.  
  134. ; Message ":step#" steps each turtle program n times
  135. (PTurtles :answer :step# '(n) '(
  136.     (dotimes (x n) (self :step))
  137.     self))
  138.  
  139.  
  140. ; Initialize things and start up
  141. (setq bx 1)
  142. (setq by 21)
  143. (setq newx 1)
  144.  
  145. ; Create some programmable turtles
  146. (cb)
  147. (setq turtles (PTurtles :new))
  148. (setq t1 (turtles :make 40 10))
  149. (setq t2 (turtles :make 41 10))
  150. (t1 :program '(:left :right :up :down))
  151. (t2 :program '(:right :left :down :up))
  152.  
  153.