[net.sources] a sample xlisp program

betz (01/06/83)

; turtle.lsp - a sample xlisp program that implements a simple form
; of turtle graphics for DEC VT125 and GIGI terminals

; to run:

;	> (load "turtle.lsp")
;	> (draw 2 2)

;    from within xlisp



; initialize the ReGIS screen
(defun clear ()
    (print "\ePpS(E)\e\\")
)

; define the turtle object class
(setq turtle (class 'new))
(turtle 'ivars '(xpos ypos head))
(turtle 'answer 'isnew '() '(
    (self 'home)
    self
))
(turtle 'answer 'home '() '(
    (setq xpos 384)
    (setq ypos 240)
    (setq head 2)
))
(turtle 'answer 'left '(n) '(
    (setq head (% (+ head n) 8))
))
(turtle 'answer 'right '(n) '(
    (setq head (% (+ head (- 8 (% n 8))) 8))
))
(turtle 'answer 'forward '(n) '(
    (move head n)
))
(turtle 'answer 'backward '(n) '(
    (move (% (+ head 4) 8) n)
))

; current turtle functions
(defun tell (t)		; set the current turtle
    (setq cturtle t)
)
(defun home ()		; home the current turtle
    (cturtle 'home)
)
(defun left (n)		; turn the current turtle left
    (cturtle 'left n)
)
(defun right (n)	; turn the current turtle right
    (cturtle 'right n)
)
(defun forward (n)	; move the current turtle forward
    (cturtle 'forward n)
)
(defun backward (n)	; move the current turtle backward
    (cturtle 'backward n)
)

; function to move the turtle
(defun move (dir n)
    (print "\ePpP[" xpos "," ypos "]V(W(M" n "))" dir "\e\\")
    (if (== dir 0) (
	(setq xpos (+ xpos n))
    ))
    (if (== dir 1) (
	(setq xpos (+ xpos n))
	(setq ypos (- ypos n))
    ))
    (if (== dir 2) (
	(setq ypos (- ypos n))
    ))
    (if (== dir 3) (
	(setq xpos (- xpos n))
	(setq ypos (- ypos n))
    ))
    (if (== dir 4) (
	(setq xpos (- xpos n))
    ))
    (if (== dir 5) (
	(setq xpos (- xpos n))
	(setq ypos (+ ypos n))
    ))
    (if (== dir 6) (
	(setq ypos (+ ypos n))
    ))
    (if (== dir 7) (
	(setq xpos (+ xpos n))
	(setq ypos (+ ypos n))
    ))
)

; some sample turtle functions
(defun square (n)
    (squarex n 4)
)
(defun squarex (n c)
    (if c (
	(forward n)
	(right 2)
	(squarex n (- c 1))
    ))
)
(defun design (n)
    (designx n 8)
)
(defun designx (n c)
    (if c (
	(square n)
	(right 1)
	(designx n (- c 1))
    ))
)
(defun bigdesign (c)
    (bigdesignx c 10)
)
(defun bigdesignx (c n)
    (if c (
	(design n)
	(bigdesignx (- c 1) (+ n 10))
    ))
)
(defun draw (n1 n2)
    (setq t1 (turtle 'new))
    (setq t2 (turtle 'new))
    (tell t1)
    (forward 100)
    (right 2)
    (forward 50)
    (bigdesign n1)
    (tell t2)
    (right 4)
    (forward 100)
    (right 2)
    (forward 50)
    (bigdesign n2)
)