add-line in world.ss properly cuts off lines now

svn: r5079

collects/htdp/Test/world-add-line.ss

@@ -0,0 +1,60 @@
+(define plain (empty-scene 100 100))
+
+(add-line plain .5 10.3 -20 80 'red)
+
+'verticals
+(equal? (add-line plain -10 90 -10 80 'red) plain) 
+(equal? (add-line plain 110 90 110 80 'red) plain)
+(equal? (add-line plain +10 90 +10 80 'red) 
+        (add-line plain +10 90 +10 80 'red))
+(equal? (add-line plain +10 900000 +10 80 'red) 
+        (add-line plain +10 100 +10 80 'red))
+(equal? (add-line plain +10 -10 +10 80 'red) 
+        (add-line plain +10 0 +10 80 'red))
+
+'horizontals
+(equal? (add-line plain 20 -10 30 -10 'red) plain)
+(equal? (add-line plain 20 110 30 110 'red) plain)
+(equal? (add-line plain 20 +10 30 +10 'red) 
+        (add-line plain 20 +10 30 +10 'red))
+(equal? (add-line plain 20 +10 30000 +10 'red) 
+        (add-line plain 20 +10 100 +10 'red))
+
+'inside-outside
+(equal? (add-line plain 10 10 -10 -10 'red) ; upper-left
+        (add-line plain 10 10 0 0 'red))
+(equal? (add-line plain 10 10 -10 0 'red) ; upper-left
+        (add-line plain 10 10 0 5 'red))
+(equal? (add-line plain 90 10 110 -10 'red) ; upper-right 
+        (add-line plain 90 10 100 0 'red))
+(equal? (add-line plain 90 10 110 0 'red) ; upper-left
+        (add-line plain 90 10 100 5 'red))
+(equal? (add-line plain 90 90 110 110 'red) ; lower-right
+        (add-line plain 90 90 100 100 'red))
+(equal? (add-line plain 90 90 110 100 'red) ; lower-right
+        (add-line plain 90 90 100 95 'red))
+(equal? (add-line plain 110 110 10 10 'red) ; lower-right
+        (add-line plain 10 10 100 100 'red))
+(equal? (add-line plain 10 10 210 110 'red) ; lower-right 
+        (add-line plain 10 10 100 55 'red))
+(equal? (add-line plain 10 10 -10 30 'red) ; lower-left
+        (add-line plain 10 10 0 20 'red))
+(equal? (add-line plain 10 10 -10 210 'red) ; lower-left
+        (add-line plain 10 10 0 110 'red))
+
+'outside-outside
+(equal? (add-line plain  -100 10 300 50 'red) ;; left-right 
+        (add-line plain 0 20 100 30 'red))
+(equal? (add-line plain -50 0 60 110 'red) ;; left-low
+        (add-line plain 0 50 50 100 'red))
+(equal? (add-line plain -50 50 60 -5 'red) ;; left-top
+        (add-line plain 0 25 50 0 'red))
+(equal? (add-line plain -10 -10 110 50 'red) ;; top-right
+        (add-line plain 10 0 100 45 'red))
+(equal? (add-line plain -10 -10 110 110 'red) ;; top-low
+        (add-line plain 0 0 100 100 'red))
+(equal? (add-line plain -10 110 110 50 'red) ;; low-right
+        (add-line plain 0 105 100 55 'red))
+
+'totally-outside
+(equal? (add-line plain -100 -100 -200 -500 'red) plain)

collects/htdp/world.ss

@@ -1,3 +1,4 @@
+;; Sun Dec 09 23:17:41 EST 2006: add-line fixed so it cuts off lines before drawing
 ;; Mon Mar 27 10:29:28 EST 2006: integrated Felix's mouse events
 ;; Wed Jan 25 13:38:42 EST 2006: on-redraw: proc is now called on installation
 ;; Tue Jan  3 11:17:50 EST 2006: changed add-line behavior in world.ss 
@@ -7,6 +8,9 @@
 (module world mzscheme
   (require
    (lib "class.ss")
+   (lib "etc.ss")
+   (lib "list.ss")
+   (lib "process.ss")
    (lib "mred.ss" "mred")
    (lib "error.ss" "htdp")
    (lib "image.ss" "htdp")
@@ -18,6 +22,7 @@
   
   (provide      ;; forall(World):
    big-bang	;; Number Number Number World -> true
+   begin-recording ;; String -> true
    end-of-time	    ;; String u Symbol -> World
    
    nw:rectangle ;; Number Number Mode Color -> Image
@@ -26,6 +31,7 @@
    run-movie    ;; (Listof Image) -> true 
    (rename add-line-to-scene add-line)
    ;; Scene Number Number Number Number Color -> Scene 
+   ;; cut all pieces that are outside the given rectangle 
    )
   
   (provide-higher-order-primitive
@@ -102,7 +108,7 @@
 	  ns
 	  (shrink ns 0 0 sw sh))))
   
-  (define (add-line-to-scene image x0 y0 x1 y1 color)
+  (define (add-line-to-scene img x0 y0 x1 y1 c)
     #|
     (check-image 'add-line image "first")
     (check-pos 'add-line x0 "second")
@@ -111,23 +117,122 @@
     (check-pos 'add-line x2 "fifth")
     (check-color 'add-line x2 "sixth")
     |#
-    (let ()
+    (local ((define w (image-width img))  
-      (define sw (image-width image))
+            (define h (image-height img)))
-      (define sh (image-height image))
+      (cond
-      (define ns (add-line image x0 y0 x1 y1 color))
+        [(and (<= 0 x0 w) (<= 0 x1 w) (<= 0 y0 w) (<= 0 y1 w)) 
-      (define nw (image-width ns))
+         (add-line img x0 y0 x1 y1 c)]
-      (define nh (image-height ns))
+        [(= x0 x1) ;; vertical 
-      (if (and (= sw nw) (= sh nh)) 
+         (if (<= 0 x0 w) (add-line img x0 (app y0 h) x0 (app y1 h) c) img)]
-	  ns
+        [(= y0 y1) ;; horizontal 
-	  (shrink ns 0 0 sw sh))))
+         (if (<= 0 y0 h) (add-line img (app x0 w) y0 (app x1 w) y0 c) img)]
+        [else 
+         (local ((define lin (points->line x0 y0 x1 y1))
+                 (define dir (direction x0 y0 x1 y1))
+                 (define-values (upp low lft rgt) (intersections lin w h))
+                 (define (add x y) (add-line img x0 y0 x y c)))
+           (cond
+             [(and (< 0 x0 w) (< 0 y0 h)) ;; (x0,y0) is in the interior
+              (case dir
+                [(upper-left)  (if (number? upp) (add upp 0) (add 0 lft))]
+                [(lower-left)  (if (number? low) (add low h) (add 0 lft))]
+                [(upper-right) (if (number? upp) (add upp 0) (add h rgt))]
+                [(lower-right) (if (number? low) (add low h) (add w rgt))]
+                [else (error 'dir "contract violation: ~e" dir)])]
+             [(and (< 0 x1 w) (< 0 y1 h)) ;; (x1,y1) in interior; symmetry!
+              (add-line-to-scene img x1 y1 x0 y0 c)]
+             [else 
+              (cond
+                [(and (number? upp) (number? low)) (add-line img upp 0 low h c)]
+                [(and (number? upp) (number? lft)) (add-line img upp 0 0 lft c)]
+                [(and (number? upp) (number? rgt)) (add-line img upp 0 w rgt c)]
+                [(and (number? low) (number? lft)) (add-line img low h 0 lft c)]
+                [(and (number? low) (number? rgt)) (add-line img low h w rgt c)]
+                [(and (number? lft) (number? rgt)) (add-line img 0 lft w rgt c)]
+                [else img])]))])))
+  
+  ;; Nat Nat -> Nat 
+  ;; y if in [0,h], otherwise the closest boundary
+  (define (app y h)
+    (cond
+      [(<= 0 y h) y]
+      [(< y 0) 0]
+      [else    h]))
+  
+  ;; Nat Nat Nat Nat -> (union 'upper-left 'upper-right 'lower-left 'lower-right)
+  ;; how to get to (x1,y1) from (x0,y0)
+  (define (direction x0 y0 x1 y1)
+    (string->symbol
+     (string-append 
+      (if (<= y0 y1) "lower" "upper") "-" (if (<= x0 x1) "right" "left"))))
+  
+  'direction 
+  (equal? (direction 10 10 0 0) 'upper-left)
+  (equal? (direction 10 10 20 20) 'lower-right)
+  (equal? (direction 10 10 0 20) 'lower-left)
+  (equal? (direction 10 10 20 0) 'upper-right)
+  
+  ;; -----------------------------------------------------------------------------
+  ;; LINEs 
+  
+  ;; Number Number -> LINE
+  ;; create a line from a slope and the intersection with the y-axis
+  (define-struct lyne (slope y0))
+  
+  ;; Nat Nat Nat Nat -> LINE
+  ;; determine the line function from the four points (or the attributes)
+  ;; ASSUME: (not (= x0 x1))
+  (define (points->line x0 y0 x1 y1)
+    (local ((define slope  (/ (- y1 y0) (- x1 x0))))
+      (make-lyne slope (- y0 (* slope x0)))))
+  
+  ;; LINE Number -> Number 
+  (define (of ln x) (+ (* (lyne-slope ln) x) (lyne-y0 ln)))
+  
+  ;; LINE Nat Nat -> [Opt Number] [Opt Number] [Opt Number] [Opt Number]
+  ;; where does the line intersect the rectangle [0,w] x [0,h]
+  ;; (values UP LW LF RT) means the line intersects with 
+  ;;  the rectangle [0,w] x [0,h] at (UP,0) or (LW,h) or (0,LF) or (w,RT)
+  ;;  when a field is false, the line doesn't interesect with that side 
+  (define (intersections l w h)
+    (values
+     (opt (X l 0) w) (opt (X l h) w) (opt (lyne-y0 l) h) (opt (of l w) h)))
+  
+  ;; Number Number -> [Opt Number]
+  (define (opt z lft) (if (<= 0 z lft) z false))
+  
+  ;; LINE Number -> Number 
+  ;; the x0 where LINE crosses y(x) = h
+  ;; assume: LINE is not a horizontal
+  (define (X ln h) (/ (- h (lyne-y0 ln)) (lyne-slope ln)))
+  
+  ;; --- TESTS --- 
+  
+  (define line1 (points->line 0 0 100 100))
+  (= (of line1 0) 0)
+  (= (of line1 100) 100)
+  (= (of line1 50) 50)
+  
+  (= (X (make-lyne 1 0) 0) 0)
+  (= (X (make-lyne 1 0) 100) 100)
+  
+  (equal? (call-with-values 
+           (lambda () (intersections (points->line -10 -10 110 110) 100 100))
+           list)
+          (list 0 100 0 100))
+  (equal? (call-with-values 
+           (lambda () (intersections (points->line 0 10 100 80) 100 100))
+           list)
+          (list false false 10 80))
+  
+  ;; -----------------------------------------------------------------------------
   
   (define (empty-scene width height)
     (check-pos 'empty-scene width "first")
     (check-pos 'empty-scene height "second")    
     (move-pinhole 
      (rectangle width height 'outline 'black)
-     (/ width -2) (/ height -2))
+     (/ width -2) (/ height -2)))
-    )
   
   ;; display all images in list in the canvas
   (define (run-movie movie)
@@ -249,15 +354,15 @@
             #t)
           (error 'on-event "the event action has been set already")))]
   
-  [define (end-of-time s)
+  (define (end-of-time s)
     (printf "end of time: ~a~n" s)
     (stop-it)
-    the-world]
+    the-world)
   
   ;; MouseEvent -> Void
-  [define on-mouse-proc void]
+  (define on-mouse-proc void)
   
-  [define (on-mouse-event f)
+  (define (on-mouse-event f)
     (check-proc 'on-mouse-event f 4 "on-mouse-event" "four arguments")
     (check-world 'on-mouse-event)
     (let ([esp (current-eventspace)])
@@ -288,7 +393,7 @@
                            (on-redraw-proc))))
                       #t)))
             #t)
-          (error 'on-mouse-event "the mouse event action has been set already")))]
+          (error 'on-mouse-event "the mouse event action has been set already"))))
   #|
   Note an alternative to the above cond is to just
   send get-event-type, which produces one of the following:
@@ -305,20 +410,19 @@
   |#                             
   
   ;; --- library 
-  [define (exn-handler e)
+  (define (exn-handler e)
-    (send the-time stop)
+    (stop-it)
-    (set! on-char-proc void)
+    (raise e))
-    (set! timer-callback void)
-    (raise e)]
   
-  [define (break-handler . _) 
+  (define (break-handler . _) 
     (printf "animation stopped")
     (stop-it)
-    the-world]
+    the-world)
   
   ;; -> Void
   (define (stop-it)
     (send the-time stop)
+    (stop-recording "blah")
     (set! on-char-proc void)
     (set! timer-callback void))
   
@@ -335,6 +439,7 @@
                                   [exn? exn-handler])
                     (define img (f the-world))
                     (check-result 'on-redraw (lambda (x) (beg:image? x)) "image" img)
+                    (when recording? (save-image img))
                     (update-frame img)
                     #t)))
           (on-redraw-proc))
@@ -348,6 +453,42 @@
     (send txt lock #t)
     (send txt end-edit-sequence))
   
+  ;; -------------------------------------------------------------------------
+  ;; recording a sequence of interactions via images 
+  (define recording? #f)
+  (define rec-where "")
+  ;; String -> true
+  (define (begin-recording d)
+    (check-arg 'record! (string? d) 'string "first" d)
+    (set! rec-where d)
+    (set! recording? #t)
+    #t)
+  ;; String -> true
+  (define (stop-recording d)
+    (check-arg 'record! (string? d) 'string "first" d)
+    (set! recording? #f)
+    (let ()
+      (define files 
+	(sort
+         (filter (lambda (x) (regexp-match #rx"i[0-9]*.png" x))
+                 (map path->string (directory-list)))
+         (lambda (x y)
+           (<= (string->number (car (regexp-match #rx"[0-9]+" x)))
+               (string->number (car (regexp-match #rx"[0-9]+" y)))))))
+      
+      (define cmdline (format "convert -delay 5 ~a ~a.gif" 
+                              (apply string-append (map (lambda (x) (format " ~a" x)) files))
+                              d))
+      (system cmdline)
+      #t))
+  
+  (define image-count 0)
+  ;; Image -> Void
+  ;; save image in a file named i<number>.png 
+  (define (save-image img)
+    (send (send img get-bitmap) save-file (format "i~a.png" image-count) 'png)
+    (set! image-count (+ image-count 1)))
+  
   (define SEQUENCE-ERROR "evaluate (big-bang Number Number Number World) first")
   )