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

split up image into core library (required for copy & paste) and other stuff (implementation of the combinators, mostly)

Browse Source 
svn: r16141

original commit: 982f533d28636bea44e4a6912092186d65ddd6c9
This commit is contained in:
Robby Findler 2009-09-28 11:36:13 +00:00
parent bd025dddc7
commit f372cf7dc4
1 changed files with 28 additions and 515 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

543
collects/2htdp/private/image-core.ss
View File

@ -2,6 +2,8 @@
#| #|
(error 'fix-me-later)
improvments/changes wrt to htdp/image: improvments/changes wrt to htdp/image:
- copying and pasting does not introduce jaggies - copying and pasting does not introduce jaggies
@ -51,42 +53,10 @@ and they all have good sample contracts. (It is amazing what we can do with kids
(require scheme/class (require scheme/class
scheme/gui/base scheme/gui/base
htdp/error
scheme/math scheme/math
(for-syntax scheme/base)) (for-syntax scheme/base))
(provide overlay
overlay/places
overlay/xy
beside
beside/places
rotate
frame
ellipse
rectangle
;; internal stuff, for the test suite
show-image
normalize-shape
rotate-atomic
rotate-simple
simple-bb
make-image image-shape
make-bb
make-overlay
make-translate
make-ellipse
make-text
make-polygon
make-point
bring-between)
(define-for-syntax id-constructor-pairs '()) (define-for-syntax id-constructor-pairs '())
@ -179,10 +149,12 @@ and they all have good sample contracts. (It is amazing what we can do with kids
(define-struct/reg-mk ellipse (width height angle mode color) #:transparent #:omit-define-syntaxes) (define-struct/reg-mk ellipse (width height angle mode color) #:transparent #:omit-define-syntaxes)
;; ;;
;; - (make-text string angle font) ;; - (make-text string angle font)
;; NOTE: font can't be the raw mred font or else copy & paste won't work
(define-struct/reg-mk text (string angle font) #:omit-define-syntaxes #:transparent) (define-struct/reg-mk text (string angle font) #:omit-define-syntaxes #:transparent)
;; ;;
;; - (make-bitmap (is-a?/c bitmap%) angle) ;; - (make-bitmap (is-a?/c bitmap%) angle)
(define-struct/reg-mk bitmap (bitmap angle)) ;; NOTE: bitmap copying needs to happen in 'write' and 'read' methods
(define-struct/reg-mk bitmap (bitmap angle) #:omit-define-syntaxes #:transparent)
;; a polygon is: ;; a polygon is:
;; ;;
@ -301,7 +273,7 @@ and they all have good sample contracts. (It is amazing what we can do with kids
(make-image (list-ref lst 0) (make-image (list-ref lst 0)
(list-ref lst 1) (list-ref lst 1)
#f) #f)
(rectangle 20 20 'solid 'black)))) (make-image (error 'fix-me-later)))))
(super-new))) (super-new)))
(provide snip-class) (provide snip-class)
@ -330,8 +302,6 @@ and they all have good sample contracts. (It is amazing what we can do with kids
(define-id->constructor id->constructor) (define-id->constructor id->constructor)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; normalize-shape : shape (atomic-shape -> atomic-shape) -> normalized-shape ;; normalize-shape : shape (atomic-shape -> atomic-shape) -> normalized-shape
;; normalizes 'shape', calling 'f' on each atomic shape in the normalized shape. ;; normalizes 'shape', calling 'f' on each atomic shape in the normalized shape.
(define (normalize-shape shape [f values]) (define (normalize-shape shape [f values])
@ -379,148 +349,6 @@ and they all have good sample contracts. (It is amazing what we can do with kids
(text? shape) (text? shape)
(bitmap? shape))) (bitmap? shape)))
;; rotate-point : x,y angle -> x,y
(define (rotate-point x y θ)
(c->xy (* (make-polar 1 (degrees->radians θ))
(xy->c x y))))
(define (xy->c x y) (make-rectangular x (- y)))
(define (c->xy c)
(values (real-part c)
(- (imag-part c))))
;
;
;
;
;
;
; ;; ;; ;;
; ;; ;; ;;
; ;;;; ;;;;;;;;; ;;;; ;;;; ;;;; ;;;;;; ;;;; ;;;; ;; ;;; ;; ;; ;;; ;;;;;;
; ;; ;; ;;;; ;;;; ;;;;;; ;;;; ;;;;;; ;;;;;; ;; ;; ;;;;;; ;;;;; ;; ;;;;;; ;;;;;;
; ;;;;;;;; ;; ;; ;;; ;;; ;; ;;; ;; ;; ;;;;;;;;;;; ;;;;; ;; ;; ;; ;;; ;;
; ;;; ;; ;; ;;; ;;; ;; ;;; ;; ;; ;;; ;;; ;;;;; ;; ;; ;; ;;; ;;
; ;;; ;; ;; ;; ;;;;;; ;; ;;;;;; ;; ;; ;;; ;; ;;;;;; ;; ;; ;; ;; ;; ;;;;;;
; ;;;; ;; ;; ;;;; ;; ;;;; ;; ;; ;;;; ;;;; ;; ;;; ;; ;; ;; ;;;;;
; ;; ;;;
; ;;;;;
;
;
(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
(member arg '("left" left "right" right "middle" middle "center" center))
'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
(member arg '("top" top "bottom" bottom "middle" middle "center" center "baseline" baseline))
'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)
arg]
[(mode)
(check-arg fn-name
(member arg '(solid outline "solid" "outline"))
'mode
i
arg)
(if (string? arg)
(string->symbol arg)
arg)]
[(width height)
(check-arg fn-name
(and (number? arg)
(not (negative? arg)))
'non-negative-number
i arg)
arg]
[(dx dy)
(check-arg fn-name
(number? arg)
'number
i arg)
arg]
[(angle)
(check-arg fn-name
(and (number? arg)
(<= 0 arg)
(< arg 360))
'angle\ in\ degrees
i arg)
arg]
[(color)
(check-color fn-name i arg)
(let ([color-str
(cond
[(symbol? arg)
(symbol->string arg)]
[(string? arg)
(symbol->string arg)]
[else arg])])
(if (send the-color-database find-color color-str)
color-str
"black"))]
[else
(error 'check "the function ~a has an argument with an unknown name: ~s"
fn-name
argname)]))
@ -574,7 +402,7 @@ and they all have good sample contracts. (It is amazing what we can do with kids
(send sl set-value (max min-scale (min max-scale (f (send sl get-value))))) (send sl set-value (max min-scale (min max-scale (f (send sl get-value)))))
(send c refresh))]) (send c refresh))])
(send (new button% [label "√"] [callback (λ x (scale-adjust sub1))] [parent bp]) min-width 100) (send (new button% [label "√"] [callback (λ x (scale-adjust sub1))] [parent bp]) min-width 100)
(send (new button% [label "²"] [callback (λ x (scale-adjust add1))] [parent bp]) min-width 100) (send (new button% [label "2"] [callback (λ x (scale-adjust add1))] [parent bp]) min-width 100)
(send f show #t))) (send f show #t)))
;; render-image : normalized-shape dc dx dy -> void ;; render-image : normalized-shape dc dx dy -> void
@ -624,330 +452,6 @@ and they all have good sample contracts. (It is amazing what we can do with kids
(* θ 2 pi (/ 360))) (* θ 2 pi (/ 360)))
;
;
;
; ;;
; ;;
; ;;
; ;;;; ;;; ;;;;;; ;; ; ;; ;;;;; ;;; ;
; ;; ;; ;; ;;;; ;; ;;;; ;; ; ;; ;; ;;
; ;;; ;; ;;;; ;;;;;; ;; ;; ;;;; ;;;;
; ;;; ;; ;;;; ;; ;; ;; ;; ;; ;;;
; ;; ;; ;;; ;;; ; ;; ;; ;; ;; ;;;
; ;;;; ;; ;;;; ;; ;; ;;;;;;; ;;
; ;;
; ;
; ;;
;; bitmap : string -> image
;; gets one of the bitmaps that comes with drscheme, scales it down by 1/8 or something
;; so that later scaling /translation/whatever will look reasonable.
;; (the error message for a bad argument will list all of the currently installed example images;
;; we may want to have some way teachers can stick new ones in there)
;; overlay : image image image ... -> image
;; places images on top of each other with their upper left corners aligned. last one goes on the bottom
(define/chk (overlay image image2 . image3)
(overlay/internal 'left 'top image (cons image2 image3)))
;; overlay/places : string string image image image ... -> image
;; the first string has to be one of "center" "middle" "left" or "right" (or symbols)
;; the second string has to be one of "center" "middle" "top" "bottom" or "baseline" (or symbols)
;; behaves like overlay, but lines up the images in the various places.
;; overlay without string arguments is the same as passing "left" and "top"
;; for the two string arguments. Passing, eg, "center" "center" lines the
;; images up at their centers.
(define/chk (overlay/places x-place y-place image image2 . image3)
(overlay/internal x-place y-place image (cons image2 image3)))
(define (overlay/internal x-place y-place fst rst)
(let loop ([fst fst]
[rst rst])
(cond
[(null? rst) fst]
[else
(let* ([fst-x-spot (find-x-spot x-place fst)]
[fst-y-spot (find-y-spot y-place fst)]
[snd-x-spot (find-x-spot x-place (car rst))]
[snd-y-spot (find-y-spot y-place (car rst))]
[dx (- fst-x-spot snd-x-spot)]
[dy (- fst-y-spot snd-y-spot)])
(loop (overlay/δ fst
(if (< dx 0) (- dx) 0)
(if (< dy 0) (- dy) 0)
(car rst)
(if (< dx 0) 0 dx)
(if (< dy 0) 0 dy))
(cdr rst)))])))
(define (find-x-spot x-place image)
(case x-place
[(left) 0]
[(middle) (/ (image-right image) 2)]
[(right) (image-right image)]))
(define (find-y-spot y-place image)
(case y-place
[(top) 0]
[(middle) (/ (image-bottom image) 2)]
[(bottom) (image-bottom image)]
[(baseline) (image-baseline image)]))
;; overlay/xy : image number number image -> image
;; places images on top of each other with their upper-left corners offset by the two numbers
(define/chk (overlay/xy image dx dy image2)
(overlay/δ image
(if (< dx 0) (- dx) 0)
(if (< dy 0) (- dy) 0)
image2
(if (< dx 0) 0 dx)
(if (< dy 0) 0 dy)))
(define (overlay/δ image1 dx1 dy1 image2 dx2 dy2)
(make-image (make-overlay (make-translate dx1 dy1 (image-shape image1))
(make-translate dx2 dy2 (image-shape image2)))
(make-bb (max (+ (image-right image1) dx1)
(+ (image-right image2) dx2))
(max (+ (image-bottom image1) dy1)
(+ (image-bottom image2) dy2))
(max (+ (image-baseline image1) dy1)
(+ (image-baseline image2) dy2)))
#f))
;; beside : image image image ... -> image
;; places images in a single horizontal row, top aligned
(define/chk (beside image1 image2 . image3)
(beside/internal 'top image1 (cons image2 image3)))
;; beside/places : string image image image ... -> image
;; places images in a horizontal row where the vertical alignment is
;; covered by the string argument
(define/chk (beside/places y-place image1 image2 . image3)
(beside/internal y-place image1 (cons image2 image3)))
(define (beside/internal y-place fst rst)
(let loop ([fst fst]
[rst rst])
(cond
[(null? rst) fst]
[else
(let* ([snd (car rst)]
[fst-y-spot (find-y-spot y-place fst)]
[snd-y-spot (find-y-spot y-place (car rst))]
[dy (- fst-y-spot snd-y-spot)])
(loop (overlay/δ fst
0
(if (< dy 0) (- dy) 0)
(car rst)
(image-right fst)
(if (< dy 0) 0 dy))
(cdr rst)))])))
;; above : image image image ... -> image
;; above/places : string I I I ... -> I
;; like beside, but vertically
;
; ;; ;; ;;
; ;; ;; ;;;
; ;;;; ;;;; ;;;;;; ;;; ;;;;; ;; ;; ;;; ;;;; ;;;;; ;;;; ;;;; ;;;;;
; ;;;;;; ;;;;;; ;;;;;;;;;; ;;;;;; ;; ;;;;;; ;; ;; ;;;; ;;;;;; ;;;; ;; ;;
; ;;; ;;; ;;; ;; ;; ;; ;; ;;; ;; ;; ;; ;;;; ;;; ;;; ;;; ;; ;;;;;
; ;;; ;;; ;;; ;; ;; ;; ;; ;;; ;; ;; ;; ;;; ;; ;;; ;;; ;;; ;; ;;;;
; ;;;;;; ;;;;;; ;; ;; ;; ;;;;;; ;; ;; ;; ;;; ;; ;;;; ;;;;;; ;; ;; ;;;
; ;;;; ;;;; ;; ;; ;; ;; ;; ;; ;; ;; ;;;;;; ;;; ;;;; ;; ;;;;;
;
;
;
;; frame : image -> image
;; draws a black frame around a image where the bounding box is
;; (useful for debugging images)
(define/chk (frame image)
(make-image (make-overlay (image-shape image)
(image-shape
(rectangle (image-right image)
(image-bottom image)
'outline
'black)))
(make-bb (image-right image)
(image-bottom image)
(image-baseline image))
#f))
;; scale : I number -> I
;; scales the I by the given factor
;; rotate : I number -> I
;; rotates the I around the top-left corner by the given angle
;; (in degrees)
;; LINEAR TIME OPERATION (sigh)
(define/chk (rotate angle image)
(define left #f)
(define top #f)
(define right #f)
(define bottom #f)
(define (add-to-bounding-box/rotate simple-shape)
(let ([rotated-shape (rotate-simple angle simple-shape)])
(let-values ([(this-left this-top this-right this-bottom) (simple-bb rotated-shape)])
(set! left (if left (min this-left left) this-left))
(set! top (if top (min this-top top) this-top))
(set! right (if right (max this-right right) this-right))
(set! bottom (if bottom (max this-bottom bottom) this-bottom)))
rotated-shape))
(let* ([rotated (normalize-shape (image-shape image) add-to-bounding-box/rotate)])
(make-image (make-translate (- left) (- top) rotated)
(make-bb (- right left) (- bottom top) (- bottom top))
#f)))
;; simple-bb : simple-shape -> (values number number number number)
;; returns the bounding box of 'shape'
;; (only called for rotated shapes, so bottom=baseline)
(define (simple-bb simple-shape)
(cond
[(polygon? simple-shape)
(let ([points (polygon-points simple-shape)])
(let* ([fx (point-x (car points))]
[fy (point-y (car points))]
[left fx]
[top fy]
[right fx]
[bottom fy])
(for-each (λ (point)
(let ([new-x (point-x point)]
[new-y (point-y point)])
(set! left (min new-x left))
(set! top (min new-y top))
(set! right (max new-x right))
(set! bottom (max new-y bottom))))
(cdr points))
(values left top right bottom)))]
[else
(let ([dx (translate-dx simple-shape)]
[dy (translate-dy simple-shape)]
[atomic-shape (translate-shape simple-shape)])
(fprintf (current-error-port) "BAD bounding box\n")
(values 0 0 100 100))]))
;; rotate-simple : angle simple-shape -> simple-shape
(define (rotate-simple θ simple-shape)
(cond
[(polygon? simple-shape)
(make-polygon (map (λ (p)
(let-values ([(xn yn) (rotate-point (point-x p) (point-y p) θ)])
(make-point xn yn)))
(polygon-points simple-shape))
(polygon-mode simple-shape)
(polygon-color simple-shape))]
[else
(let-values ([(dx dy) (c->xy (* (make-polar 1 (degrees->radians θ))
(xy->c (translate-dx simple-shape)
(translate-dy simple-shape))))])
(make-translate
dx
dy
(rotate-atomic θ (translate-shape simple-shape))))]))
;; rotate-atomic : angle np-atomic-shape -> np-atomic-shape
(define (rotate-atomic θ atomic-shape)
(cond
[(ellipse? atomic-shape)
(cond
[(= (ellipse-width atomic-shape)
(ellipse-height atomic-shape))
atomic-shape]
[else
(let ([new-angle (bring-between (+ θ (ellipse-angle atomic-shape)) 180)])
(cond
[(< new-angle 90)
(make-ellipse (ellipse-width atomic-shape)
(ellipse-height atomic-shape)
new-angle
(ellipse-mode atomic-shape)
(ellipse-color atomic-shape))]
[else
(make-ellipse (ellipse-height atomic-shape)
(ellipse-width atomic-shape)
(- new-angle 90)
(ellipse-mode atomic-shape)
(ellipse-color atomic-shape))]))])]
[(text? atomic-shape)
(make-text (text-string atomic-shape)
(bring-between (+ θ (text-angle atomic-shape)) 360)
(text-font atomic-shape))]
[(bitmap? atomic-shape)
(make-bitmap (bitmap-bitmap atomic-shape)
(bring-between (+ θ (bitmap-angle atomic-shape)) 360))]))
;; bring-between : number number -> number
;; returns a number that is much like the modulo of 'x' and 'upper-bound'
;; but does this by repeated subtraction, since modulo only works on integers
(define (bring-between x upper-bound)
(let loop ([x x])
(cond
[(< x 0)
(loop (+ x upper-bound))]
[(< x upper-bound)
x]
[else
(loop (- x upper-bound))])))
;; stamp : I I -> I
;; treats the first I as if it were a mask and uses that mask to
;; mask out parts of the first I (the mask is solid; no alpha stuff
;; here, even if dim were used).
;; only accepts solid black Is
;; see-thru : I number -> I
;; applies an alpha value to the I, making it translucent
;; -- as in the current I library, but they don't actually create
;; bitmaps, but instead just records that are rendered right as they are
;; about to be drawn
;; rectangle
(define/chk (rectangle width height mode color)
(make-image (make-polygon (rectangle-points width height)
mode
color)
(make-bb width
height
height)
#f))
(define (rectangle-points width height)
(list (make-point 0 0)
(make-point width 0)
(make-point width height)
(make-point 0 height)))
;; circle
;; ellipse
;; triangle
;; line
;; star
;; text
;; regular-polygon
(define/chk (ellipse width height mode color)
(make-image (make-ellipse width height
0
mode
color)
(make-bb width height height)
#f))
(define (mode-color->pen mode color) (define (mode-color->pen mode color)
(send the-pen-list find-or-create-pen color 1 (send the-pen-list find-or-create-pen color 1
(case mode (case mode
@ -960,15 +464,24 @@ and they all have good sample contracts. (It is amazing what we can do with kids
[(outline) 'transparent] [(outline) 'transparent]
[(solid) 'solid]))) [(solid) 'solid])))
;; add-line : I number number number number -> I
;; add-line : string string I number number number number -> I
;; like add-line, but adapted to use coordinates relative the top-left of the I,
;; or to the user-specified spot
;; add-curve : I posn number number posn number number -> I
;; add-curve : string string I posn number number posn number number -> I
;; the posns are the start and end points of the curve
;; the pair of numbers following each posn are the angle and "pull" of the curve
;; see pin-line in slideshow
;; the initial strings in the second instance of add-curve are like the strings in add-line
(provide make-image image-shape
(struct-out bb)
(struct-out point)
make-overlay overlay? overlay-top overlay-bottom
make-translate translate? translate-dx translate-dy translate-shape
make-ellipse ellipse? ellipse-width ellipse-height ellipse-angle ellipse-mode ellipse-color
make-text text? text-string text-angle text-font
make-polygon polygon? polygon-points polygon-mode polygon-color
make-bitmap bitmap? bitmap-bitmap bitmap-angle
degrees->radians
normalize-shape
image?
image-right
image-bottom
image-baseline
show-image)