(define *default-context* (viewer-context "Scrapper Test Pattern"))
(define (e) (clear-page *default-context*))
(define Girl22 (pixel-array-from-ais "Girl22-green.ais"))
(define brick (make-brick '#(
#(0 1 1)
#(2 3 3)
#(11 11 10)
#(14 15 15)
#(12 13 13)
#(8 9 9)
#(7 7 6)
#(4 5 5)
#(1 1 1)
) 16 0))
(define brick (make-brick '#(#(15 14 14) #(13 12 12) #(4 4 5) #(1 0 0) #(3 2 2) #(7 6 6) #(8 8 9) #(11 10 10) #(14 14 14)) 16 0))
(begin (define brick (make-dot-screen-brick 4 1.5 1 0.01 20 255 (make-scale2 3 1))) (e) (make-wedge))
(begin (define brick (make-dot-screen-brick 3 7.125016 1 0.01 30 255 (make-scale2 3 1))) (e) (make-wedge))
(begin (define brick (make-dot-screen-brick 3 0 1 0.01 30 255 (make-scale2 3 1))) (e) (make-wedge))
(begin (define brick (make-dot-screen-brick 2 0 1 0.01 30 255 (make-scale2 3 1))) (e) (make-wedgel))
(define *default-pixelToDevice* (make-scale2 3 1))
(define (check-brick-spec item)
(if (not (= (length item) 2)) (error item "is not a list of length 2"))
(if (not (memq (car item) '(ppd deg shape relerr levels maxsamp pixtodev)))
(error item "has an unknown keyword"))
)
(define (brick<-spec 2list)
(define pixels-per-dot (assq 'ppd 2list))
(define degrees (assq 'deg 2list))
(define shape (assq 'shape 2list))
(define allowedRelativeError (assq 'relerr 2list))
(define minLevels (assq 'levels 2list))
(define maxSample (assq 'maxsamp 2list))
(define pixelToDevice (assq 'pixtodev 2list))
(for-each check-brick-spec 2list)
(make-dot-screen-brick
(if pixels-per-dot (cadr pixels-per-dot) 4)
(if degrees (cadr degrees) 0)
(if shape (cadr shape) 0.5)
(if allowedRelativeError (cadr allowedRelativeError) 0.1)
(if minLevels (cadr minLevels) 10)
(if maxSample (cadr maxSample) 255)
(if pixelToDevice (cadr pixelToDevice) *default-pixelToDevice*)
)
)
(define c (printer-context 900 2560 brick))
(scale2 1 3 c)
(define (make-wedge)
(define c (printer-context 600 600 brick))
(make-patches 32 16 600 c)
(mask-pixel-array (pixel-array-from-printer-context c))
)
(define (make-wedgel)
(define c (printer-context 600 800 brick))
(make-patches 64 10 600 c)
(mask-pixel-array (pixel-array-from-printer-context c))
)
(define *default-font* (find-font "Xerox/XC1-2-2/Modern" 12))
(define *place-text-x* 4)
(define *place-text-y* 3)
(define (make-v-patches n w h . rest)
(define c (if (null? rest) *default-context* (car rest)))
(define deltah (/ h (+ n 1.0)))
(define port (open-output-string))
(set-font *default-font* c)
(let loop ((i 0))
(if (<= i n) (begin
(set-gray (/ i n) c)
(mask-rectangle 0 (* i deltah) w deltah c)
(if (> deltah 8) (begin
(set-gray 1 c)
(set-xy (+ w *place-text-x*) (+ (* i deltah) *place-text-y*) c)
(display i port)
(display "/" port)
(display n port)
(show-string (get-output-string port) c)
))
(loop (+ i 1))))
)
)
(define (make-patches n w h . rest)
(define c (if (null? rest) *default-context* (car rest)))
(define d (+ w 2))
(let loop ((i 0))
(if (<= i n) (begin
(set-gray (/ i n) c)
(mask-rectangle (* i d) 0 w h c)
(loop (+ i 1))))
)
)
(define (chart-n n . rest)
(define c (if (null? rest) *default-context* (car rest)))
(make-v-patches n 30 320 c)
(do-save
(lambda ()
(translate 70 0 c)
(make-v-patches 320 30 320 c)
)
c
)
)
(define *the-chart* #f)
(define *the-brick-spec* #f)
(define (dc) (e) (mask-pixel-array (pixel-array-from-printer-context *the-chart*)))
(define (make-print-chart-n n brick-spec)
(let*
((brick (brick<-spec brick-spec))
(c (printer-context 3840 448 brick))
(port (open-output-string))
)
(scale2 4 12 c)
(set-xy 8 2 c)
(rotate 90 c)
(display brick-spec port)
(set-font (find-font "Xerox/XC1-2-2/Modern" 8) c)
(show-string (get-output-string port) c)
(rotate -90 c)
(translate 10 0 c)
(chart-n n c)
(set! *the-chart* c)
(set! *the-brick-spec* brick-spec)
)
)
(set-colored-texture Girl22 (make-scale 1) (make-gray-linear-color-operator 255 0 '()) c)
(mask-box 0 0 30000 30000 c)
(mask-pixel-array (pixel-array-from-printer-context c))
(define (stripes)
(set-gray .5)
(let loop ((x 0)) (mask-vector x 0 x 1000) (if (< x 300) (loop (+ 1 x))))
(set-gray 1)
(let loop ((x 0)) (mask-vector x 0 x 1000) (if (< x 300) (loop (+ 3 x))))
)
(define (walk-c m)
(let ((event (viewer-read)))
(case (car event)
((buttondown)
(set! m (make-product m (make-translation (- (caddr event)) (- (cadddr event)))))
)
((buttonup)
(set! m (make-product m (make-translation (caddr event) (cadddr event))))
(do-save (lambda ()
(modify-current-transformation m)
(e)
(mask-pixel-array (pixel-array-from-printer-context c))
))
)
((mouseto)
(if (not (viewer-input-ready?)) (do-save (lambda ()
(modify-current-transformation (make-product m (make-translation (cadr event) (caddr event))))
(e)
(mask-pixel-array (pixel-array-from-printer-context c))
)))
)
)
)
(walk-c m)
)
(define (walk m)
(let ((event (viewer-read)))
(case (car event)
((buttondown)
(set! m (make-product m (make-translation (- (caddr event)) (- (cadddr event)))))
)
((buttonup)
(set! m (make-product m (make-translation (caddr event) (cadddr event))))
(do-save (lambda ()
(modify-current-transformation m)
(e)
(mask-pixel-array girl22-bitmap)
))
)
((mouseto)
(if (not (viewer-input-ready?)) (do-save (lambda ()
(modify-current-transformation (make-product m (make-translation (cadr event) (caddr event))))
(e)
(mask-pixel-array girl22-bitmap)
)))
)
)
)
(walk m)
)
(define (run)
(make-print-chart-n 25 '((ppd 2)(shape 1)(relerr 0.1)(levels 30))) (dc)
(write-ais "Chart25-2ppd.ais" (pixel-array-from-printer-context *the-chart*) #f)
(make-print-chart-n 25 '((ppd 3)(shape 1)(relerr 0.1)(levels 30))) (dc)
(write-ais "Chart25-3ppd.ais" (pixel-array-from-printer-context *the-chart*) #f)
(make-print-chart-n 25 '((ppd 4)(deg 45)(shape 0.45)(relerr 0.1)(levels 30))) (dc)
(write-ais "Chart25-4ppd-dot.ais" (pixel-array-from-printer-context *the-chart*) #f)
)
(write-ais "Girl22-3x9.ais" (pixel-array-from-printer-context c) #f)