add-line in world.ss properly cuts off lines now
svn: r5079
This commit is contained in:
Matthias Felleisen
parent
4e25faaccc
commit
5edb1ce300
60
collects/htdp/Test/world-add-line.ss
Normal file
60
collects/htdp/Test/world-add-line.ss
Normal file
|
|
@ -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)
|
||||
|
|
@ -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")
|
||||
|
|
@ -17,8 +21,9 @@
|
|||
(provide (all-from-except (lib "image.ss" "htdp") add-line))
|
||||
|
||||
(provide ;; forall(World):
|
||||
big-bang ;; Number Number Number World -> true
|
||||
end-of-time ;; String u Symbol -> 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
|
||||
place-image ;; Image Number Number Scence -> Scene
|
||||
|
|
@ -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 ()
|
||||
(define sw (image-width image))
|
||||
(define sh (image-height image))
|
||||
(define ns (add-line image x0 y0 x1 y1 color))
|
||||
(define nw (image-width ns))
|
||||
(define nh (image-height ns))
|
||||
(if (and (= sw nw) (= sh nh))
|
||||
ns
|
||||
(shrink ns 0 0 sw sh))))
|
||||
(local ((define w (image-width img))
|
||||
(define h (image-height img)))
|
||||
(cond
|
||||
[(and (<= 0 x0 w) (<= 0 x1 w) (<= 0 y0 w) (<= 0 y1 w))
|
||||
(add-line img x0 y0 x1 y1 c)]
|
||||
[(= x0 x1) ;; vertical
|
||||
(if (<= 0 x0 w) (add-line img x0 (app y0 h) x0 (app y1 h) c) img)]
|
||||
[(= y0 y1) ;; horizontal
|
||||
(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)
|
||||
(send the-time stop)
|
||||
(set! on-char-proc void)
|
||||
(set! timer-callback void)
|
||||
(raise e)]
|
||||
(define (exn-handler e)
|
||||
(stop-it)
|
||||
(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")
|
||||
)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user