;; This file contains a DrScheme library version of the functional graphics ;; system for use with Concrete Abstractions: An Introduction to Computer ;; Science Using Scheme, by Max Hailperin, Barbara Kaiser, and Karl Knight. (unit/sig (default-image-size line quarter-turn-right mirror-image invert overlay resize-image stack filled-triangle write-image-as-epsf) (import plt:userspace^) (define default-image-size 100) (define read-write-stub (lambda (s) ; fungraph snip I/O unimplemented, since on wrong snip class list anyhow #f)) (define fungraph-snipclass (make-object (class-asi wx:snip-class% (public (read read-write-stub))))) (send* fungraph-snipclass (set-version 1) (set-classname "fungraph-snip%")) (send (wx:get-the-snip-class-list) add fungraph-snipclass) ; the wrong list! (define fungraph-snip% (class wx:snip% (w h) (public (width w) (height h)) (inherit set-snipclass) (public (write read-write-stub) (get-extent (lambda (dc x y w h descent space lspace rspace) (for-each (lambda (box value) (if (not (null? box)) (set-box! box (exact->inexact value)))) (list w h descent space lspace rspace) (list width height 0 0 0 0)))) (draw (let* ([body-pen (send wx:the-pen-list find-or-create-pen "BLACK" 1 wx:const-solid)] [body-brush (send wx:the-brush-list find-or-create-brush "BLACK" wx:const-solid)] [other-pen (send wx:the-pen-list find-or-create-pen "WHITE" 1 wx:const-solid)] [other-brush (send wx:the-brush-list find-or-create-brush "WHITE" wx:const-solid)]) (lambda (dc x y left top right bottom dx dy drawCaret) (let ([orig-pen (send dc get-pen)] [orig-brush (send dc get-brush)]) (fungraph-draw dc (lambda (x0 y0) (+ x (* .5 (+ 1 x0) width))) (lambda (x0 y0) (+ y (* .5 (- 1 y0) height))) body-pen body-brush other-pen other-brush) (send dc set-pen body-pen) (send dc draw-line x y (+ x width) y) (send dc draw-line (+ x width) y (+ x width) (+ y height)) (send dc draw-line (+ x width) (+ y height) x (+ y height)) (send dc draw-line x (+ y height) x y) (send dc set-pen orig-pen) (send dc set-brush orig-brush))))) (fungraph-draw (lambda (dc xt yt bp bb op ob) #f))) (sequence (super-init) (set-snipclass fungraph-snipclass)))) (define image? (lambda (obj) ;; roundabout code below is because the obvious ;; (is-a? obj fungraph-snip%) ;; doesn't work with objects left around across ;; reloadings of this library (and (object? obj) (ivar-in-class? 'fungraph-draw (object-class obj))))) (define image-width (lambda (i) (ivar i width))) (define image-height (lambda (i) (ivar i height))) (define line-fungraph-snip% (class fungraph-snip% (ix0 iy0 ix1 iy1 w h) (private (x0 ix0) (y0 iy0) (x1 ix1) (y1 iy1)) (inherit width height get-style) (public (fungraph-draw (lambda (dc xt yt body-pen body-brush other-pen other-brush) (let ((x0dc (xt x0 y0)) (x1dc (xt x1 y1)) (y0dc (yt x0 y0)) (y1dc (yt x1 y1))) (send dc set-pen body-pen) (send dc draw-line x0dc y0dc x1dc y1dc)))) (copy (lambda () (let ((new (make-object line-fungraph-snip% x0 y0 x1 y1 width height))) (send new set-style (get-style)) new)))) (sequence (super-init w h)))) (define line (lambda (x0 y0 x1 y1 . wh) (if (not (real? x0)) (error "x0 argument to line not a real" x0)) (if (not (real? x1)) (error "x1 argument to line not a real" x1)) (if (not (real? y0)) (error "y0 argument to line not a real" y0)) (if (not (real? y1)) (error "y1 argument to line not a real" y1)) (let ((width default-image-size) (height default-image-size)) (if (not (null? wh)) (begin (set! width (car wh)) (if (not (null? (cdr wh))) (begin (set! height (cadr wh)) (if (not (null? (cddr wh))) (error "too many argument to line"))) (set! height width)))) (if (not (and (integer? height) (integer? width) (exact? height) (exact? width) (> height 0) (> width 0))) (error "illegal size specification in line" wh)) (make-object line-fungraph-snip% x0 y0 x1 y1 width height)))) (define qtr-fungraph-snip% (class fungraph-snip% (i) (private (image i)) (inherit get-style) (public (fungraph-draw (lambda (dc xt yt body-pen body-brush other-pen other-brush) (send image fungraph-draw dc (lambda (x y) (xt y (- x))) (lambda (x y) (yt y (- x))) body-pen body-brush other-pen other-brush))) (copy (lambda () (let ((new (make-object qtr-fungraph-snip% image))) (send new set-style (get-style)) new)))) (sequence (super-init (image-height image) (image-width image))))) (define (quarter-turn-right image) (if (not (image? image)) (error "argument to quarter-turn-right not an image" image)) (make-object qtr-fungraph-snip% image)) (define mi-fungraph-snip% (class fungraph-snip% (i) (private (image i)) (inherit get-style) (public (fungraph-draw (lambda (dc xt yt body-pen body-brush other-pen other-brush) (send image fungraph-draw dc (lambda (x y) (xt (- x) y)) (lambda (x y) (yt (- x) y)) body-pen body-brush other-pen other-brush))) (copy (lambda () (let ((new (make-object mi-fungraph-snip% image))) (send new set-style (get-style)) new)))) (sequence (super-init (image-width image) (image-height image))))) (define (mirror-image image) (if (not (image? image)) (error "argument to mirror-image not an image" image)) (make-object mi-fungraph-snip% image)) (define inverted-fungraph-snip% (class fungraph-snip% (i) (private (image i)) (inherit get-style) (public (fungraph-draw (lambda (dc xt yt body-pen body-brush other-pen other-brush) (let ((minx (min (xt -1 -1) (xt -1 1) (xt 1 -1) (xt 1 1))) (miny (min (yt -1 -1) (yt -1 1) (yt 1 -1) (yt 1 1))) (maxx (max (xt -1 -1) (xt -1 1) (xt 1 -1) (xt 1 1))) (maxy (max (yt -1 -1) (yt -1 1) (yt 1 -1) (yt 1 1)))) (send dc set-pen body-pen) (send dc set-brush body-brush) (send dc draw-rectangle minx miny (- maxx minx) (- maxy miny)) (send image fungraph-draw dc xt yt other-pen other-brush body-pen body-brush)))) (copy (lambda () (let ((new (make-object inverted-fungraph-snip% image))) (send new set-style (get-style)) new)))) (sequence (super-init (image-width image) (image-height image))))) (define invert (lambda (image) (if (not (image? image)) (error "argument to invert not an image" image)) (make-object inverted-fungraph-snip% image))) (define overlayed-fungraph-snip% (class fungraph-snip% (is) (private (images is)) (inherit get-style) (public (fungraph-draw (lambda (dc xt yt body-pen body-brush other-pen other-brush) (for-each (lambda (image) (send image fungraph-draw dc xt yt body-pen body-brush other-pen other-brush)) images))) (copy (lambda () (let ((new (make-object overlayed-fungraph-snip% images))) (send new set-style (get-style)) new)))) (sequence (super-init (image-width (car images)) (image-height (car images)))))) (define (overlay image . images) (if (not (image? image)) (error "argument to overlay not an image" image)) (let ((w (image-width image)) (h (image-height image))) (for-each (lambda (i) (if (not (image? i)) (error "argument to overlay not an image" i)) (if (not (and (= (image-width i) w) (= (image-height i) h))) (error "Only images of equal size can be overlayed" (cons image images)))) images) (make-object overlayed-fungraph-snip% (cons image images)))) (define resized-fungraph-snip% (class fungraph-snip% (i w h) (private (image i)) (inherit width height get-style) (public (fungraph-draw (lambda (dc xt yt body-pen body-brush other-pen other-brush) (send image fungraph-draw dc xt yt body-pen body-brush other-pen other-brush))) (copy (lambda () (let ((new (make-object resized-fungraph-snip% image width height))) (send new set-style (get-style)) new)))) (sequence (super-init w h)))) (define (resize-image image . wh) (if (not (image? image)) (error "argument to resize-image not an image" image)) (let ((width default-image-size) (height default-image-size)) (if (not (null? wh)) (begin (set! width (car wh)) (if (not (null? (cdr wh))) (begin (set! height (cadr wh)) (if (not (null? (cddr wh))) (error "too many argument to resize-image"))) (set! height width)))) (if (not (and (integer? height) (integer? width) (exact? height) (exact? width) (> height 0) (> width 0))) (error "illegal size specification in resize-image" wh)) (make-object resized-fungraph-snip% image width height))) (define stacked-fungraph-snip% (class fungraph-snip% (t b) (private (top t) (bottom b)) (inherit get-style) (public (fungraph-draw (let ((th (image-height t)) (bh (image-height b))) (let* ((h (+ th bh)) (inexact-h (exact->inexact h))) (let ((tscale (/ th inexact-h)) (bscale (/ bh inexact-h))) (lambda (dc xt yt body-pen body-brush other-pen other-brush) (send top fungraph-draw dc (lambda (x y) (xt x (+ (* tscale y) bscale))) (lambda (x y) (yt x (+ (* tscale y) bscale))) body-pen body-brush other-pen other-brush) (send bottom fungraph-draw dc (lambda (x y) (xt x (- (* bscale y) tscale))) (lambda (x y) (yt x (- (* bscale y) tscale))) body-pen body-brush other-pen other-brush)))))) (copy (lambda () (let ((new (make-object stacked-fungraph-snip% top bottom))) (send new set-style (get-style)) new)))) (sequence (super-init (image-width t) (+ (image-height t) (image-height b)))))) (define (stack top . rest) (define (stack2 top bottom) (if (not (image? top)) (error "argument to stack not an image" top)) (if (not (image? bottom)) (error "argument to stack not an image" bottom)) (if (not (= (image-width top) (image-width bottom))) (error "Attempt to stack images of different widths" (list top bottom)) (make-object stacked-fungraph-snip% top bottom))) (let loop ((image top) (images rest)) (if (null? images) image (loop (stack2 image (car images)) (cdr images))))) (define ft-fungraph-snip% (class fungraph-snip% (ix0 iy0 ix1 iy1 ix2 iy2 w h) (private (x0 ix0) (y0 iy0) (x1 ix1) (y1 iy1) (x2 ix2) (y2 iy2)) (inherit width height get-style) (public (fungraph-draw (lambda (dc xt yt body-pen body-brush other-pen other-brush) (send dc set-pen body-pen) (send dc set-brush body-brush) (send dc draw-polygon (map (lambda (x y) (make-object wx:point% (xt x y) (yt x y))) (list x0 x1 x2) (list y0 y1 y2))))) (copy (lambda () (let ((new (make-object ft-fungraph-snip% x0 y0 x1 y1 x2 y2 width height))) (send new set-style (get-style)) new)))) (sequence (super-init w h)))) (define filled-triangle (lambda (x0 y0 x1 y1 x2 y2 . wh) (if (not (real? x0)) (error "x0 argument to filled-triangle not a real" x0)) (if (not (<= -1 x0 1)) (error "x0 argument to filled-triangle not in -1 to 1 range" x0)) (if (not (real? x1)) (error "x1 argument to filled-triangle not a real" x1)) (if (not (<= -1 x1 1)) (error "x1 argument to filled-triangle not in -1 to 1 range" x1)) (if (not (real? x2)) (error "x2 argument to filled-triangle not a real" x2)) (if (not (<= -1 x2 1)) (error "x2 argument to filled-triangle not in -1 to 1 range" x2)) (if (not (real? y0)) (error "y0 argument to filled-triangle not a real" y0)) (if (not (<= -1 y0 1)) (error "y0 argument to filled-triangle not in -1 to 1 range" y0)) (if (not (real? y1)) (error "y1 argument to filled-triangle not a real" y1)) (if (not (<= -1 y1 1)) (error "y1 argument to filled-triangle not in -1 to 1 range" y1)) (if (not (real? y2)) (error "y2 argument to filled-triangle not a real" y2)) (if (not (<= -1 y2 1)) (error "y2 argument to filled-triangle not in -1 to 1 range" y2)) (let ((width default-image-size) (height default-image-size)) (if (not (null? wh)) (begin (set! width (car wh)) (if (not (null? (cdr wh))) (begin (set! height (cadr wh)) (if (not (null? (cddr wh))) (error "too many argument to filled-triangle"))) (set! height width)))) (if (not (and (integer? height) (integer? width) (exact? height) (exact? width) (> height 0) (> width 0))) (error "illegal size specification in filled-triangle" wh)) (make-object ft-fungraph-snip% x0 y0 x1 y1 x2 y2 width height)))) (define write-image-as-epsf (let ((margin 72.0)) (lambda (snip filename) (let ((dc (#%make-object wx:post-script-dc% filename #t '()))) (if (send dc ok?) (begin (send dc start-doc filename) (send dc start-page) (let ((wbox (box 0.0)) (hbox (box 0.0))) (send snip get-extent dc margin margin wbox hbox '() '() '() '()) (send snip draw dc margin margin margin margin (+ margin (unbox wbox)) (+ margin (unbox hbox)) 0.0 0.0 wx:const-snip-draw-no-caret)) (send dc end-page) (send dc end-doc))))))) )