; turtle graphics
(define xpos 0) (define ypos 0) (define pen? #t) (define head 0)
(define (send x . xs)
(cond ((null? xs) (display x) (newline))
(else (display x) (display " ") (apply send xs))))
(define (clearscreen)
(set! xpos 0)
(set! ypos 0)
(set! pen? #t)
(set! head 0)
(send "%!")
(send "initgraphics")
(send "newpath 306 396 moveto")
(send "currentpoint translate")
(send "0 setgray 2 setlinewidth"))
(define (penup) (set! pen? #f))
(define (pendown) (set! pen? #t))
(define (forward n)
(let ((newx (inexact->exact (round
(+ xpos (* n (sin (* head 0.017453292519943295)))))))
(newy (inexact->exact (round
(+ ypos (* n (cos (* head 0.017453292519943295))))))))
(send newx newy (if pen? "lineto" "moveto"))
(set! xpos newx) (set! ypos newy)))
(define (back n)
(let ((newx (inexact->exact (round
(- xpos (* n (sin (* head 0.017453292519943295)))))))
(newy (inexact->exact (round
(- ypos (* n (cos (* head 0.017453292519943295))))))))
(send newx newy (if pen? "lineto" "moveto"))
(set! xpos newx) (set! ypos newy)))
(define (left n) (set! head (modulo (- head n) 360)))
(define (right n) (set! head (modulo (+ head n) 360)))
(define (setpos x y)
(send x y (if pen? "lineto" "moveto"))
(set! xpos x) (set! ypos y))
(define (setheading n) (set! head n))
(define (pos) (values xpos ypos))
(define (heading) head)
(define (done) (send "stroke showpage"))
(define (tree size)
(cond ((< size 5) (forward size) (back size))
(else (forward (/ size 3))
(left 30) (tree (* size 2/3)) (right 30)
(back (/ size 3))
(forward (/ size 2))
(right 25) (tree (/ size 2)) (left 25)
(back (/ size 2))
(forward (* size 5/6))
(right 25) (tree (/ size 2)) (left 25)
(back (* size 5/6)))))
(clearscreen)
(tree 50)
(done)