suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

separated 2htdp/universe from htdp/image, allowing either htdp/image or 2htdp/image to be used

Browse Source 
svn: r17430
This commit is contained in:
Robby Findler 2009-12-29 23:59:39 +00:00
parent 2e4926ebb3
commit e821a0c461
19 changed files with 709 additions and 710 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/2htdp/image.ss
View File

@ -47,7 +47,8 @@ and they all have good sample contracts. (It is amazing what we can do with kids
(require mrlib/image-core
"private/image-more.ss")
"private/image-more.ss"
"private/img-err.ss")
(provide overlay
overlay/align

47
collects/2htdp/private/check-aux.ss
View File

@ -1,7 +1,6 @@
#lang scheme
(require htdp/image
htdp/error)
(require htdp/error)
(provide (all-defined-out))
@ -33,18 +32,8 @@
;; -----------------------------------------------------------------------------
;; Any -> Boolean
(define (scene? i)
(and (image? i) (internal-scene? i)))
;; Image -> Boolean
(define (internal-scene? i)
(and (= 0 (pinhole-x i)) (= 0 (pinhole-y i))))
;; Number Symbol Symbol -> Integer
(define (number->integer x . rst)
(define t (if (pair? rst) (car rst) ""))
(define p (if (and (pair? rst) (pair? (cdr rst))) (cadr rst) ""))
(define (number->integer x [t ""] [p ""])
(check-arg t (and (number? x) (real? x)) "real number" p x)
(inexact->exact (floor x)))
@ -163,34 +152,4 @@
;; Symbol Any String -> Void
(define (check-pos t c r)
(check-arg
t (and (number? c) (>= (number->integer c t r) 0)) "positive integer" r c))
;; Symbol Any String String *-> Void
(define (check-image tag i rank . other-message)
(if (and (pair? other-message) (string? (car other-message)))
(check-arg tag (image? i) (car other-message) rank i)
(check-arg tag (image? i) "image" rank i)))
;; Symbol Any String -> Void
(define (check-scene tag i rank)
(define error "image with pinhole at (~s,~s)")
(if (image? i)
(check-arg tag (internal-scene? i) "scene" rank (image-pins i))
(check-arg tag #f "scene" rank i)))
;; Symbol Any -> Void
(define (check-scene-result tname i)
(if (image? i)
(check-result tname internal-scene? "scene" i (image-pins i))
(check-result tname (lambda (x) (image? x)) "scene" i)))
(define (image-pins i)
(format "image with pinhole at (~s,~s)" (pinhole-x i) (pinhole-y i)))
;; Symbol (union Symbol String) Nat -> Void
(define (check-mode tag s rank)
(check-arg tag (or (eq? s 'solid)
(eq? s 'outline)
(string=? "solid" s)
(string=? "outline" s)) "mode (solid or outline)" rank s))
t (and (real? c) (>= (number->integer c t r) 0)) "positive integer" r c))

220
collects/2htdp/private/image-more.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base
(require "../../mrlib/image-core.ss"
"img-err.ss"
scheme/contract
scheme/class
scheme/gui/base
@ -58,216 +59,6 @@
(send bm save-file filename 'png)))
;
;
;
;
;
;
; ;; ;; ;;
; ;; ;; ;;
; ;;;; ;;;;;;;;; ;;;; ;;;; ;;;; ;;;;;; ;;;; ;;;; ;; ;;; ;; ;; ;;; ;;;;;;
; ;; ;; ;;;; ;;;; ;;;;;; ;;;; ;;;;;; ;;;;;; ;; ;; ;;;;;; ;;;;; ;; ;;;;;; ;;;;;;
; ;;;;;;;; ;; ;; ;;; ;;; ;; ;;; ;; ;; ;;;;;;;;;;; ;;;;; ;; ;; ;; ;;; ;;
; ;;; ;; ;; ;;; ;;; ;; ;;; ;; ;; ;;; ;;; ;;;;; ;; ;; ;; ;;; ;;
; ;;; ;; ;; ;; ;;;;;; ;; ;;;;;; ;; ;; ;;; ;; ;;;;;; ;; ;; ;; ;; ;; ;;;;;;
; ;;;; ;; ;; ;;;; ;; ;;;; ;; ;; ;;;; ;;;; ;; ;;; ;; ;; ;; ;;;;;
; ;; ;;;
; ;;;;;
;
;
(define-syntax define/chk
(λ (stx)
(syntax-case stx ()
[(define/chk (fn-name args ... . final-arg) body ...)
(identifier? #'final-arg)
(let ([len (length (syntax->list #'(args ...)))])
(with-syntax ([(i ...) (build-list len values)])
#`(define (fn-name args ... . final-arg)
(let ([args (check/normalize 'fn-name 'args args i)] ...
[final-arg (map/i (λ (x j) (check/normalize 'fn-name 'final-arg x (+ #,len j)))
final-arg)])
body ...))))]
[(define/chk (fn-name args ...) body ...)
(with-syntax ([(i ...) (build-list (length (syntax->list #'(args ...))) add1)])
#'(define (fn-name args ...)
(let ([args (check/normalize 'fn-name 'args args i)] ...)
body ...)))])))
(define (map/i f l)
(let loop ([l l]
[i 0])
(cond
[(null? l) null]
[else (cons (f (car l) i)
(loop (cdr l) (+ i 1)))])))
;; check/normalize : symbol symbol any number -> any
;; based on the name of the argument, checks to see if the input
;; is valid and, if so, transforms it to a specific kind of value
;; width, height -> number
;; mode -> 'outline 'solid
;; color -> (is-a?/c color<%>)
(define (check/normalize fn-name argname arg i)
(case argname
[(x-place)
(check-arg fn-name
(x-place? arg)
'x-place
i
arg)
(let ([sym (if (string? arg)
(string->symbol arg)
arg)])
(if (eq? sym 'center)
'middle
sym))]
[(y-place)
(check-arg fn-name
(y-place? arg)
'y-place
i
arg)
(let ([sym (if (string? arg)
(string->symbol arg)
arg)])
(if (eq? sym 'center)
'middle
sym))]
[(image image1 image2 image3)
(check-arg fn-name
(image? arg)
'image
i
arg)
(to-img arg)]
[(mode)
(check-arg fn-name
(mode? arg)
'mode
i
arg)
(if (string? arg)
(string->symbol arg)
arg)]
[(width height radius side-length side-length1 side-length2)
(check-arg fn-name
(and (real? arg)
(not (negative? arg)))
'non-negative-real-number
i arg)
arg]
[(dx dy x1 y1 x2 y2 factor x-factor y-factor)
(check-arg fn-name
(real? arg)
'real\ number
i arg)
arg]
[(side-count)
(check-arg fn-name
(side-count? arg)
'side-count
i arg)
arg]
[(step-count)
(check-arg fn-name
(step-count? arg)
'step-count
i arg)
arg]
[(angle)
(check-arg fn-name
(angle? arg)
'angle\ in\ degrees
i arg)
(if (< arg 0)
(+ arg 360)
arg)]
[(color)
(check-color fn-name i arg)
(let ([color-str
(cond
[(symbol? arg)
(symbol->string arg)]
[else arg])])
(if (send the-color-database find-color color-str)
color-str
"black"))]
[(string)
(check-arg fn-name (string? arg) 'string i arg)
arg]
[(font-size)
(check-arg fn-name (and (integer? arg) (<= 1 arg 255)) 'font-size i arg)
arg]
[(face)
(check-arg fn-name (or (not arg) (string? arg)) 'face i arg)
arg]
[(family)
(check-arg fn-name (memq arg '(default decorative roman script swiss modern symbol system)) 'family i arg)
arg]
[(style)
(check-arg fn-name (memq arg '(normal italic slant)) 'style i arg)
arg]
[(weight)
(check-arg fn-name (memq arg '(normal bold light)) 'weight i arg)
arg]
[(underline)
(and arg #t)]
[(posns)
(check-arg fn-name
(and (list? arg)
(andmap posn? arg))
'list-of-posns
i arg)
(check-arg fn-name
(>= (length arg) 3)
'list-of-at-least-three-posns
i arg)
arg]
[else
(error 'check "the function ~a has an argument with an unknown name: ~s"
fn-name
argname)]))
(define (y-place? arg)
(member arg '("top" top "bottom" bottom "middle" middle "center" center "baseline" baseline)))
(define (x-place? arg)
(member arg '("left" left "right" right "middle" middle "center" center)))
(define (mode? arg)
(member arg '(solid outline "solid" "outline")))
(define (angle? arg)
(and (real? arg)
(< -360 arg 360)))
(define (side-count? i)
(and (integer? i)
(3 . <= . i)))
(define (step-count? i)
(and (integer? i)
(1 . <= . i)))
(define (color? c) (or (symbol? c) (string? c)))
(define (to-img arg)
(cond
[(is-a? arg image-snip%) (image-snip->image arg)]
[(is-a? arg bitmap%) (bitmap->image arg)]
[else arg]))
(define (image-snip->image is)
(bitmap->image (send is get-bitmap)
(or (send is get-bitmap-mask)
(send (send is get-bitmap) get-loaded-mask))))
(define (bitmap->image bm [mask-bm (send bm get-loaded-mask)])
(let ([w (send bm get-width)]
[h (send bm get-height)])
(make-image (make-translate (/ w 2)
(/ h 2)
(make-bitmap bm mask-bm 0 1 1 #f #f))
(make-bb w h h)
#f)))
;
;
;
@ -978,19 +769,10 @@
save-image
bring-between
image-snip->image
bitmap->image
scale
scale/xy
x-place?
y-place?
mode?
angle?
side-count?
color?
image-width
image-height

200
collects/2htdp/private/image.ss
View File

@ -1,200 +0,0 @@
#lang scheme
(require htdp/image htdp/error "check-aux.ss")
;
;
; ;;;;; ;;;;;
; ; ;
; ; ;
; ; ;;; ; ;;;; ;;;; ;;; ; ; ; ; ;; ;;;
; ; ; ;;; ; ; ; ; ; ; ;;;;; ; ; ;; ; ; ;
; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ;; ; ;; ; ; ; ;; ; ; ; ;
; ;;;;; ; ; ; ;; ; ;; ; ;;;; ; ;; ; ; ; ;;;
; ;
; ;;;;
;
(provide (all-from-out htdp/image))
(provide
;; type Scene = Image with pinhole in origin
nw:rectangle ;; Number Number Mode Color -> Image
;; create a rectangle with pinhole in the upper-left corner
place-image ;; Image Number Number Scene -> Scene
;; place image at (x,y) in given scene
empty-scene ;; Number Number -> Scene
;; create an empty scene of size width x height (!= (nw:rectangle width height))
scene+line ;; Scene Number Number Number Number Color -> Scene
;; cut all pieces that are outside the given rectangle
)
(define (nw:rectangle width height mode color)
(check-pos 'rectangle width "first")
(check-pos 'rectangle height "second")
(check-mode 'rectangle mode "third")
(check-color 'rectangle color "fourth")
(put-pinhole (rectangle width height mode color) 0 0))
(define (place-image image x y scene)
(check-image 'place-image image "first")
(check-arg 'place-image (real? x) 'real "second" x)
(check-arg 'place-image (real? y) 'real "third" y)
(check-scene 'place-image scene "fourth")
(let ([x (number->integer x)]
[y (number->integer y)])
(place-image0 image x y scene)))
(define (empty-scene width height)
(check-pos 'empty-scene width "first")
(check-pos 'empty-scene height "second")
(put-pinhole
(overlay (rectangle width height 'solid 'white)
(rectangle width height 'outline 'black))
0 0))
(define (scene+line img x0 y0 x1 y1 c)
;; img and c are checked via calls to add-line from image.ss
(check-arg 'scene+line (scene? img) "scene" "first" "plain image")
(check-arg 'scene+line (real? x0) "number" "second" x0)
(check-arg 'scene+line (real? y0) "number" "third" y0)
(check-arg 'scene+line (real? x1) "number" "fourth" x1)
(check-arg 'scene+line (real? y1) "number" "fifth" y1)
(let ([x0 (number->integer x0 'scene+line 'second)]
[x1 (number->integer x1 'scene+line 'third)]
[y0 (number->integer y0 'scene+line 'fourth)]
[y1 (number->integer y1 'scene+line 'fifth)])
(add-line-to-scene0 img x0 y0 x1 y1 c)))
;; Image Number Number Image -> Image
(define (place-image0 image x y scene)
(define sw (image-width scene))
(define sh (image-height scene))
(define ns (overlay/xy scene x y image))
(define nw (image-width ns))
(define nh (image-height ns))
(if (and (= sw nw) (= sh nh)) ns (shrink ns 0 0 (- sw 1) (- sh 1))))
;; Image Number Number Number Number Color -> Image
(define (add-line-to-scene0 img x0 y0 x1 y1 c)
(define w (image-width img))
(define h (image-height img))
(cond
[(and (<= 0 x0) (< x0 w) (<= 0 y0) (< y0 w)
(<= 0 x1) (< x1 w) (<= 0 y1) (< y1 w))
;; everything is inside
(add-line img x0 y0 x1 y1 c)]
[(and (or (> 0 x0) (>= x0 w)) (or (> 0 y0) (>= y0 w))
(or (> 0 x1) (>= x1 w)) (or (> 0 y1) (>= y1 w)))
;; everythhing is outside
img]
[(= 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
;; partial off-screen
(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-scene0 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
[(and (<= 0 y) (< y h)) y]
[(< y 0) 0]
[else (- h 1)]))
;; 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"))))
#| TESTS
'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))
|#

230
collects/2htdp/private/img-err.ss Normal file
View File

@ -0,0 +1,230 @@
#lang scheme/base
(provide define/chk
to-img
x-place?
y-place?
mode?
angle?
side-count?
color?
image-snip->image
bitmap->image)
(require htdp/error
scheme/class
lang/posn
scheme/gui/base
"../../mrlib/image-core.ss"
(for-syntax scheme/base
scheme/list))
;
;
;
;
;
;
; ;; ;; ;;
; ;; ;; ;;
; ;;;; ;;;;;;;;; ;;;; ;;;; ;;;; ;;;;;; ;;;; ;;;; ;; ;;; ;; ;; ;;; ;;;;;;
; ;; ;; ;;;; ;;;; ;;;;;; ;;;; ;;;;;; ;;;;;; ;; ;; ;;;;;; ;;;;; ;; ;;;;;; ;;;;;;
; ;;;;;;;; ;; ;; ;;; ;;; ;; ;;; ;; ;; ;;;;;;;;;;; ;;;;; ;; ;; ;; ;;; ;;
; ;;; ;; ;; ;;; ;;; ;; ;;; ;; ;; ;;; ;;; ;;;;; ;; ;; ;; ;;; ;;
; ;;; ;; ;; ;; ;;;;;; ;; ;;;;;; ;; ;; ;;; ;; ;;;;;; ;; ;; ;; ;; ;; ;;;;;;
; ;;;; ;; ;; ;;;; ;; ;;;; ;; ;; ;;;; ;;;; ;; ;;; ;; ;; ;; ;;;;;
; ;; ;;;
; ;;;;;
;
;
(define-syntax define/chk
(λ (stx)
(syntax-case stx ()
[(define/chk (fn-name args ... . final-arg) body ...)
(identifier? #'final-arg)
(let ([len (length (syntax->list #'(args ...)))])
(with-syntax ([(i ...) (build-list len values)])
#`(define (fn-name args ... . final-arg)
(let ([args (check/normalize 'fn-name 'args args i)] ...
[final-arg (map/i (λ (x j) (check/normalize 'fn-name 'final-arg x (+ #,len j)))
final-arg)])
body ...))))]
[(define/chk (fn-name args ...) body ...)
(with-syntax ([(i ...) (build-list (length (syntax->list #'(args ...))) add1)])
#'(define (fn-name args ...)
(let ([args (check/normalize 'fn-name 'args args i)] ...)
body ...)))])))
(define (map/i f l)
(let loop ([l l]
[i 0])
(cond
[(null? l) null]
[else (cons (f (car l) i)
(loop (cdr l) (+ i 1)))])))
;; check/normalize : symbol symbol any number -> any
;; based on the name of the argument, checks to see if the input
;; is valid and, if so, transforms it to a specific kind of value
;; width, height -> number
;; mode -> 'outline 'solid
;; color -> (is-a?/c color<%>)
(define (check/normalize fn-name argname arg i)
(case argname
[(x-place)
(check-arg fn-name
(x-place? arg)
'x-place
i
arg)
(let ([sym (if (string? arg)
(string->symbol arg)
arg)])
(if (eq? sym 'center)
'middle
sym))]
[(y-place)
(check-arg fn-name
(y-place? arg)
'y-place
i
arg)
(let ([sym (if (string? arg)
(string->symbol arg)
arg)])
(if (eq? sym 'center)
'middle
sym))]
[(image image1 image2 image3)
(check-arg fn-name
(image? arg)
'image
i
arg)
(to-img arg)]
[(mode)
(check-arg fn-name
(mode? arg)
'mode
i
arg)
(if (string? arg)
(string->symbol arg)
arg)]
[(width height radius side-length side-length1 side-length2)
(check-arg fn-name
(and (real? arg)
(not (negative? arg)))
'non-negative-real-number
i arg)
arg]
[(dx dy x1 y1 x2 y2 factor x-factor y-factor)
(check-arg fn-name
(real? arg)
'real\ number
i arg)
arg]
[(side-count)
(check-arg fn-name
(side-count? arg)
'side-count
i arg)
arg]
[(step-count)
(check-arg fn-name
(step-count? arg)
'step-count
i arg)
arg]
[(angle)
(check-arg fn-name
(angle? arg)
'angle\ in\ degrees
i arg)
(if (< arg 0)
(+ arg 360)
arg)]
[(color)
(check-color fn-name i arg)
(let ([color-str
(cond
[(symbol? arg)
(symbol->string arg)]
[else arg])])
(if (send the-color-database find-color color-str)
color-str
"black"))]
[(string)
(check-arg fn-name (string? arg) 'string i arg)
arg]
[(font-size)
(check-arg fn-name (and (integer? arg) (<= 1 arg 255)) 'font-size i arg)
arg]
[(face)
(check-arg fn-name (or (not arg) (string? arg)) 'face i arg)
arg]
[(family)
(check-arg fn-name (memq arg '(default decorative roman script swiss modern symbol system)) 'family i arg)
arg]
[(style)
(check-arg fn-name (memq arg '(normal italic slant)) 'style i arg)
arg]
[(weight)
(check-arg fn-name (memq arg '(normal bold light)) 'weight i arg)
arg]
[(underline)
(and arg #t)]
[(posns)
(check-arg fn-name
(and (list? arg)
(andmap posn? arg))
'list-of-posns
i arg)
(check-arg fn-name
(>= (length arg) 3)
'list-of-at-least-three-posns
i arg)
arg]
[else
(error 'check "the function ~a has an argument with an unknown name: ~s"
fn-name
argname)]))
(define (y-place? arg)
(member arg '("top" top "bottom" bottom "middle" middle "center" center "baseline" baseline)))
(define (x-place? arg)
(member arg '("left" left "right" right "middle" middle "center" center)))
(define (mode? arg)
(member arg '(solid outline "solid" "outline")))
(define (angle? arg)
(and (real? arg)
(< -360 arg 360)))
(define (side-count? i)
(and (integer? i)
(3 . <= . i)))
(define (step-count? i)
(and (integer? i)
(1 . <= . i)))
(define (color? c) (or (symbol? c) (string? c)))
(define (to-img arg)
(cond
[(is-a? arg image-snip%) (image-snip->image arg)]
[(is-a? arg bitmap%) (bitmap->image arg)]
[else arg]))
(define (image-snip->image is)
(bitmap->image (send is get-bitmap)
(or (send is get-bitmap-mask)
(send (send is get-bitmap) get-loaded-mask))))
(define (bitmap->image bm [mask-bm (send bm get-loaded-mask)])
(let ([w (send bm get-width)]
[h (send bm get-height)])
(make-image (make-translate (/ w 2)
(/ h 2)
(make-bitmap bm mask-bm 0 1 1 #f #f))
(make-bb w h h)
#f)))

64
collects/2htdp/private/universe-image.ss Normal file
View File

@ -0,0 +1,64 @@
#lang scheme/base
(require (prefix-in 2: 2htdp/image)
(prefix-in 1: htdp/image)
htdp/error)
(provide image? scene? image-width image-height text
check-image check-scene check-scene-result)
(define (scene? x)
;; be sure to check 2:image? first so that
;; bitmaps are always okay (more specifically,
;; so that we don't reject a 2htdp/image universe
;; program that uses a bitmap (bitmap pinholes
;; are not at (0,0).)).
(or (2:image? x)
(1:scene? x)))
(define (image? x) (or (1:image? x) (2:image? x)))
(define (text a b c) (2:text a b c))
(define (image-width x)
(check-arg 'image-width
(image? x)
'image
1
x)
(if (2:image? x)
(2:image-width x)
(1:image-width x)))
(define (image-height x)
(check-arg 'image-height
(image? x)
'image
1
x)
(if (2:image? x)
(2:image-height x)
(1:image-height x)))
;; Symbol Any String String *-> Void
(define (check-image tag i rank . other-message)
(if (and (pair? other-message) (string? (car other-message)))
(check-arg tag (image? i) (car other-message) rank i)
(check-arg tag (image? i) "image" rank i)))
(define (check-scene tag i rank)
(define error "image with pinhole at (~s,~s)")
(if (2:image? i)
i
(if (1:image? i)
(check-arg tag (1:scene? i) "scene" rank (image-pins i))
(check-arg tag #f "scene" rank i))))
(define (check-scene-result tname i)
(if (2:image? i)
i
(if (1:image? i)
(check-result tname 1:scene? "scene" i (image-pins i))
(check-result tname #f "scene" i))))
(define (image-pins i)
(format "image with pinhole at (~s,~s)" (1:pinhole-x i) (1:pinhole-y i)))

2
collects/2htdp/private/world.ss
View File

@ -5,7 +5,7 @@
"last.ss"
"checked-cell.ss"
"stop.ss"
htdp/image
"universe-image.ss"
htdp/error
mzlib/runtime-path
mrlib/bitmap-label

1
collects/2htdp/uchat/chatter.ss
View File

@ -2,6 +2,7 @@
;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname chatter) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
(require 2htdp/universe)
(require htdp/image)
(require "auxiliaries.ss")
#|

5
collects/2htdp/universe.ss
View File

@ -13,7 +13,7 @@
"private/syn-aux-aux.ss"
"private/syn-aux.ss"
"private/check-aux.ss"
"private/image.ss"
"private/universe-image.ss"
"private/world.ss"
"private/universe.ss"
"private/launch-many-worlds.ss"
@ -21,8 +21,6 @@
htdp/error
(rename-in lang/prim (first-order->higher-order f2h)))
(provide (all-from-out "private/image.ss"))
(provide
(rename-out (make-stop-the-world stop-with))) ;; World -> STOP
@ -34,7 +32,6 @@
(provide
sexp? ;; Any -> Boolean
scene? ;; Any -> Boolean
)
(define-keywords AllSpec

2
collects/2htdp/utest/shared.ss
View File

@ -1,6 +1,6 @@
#lang scheme
(require 2htdp/universe htdp/testing)
(require 2htdp/universe htdp/testing htdp/image)
;(require "../2htdp/universe.ss" htdp/testing)
;; World = Number | 'resting

2
collects/games/chat-noir/chat-noir-literate.ss
View File

@ -49,7 +49,7 @@ and some code that builds an initial world and starts the game.
@chunk[<main>
(require scheme/list scheme/math
(for-syntax scheme/base))
(require 2htdp/universe lang/posn scheme/contract)
(require 2htdp/universe htdp/image lang/posn scheme/contract)
<world>
<breadth-first-search>
<board->graph>

243
collects/htdp/image.ss
View File

@ -1,3 +1,5 @@
#lang scheme/base
#|
The test suite for this code is in
@ -5,7 +7,6 @@ plt/collects/tests/mzscheme/htdp-image.ss
|#
#lang scheme/base
(require mred
mzlib/class
@ -18,6 +19,7 @@ plt/collects/tests/mzscheme/htdp-image.ss
(provide-primitives
image?
scene?
image=?
image-width
image-height
@ -79,6 +81,7 @@ plt/collects/tests/mzscheme/htdp-image.ss
;; ----------------------------------------
(define (to-exact-int x) (floor0 (if (exact? x) x (inexact->exact x))))
(define (floor0 n)
(cond
[(< n 0) (- (floor (- n)))]
@ -218,8 +221,8 @@ plt/collects/tests/mzscheme/htdp-image.ss
(check-image 'overlay/xy b "fourth")
(real-overlay/xy 'overlay/xy
a
(floor0 (if (exact? dx) dx (inexact->exact dx)))
(floor0 (if (exact? dy) dy (inexact->exact dy)))
(to-exact-int dx)
(to-exact-int dy)
b))
(define (real-overlay/xy name raw-a raw-delta-x raw-delta-y raw-b)
@ -266,10 +269,10 @@ plt/collects/tests/mzscheme/htdp-image.ss
(check-size/0 'shrink in-up "third")
(check-size/0 'shrink in-right "fourth")
(check-size/0 'shrink in-down "fifth")
(let ([left (inexact->exact (floor0 in-left))]
[up (inexact->exact (floor0 in-up))]
[right (inexact->exact (floor0 in-right))]
[down (inexact->exact (floor0 in-down))]
(let ([left (to-exact-int in-left)]
[up (to-exact-int in-up)]
[right (to-exact-int in-right)]
[down (to-exact-int in-down)]
[img (coerce-to-cache-image-snip raw-img)])
(let-values ([(i-px i-py) (send img get-pinhole)]
[(i-width i-height) (send img get-size)])
@ -299,16 +302,16 @@ plt/collects/tests/mzscheme/htdp-image.ss
(check-image 'shrink-tl raw-img "first")
(check-size 'shrink-tl in-x "second")
(check-size 'shrink-tl in-y "third")
(let ([x (inexact->exact (floor0 in-x))]
[y (inexact->exact (floor0 in-y))])
(let ([x (to-exact-int in-x)]
[y (to-exact-int in-y)])
(put-pinhole (shrink (put-pinhole raw-img 0 0) 0 0 (- x 1) (- y 1)) (/ x 2) (/ y 2))))
(define (shrink-tr raw-img in-x in-y)
(check-image 'shrink-tr raw-img "first")
(check-size 'shrink-tr in-x "second")
(check-size 'shrink-tr in-y "third")
(let ([x (inexact->exact (floor0 in-x))]
[y (inexact->exact (floor0 in-y))])
(let ([x (to-exact-int in-x)]
[y (to-exact-int in-y)])
(put-pinhole (shrink (put-pinhole raw-img (- (image-width raw-img) 1) 0) (- x 1) 0 0 (- y 1))
(/ x 2)
(/ y 2))))
@ -317,8 +320,8 @@ plt/collects/tests/mzscheme/htdp-image.ss
(check-image 'shrink-bl raw-img "first")
(check-size 'shrink-bl in-x "second")
(check-size 'shrink-bl in-y "third")
(let ([x (inexact->exact (floor0 in-x))]
[y (inexact->exact (floor0 in-y))])
(let ([x (to-exact-int in-x)]
[y (to-exact-int in-y)])
(put-pinhole (shrink (put-pinhole raw-img 0 (- (image-height raw-img) 1)) 0 (- y 1) (- x 1) 0)
(/ x 2)
(/ y 2))))
@ -327,8 +330,8 @@ plt/collects/tests/mzscheme/htdp-image.ss
(check-image 'shrink-br raw-img "first")
(check-size 'shrink-br in-x "second")
(check-size 'shrink-br in-y "third")
(let ([x (inexact->exact (floor0 in-x))]
[y (inexact->exact (floor0 in-y))])
(let ([x (to-exact-int in-x)]
[y (to-exact-int in-y)])
(put-pinhole (shrink (put-pinhole raw-img (- (image-width raw-img) 1) (- (image-height raw-img) 1))
(- x 1)
(- y 1)
@ -1027,3 +1030,213 @@ converting from the computer's coordinates, we get:
(alpha-color-green ac)
(alpha-color-blue ac)
(loop (cdr cl))))])))
;
;
;
;
; ;;; ;
; ;
; ;; ;;; ;; ;;;;;;; ; ; ;;;; ; ;; ; ;;; ;;; ;;; ;;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;; ; ;;; ;;;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ;; ; ; ; ;;;; ; ; ; ; ;;; ; ;;; ;;;
;
;
;
(provide
;; type Scene = Image with pinhole in origin
nw:rectangle ;; Number Number Mode Color -> Image
;; create a rectangle with pinhole in the upper-left corner
place-image ;; Image Number Number Scene -> Scene
;; place image at (x,y) in given scene
empty-scene ;; Number Number -> Scene
;; create an empty scene of size width x height (!= (nw:rectangle width height))
scene+line ;; Scene Number Number Number Number Color -> Scene
;; cut all pieces that are outside the given rectangle
)
(define (nw:rectangle width height mode color)
(check-size/0 'nw:rectangle width "first")
(check-size/0 'nw:rectangle height "second")
(check-mode 'nw:rectangle mode "third")
(check-image-color 'nw:rectangle color "fourth")
(put-pinhole (rectangle width height mode color) 0 0))
(define (place-image image x y scene)
(check-image 'place-image image "first")
(check-arg 'place-image (real? x) 'real "second" x)
(check-arg 'place-image (real? y) 'real "third" y)
(check-scene 'place-image scene "fourth")
(let ([x (to-exact-int x)]
[y (to-exact-int y)])
(place-image0 image x y scene)))
(define (empty-scene width height)
(check-size/0 'empty-scene width "first")
(check-size/0 'empty-scene height "second")
(put-pinhole
(overlay (rectangle width height 'solid 'white)
(rectangle width height 'outline 'black))
0 0))
(define (scene+line img x0 y0 x1 y1 c)
;; img and c are checked via calls to add-line from image.ss
(check-arg 'scene+line (scene? img) "scene" "first" "plain image")
(check-arg 'scene+line (real? x0) "number" "second" x0)
(check-arg 'scene+line (real? y0) "number" "third" y0)
(check-arg 'scene+line (real? x1) "number" "fourth" x1)
(check-arg 'scene+line (real? y1) "number" "fifth" y1)
(check-image-color 'scene+line c "sixth")
(let ([x0 (to-exact-int x0)]
[x1 (to-exact-int x1)]
[y0 (to-exact-int y0)]
[y1 (to-exact-int y1)])
(add-line-to-scene0 img x0 y0 x1 y1 c)))
;; Image Number Number Image -> Image
(define (place-image0 image x y scene)
(define sw (image-width scene))
(define sh (image-height scene))
(define ns (overlay/xy scene x y image))
(define nw (image-width ns))
(define nh (image-height ns))
(if (and (= sw nw) (= sh nh)) ns (shrink ns 0 0 (- sw 1) (- sh 1))))
;; Image Number Number Number Number Color -> Image
(define (add-line-to-scene0 img x0 y0 x1 y1 c)
(define w (image-width img))
(define h (image-height img))
(cond
[(and (<= 0 x0) (< x0 w) (<= 0 y0) (< y0 w)
(<= 0 x1) (< x1 w) (<= 0 y1) (< y1 w))
;; everything is inside
(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
;; partial off-screen
(let ()
(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-scene0 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
[(and (<= 0 y) (< y h)) y]
[(< y 0) 0]
[else (- h 1)]))
;; 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"))))
#| TESTS
'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)
(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 #f))
;; 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 #f #f 10 80))
|#
;; Symbol Any String -> Void
(define (check-scene tag i rank)
(define error "image with pinhole at (~s,~s)")
(if (image? i)
(check-arg tag (scene? i) "scene" rank (image-pins i))
(check-arg tag #f "scene" rank i)))
;; Symbol Any -> Void
(define (check-scene-result tname i)
(if (image? i)
(check-result tname scene? "scene" i (image-pins i))
(check-result tname (lambda (x) (image? x)) "scene" i)))
(define (image-pins i)
(format "image with pinhole at (~s,~s)" (pinhole-x i) (pinhole-y i)))

55
collects/htdp/tests/world-add-line.ss
View File

@ -1,71 +1,72 @@
;; The first three lines of this file were inserted by DrScheme. They record metadata
;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-beginner-reader.ss" "lang")((modname world-add-line) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
(require (lib "world.ss" "htdp"))
; (require 2htdp/universe)
#lang scheme/base
(require htdp/image test-engine/scheme-tests)
(define plain (empty-scene 100 100))
(scene+line plain .5 10.3 -20 80 'red)
; (scene+line plain .5 10.3 -20 80 'red)
'verticals
(check-expect (scene+line plain -10 90 -10 80 'red) plain)
(check-expect (scene+line plain 110 90 110 80 'red) plain)
(check-expect (scene+line plain +10 90 +10 80 'red)
(scene+line plain +10 90 +10 80 'red))
(scene+line plain +10 90 +10 80 'red))
#;
(check-expect (scene+line plain +10 900000 +10 80 'red)
(scene+line plain +10 100 +10 80 'red))
(scene+line plain +10 100 +10 80 'red))
;; can't make image of this size
(check-expect (scene+line plain +10 -10 +10 80 'red)
(scene+line plain +10 0 +10 80 'red))
(scene+line plain +10 0 +10 80 'red))
'horizontals
(check-expect (scene+line plain 20 -10 30 -10 'red) plain)
(check-expect (scene+line plain 20 110 30 110 'red) plain)
(check-expect (scene+line plain 20 +10 30 +10 'red)
(scene+line plain 20 +10 30 +10 'red))
(scene+line plain 20 +10 30 +10 'red))
#;
(check-expect (scene+line plain 20 +10 30000 +10 'red)
(scene+line plain 20 +10 100 +10 'red))
(scene+line plain 20 +10 100 +10 'red))
;; can't make image of this size
'inside-outside
(check-expect (scene+line plain 10 10 -10 -10 'red) ; upper-left
(scene+line plain 10 10 0 0 'red))
(scene+line plain 10 10 0 0 'red))
(check-expect (scene+line plain 10 10 -10 0 'red) ; upper-left
(scene+line plain 10 10 0 5 'red))
(scene+line plain 10 10 0 5 'red))
(check-expect (scene+line plain 90 10 110 -10 'red) ; upper-right
(scene+line plain 90 10 100 0 'red))
(scene+line plain 90 10 100 0 'red))
(check-expect (scene+line plain 90 10 110 0 'red) ; upper-left
(scene+line plain 90 10 100 5 'red))
(scene+line plain 90 10 100 5 'red))
(check-expect (scene+line plain 90 90 110 110 'red) ; lower-right
(scene+line plain 90 90 100 100 'red))
(scene+line plain 90 90 100 100 'red))
(check-expect (scene+line plain 90 90 110 100 'red) ; lower-right
(scene+line plain 90 90 100 95 'red))
(scene+line plain 90 90 100 95 'red))
(check-expect (scene+line plain 110 110 10 10 'red) ; lower-right
(scene+line plain 10 10 100 100 'red))
(scene+line plain 10 10 100 100 'red))
(check-expect (scene+line plain 10 10 210 110 'red) ; lower-right
(scene+line plain 10 10 100 55 'red))
(scene+line plain 10 10 100 55 'red))
(check-expect (scene+line plain 10 10 -10 30 'red) ; lower-left
(scene+line plain 10 10 0 20 'red))
(scene+line plain 10 10 0 20 'red))
(check-expect (scene+line plain 10 10 -10 210 'red) ; lower-left
(scene+line plain 10 10 0 110 'red))
(scene+line plain 10 10 0 110 'red))
'outside-outside
(check-expect (scene+line plain -100 10 300 50 'red) ;; left-right
(scene+line plain 0 20 100 30 'red))
(scene+line plain 0 20 100 30 'red))
(check-expect (scene+line plain -50 0 60 110 'red) ;; left-low
(scene+line plain 0 50 50 100 'red))
(scene+line plain 0 50 50 100 'red))
(check-expect (scene+line plain -50 50 60 -5 'red) ;; left-top
(scene+line plain 0 25 50 0 'red))
(scene+line plain 0 25 50 0 'red))
(check-expect (scene+line plain -10 -10 110 50 'red) ;; top-right
(scene+line plain 10 0 100 45 'red))
(scene+line plain 10 0 100 45 'red))
(check-expect (scene+line plain -10 -10 110 110 'red) ;; top-low
(scene+line plain 0 0 100 100 'red))
(scene+line plain 0 0 100 100 'red))
(check-expect (scene+line plain -10 110 110 50 'red) ;; low-right
(scene+line plain 0 105 100 55 'red))
(scene+line plain 0 105 100 55 'red))
'totally-outside
(check-expect (scene+line plain -100 -100 -200 -500 'red) plain)
(test)

62
collects/htdp/world.ss
View File

@ -104,15 +104,6 @@ Matthew
;; =============================
(provide (all-from-out htdp/image))
(provide
;; Scene is Image with pinhole in origin
nw:rectangle ;; Number Number Mode Color -> Image
place-image ;; Image Number Number Scene -> Scene
empty-scene ;; Number Number -> Scene
scene+line ;; Scene Number Number Number Number Color -> Scene
;; cut all pieces that are outside the given rectangle
)
;; world manipulation functions:
;; =============================
(provide ;; forall(World):
@ -166,57 +157,6 @@ Matthew
;; ---------------------------------------------------------------------------
;
;
; ;;;;; ;;;;;
; ; ; ;
; ; ; ;
; ; ; ; ; ;; ;;; ; ;;; ;;;;; ; ; ;;; ; ;;;;
; ;;;;; ; ; ;; ; ; ; ;; ; ; ; ; ; ;;; ; ;
; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;
; ;;;;; ; ; ;;;; ;;; ; ;; ; ;;;;; ; ; ; ;; ;
; ; ;
; ; ;;;;
;
(define (nw:rectangle width height mode color)
(check-size/0 'nw:rectangle width "first")
(check-size/0 'nw:rectangle height "second")
(check-mode 'rectangle mode "third")
(check-sym/string-color 'rectangle color "fourth")
(put-pinhole (rectangle width height mode color) 0 0))
(define (place-image image x y scene)
(check-image 'place-image image "first")
(check-arg 'place-image (number? x) 'integer "second" x)
(check-arg 'place-image (number? y) 'integer "third" y)
(check-scene 'place-image scene "fourth")
(let ([x (number->integer x)]
[y (number->integer y)])
(place-image0 image x y scene)))
(define (empty-scene width height)
(check-size/0 'empty-scene width "first")
(check-size/0 'empty-scene height "second")
(put-pinhole
(overlay (rectangle width height 'solid 'white)
(rectangle width height 'outline 'black))
0 0))
(define (scene+line img x0 y0 x1 y1 c)
;; img and c are checked via calls to add-line from image.ss
(check-arg 'scene+line (scene? img) "scene" "first" "plain image")
(check-arg 'scene+line (number? x0) "number" "second" x0)
(check-arg 'scene+line (number? y0) "number" "third" y0)
(check-arg 'scene+line (number? x1) "number" "fourth" x1)
(check-arg 'scene+line (number? y1) "number" "fifth" y1)
(let ([x0 (number->integer x0)]
[x1 (number->integer x1)]
[y0 (number->integer y0)]
[y1 (number->integer y1)])
(add-line-to-scene0 img x0 y0 x1 y1 c)))
;
;
@ -407,8 +347,6 @@ Matthew
(pinhole-x i) (pinhole-y i)))
(check-arg tag #f "image" rank i)))
(define (scene? i) (and (= 0 (pinhole-x i)) (= 0 (pinhole-y i))))
;; Symbol Any String -> Void
(define (check-sym/string-color tag width rank)
(check-arg tag (or (symbol? width) (string? width))

40
collects/lang/private/imageeq.ss
View File

@ -1,19 +1,25 @@
(module imageeq mzscheme
(require mred
mrlib/cache-image-snip
mzlib/class)
(provide image? image=?
coerce-to-cache-image-snip
snip-size
bitmaps->cache-image-snip)
#lang scheme/base
(require scheme/gui/base
mrlib/cache-image-snip
mzlib/class)
(define (image? a)
(or (is-a? a image-snip%)
(is-a? a cache-image-snip%)))
(provide scene? image? image=?
coerce-to-cache-image-snip
snip-size
bitmaps->cache-image-snip)
(define (image=? a-raw b-raw)
(unless (image? a-raw) (raise-type-error 'image=? "image" 0 a-raw b-raw))
(unless (image? b-raw) (raise-type-error 'image=? "image" 1 a-raw b-raw))
;; Rely on image-snip% implementing equal<%>:
(equal? a-raw b-raw)))
(define (image? a)
(or (is-a? a image-snip%)
(is-a? a cache-image-snip%)))
(define (image=? a-raw b-raw)
(unless (image? a-raw) (raise-type-error 'image=? "image" 0 a-raw b-raw))
(unless (image? b-raw) (raise-type-error 'image=? "image" 1 a-raw b-raw))
;; Rely on image-snip% implementing equal<%>:
(equal? a-raw b-raw))
(define (scene? i)
(and (image? i)
(let-values ([(x y) (send (coerce-to-cache-image-snip i) get-pinhole)])
(and (= 0 x)
(= 0 y)))))

107
collects/teachpack/2htdp/scribblings/universe.scrbl
View File

@ -2,9 +2,9 @@
@(require scribble/manual "shared.ss"
(for-label scheme
(only-in lang/htdp-beginner check-expect)
(only-in lang/htdp-beginner check-expect)
teachpack/2htdp/universe
teachpack/htdp/image))
2htdp/image))
@(require scribble/struct)
@(define (table* . stuff)
@ -56,30 +56,15 @@ The purpose of this documentation is to give experienced Schemers and HtDP
@link["http://world.cs.brown.edu/"]{How to Design Worlds}.
@; -----------------------------------------------------------------------------
@section{Background}
The universe teachpack assumes working knowledge of the basic image manipulation primitives,
either @schememodname[htdp/image] or @schememodname[2htdp/image]. Its operations
sometimes require scenes which for @scheme[htdp/image] images means an image whose
pinhole is at (0,0). For @schememodname[2htdp/image], every image is a scene.
@section[#:tag "basics"]{Basics}
The teachpack assumes working knowledge of the basic image manipulation
primitives and supports several functions that require a special kind of
image, called a @deftech{scene}, which is an image whose pinholes are at
position @math{(0, 0)}. For example, the teachpack displays only
@tech{scene}s in its canvas.
@defproc[(scene? [x any/c]) boolean?]{
determines whether @scheme[x] is a @tech{scene}.}
@defproc[(empty-scene [width natural-number/c]
[height natural-number/c])
scene?]{
creates a plain white, @scheme[width] x @scheme[height] @tech{scene}.}
@defproc[(place-image [img image?] [x number?] [y number?]
[s scene?])
scene?]{
creates a scene by placing @scheme[img] at
@math{(@scheme[x], @scheme[y])} into @scheme[s];
@math{(@scheme[x], @scheme[y])} are computer graphics coordinates,
i.e., they count right and down from the upper-left corner.}
The example programs in this document are all written using @schememodname[2htdp/image]
primitives.
@; -----------------------------------------------------------------------------
@section[#:tag "simulations"]{Simple Simulations}
@ -89,7 +74,7 @@ The simplest kind of animated @tech{world} program is a time-based
supply a function that creates a scene for each natural number. By handing
this function to the teachpack displays the simulation.
@defproc[(animate [create-image (-> natural-number/c scene)])
@defproc[(animate [create-image (-> natural-number/c scene?)])
true]{
opens a canvas and starts a clock that tick 28 times per second. Every
@ -104,16 +89,18 @@ The simplest kind of animated @tech{world} program is a time-based
Example:
@schemeblock[
(define (create-UFO-scene height)
(place-image UFO 50 height (empty-scene 100 100)))
(underlay/xy (rectangle 100 100 "solid" "white") 50 height UFO))
(define UFO
(overlay (circle 10 'solid 'green)
(rectangle 40 4 'solid 'green)))
(underlay/align "center"
"center"
(circle 10 "solid" "green")
(rectangle 40 4 "solid" "green")))
(animate create-UFO-scene)
]
@defproc[(run-simulation [create-image (-> natural-number/c scene)])
@defproc[(run-simulation [create-image (-> natural-number/c scene?)])
true]{
@scheme[animate] was originally called @scheme[run-simulation], and this
@ -489,12 +476,14 @@ a short-hand for three lines of code:
@(begin
#reader scribble/comment-reader
@schemeblock[
(define (create-UFO-scene height)
(place-image UFO 50 height (empty-scene 100 100)))
(define (create-UFO-scene height)
(underlay/xy (rectangle 100 100 "solid" "white") 50 height UFO))
(define UFO
(overlay (circle 10 'solid 'green)
(rectangle 40 4 'solid 'green)))
(underlay/align "center"
"center"
(circle 10 "solid" "green")
(rectangle 40 4 "solid" "green")))
;; (run-simulation create-UFO-scene) is short for:
(big-bang 0
@ -505,26 +494,6 @@ a short-hand for three lines of code:
Exercise: Add a condition for stopping the flight of the UFO when it
reaches the bottom.
@; -----------------------------------------------------------------------------
@section[#:tag "scenes-and-images"]{Scenes and Images}
For the creation of scenes from the world, use the functions from
@secref["image"]. The teachpack adds the following two functions, which
are highly useful for creating scenes.
@defproc[(nw:rectangle [width natural-number/c] [height natural-number/c] [solid-or-outline Mode] [c Color]) image?]{
creates a @scheme[width] by @scheme[height] rectangle, solid or outlined as specified by
@scheme[solid-or-outline] and colored according to @scheme[c], with a pinhole at the upper left
corner.}
@defproc[(scene+line [s scene?][x0 number?][y0 number?][x1 number?][y1 number?][c Color]) scene?]{
creates a scene by placing a line of color @scheme[c] from
@math{(@scheme[x0], @scheme[y0])} to @math{(@scheme[x1],
@scheme[y1])} using computer graphics coordinates. In contrast to
the @scheme[add-line] function, @scheme[scene+line] cuts off those
portions of the line that go beyond the boundaries of the given
@scheme[s].}
@; -----------------------------------------------------------------------------
@section[#:tag "world-example"]{A First Sample World}
@ -1095,8 +1064,8 @@ Once you have designed a world program, add a function definition
#reader scribble/comment-reader
(schemeblock
> (launch-many-worlds (main "matthew")
(main "kathi")
(main "h3"))
(main "kathi")
(main "h3"))
10
25
33
@ -1607,16 +1576,17 @@ Finally, here is the third function, which renders the state as a scene:
; WorldState -> Scene
; render the state of the world as a scene
(check-expect (render HEIGHT) (place-image BALL 50 HEIGHT MT))
(check-expect (render HEIGHT) (underlay/xy MT 50 HEIGHT BALL))
(check-expect (render 'resting)
(place-image (text "resting" 11 'red) 10 10 MT))
(underlay/xy MT 10 10 (text "resting" 11 "red")))
(define (render w)
(place-image
(text name 11 'black) 5 85
(underlay/xy
(cond
[(symbol? w) (place-image (text "resting" 11 'red) 10 10 MT)]
[(number? w) (place-image BALL 50 w MT)])))
[(symbol? w) (underlay/xy MT 10 10 (text "resting" 11 "red"))]
[(number? w) (underlay/xy MT 50 w BALL)])
5 85
(text name 11 "black")))
))
@ -1631,17 +1601,18 @@ Finally, here is the third function, which renders the state as a scene:
(check-expect
((draw "Carl") 100)
(place-image (text "Carl" 11 'black)
(underlay/xy (underlay/xy MT 50 100 BALL)
5 85
(place-image BALL 50 100 MT)))
(text "Carl" 11 "black")))
(define (draw name)
(lambda (w)
(place-image
(text name 11 'black) 5 85
(overlay/xy
(cond
[(symbol? w) (place-image (text "resting" 11 'red) 10 10 MT)]
[(number? w) (place-image BALL 50 w MT)]))))
[(symbol? w) (underlay/xy MT 10 10 (text "resting" 11 "red"))]
[(number? w) (underlay/xy MT 50 w BALL)])
5 85
(text name 11 'black))))
))

42
collects/teachpack/htdp/scribblings/image.scrbl
View File

@ -221,6 +221,48 @@ Shrinks an image around its pinhole. The numbers are the pixels to save to
left, above, to the right, and below the pinhole, respectively. The pixel
directly on the pinhole is always saved.}
@;-----------------------------------------------------------------------------
@section[#:tag "scenes"]{Scenes}
A @deftech{scene} is an image, but with the pinhole in the upper-left corner, i.e.
an image where @scheme[pinhole-x] and @scheme[pinhole-y] both return
@scheme[0].
Scenes are particularly useful with the
@schememodname[2htdp/universe]
and
@schememodname[htdp/world]
teachpacks, since it displays only @tech{scene}s in its canvas.
@defproc[(scene? [x any/c]) boolean?]{Is @scheme[x] an scene?}
@defproc[(empty-scene [width natural-number/c]
[height natural-number/c])
scene?]{
creates a plain white, @scheme[width] x @scheme[height] @tech{scene}.}
@defproc[(place-image [img image?] [x number?] [y number?]
[s scene?])
scene?]{
creates a scene by placing @scheme[img] at
@math{(@scheme[x], @scheme[y])} into @scheme[s];
@math{(@scheme[x], @scheme[y])} are computer graphics coordinates,
i.e., they count right and down from the upper-left corner.}
@defproc[(nw:rectangle [width natural-number/c] [height natural-number/c] [solid-or-outline Mode] [c Color]) image?]{
creates a @scheme[width] by @scheme[height] rectangle, solid or outlined as specified by
@scheme[solid-or-outline] and colored according to @scheme[c], with a pinhole at the upper left
corner.}
@defproc[(scene+line [s scene?][x0 number?][y0 number?][x1 number?][y1 number?][c Color]) scene?]{
creates a scene by placing a line of color @scheme[c] from
@math{(@scheme[x0], @scheme[y0])} to @math{(@scheme[x1],
@scheme[y1])} using computer graphics coordinates. In contrast to
the @scheme[add-line] function, @scheme[scene+line] cuts off those
portions of the line that go beyond the boundaries of the given
@scheme[s].}
@;-----------------------------------------------------------------------------
@section[#:tag "pixel-lists"]{Miscellaneous Image Manipulation and Creation}

50
collects/teachpack/htdp/scribblings/world.scrbl
View File

@ -27,35 +27,6 @@ The teachpack provides two sets of tools. The first allows students to
create and display a series of animated scenes, i.e., a simulation. The
second one generalizes the first by adding interactive GUI features.
@; -----------------------------------------------------------------------------
@section[#:tag "basics"]{Basics}
The teachpack assumes working knowledge of the basic image manipulation
primitives and introduces a special kind of image: a scene.
@deftech{Scene}@;
@schemeblock[
;; Image -> Boolean
(define (focus-at-0-0 i)
(and (= (pinhole-x i) 0) (= (pinhole-y i) 0)))
(and/c image? focus-at-0-0)]
The teachpack can display only @tech{Scene}s, which are images whose
pinholes are at position @scheme[(0,0)].
@defproc[(empty-scene [width natural-number/c]
[height natural-number/c])
(unsyntax @tech{Scene})]{
Creates a @scheme[width] x @scheme[height] @tech{Scene}.}
@defproc[(place-image [img image?] [x number?] [y number?]
[s (unsyntax @tech{Scene})])
(unsyntax @tech{Scene})]{
Creates a scene by placing @scheme[img] at @scheme[(x,y)] into @scheme[s];
@scheme[(x,y)] are comp. graph. coordinates, i.e., they count right and
down from the upper-left corner.}
@; -----------------------------------------------------------------------------
@section[#:tag "simulations"]{Simple Simulations}
@ -207,27 +178,6 @@ Example: The following examples shows that @scheme[(run-simulation 100 100
Exercise: Add a condition for stopping the flight of the UFO when it
reaches the bottom.
@; -----------------------------------------------------------------------------
@section{Scenes and Images}
For the creation of scenes from the world, use the functions from
@secref["image"]. The following two functions have turned out to be useful
for the creation of scenes, too.
@defproc[(nw:rectangle [width natural-number/c] [height natural-number/c] [solid-or-filled Mode] [c Color]) image?]{
Creates a @scheme[width] x @scheme[height] rectangle, solid or outlined as specified by
@scheme[solid-or-filled] and colored according to @scheme[c], with a pinhole at the upper left
corner.}
@defproc[(scene+line [s (unsyntax @tech{Scene})][x0 number?][y0 number?][x1 number?][y1 number?][c Color]) (unsyntax @tech{Scene})]{
Creates a scene by placing a line of color @scheme[c] from @scheme[(x0,y0)] to
@scheme[(x1,y1)] into @scheme[scene];
@scheme[(x,y)] are comp. graph. coordinates;
in contrast to the @scheme[add-line] function, this
one cuts off those portions of the line that go beyond the boundaries of
the given @scheme[s].}
@; -----------------------------------------------------------------------------
@(define (table* . stuff)

44
collects/tests/mzscheme/htdp-image.ss
View File

@ -1236,6 +1236,34 @@
'clr-text-clr
(ignore (text "abc" 12 (make-color 0 0 255))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; test scene-based functions
;;
(test #t
'nw:rectangle1
(image=? (put-pinhole (rectangle 10 10 'solid 'black) 0 0)
(nw:rectangle 10 10 'solid 'black)))
(test #t
'empty-scene1
(image=? (put-pinhole
(overlay (rectangle 10 10 'solid 'white)
(rectangle 10 10 'outline 'black))
0 0)
(empty-scene 10 10)))
(test #t
'place-image1
(image=?
(overlay/xy (nw:rectangle 50 50 'solid 'orange)
10 12
(rectangle 10 10 'solid 'purple))
(place-image (rectangle 10 10 'solid 'purple)
10 12
(nw:rectangle 50 50 'solid 'orange))))
(define (tp-exn/num re)
(lambda (exn)
(and (exn:fail? exn)
@ -1269,6 +1297,10 @@
(err/rt-name-test (overlay/xy image-snip1 #f #f #f) "second")
(err/rt-name-test (overlay/xy image-snip1 1 #f #f) "third")
(err/rt-name-test (overlay/xy image-snip1 1 1 #f) "fourth")
(err/rt-name-test (place-image #f #f #f #f) "first")
(err/rt-name-test (place-image image-snip1 #f #f #f) "second")
(err/rt-name-test (place-image image-snip1 1 #f #f) "third")
(err/rt-name-test (place-image image-snip1 1 1 #f) "fourth")
(err/rt-name-test (pinhole-x 1) "first")
(err/rt-name-test (pinhole-y 1) "first")
(err/rt-name-test (move-pinhole #f #f #f) "first")
@ -1278,6 +1310,12 @@
(err/rt-name-test (rectangle 10 #f #f #f) "second")
(err/rt-name-test (rectangle 10 10 #f #f) "third")
(err/rt-name-test (rectangle 10 10 'solid #f) "fourth")
(err/rt-name-test (nw:rectangle #f #f #f #f) "first")
(err/rt-name-test (nw:rectangle 10 #f #f #f) "second")
(err/rt-name-test (nw:rectangle 10 10 #f #f) "third")
(err/rt-name-test (nw:rectangle 10 10 'solid #f) "fourth")
(err/rt-name-test (empty-scene #f #f) "first")
(err/rt-name-test (empty-scene 10 #f) "second")
(err/rt-name-test (circle #f #f #f) "first")
(err/rt-name-test (circle 10 #f #f) "second")
(err/rt-name-test (circle 10 'solid #f) "third")
@ -1297,6 +1335,12 @@
(err/rt-name-test (add-line image-snip1 10 10 #f #f #f) "fourth")
(err/rt-name-test (add-line image-snip1 10 10 11 #f #f) "fifth")
(err/rt-name-test (add-line image-snip1 10 10 11 11 #f) "sixth")
(err/rt-name-test (scene+line #f #f #f #f #f #f) "first")
(err/rt-name-test (scene+line (nw:rectangle 10 10 'solid 'blue) #f #f #f #f #f) "second")
(err/rt-name-test (scene+line (nw:rectangle 10 10 'solid 'blue) 10 #f #f #f #f) "third")
(err/rt-name-test (scene+line (nw:rectangle 10 10 'solid 'blue) 10 10 #f #f #f) "fourth")
(err/rt-name-test (scene+line (nw:rectangle 10 10 'solid 'blue) 10 10 11 #f #f) "fifth")
(err/rt-name-test (scene+line (nw:rectangle 10 10 'solid 'blue) 10 10 11 11 #f) "sixth")
(err/rt-name-test (text #f #f #f) "first")
(err/rt-name-test (text "abc" #f #f) "second")
(err/rt-name-test (text "abc" 10 #f) "third")