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

make color and pen from 2htdp/image be structs in the sense

Browse Source 
that 'color' and 'pen' have compile-time info saying that
they are structs

closes PR 13146
This commit is contained in:
Robby Findler 2012-09-28 15:08:49 -05:00
parent 8971cb5981
commit e0c4e4055d
2 changed files with 62 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
collects/2htdp/image.rkt
View File

@ -37,7 +37,8 @@ and they all have good sample contracts. (It is amazing what we can do with kids
"private/image-more.rkt"
"private/img-err.rkt"
(only-in lang/prim provide-primitive provide-primitives define-primitive)
htdp/error)
htdp/error
(for-syntax racket/base))
(provide-primitives
overlay
@ -58,7 +59,7 @@ and they all have good sample contracts. (It is amazing what we can do with kids
above
above/align
crop
crop
rotate
flip-horizontal
flip-vertical
@ -112,8 +113,6 @@ and they all have good sample contracts. (It is amazing what we can do with kids
pen-cap?
pen-join?
real-valued-posn?
color-red color-blue color-green color-alpha color? color
pen-color pen-width pen-style pen-cap pen-join
image-width
image-height
@ -128,8 +127,7 @@ and they all have good sample contracts. (It is amazing what we can do with kids
underlay/pinhole
make-color
make-pen pen
pen?
make-pen
step-count?
save-image
save-svg-image
@ -142,10 +140,41 @@ and they all have good sample contracts. (It is amazing what we can do with kids
empty-image)
(define-primitive make-color build-color/make-color)
(define-primitive color build-color/color)
(define-primitive color build-color/color
(list #f
#'color #':color?
(list #':color-alpha #':color-blue #':color-green #':color-red)
(list #f #f #f #f)
#f))
(define-primitive make-pen build-pen/make-pen)
(define-primitive pen build-pen/pen)
(define-primitive pen build-pen/pen
(list #f
#'pen #':pen?
(list #':pen-join #':pen-cap #':pen-style #':pen-width #':pen-color)
(list #f #f #f #f #f)
#f))
(provide color pen)
#;
(provide (rename-out [build-color make-color])
(rename-out [build-pen make-pen]))
(define-primitive :color-red color-red)
(define-primitive :color-blue color-blue)
(define-primitive :color-green color-green)
(define-primitive :color-alpha color-alpha)
(define-primitive :color? color?)
(define-primitive :pen-color pen-color)
(define-primitive :pen-width pen-width)
(define-primitive :pen-style pen-style)
(define-primitive :pen-cap pen-cap)
(define-primitive :pen-join pen-join)
(define-primitive :pen? pen?)
(provide (rename-out [:color-red color-red]
[:color-blue color-blue]
[:color-green color-green]
[:color-alpha color-alpha]
[:color? color?]
[:pen-color pen-color]
[:pen-width pen-width]
[:pen-style pen-style]
[:pen-cap pen-cap]
[:pen-join pen-join]
[:pen? pen?]))

23
collects/2htdp/tests/test-image.rkt
View File

@ -57,7 +57,8 @@
file/convertible
(only-in lang/imageeq image=?)
(prefix-in 1: htdp/image)
(only-in lang/htdp-advanced equal~?))
(only-in lang/htdp-advanced equal~?)
racket/match)
(require (for-syntax racket/base))
(define-syntax (test stx)
@ -2063,6 +2064,26 @@
0 0 "center" "center"
(rectangle 10 100 'solid 'blue)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; make sure color and pen structs cooperate with racket
;; struct operations (not just teaching langs)
;;
(test (struct-copy color (color 0 0 0) [red 2])
=>
(color 2 0 0))
(test (struct-copy pen (pen "red" 1 "solid" "round" "round") [color "blue"])
=>
(pen "blue" 1 "solid" "round" "round"))
(test (match (color 1 2 3)
[(color r g b a) (list r g b)]
[_ #f])
=>
(list 1 2 3))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; test errors.