xlisponly/lsp/turtles.lsp

   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