From 1be78ec7ab0040d4641271141dab3c87d775c49e Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Fri, 24 Jul 2009 20:46:54 +0000
Subject: [PATCH] PR 10343

svn: r15553
---
 .../graphics/scribblings/value-turtles.scrbl  |   2 +-
 collects/graphics/turtle-sig.ss               |  32 --
 collects/graphics/turtle-unit.ss              | 473 ----------------
 collects/graphics/turtles.ss                  | 506 +++++++++++++++++-
 4 files changed, 500 insertions(+), 513 deletions(-)
 delete mode 100644 collects/graphics/turtle-sig.ss
 delete mode 100644 collects/graphics/turtle-unit.ss

diff --git a/collects/graphics/scribblings/value-turtles.scrbl b/collects/graphics/scribblings/value-turtles.scrbl
index db8edad09d..2976ed2982 100644
--- a/collects/graphics/scribblings/value-turtles.scrbl
+++ b/collects/graphics/scribblings/value-turtles.scrbl
@@ -78,7 +78,7 @@ only the line drawings of the first turtles argument.}
 
 @section[#:tag "value-examples"]{Examples}
 
-@defmodule[graphics/value-turtle-examples]
+@defmodule[graphics/value-turtles-examples]
 
 The @schememodname[graphics/value-turtle-examples] library is similar
 to @schememodname[graphics/turtle-examples], but using
diff --git a/collects/graphics/turtle-sig.ss b/collects/graphics/turtle-sig.ss
deleted file mode 100644
index b49e359269..0000000000
--- a/collects/graphics/turtle-sig.ss
+++ /dev/null
@@ -1,32 +0,0 @@
-#lang scheme/signature
-
-turtles
-clear home
-turn turn/radians
-move move-offset
-draw draw-offset
-erase erase-offset
-
-save-turtle-bitmap
-
-splitfn split*fn tpromptfn
-turtle-window-size
-
-display-lines-in-drawing
-
-(define-syntaxes (split)
-  (lambda (x)
-    (syntax-case x ()
-      ((_ args ...)
-       (syntax (splitfn (lambda () args ...)))))))
-
-(define-syntaxes (split*)
-  (syntax-rules ()
-    [(_ e0 e ...)
-     (split*fn (list (lambda () e0) (lambda () e) ...))]))
-
-(define-syntaxes (tprompt)
-  (lambda (x)
-    (syntax-case x ()
-      ((_ e1 ...)
-       (syntax (tpromptfn (lambda () e1 ...)))))))
diff --git a/collects/graphics/turtle-unit.ss b/collects/graphics/turtle-unit.ss
deleted file mode 100644
index 94d813033e..0000000000
--- a/collects/graphics/turtle-unit.ss
+++ /dev/null
@@ -1,473 +0,0 @@
-#lang scheme/unit
-
-(require mred/mred-sig
-         mzlib/class
-         mzlib/class100
-         mzlib/list
-         mzlib/etc
-         "turtle-sig.ss")
-
-(import [prefix mred: mred^])
-(export turtle^)
-(init-depend mred^)
-
-(define turtles:window #f)
-(define turtles:shown? #f)
-
-(define pi 3.141592653589793)
-(define pi/2 (/ pi 2))
-
-(define icon-pen (send mred:the-pen-list find-or-create-pen "SALMON" 1 'xor))
-(define icon-brush (send mred:the-brush-list find-or-create-brush "SALMON" 'xor))
-(define blank-pen (send mred:the-pen-list find-or-create-pen "BLACK" 1 'transparent))
-(define w-pen (send mred:the-pen-list find-or-create-pen "white" 1 'solid))
-(define b-pen (send mred:the-pen-list find-or-create-pen "black" 1 'solid))
-
-(define show-turtle-icons? #t)
-
-;; turtle-style : (union 'triangle 'line 'empty)
-(define turtle-style 'triangle)
-
-(define plot-window%
-  (class100 mred:frame% (name width height)
-    
-    (private-field
-     [bitmap (make-object mred:bitmap% width height #t)])      
-    
-    (inherit show)
-    (private-field
-     [memory-dc (make-object mred:bitmap-dc%)]
-     [pl (make-object mred:point% 0 0)]
-     [pr (make-object mred:point% 0 0)]
-     [ph (make-object mred:point% 0 0)]
-     [points (list pl pr ph)])
-    (public
-      [get-canvas
-       (lambda ()
-         canvas)]
-      [flip-icons
-       (lambda ()
-         (case turtle-style
-           [(triangle line)
-            (flatten (lambda (x) x))
-            (let* ([dc (send canvas get-dc)]
-                   [proc
-                    (if (eq? turtle-style 'line)
-                        (lambda (turtle)
-                          (let ([x (turtle-x turtle)]
-                                [y (turtle-y turtle)]
-                                [theta (turtle-angle turtle)]
-                                [size 2])
-                            (send dc draw-line
-                                  x y
-                                  (+ x (* size (cos theta)))
-                                  (+ y (* size (sin theta))))))
-                        (lambda (turtle)
-                          (let* ([x (turtle-x turtle)]
-                                 [y (turtle-y turtle)]
-                                 [theta (turtle-angle turtle)]
-                                 [long-size 20]
-                                 [short-size 7]
-                                 [l-theta (+ theta pi/2)]
-                                 [r-theta (- theta pi/2)])
-                            (send ph set-x (+ x (* long-size (cos theta))))
-                            (send ph set-y (+ y (* long-size (sin theta))))
-                            (send pl set-x (+ x (* short-size (cos l-theta))))
-                            (send pl set-y (+ y (* short-size (sin l-theta))))
-                            (send pr set-x (+ x (* short-size (cos r-theta))))
-                            (send pr set-y (+ y (* short-size (sin r-theta))))
-                            (send dc draw-polygon points))))])
-              (if (eq? turtle-style 'line)
-                  (send dc set-pen icon-pen)
-                  (begin
-                    (send dc set-pen blank-pen)
-                    (send dc set-brush icon-brush)))
-              (for-each proc turtles-state)
-              (send dc set-pen b-pen))]
-           [else
-            (void)]))]
-      [clear
-       (lambda () 
-         (send memory-dc clear)
-         (send canvas on-paint))])
-    (sequence
-      (send memory-dc set-bitmap bitmap)
-      (send memory-dc clear)
-      (super-init name #f width height))
-    
-    (public
-      [on-menu-command (lambda (op) (turtles #f))])
-    (private-field
-     [menu-bar (make-object mred:menu-bar% this)]
-     [file-menu (make-object mred:menu% "File" menu-bar)])
-    (sequence 
-      (make-object mred:menu-item%
-                   "Print"
-                   file-menu
-                   (lambda (_1 _2)
-                     (print)))
-      (make-object mred:menu-item%
-                   "Close"
-                   file-menu
-                   (lambda (_1 _2)
-                     (turtles #f))))
-    
-    (public
-      [save-turtle-bitmap
-       (lambda (fn type)
-         (send bitmap save-file fn type))])
-    
-    (private-field
-     [canvas% 
-      (class100 mred:canvas% args
-        (inherit get-dc)
-        (override
-          [on-paint
-           (lambda ()
-             (let ([dc (get-dc)])
-               (send dc clear)
-               (send dc draw-bitmap (send memory-dc get-bitmap) 0 0)
-               (flip-icons)))])
-        (sequence (apply super-init args)))]
-     [canvas (make-object canvas% this)]
-     [dc (send canvas get-dc)])
-    
-    (public
-      [wipe-line (lambda (a b c d)
-                   (send memory-dc set-pen w-pen)
-                   (send dc set-pen w-pen)
-                   (send memory-dc draw-line a b c d)
-                   (send dc draw-line a b c d)
-                   (send memory-dc set-pen b-pen)
-                   (send dc set-pen b-pen))]
-      [draw-line (lambda (a b c d)
-                   (send memory-dc draw-line a b c d)
-                   (send dc draw-line a b c d))])
-    (sequence
-      (send canvas min-width width)
-      (send canvas min-height height)
-      (send this clear))))
-
-(define turtle-window-size
-  (let-values ([(w h) (mred:get-display-size)]
-               [(user/client-offset) 65]
-               [(default-size) 800])
-    (min default-size
-         (- w user/client-offset)
-         (- h user/client-offset))))
-
-(define-struct turtle (x y angle))
-                                        ; x : int
-                                        ; y: int
-                                        ; angle : int
-
-(define-struct cached (turtles cache))
-                                        ; turtles : (list-of turtle)
-                                        ; cache : turtle -> turtle
-
-(define-struct tree (children))
-                                        ; children : (list-of cached)
-
-(define clear-turtle (make-turtle (/ turtle-window-size 2)
-                                  (/ turtle-window-size 2) 0))
-
-;; turtles-state is either a
-;;    - (list-of turtle) or
-;;    - tree 
-(define turtles-state (list clear-turtle))
-
-;; the cache contains a turtle-offset, which is represented
-;; by a turtle -- but it is a delta not an absolute.
-(define empty-cache (make-turtle 0 0 0))
-(define turtles-cache empty-cache)
-
-(define init-error (lambda _ (error 'turtles "Turtles not initialized. Evaluate (turtles).")))
-(define inner-line init-error)
-(define inner-wipe-line init-error)
-(define inner-clear-window init-error)
-(define inner-flip-icons init-error)
-(define inner-save-turtle-bitmap init-error)
-
-(define line
-  (lambda (a b c d)
-    (set! lines-in-drawing (cons (make-draw-line a b c d) lines-in-drawing))
-    (inner-line a b c d)))
-(define do-wipe-line
-  (lambda (a b c d)
-    (set! lines-in-drawing (cons (make-wipe-line a b c d) lines-in-drawing))
-    (inner-wipe-line a b c d)))
-(define (flip-icons) (inner-flip-icons))
-
-(define clear-window (lambda () (inner-clear-window)))
-(define save-turtle-bitmap (lambda (x y) (inner-save-turtle-bitmap x y)))
-
-(define turtles
-  (case-lambda
-   [() (turtles #t)]
-   [(x)
-    (set! turtles:shown? x)
-    (unless turtles:window
-      (set! turtles:window
-            (make-object plot-window%
-                         "Turtles"
-                         turtle-window-size
-                         turtle-window-size))
-      (set! inner-line (lambda x (send turtles:window draw-line . x)))
-      (set! inner-wipe-line (lambda x (send turtles:window wipe-line . x)))
-      (set! inner-clear-window (lambda x (send turtles:window clear . x)))
-      (set! inner-save-turtle-bitmap (lambda x (send turtles:window save-turtle-bitmap . x)))
-      (set! flip-icons (lambda x (send turtles:window flip-icons . x))))
-    (send turtles:window show x)
-    (send turtles:window get-canvas)]))
-
-(define clear 
-  (lambda ()
-    (set! turtles-cache empty-cache)
-    (set! turtles-state (list clear-turtle))
-    (set! lines-in-drawing null)
-    (clear-window)))
-
-(define home
-  (lambda ()
-    (flip-icons)
-    (set! turtles-cache empty-cache)
-    (set! turtles-state (list clear-turtle))
-    (flip-icons)))
-
-;; cache elements:
-(define-struct c-forward (distance))
-(define-struct c-turn (angle))
-(define-struct c-draw (distance))
-(define-struct c-offset (x y))
-
-;; combines a cache-element and a turtle-offset.
-;; turtle-offsets are represented as turtles, 
-;; however they are deltas, not absolutes.
-(define combine
-  (lambda (entry cache)
-    (cond 
-     [(c-forward? entry)
-      (let* ([n (c-forward-distance entry)]
-             [angle (turtle-angle cache)]
-             [x (turtle-x cache)]
-             [y (turtle-y cache)]
-             [newx (+ x (* n (cos angle)))]
-             [newy (+ y (* n (sin angle)))])
-        (make-turtle newx newy angle))]
-     [(c-offset? entry)
-      (let* ([tx (turtle-x cache)]
-             [ty (turtle-y cache)]
-             [newx (+ tx (c-offset-x entry))]
-             [newy (+ ty (c-offset-y entry))])
-        (make-turtle newx newy 
-                     (turtle-angle cache)))]
-     [(c-turn? entry)
-      (make-turtle (turtle-x cache)
-                   (turtle-y cache)
-                   (- (turtle-angle cache)
-                      (c-turn-angle entry)))]
-     [else
-      (error 'turtles-cache "illegal entry in cache: ~a" entry)])))
-
-;; this applies an offset to a turtle.
-;; an offset is a turtle, representing what would happen 
-;;    if the turtle had started at zero.
-(define apply-cache
-  (lambda (offset)
-    (let ([x (turtle-x offset)]
-          [y (turtle-y offset)]
-          [offset-angle (turtle-angle offset)])
-      (lambda (turtle)
-        (let* ([angle (turtle-angle turtle)])
-          (let* ([c (cos angle)]
-                 [s (sin angle)]
-                 [rx (- (* x c) (* y s))]
-                 [ry (+ (* y c) (* x s))])
-            (make-turtle (+ rx (turtle-x turtle))
-                         (+ ry (turtle-y turtle))
-                         (+ offset-angle angle))))))))
-
-(define flatten
-  (lambda (at-end)
-    (letrec ([walk-turtles
-              (lambda (turtles cache list)
-                (cond
-                 [(tree? turtles)
-                  (let ([children (tree-children turtles)]
-                        [ac (apply-cache cache)])
-                    (foldl (lambda (child list)
-                             (walk-turtles (cached-turtles child)
-                                           (ac (cached-cache child))
-                                           list))
-                           list
-                           children))]
-                 [else
-                  (let ([f (compose at-end (apply-cache cache))])
-                    (foldl (lambda (t l) (cons (f t) l)) list turtles))]))])
-      (set! turtles-state (walk-turtles turtles-state turtles-cache null))
-      (set! turtles-cache empty-cache))))
-
-(define draw/erase
-  (lambda (doit)
-    (lambda (n)
-      (flip-icons)
-      (flatten
-       (lambda (turtle)
-         (let* ([x (turtle-x turtle)]
-                [y (turtle-y turtle)]
-                [angle (turtle-angle turtle)]
-                [d (if (zero? n) 0 (sub1 (abs n)))]
-                [res (if (< n 0) (- d) d)]
-                [c (cos angle)]
-                [s (sin angle)]
-                [drawx (+ x (* res c))]
-                [drawy (+ y (* res s))]
-                [newx (+ x (* n c))]
-                [newy (+ y (* n s))])
-           (unless (zero? n)
-             (doit x y drawx drawy))
-           (make-turtle newx newy angle))))
-      (flip-icons))))
-
-(define draw (draw/erase (lambda (a b c d) (line a b c d))))
-(define erase (draw/erase (lambda (a b c d) (do-wipe-line a b c d))))
-
-(define move
-  (lambda (n)
-    (flip-icons)
-    (set! turtles-cache (combine (make-c-forward n) turtles-cache))
-    (flip-icons)))
-
-(define turn/radians
-  (lambda (d)
-    (flip-icons)
-    (set! turtles-cache (combine (make-c-turn d) turtles-cache))
-    (flip-icons)))
-
-(define turn
-  (lambda (c)
-    (turn/radians (* (/ c 360) 2 pi))))
-
-(define move-offset
-  (lambda (x y)
-    (flip-icons)
-    (set! turtles-cache (combine (make-c-offset x y) turtles-cache))
-    (flip-icons)))
-
-(define erase/draw-offset
-  (lambda (doit)
-    (lambda (x y)
-      (flip-icons)
-      (flatten
-       (lambda (turtle)
-         (let* ([tx (turtle-x turtle)]
-                [ty (turtle-y turtle)]
-                [newx (+ tx x)]
-                [newy (+ ty y)])
-           (doit tx ty newx newy)
-           (make-turtle newx newy (turtle-angle turtle)))))
-      (flip-icons))))
-
-(define erase-offset (erase/draw-offset (lambda (a b c d) (do-wipe-line a b c d))))
-(define draw-offset (erase/draw-offset (lambda (a b c d) (line a b c d))))
-
-(define splitfn
-  (lambda (e)
-    (let ([t turtles-state]
-          [c turtles-cache])
-      (e)
-      (flip-icons)
-      (set! turtles-state
-            (make-tree (list (make-cached turtles-state turtles-cache)
-                             (make-cached t c))))
-      (set! turtles-cache empty-cache)
-      (flip-icons))))
-
-(define split*fn
-  (lambda (es)
-    (let ([t turtles-state]
-          [c turtles-cache]
-          [l '()])
-      (for-each (lambda (x)
-                  (x)
-                  (set! l (cons (make-cached turtles-state turtles-cache) l))
-                  (flip-icons)
-                  (set! turtles-state t)
-                  (set! turtles-cache c)
-                  (flip-icons))
-                es)
-      (flip-icons)
-      (set! turtles-cache empty-cache)
-      (set! turtles-state (make-tree l))
-      (flip-icons))))
-
-
-(define tpromptfn
-  (lambda (thunk)
-    (let ([save-turtles-cache #f]
-          [save-turtles-state #f])
-      (dynamic-wind
-          (lambda ()
-            (set! save-turtles-cache turtles-cache)
-            (set! save-turtles-state turtles-state))
-          (lambda ()
-            (thunk))
-          (lambda ()
-            (flip-icons)
-            (set! turtles-cache save-turtles-cache)
-            (set! turtles-state save-turtles-state)
-            (flip-icons))))))
-
-
-(define-struct drawing-line (x1 y1 x2 y2))
-(define-struct (wipe-line drawing-line) ())
-(define-struct (draw-line drawing-line) ())
-(define lines-in-drawing null)
-
-(define (draw-lines-into-dc dc)
-  (for-each (lambda (line)
-              (cond
-               [(wipe-line? line) (send dc set-pen w-pen)]
-               [(draw-line? line) (send dc set-pen b-pen)])
-              (send dc draw-line
-                    (drawing-line-x1 line)
-                    (drawing-line-y1 line)
-                    (drawing-line-x2 line)
-                    (drawing-line-y2 line)))
-            lines-in-drawing))
-
-;; used to test printing
-(define (display-lines-in-drawing)
-  (let* ([lines-in-drawing-canvas%
-          (class100 mred:canvas% (frame)
-            (inherit get-dc)
-            (override
-              [on-paint
-               (lambda ()
-                 (draw-lines-into-dc (get-dc)))])
-            (sequence
-              (super-init frame)))]
-         [frame (make-object mred:frame% "Lines in Drawing")]
-         [canvas (make-object lines-in-drawing-canvas% frame)])
-    (send frame show #t)))
-
-
-(define (print)
-  (case (system-type)
-    [(macos macosx windows)
-     (let ([dc (make-object mred:printer-dc%)])
-       (send dc start-doc "Turtles")
-       (send dc start-page)
-       (draw-lines-into-dc dc)
-       (send dc end-page)
-       (send dc end-doc))]
-    [(unix)
-     (let ([dc (make-object mred:post-script-dc%)])
-       (send dc start-doc "Turtles")
-       (send dc start-page)
-       (draw-lines-into-dc dc)
-       (send dc end-page)
-       (send dc end-doc))]
-    [else
-     (mred:message-box "Turtles"
-                       "Printing is not supported on this platform")]))
diff --git a/collects/graphics/turtles.ss b/collects/graphics/turtles.ss
index 65f1a23313..3ef318a8b7 100644
--- a/collects/graphics/turtles.ss
+++ b/collects/graphics/turtles.ss
@@ -1,9 +1,501 @@
-(module turtles mzscheme
-  (require mzlib/unit
-	   mred/mred-unit
-	   "turtle-sig.ss"
-	   "turtle-unit.ss")
+#lang scheme
 
-  (provide-signature-elements turtle^)
+(require (prefix-in mred: mred)
+         mzlib/class
+         mzlib/class100
+         mzlib/list
+         mzlib/etc
+         "turtle-sig.ss")
 
-  (define-values/invoke-unit/infer (export turtle^) (link turtle@ standard-mred@)))
+(provide turtles
+         clear home
+         turn turn/radians
+         move move-offset
+         draw draw-offset
+         erase erase-offset
+         
+         save-turtle-bitmap
+         
+         splitfn split*fn tpromptfn
+         turtle-window-size
+         
+         display-lines-in-drawing)
+
+(define turtles:window #f)
+(define turtles:shown? #f)
+
+(define pi 3.141592653589793)
+(define pi/2 (/ pi 2))
+
+(define icon-pen (send mred:the-pen-list find-or-create-pen "SALMON" 1 'xor))
+(define icon-brush (send mred:the-brush-list find-or-create-brush "SALMON" 'xor))
+(define blank-pen (send mred:the-pen-list find-or-create-pen "BLACK" 1 'transparent))
+(define w-pen (send mred:the-pen-list find-or-create-pen "white" 1 'solid))
+(define b-pen (send mred:the-pen-list find-or-create-pen "black" 1 'solid))
+
+(define show-turtle-icons? #t)
+
+;; turtle-style : (union 'triangle 'line 'empty)
+(define turtle-style 'triangle)
+
+(define plot-window%
+  (class100 mred:frame% (name width height)
+    
+    (private-field
+     [bitmap (make-object mred:bitmap% width height #t)])      
+    
+    (inherit show)
+    (private-field
+     [memory-dc (make-object mred:bitmap-dc%)]
+     [pl (make-object mred:point% 0 0)]
+     [pr (make-object mred:point% 0 0)]
+     [ph (make-object mred:point% 0 0)]
+     [points (list pl pr ph)])
+    (public
+      [get-canvas
+       (lambda ()
+         canvas)]
+      [flip-icons
+       (lambda ()
+         (case turtle-style
+           [(triangle line)
+            (flatten (lambda (x) x))
+            (let* ([dc (send canvas get-dc)]
+                   [proc
+                    (if (eq? turtle-style 'line)
+                        (lambda (turtle)
+                          (let ([x (turtle-x turtle)]
+                                [y (turtle-y turtle)]
+                                [theta (turtle-angle turtle)]
+                                [size 2])
+                            (send dc draw-line
+                                  x y
+                                  (+ x (* size (cos theta)))
+                                  (+ y (* size (sin theta))))))
+                        (lambda (turtle)
+                          (let* ([x (turtle-x turtle)]
+                                 [y (turtle-y turtle)]
+                                 [theta (turtle-angle turtle)]
+                                 [long-size 20]
+                                 [short-size 7]
+                                 [l-theta (+ theta pi/2)]
+                                 [r-theta (- theta pi/2)])
+                            (send ph set-x (+ x (* long-size (cos theta))))
+                            (send ph set-y (+ y (* long-size (sin theta))))
+                            (send pl set-x (+ x (* short-size (cos l-theta))))
+                            (send pl set-y (+ y (* short-size (sin l-theta))))
+                            (send pr set-x (+ x (* short-size (cos r-theta))))
+                            (send pr set-y (+ y (* short-size (sin r-theta))))
+                            (send dc draw-polygon points))))])
+              (if (eq? turtle-style 'line)
+                  (send dc set-pen icon-pen)
+                  (begin
+                    (send dc set-pen blank-pen)
+                    (send dc set-brush icon-brush)))
+              (for-each proc turtles-state)
+              (send dc set-pen b-pen))]
+           [else
+            (void)]))]
+      [clear
+       (lambda () 
+         (send memory-dc clear)
+         (send canvas on-paint))])
+    (sequence
+      (send memory-dc set-bitmap bitmap)
+      (send memory-dc clear)
+      (super-init name #f width height))
+    
+    (public
+      [on-menu-command (lambda (op) (turtles #f))])
+    (private-field
+     [menu-bar (make-object mred:menu-bar% this)]
+     [file-menu (make-object mred:menu% "File" menu-bar)])
+    (sequence 
+      (make-object mred:menu-item%
+                   "Print"
+                   file-menu
+                   (lambda (_1 _2)
+                     (print)))
+      (make-object mred:menu-item%
+                   "Close"
+                   file-menu
+                   (lambda (_1 _2)
+                     (turtles #f))))
+    
+    (public
+      [save-turtle-bitmap
+       (lambda (fn type)
+         (send bitmap save-file fn type))])
+    
+    (private-field
+     [canvas% 
+      (class100 mred:canvas% args
+        (inherit get-dc)
+        (override
+          [on-paint
+           (lambda ()
+             (let ([dc (get-dc)])
+               (send dc clear)
+               (send dc draw-bitmap (send memory-dc get-bitmap) 0 0)
+               (flip-icons)))])
+        (sequence (apply super-init args)))]
+     [canvas (make-object canvas% this)]
+     [dc (send canvas get-dc)])
+    
+    (public
+      [wipe-line (lambda (a b c d)
+                   (send memory-dc set-pen w-pen)
+                   (send dc set-pen w-pen)
+                   (send memory-dc draw-line a b c d)
+                   (send dc draw-line a b c d)
+                   (send memory-dc set-pen b-pen)
+                   (send dc set-pen b-pen))]
+      [draw-line (lambda (a b c d)
+                   (send memory-dc draw-line a b c d)
+                   (send dc draw-line a b c d))])
+    (sequence
+      (send canvas min-width width)
+      (send canvas min-height height)
+      (send this clear))))
+
+(define turtle-window-size
+  (let-values ([(w h) (mred:get-display-size)]
+               [(user/client-offset) 65]
+               [(default-size) 800])
+    (min default-size
+         (- w user/client-offset)
+         (- h user/client-offset))))
+
+(define-struct turtle (x y angle))
+                                        ; x : int
+                                        ; y: int
+                                        ; angle : int
+
+(define-struct cached (turtles cache))
+                                        ; turtles : (list-of turtle)
+                                        ; cache : turtle -> turtle
+
+(define-struct tree (children))
+                                        ; children : (list-of cached)
+
+(define clear-turtle (make-turtle (/ turtle-window-size 2)
+                                  (/ turtle-window-size 2) 0))
+
+;; turtles-state is either a
+;;    - (list-of turtle) or
+;;    - tree 
+(define turtles-state (list clear-turtle))
+
+;; the cache contains a turtle-offset, which is represented
+;; by a turtle -- but it is a delta not an absolute.
+(define empty-cache (make-turtle 0 0 0))
+(define turtles-cache empty-cache)
+
+(define init-error (lambda _ (error 'turtles "Turtles not initialized. Evaluate (turtles).")))
+(define inner-line init-error)
+(define inner-wipe-line init-error)
+(define inner-clear-window init-error)
+(define inner-flip-icons init-error)
+(define inner-save-turtle-bitmap init-error)
+
+(define line
+  (lambda (a b c d)
+    (set! lines-in-drawing (cons (make-draw-line a b c d) lines-in-drawing))
+    (inner-line a b c d)))
+(define do-wipe-line
+  (lambda (a b c d)
+    (set! lines-in-drawing (cons (make-wipe-line a b c d) lines-in-drawing))
+    (inner-wipe-line a b c d)))
+(define (flip-icons) (inner-flip-icons))
+
+(define clear-window (lambda () (inner-clear-window)))
+(define save-turtle-bitmap (lambda (x y) (inner-save-turtle-bitmap x y)))
+
+(define turtles
+  (case-lambda
+   [() (turtles #t)]
+   [(x)
+    (set! turtles:shown? x)
+    (unless turtles:window
+      (set! turtles:window
+            (make-object plot-window%
+                         "Turtles"
+                         turtle-window-size
+                         turtle-window-size))
+      (set! inner-line (lambda x (send turtles:window draw-line . x)))
+      (set! inner-wipe-line (lambda x (send turtles:window wipe-line . x)))
+      (set! inner-clear-window (lambda x (send turtles:window clear . x)))
+      (set! inner-save-turtle-bitmap (lambda x (send turtles:window save-turtle-bitmap . x)))
+      (set! flip-icons (lambda x (send turtles:window flip-icons . x))))
+    (send turtles:window show x)
+    (send turtles:window get-canvas)]))
+
+(define clear 
+  (lambda ()
+    (set! turtles-cache empty-cache)
+    (set! turtles-state (list clear-turtle))
+    (set! lines-in-drawing null)
+    (clear-window)))
+
+(define home
+  (lambda ()
+    (flip-icons)
+    (set! turtles-cache empty-cache)
+    (set! turtles-state (list clear-turtle))
+    (flip-icons)))
+
+;; cache elements:
+(define-struct c-forward (distance))
+(define-struct c-turn (angle))
+(define-struct c-draw (distance))
+(define-struct c-offset (x y))
+
+;; combines a cache-element and a turtle-offset.
+;; turtle-offsets are represented as turtles, 
+;; however they are deltas, not absolutes.
+(define combine
+  (lambda (entry cache)
+    (cond 
+     [(c-forward? entry)
+      (let* ([n (c-forward-distance entry)]
+             [angle (turtle-angle cache)]
+             [x (turtle-x cache)]
+             [y (turtle-y cache)]
+             [newx (+ x (* n (cos angle)))]
+             [newy (+ y (* n (sin angle)))])
+        (make-turtle newx newy angle))]
+     [(c-offset? entry)
+      (let* ([tx (turtle-x cache)]
+             [ty (turtle-y cache)]
+             [newx (+ tx (c-offset-x entry))]
+             [newy (+ ty (c-offset-y entry))])
+        (make-turtle newx newy 
+                     (turtle-angle cache)))]
+     [(c-turn? entry)
+      (make-turtle (turtle-x cache)
+                   (turtle-y cache)
+                   (- (turtle-angle cache)
+                      (c-turn-angle entry)))]
+     [else
+      (error 'turtles-cache "illegal entry in cache: ~a" entry)])))
+
+;; this applies an offset to a turtle.
+;; an offset is a turtle, representing what would happen 
+;;    if the turtle had started at zero.
+(define apply-cache
+  (lambda (offset)
+    (let ([x (turtle-x offset)]
+          [y (turtle-y offset)]
+          [offset-angle (turtle-angle offset)])
+      (lambda (turtle)
+        (let* ([angle (turtle-angle turtle)])
+          (let* ([c (cos angle)]
+                 [s (sin angle)]
+                 [rx (- (* x c) (* y s))]
+                 [ry (+ (* y c) (* x s))])
+            (make-turtle (+ rx (turtle-x turtle))
+                         (+ ry (turtle-y turtle))
+                         (+ offset-angle angle))))))))
+
+(define flatten
+  (lambda (at-end)
+    (letrec ([walk-turtles
+              (lambda (turtles cache list)
+                (cond
+                 [(tree? turtles)
+                  (let ([children (tree-children turtles)]
+                        [ac (apply-cache cache)])
+                    (foldl (lambda (child list)
+                             (walk-turtles (cached-turtles child)
+                                           (ac (cached-cache child))
+                                           list))
+                           list
+                           children))]
+                 [else
+                  (let ([f (compose at-end (apply-cache cache))])
+                    (foldl (lambda (t l) (cons (f t) l)) list turtles))]))])
+      (set! turtles-state (walk-turtles turtles-state turtles-cache null))
+      (set! turtles-cache empty-cache))))
+
+(define draw/erase
+  (lambda (doit)
+    (lambda (n)
+      (flip-icons)
+      (flatten
+       (lambda (turtle)
+         (let* ([x (turtle-x turtle)]
+                [y (turtle-y turtle)]
+                [angle (turtle-angle turtle)]
+                [d (if (zero? n) 0 (sub1 (abs n)))]
+                [res (if (< n 0) (- d) d)]
+                [c (cos angle)]
+                [s (sin angle)]
+                [drawx (+ x (* res c))]
+                [drawy (+ y (* res s))]
+                [newx (+ x (* n c))]
+                [newy (+ y (* n s))])
+           (unless (zero? n)
+             (doit x y drawx drawy))
+           (make-turtle newx newy angle))))
+      (flip-icons))))
+
+(define draw (draw/erase (lambda (a b c d) (line a b c d))))
+(define erase (draw/erase (lambda (a b c d) (do-wipe-line a b c d))))
+
+(define move
+  (lambda (n)
+    (flip-icons)
+    (set! turtles-cache (combine (make-c-forward n) turtles-cache))
+    (flip-icons)))
+
+(define turn/radians
+  (lambda (d)
+    (flip-icons)
+    (set! turtles-cache (combine (make-c-turn d) turtles-cache))
+    (flip-icons)))
+
+(define turn
+  (lambda (c)
+    (turn/radians (* (/ c 360) 2 pi))))
+
+(define move-offset
+  (lambda (x y)
+    (flip-icons)
+    (set! turtles-cache (combine (make-c-offset x y) turtles-cache))
+    (flip-icons)))
+
+(define erase/draw-offset
+  (lambda (doit)
+    (lambda (x y)
+      (flip-icons)
+      (flatten
+       (lambda (turtle)
+         (let* ([tx (turtle-x turtle)]
+                [ty (turtle-y turtle)]
+                [newx (+ tx x)]
+                [newy (+ ty y)])
+           (doit tx ty newx newy)
+           (make-turtle newx newy (turtle-angle turtle)))))
+      (flip-icons))))
+
+(define erase-offset (erase/draw-offset (lambda (a b c d) (do-wipe-line a b c d))))
+(define draw-offset (erase/draw-offset (lambda (a b c d) (line a b c d))))
+
+(define splitfn
+  (lambda (e)
+    (let ([t turtles-state]
+          [c turtles-cache])
+      (e)
+      (flip-icons)
+      (set! turtles-state
+            (make-tree (list (make-cached turtles-state turtles-cache)
+                             (make-cached t c))))
+      (set! turtles-cache empty-cache)
+      (flip-icons))))
+
+(define split*fn
+  (lambda (es)
+    (let ([t turtles-state]
+          [c turtles-cache]
+          [l '()])
+      (for-each (lambda (x)
+                  (x)
+                  (set! l (cons (make-cached turtles-state turtles-cache) l))
+                  (flip-icons)
+                  (set! turtles-state t)
+                  (set! turtles-cache c)
+                  (flip-icons))
+                es)
+      (flip-icons)
+      (set! turtles-cache empty-cache)
+      (set! turtles-state (make-tree l))
+      (flip-icons))))
+
+
+(define tpromptfn
+  (lambda (thunk)
+    (let ([save-turtles-cache #f]
+          [save-turtles-state #f])
+      (dynamic-wind
+          (lambda ()
+            (set! save-turtles-cache turtles-cache)
+            (set! save-turtles-state turtles-state))
+          (lambda ()
+            (thunk))
+          (lambda ()
+            (flip-icons)
+            (set! turtles-cache save-turtles-cache)
+            (set! turtles-state save-turtles-state)
+            (flip-icons))))))
+
+
+(define-struct drawing-line (x1 y1 x2 y2))
+(define-struct (wipe-line drawing-line) ())
+(define-struct (draw-line drawing-line) ())
+(define lines-in-drawing null)
+
+(define (draw-lines-into-dc dc)
+  (for-each (lambda (line)
+              (cond
+               [(wipe-line? line) (send dc set-pen w-pen)]
+               [(draw-line? line) (send dc set-pen b-pen)])
+              (send dc draw-line
+                    (drawing-line-x1 line)
+                    (drawing-line-y1 line)
+                    (drawing-line-x2 line)
+                    (drawing-line-y2 line)))
+            lines-in-drawing))
+
+;; used to test printing
+(define (display-lines-in-drawing)
+  (let* ([lines-in-drawing-canvas%
+          (class100 mred:canvas% (frame)
+            (inherit get-dc)
+            (override
+              [on-paint
+               (lambda ()
+                 (draw-lines-into-dc (get-dc)))])
+            (sequence
+              (super-init frame)))]
+         [frame (make-object mred:frame% "Lines in Drawing")]
+         [canvas (make-object lines-in-drawing-canvas% frame)])
+    (send frame show #t)))
+
+
+(define (print)
+  (case (system-type)
+    [(macos macosx windows)
+     (let ([dc (make-object mred:printer-dc%)])
+       (send dc start-doc "Turtles")
+       (send dc start-page)
+       (draw-lines-into-dc dc)
+       (send dc end-page)
+       (send dc end-doc))]
+    [(unix)
+     (let ([dc (make-object mred:post-script-dc%)])
+       (send dc start-doc "Turtles")
+       (send dc start-page)
+       (draw-lines-into-dc dc)
+       (send dc end-page)
+       (send dc end-doc))]
+    [else
+     (mred:message-box "Turtles"
+                       "Printing is not supported on this platform")]))
+
+
+(define-syntaxes (split)
+  (lambda (x)
+    (syntax-case x ()
+      ((_ args ...)
+       (syntax (splitfn (lambda () args ...)))))))
+
+(define-syntaxes (split*)
+  (syntax-rules ()
+    [(_ e0 e ...)
+     (split*fn (list (lambda () e0) (lambda () e) ...))]))
+
+(define-syntaxes (tprompt)
+  (lambda (x)
+    (syntax-case x ()
+      ((_ e1 ...)
+       (syntax (tpromptfn (lambda () e1 ...)))))))
\ No newline at end of file