; 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)