diff --git a/collects/2htdp/image.ss b/collects/2htdp/image.ss index f55a9ff00a..9708e75559 100644 --- a/collects/2htdp/image.ss +++ b/collects/2htdp/image.ss @@ -1,5 +1,6 @@ #lang scheme/base -(require "private/image-core.ss") +(require "private/image-core.ss" + "private/image-more.ss") (provide overlay overlay/places overlay/xy diff --git a/collects/2htdp/private/image-core.ss b/collects/2htdp/private/image-core.ss index 10be11bf13..ba07dbeb4e 100644 --- a/collects/2htdp/private/image-core.ss +++ b/collects/2htdp/private/image-core.ss @@ -2,6 +2,8 @@ #| +(error 'fix-me-later) + improvments/changes wrt to htdp/image: - 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 scheme/gui/base - htdp/error scheme/math (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 '()) @@ -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) ;; ;; - (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) ;; ;; - (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: ;; @@ -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) (list-ref lst 1) #f) - (rectangle 20 20 'solid 'black)))) + (make-image (error 'fix-me-later))))) (super-new))) (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) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; normalize-shape : shape (atomic-shape -> atomic-shape) -> normalized-shape ;; normalizes 'shape', calling 'f' on each atomic shape in the normalized shape. (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) (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 c refresh))]) (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))) ;; 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))) -; -; -; -; ;; -; ;; -; ;; -; ;;;; ;;; ;;;;;; ;; ; ;; ;;;;; ;;; ; -; ;; ;; ;; ;;;; ;; ;;;; ;; ; ;; ;; ;; -; ;;; ;; ;;;; ;;;;;; ;; ;; ;;;; ;;;; -; ;;; ;; ;;;; ;; ;; ;; ;; ;; ;;; -; ;; ;; ;;; ;;; ; ;; ;; ;; ;; ;;; -; ;;;; ;; ;;;; ;; ;; ;;;;;;; ;; -; ;; -; ; -; ;; - - -;; 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) (send the-pen-list find-or-create-pen color 1 (case mode @@ -960,15 +464,24 @@ and they all have good sample contracts. (It is amazing what we can do with kids [(outline) 'transparent] [(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) \ No newline at end of file diff --git a/collects/2htdp/private/image-more.ss b/collects/2htdp/private/image-more.ss index 0815532643..ec79840693 100644 --- a/collects/2htdp/private/image-more.ss +++ b/collects/2htdp/private/image-more.ss @@ -1,41 +1,7 @@ #lang scheme/base -#| - -improvments/changes wrt to htdp/image: - - - copying and pasting does not introduce jaggies - - equal comparisions are more efficient - - added rotation & scaling - - got rid of pinholes (see the new overlay, beside, and above functions) - -todo: sort out wxme library support (loading in text mode). - -;; when rendering these things in error messages, -;; they should come out as # -;; (automatically scale them down so they fit) - -;; redex randomized testing: see if normalization produces normalized shapes. -;; see if normalization always puts things in the right order - -;; need to change error messages to say "the width (second) argument" -;; by passing "width (second)" to the check-arg function - - -From Matthias: (to use to compare with this library) - - -You asked about exercises and code snippets for HtDP/2e yesterday. I actually do have a bunch of stuff in - - svn: 2HtDP/SampleCode/ - -and they all have good sample contracts. (It is amazing what we can do with kids who have just a few weeks of cs down; I would have never dared to write an editor after six weeks in Algol.) - - -|# - - -(require scheme/class +(require "image-core.ss" + scheme/class scheme/gui/base htdp/error scheme/math @@ -55,326 +21,9 @@ and they all have good sample contracts. (It is amazing what we can do with kids ellipse rectangle - ;; internal stuff, for the test suite - - show-picture - - normalize-shape - rotate-atomic - rotate-simple - simple-bb - make-picture picture-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 (add-id-constructor-pair a b) - (set! id-constructor-pairs (cons (list a b) id-constructor-pairs))) - -(define-syntax (define-struct/reg-mk stx) - (syntax-case stx () - [(_ id . rest) - (let ([build-name - (λ (fmt) - (datum->syntax #'id (string->symbol (format fmt (syntax->datum #'id)))))]) - (add-id-constructor-pair (build-name "struct:~a") - (build-name "make-~a")) - #'(define-struct id . rest))])) - -(define-syntax (define-id->constructor stx) - (syntax-case stx () - [(_ fn) - #`(define (fn x) - (case x - #,@(map (λ (x) - (with-syntax ([(struct: maker) x]) - #`[(struct:) maker])) - id-constructor-pairs)))])) - -(define-struct/reg-mk point (x y) #:transparent) - - -; -; -; -; -; -; -; ;; ;; ;; ;;; -; ;; ;;; ;; ;;; -; ;;;;; ;;;; ;;;;; ;;;; ;;;;; ;;;; ;;;;; ;; ;;; -; ;;;;;; ;; ;; ;;;; ;; ;; ;;;;;; ;; ;; ;;;; ;;;;;; -; ;;; ;; ;;;; ;;; ;;;; ;;; ;; ;;;;;;;; ;; ;; ;; -; ;;; ;; ;;; ;; ;;; ;;; ;; ;;; ;; ;;; ;; ;; ;; -; ;;;;;; ;;; ;; ;;;;;;; ;; ;;;;;; ;;; ;; ;; ;; ;; -; ;;;;; ;;;;;; ;;; ;;;;;; ;;;;; ;;;; ;; ;; ;; -; -; -; -; - - -;; a picture is -;; (make-picture shape bb boolean) -;; NOTE: the shape field is mutated when normalized, as -;; is the normalized? field. -(define (make-picture shape bb normalized?) (new picture% [shape shape] [bb bb] [normalized? normalized?])) -(define (picture-shape p) (send p get-shape)) -(define (picture-bb p) (send p get-bb)) -(define (picture-normalized? p) (send p get-normalized?)) -(define (set-picture-shape! p s) (send p set-shape s)) -(define (set-picture-normalized?! p n?) (send p set-normalized? n?)) -(define (picture-right picture) (bb-right (picture-bb picture))) -(define (picture-bottom picture) (bb-bottom (picture-bb picture))) -(define (picture-baseline picture) (bb-baseline (picture-bb picture))) -(define (picture? p) (is-a? p picture%)) - - -;; a bb is (bounding box) -;; (make-bb number number number) -(define-struct/reg-mk bb (right bottom baseline) #:transparent) - -;; a shape is either: -;; -;; - (make-overlay shape shape) -;; the shapes are in the order passed to the overlay or beside, -;; which means the bottom one should be drawn first so as to appear -;; underneath the top one. -(define-struct/reg-mk overlay (top bottom) #:transparent #:omit-define-syntaxes) -;; -;; - (make-translate dx dy shape) -(define-struct/reg-mk translate (dx dy shape) #:transparent #:omit-define-syntaxes) -;; -;; - atomic-shape - -;; an atomic-shape is either: -;; - polygon -;; - np-atomic-shape - -;; a np-atomic-shape is: -;; -;; - (make-ellipse width height angle mode color) -(define-struct/reg-mk ellipse (width height angle mode color) #:transparent #:omit-define-syntaxes) -;; -;; - (make-text string angle font) -(define-struct/reg-mk text (string angle font) #:omit-define-syntaxes #:transparent) -;; -;; - (make-bitmap (is-a?/c bitmap%) angle) -(define-struct/reg-mk bitmap (bitmap angle)) - -;; a polygon is: -;; -;; - (make-polygon (listof points) angle pen brush) -(define-struct/reg-mk polygon (points mode color) #:transparent #:omit-define-syntaxes - #:property prop:equal+hash - (list (λ (a b rec) (polygon-equal? a b rec)) (λ (x y) 42) (λ (x y) 3))) - -;; a normalized-shape (subtype of shape) is either -;; - (make-overlay normalized-shape simple-shape) -;; - simple-shape - -;; a simple-shape (subtype of shape) is -;; - (make-translate dx dy np-atomic-shape) -;; - polygon - -;; an angle is a number between 0 and 360 (degrees) - -(define (polygon-equal? p1 p2 eq-recur) - (and (eq-recur (polygon-mode p1) (polygon-mode p2)) - (eq-recur (polygon-color p1) (polygon-color p2)) - (let ([p1-points (polygon-points p1)] - [p2-points (polygon-points p2)]) - (or (and (null? p1-points) - (null? p2-points)) - (and (not (or (null? p1-points) - (null? p2-points))) - (eq-recur (rotate-to-zero (closest-to-zero p1-points) p1-points) - (rotate-to-zero (closest-to-zero p2-points) p2-points))))))) - -(define (rotate-to-zero zero-p points) - (let loop ([points points] - [acc null]) - (cond - [(equal? (car points) zero-p) - (append points (reverse acc))] - [else - (loop (cdr points) - (cons (car points) acc))]))) - -(define (closest-to-zero points) - (car (sort points < #:key (λ (p) (+ (point-x p) (point-y p)))))) - - -; -; -; -; ;; ;; ;; -; ;; ;;;; ; -; ; ; ;; ; -; ;; ;;;;;;;;; ;;;;; ;;;;;; ;;;; ; ;; ; -; ;; ;; ;;; ;;;; ;; ;; ;; ;;; ;; ;; ; -; ;; ;; ;;; ;;; ;;;; ;;; ;; ;;;;;; ; ;;; -; ;; ;; ;;; ;;;;; ;; ;;; ;; ;;; ;; -; ;; ;; ;;; ;;;;; ;; ;;;;; ;;; ; ; ;; ;; -; ;; ;; ;;; ;;;;;;;;;; ;;;;;; ;;;; ;; ;;; -; ;; ;; -; ;; ; -; ;;;; - -(define-local-member-name get-shape set-shape get-bb get-normalized? set-normalized get-normalized-shape) - -(define picture% - (class* snip% (equal<%>) - (init-field shape bb normalized?) - (define/public (equal-to? that eq-recur) - (eq-recur (get-normalized-shape) - (send that get-normalized-shape))) - (define/public (equal-hash-code-of y) 42) - (define/public (equal-secondary-hash-code-of y) 3) - - (define/public (get-shape) shape) - (define/public (set-shape s) (set! shape s)) - (define/public (get-bb) bb) - (define/public (get-normalized?) normalized?) - (define/public (set-normalized? n?) (set! normalized? n?)) - - (define/public (get-normalized-shape) - (unless normalized? - (set! shape (normalize-shape shape values)) - (set! normalized? #t)) - shape) - - (define/override (copy) (make-picture shape bb normalized?)) - (define/override (draw dc x y left top right bottom dx dy draw-caret?) - (render-picture this dc x y)) - (define/override (get-extent dc x y [w #f] [h #f] [descent #f] [space #f] [lspace #f] [rspace #f]) - (send (get-the-snip-class-list) add snip-class) - (let ([bottom (bb-bottom bb)]) - (set-box/f! w (bb-right bb)) - (set-box/f! h bottom) - (set-box/f! descent (- bottom (bb-baseline bb))) - (set-box/f! space 0) - (set-box/f! lspace 0) - (set-box/f! rspace 0))) - - (define/override (write f) - (send f put (string->bytes/utf-8 (format "~s" (list shape bb))))) - - (super-new) - - (inherit set-snipclass) - (set-snipclass snip-class))) - -(define scheme/base:read read) - -(define picture-snipclass% - (class snip-class% - (define/override (read f) - (let* ([str (bytes->string/utf-8 (send f get-unterminated-bytes))] - [lst (parse - (scheme/base:read - (open-input-string - str)))]) - (if lst - (make-picture (list-ref lst 0) - (list-ref lst 1) - #f) - (rectangle 20 20 'solid 'black)))) - (super-new))) - -(provide snip-class) -(define snip-class (new picture-snipclass%)) -(send snip-class set-classname (format "~s" '(lib "picture.ss" "2htdp/private"))) -(send snip-class set-version 1) -(send (get-the-snip-class-list) add snip-class) - -(define (set-box/f! b v) (when (box? b) (set-box! b v))) - -(define (parse sexp) - (let/ec k - (let loop ([sexp sexp]) - (cond - [(pair? sexp) (cons (loop (car sexp)) (loop (cdr sexp)))] - [(vector? sexp) - (if (= (vector-length sexp) 0) - (k #f) - (let ([constructor (id->constructor (vector-ref sexp 0))] - [args (cdr (vector->list sexp))]) - (if (and constructor - (procedure-arity-includes? constructor (length args))) - (apply constructor (map loop args)) - (k #f))))] - [else sexp])))) - -(define-id->constructor id->constructor) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; normalize-shape : shape (atomic-shape -> atomic-shape) -> normalized-shape -;; normalizes 'shape', calling 'f' on each atomic shape in the normalized shape. -(define (normalize-shape shape [f values]) - (let loop ([shape shape] - [dx 0] - [dy 0] - [bottom #f]) - (cond - [(translate? shape) - (loop (translate-shape shape) - (+ dx (translate-dx shape)) - (+ dy (translate-dy shape)) - bottom)] - [(overlay? shape) - (loop (overlay-bottom shape) - dx dy - (loop (overlay-top shape) - dx dy bottom))] - [(polygon? shape) - (let ([this-one (make-polygon (map (λ (p) - (make-point (+ dx (point-x p)) - (+ dy (point-y p)))) - (polygon-points shape)) - (polygon-mode shape) - (polygon-color shape))]) - (if bottom - (make-overlay bottom (f this-one)) - (f this-one)))] - [(np-atomic-shape? shape) - (let ([this-one (make-translate dx dy shape)]) - (if bottom - (make-overlay bottom (f this-one)) - (f this-one)))] - [else - (error 'normalize-shape "unknown shape ~s\n" shape)]))) - -(define (atomic-shape? shape) - (or (ellipse? shape) - (text? shape) - (polygon? shape) - (bitmap? shape))) - -(define (np-atomic-shape? shape) - (or (ellipse? shape) - (text? 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)))) - ; ; @@ -454,10 +103,10 @@ and they all have good sample contracts. (It is amazing what we can do with kids (if (eq? sym 'center) 'middle sym))] - [(picture picture1 picture2 picture3) + [(image image1 image2 image3) (check-arg fn-name - (picture? arg) - 'picture + (image? arg) + 'image i arg) arg] @@ -509,107 +158,6 @@ and they all have good sample contracts. (It is amazing what we can do with kids argname)])) - -; -; -; -; -; -; -; ;; ;; -; ;; ;; -; ;;;; ;;;; ;; ;;; ;;;;; ;;;; ;;;;;;; ;; ;;; ;;;;;; -; ;;;; ;; ;; ;;;;;; ;;;;;; ;; ;; ;;;; ;; ;;;;;; ;;;;;; -; ;; ;;;;;;;; ;; ;; ;;; ;; ;;;;;;;; ;; ;; ;; ;; ;;; ;; -; ;; ;;; ;; ;; ;;; ;; ;;; ;; ;; ;; ;; ;;; ;; -; ;; ;;; ;; ;; ;; ;;;;;; ;;; ;; ;; ;; ;; ;; ;;;;;; -; ;; ;;;; ;; ;; ;;;;; ;;;; ;; ;; ;; ;; ;;;;; -; ;; ;;; -; ;;;;; -; -; - -(define (show-picture g [extra-space 0]) - (letrec ([f (new frame% [label ""])] - [c (new canvas% - [parent f] - [min-width (+ extra-space (inexact->exact (floor (picture-right g))))] - [min-height (+ extra-space (inexact->exact (floor (picture-bottom g))))] - [paint-callback - (λ (c dc) - (send dc set-smoothing 'aligned) - (let-values ([(w h) (send c get-client-size)]) - (let ([scale (send sl get-value)]) - (send dc set-scale scale scale) - (render-picture - g - dc - (inexact->exact (floor (- (/ w 2 scale) (/ (picture-right g) 2)))) - (inexact->exact (floor (- (/ h 2 scale) (/ (picture-bottom g) 2))))))))])] - [min-scale 1] - [max-scale 10] - [sl (new slider% - [label "Scale factor"] - [parent f] - [min-value min-scale] - [max-value max-scale] - [callback (λ ignore (send c refresh))])] - [bp (new horizontal-panel% [parent f] [alignment '(center center)] [stretchable-height #f])] - [scale-adjust - (λ (f) - (send sl set-value (max min-scale (min max-scale (f (send sl get-value))))) - (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 add1))] [parent bp]) min-width 100) - (send f show #t))) - -;; render-picture : normalized-shape dc dx dy -> void -(define (render-picture picture dc dx dy) - (let loop ([shape (send picture get-normalized-shape)]) - (cond - [(overlay? shape) - (render-simple-shape (overlay-bottom shape) dc dx dy) - (loop (overlay-top shape))] - [else - (render-simple-shape shape dc dx dy)]))) - -(define (render-simple-shape simple-shape dc dx dy) - (cond - [(polygon? simple-shape) - (let ([path (new dc-path%)] - [points (polygon-points simple-shape)]) - (send path move-to (point-x (car points)) (point-y (car points))) - (let loop ([points (cdr points)]) - (unless (null? points) - (send path line-to (point-x (car points)) (point-y (car points))) - (loop (cdr points)))) - (send path line-to (point-x (car points)) (point-y (car points))) - (send dc set-pen (mode-color->pen (polygon-mode simple-shape) (polygon-color simple-shape))) - (send dc set-brush (mode-color->brush (polygon-mode simple-shape) (polygon-color simple-shape))) - (send dc draw-path path dx dy))] - [else - (let ([dx (+ dx (translate-dx simple-shape))] - [dy (+ dy (translate-dy simple-shape))] - [atomic-shape (translate-shape simple-shape)]) - (cond - [(ellipse? atomic-shape) - (let ([path (new dc-path%)] - [θ (degrees->radians (ellipse-angle atomic-shape))]) - (send path ellipse 0 0 (ellipse-width atomic-shape) (ellipse-height atomic-shape)) - (send path rotate θ) - (send dc set-pen (mode-color->pen (ellipse-mode atomic-shape) (ellipse-color atomic-shape))) - (send dc set-brush (mode-color->brush (ellipse-mode atomic-shape) (ellipse-color atomic-shape))) - (send dc draw-path path dx dy))] - - [(text? atomic-shape) - (let ([θ (degrees->radians (text-angle atomic-shape))]) - (send dc set-font (text-font atomic-shape)) - (send dc draw-text (text-string atomic-shape) dx dy #f 0 angle))]))])) - -(define (degrees->radians θ) - (* θ 2 pi (/ 360))) - - ; ; ; @@ -627,28 +175,28 @@ and they all have good sample contracts. (It is amazing what we can do with kids ; ;; -;; bitmap : string -> picture +;; 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 pictures; +;; (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 : picture picture picture ... -> picture -;; places pictures on top of each other with their upper left corners aligned. last one goes on the bottom +;; 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 picture picture2 . picture3) - (overlay/internal 'left 'top picture (cons picture2 picture3))) +(define/chk (overlay image image2 . image3) + (overlay/internal 'left 'top image (cons image2 image3))) -;; overlay/places : string string picture picture picture ... -> picture +;; 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 pictures in the various places. +;; 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 -;; pictures up at their centers. +;; images up at their centers. -(define/chk (overlay/places x-place y-place picture picture2 . picture3) - (overlay/internal x-place y-place picture (cons picture2 picture3))) +(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] @@ -670,51 +218,51 @@ and they all have good sample contracts. (It is amazing what we can do with kids (if (< dy 0) 0 dy)) (cdr rst)))]))) -(define (find-x-spot x-place picture) +(define (find-x-spot x-place image) (case x-place [(left) 0] - [(middle) (/ (picture-right picture) 2)] - [(right) (picture-right picture)])) + [(middle) (/ (image-right image) 2)] + [(right) (image-right image)])) -(define (find-y-spot y-place picture) +(define (find-y-spot y-place image) (case y-place [(top) 0] - [(middle) (/ (picture-bottom picture) 2)] - [(bottom) (picture-bottom picture)] - [(baseline) (picture-baseline picture)])) + [(middle) (/ (image-bottom image) 2)] + [(bottom) (image-bottom image)] + [(baseline) (image-baseline image)])) -;; overlay/xy : picture number number picture -> picture -;; places pictures on top of each other with their upper-left corners offset by the two numbers +;; 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 picture dx dy picture2) - (overlay/δ picture +(define/chk (overlay/xy image dx dy image2) + (overlay/δ image (if (< dx 0) (- dx) 0) (if (< dy 0) (- dy) 0) - picture2 + image2 (if (< dx 0) 0 dx) (if (< dy 0) 0 dy))) -(define (overlay/δ picture1 dx1 dy1 picture2 dx2 dy2) - (make-picture (make-overlay (make-translate dx1 dy1 (picture-shape picture1)) - (make-translate dx2 dy2 (picture-shape picture2))) - (make-bb (max (+ (picture-right picture1) dx1) - (+ (picture-right picture2) dx2)) - (max (+ (picture-bottom picture1) dy1) - (+ (picture-bottom picture2) dy2)) - (max (+ (picture-baseline picture1) dy1) - (+ (picture-baseline picture2) dy2))) - #f)) +(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 : picture picture picture ... -> picture -;; places pictures in a single horizontal row, top aligned -(define/chk (beside picture1 picture2 . picture3) - (beside/internal 'top picture1 (cons picture2 picture3))) +;; 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 picture picture picture ... -> picture -;; places pictures in a horizontal row where the vertical alignment is +;; 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 picture1 picture2 . picture3) - (beside/internal y-place picture1 (cons picture2 picture3))) +(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] @@ -730,11 +278,11 @@ and they all have good sample contracts. (It is amazing what we can do with kids 0 (if (< dy 0) (- dy) 0) (car rst) - (picture-right fst) + (image-right fst) (if (< dy 0) 0 dy)) (cdr rst)))]))) -;; above : picture picture picture ... -> picture +;; above : image image image ... -> image ;; above/places : string I I I ... -> I ;; like beside, but vertically @@ -752,21 +300,21 @@ and they all have good sample contracts. (It is amazing what we can do with kids ; ; -;; frame : picture -> picture -;; draws a black frame around a picture where the bounding box is -;; (useful for debugging pictures) +;; frame : image -> image +;; draws a black frame around a image where the bounding box is +;; (useful for debugging images) -(define/chk (frame picture) - (make-picture (make-overlay (picture-shape picture) - (picture-shape - (rectangle (picture-right picture) - (picture-bottom picture) - 'outline - 'black))) - (make-bb (picture-right picture) - (picture-bottom picture) - (picture-baseline picture)) - #f)) +(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 @@ -775,7 +323,7 @@ and they all have good sample contracts. (It is amazing what we can do with kids ;; rotates the I around the top-left corner by the given angle ;; (in degrees) ;; LINEAR TIME OPERATION (sigh) -(define/chk (rotate angle picture) +(define/chk (rotate angle image) (define left #f) (define top #f) (define right #f) @@ -788,10 +336,10 @@ and they all have good sample contracts. (It is amazing what we can do with kids (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 (picture-shape picture) add-to-bounding-box/rotate)]) - (make-picture (make-translate (- left) (- top) rotated) - (make-bb (- right left) (- bottom top) (- bottom top)) - #f))) + (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' @@ -873,6 +421,17 @@ and they all have good sample contracts. (It is amazing what we can do with kids (make-bitmap (bitmap-bitmap atomic-shape) (bring-between (+ θ (bitmap-angle atomic-shape)) 360))])) +;; 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)))) + + ;; 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 @@ -903,13 +462,13 @@ and they all have good sample contracts. (It is amazing what we can do with kids ;; rectangle (define/chk (rectangle width height mode color) - (make-picture (make-polygon (rectangle-points width height) - mode - color) - (make-bb width - height - height) - #f)) + (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) @@ -927,12 +486,12 @@ and they all have good sample contracts. (It is amazing what we can do with kids ;; regular-polygon (define/chk (ellipse width height mode color) - (make-picture (make-ellipse width height - 0 - mode - color) - (make-bb width height height) - #f)) + (make-image (make-ellipse width height + 0 + mode + color) + (make-bb width height height) + #f)) (define (mode-color->pen mode color) (send the-pen-list find-or-create-pen color 1 diff --git a/collects/tests/2htdp/test-image.ss b/collects/tests/2htdp/test-image.ss index 46002964ff..e29bd68a14 100644 --- a/collects/tests/2htdp/test-image.ss +++ b/collects/tests/2htdp/test-image.ss @@ -1,8 +1,11 @@ #lang scheme/base -(require "../../2htdp/private/image-core.ss" +(require "../../2htdp/private/image-core.ss" + "../../2htdp/private/image-more.ss" scheme/math tests/eli-tester) +;(define-syntax-rule (test a => b) (begin a b)) + (show-image (overlay/xy (rectangle 100 10 'solid 'red) 0