turtle-r7rs/simple.sld

(define-library (turtle simple)
  (import (turtle turtle3)
          (turtle vector)
          (scheme case-lambda)
          (only (scheme inexact) acos)
          (scheme base))
  (export forward back right left up down
          fd bk rt lt pu pd
          pos set-pos tilt set-tilt
          bg-color line-color line-width
          show hide draw-line home reset-tilt
          repeat xcor ycor setx sety
          clear-screen max-recur face
          distance angle circle)
  (begin
    (define current-tilt 0)
    (define (tilt)
      current-tilt)
    (define (set-tilt theta)
      (yaw! t (- current-tilt))
      (set! current-tilt theta)
      (yaw! t theta))
    (define t (make-turtle))
    (define (home)
      (set-pos 0 0))
    (define (reset-tilt)
      (set-tilt 0))
    (define (show)
      (show! t))
    (define (hide)
      (hide! t))
    (define (forward dist)
      (forward! t dist))
    (define (back dist)
      (forward! t (- dist)))
    (define (right theta)
      (set! current-tilt (- current-tilt theta))
      (yaw! t (- theta)))
    (define (left theta)
      (set! current-tilt (+ current-tilt theta))
      (yaw! t theta))
    (define (up)
      (pen-up! t))
    (define (down)
      (pen-down! t))
    (define fd forward)
    (define bk back)
    (define lt left)
    (define rt right)
    (define pu up)
    (define pd down)
    (define (pos)
      (get-pos t))
    (define (down?)
      (pen-down? t))
    (define face
      (case-lambda
       ((v)
        (face! t v))
       ((x y)
        (face (vector x y)))))
    (define set-pos
      (case-lambda
       ((v)
        (let ((x1 (xcor))
              (y1 (ycor))
              (x2 (vector-ref v 0))
              (y2 (vector-ref v 1)))
          (set-pos! t (vector-append v #(0)))
          (if (down?)
              (draw-line x1 y1 x2 y2))))
       ((x y) (set-pos (vector x y)))))
    (define (xcor)
      (vector-ref (pos) 0))
    (define (ycor)
      (vector-ref (pos) 1))
    (define (setx xval)
      (set-pos (vector (+ xval (xcor))
                       (ycor))))
    (define (sety yval)
      (set-pos (vector (xcor)
                       (+ yval (ycor)))))
    (define (distance A B)
      (vector-distance A B))
    (define (angle A B C)
      (radians->degrees
       (vector-angle (vector-difference B A)
                     (vector-difference B C))))
    (define (circle r)
      (define pi (* 2 (acos 0)))
      (rt 4.5)
      (repeat (40)
        (fd (* 2 pi r 1/40))
        (rt 9))
      (lt 4.5))))