#lang slideshow (require scheme/class scheme/gui/base) (provide well well+sign well+sign* sign one-in-sign) (define (mk-block w h dt dr db dl) (let ([p (new dc-path%)] [d 4] [tx 1/2] [rx 1/2] [bx 1/2] [lx 1/2]) (send p move-to d 0) (send p curve-to (* w 1/3 tx) 0 (* w 2/3 tx) dt (* w tx) dt) (send p curve-to (* w (- 1 (* 2/3 (- 1 tx)))) dt (* w (- 1 (* 1/3 (- 1 tx)))) 0 (- w d) 0) (send p curve-to w 0 w 0 w d) (send p curve-to w (* h 1/3 rx) (- w dr) (* h 2/3 rx) (- w dr) (* h rx)) (send p curve-to (- w dr) (* h (- 1 (* 2/3 (- 1 rx)))) w (* h (- 1 (* 1/3 (- 1 rx)))) w (- h d)) (send p curve-to w h w h (- w d) h) (send p curve-to (* w (- 1 (* 1/3 (- 1 bx)))) h (* w (- 1 (* 2/3 (- 1 bx)))) (- h db) (* w bx) (- h db)) (send p curve-to (* w 2/3 bx) (- h db) (* w 1/3 bx) h d h) (send p curve-to 0 h 0 h 0 (- h d)) (send p curve-to 0 (* h (- 1 (* 1/3 (- 1 lx)))) dl (* h (- 1 (* 2/3 (- 1 lx)))) dl (* h lx)) (send p curve-to dl (* h 2/3 lx) 0 (* h 1/3 lx) 0 d) (send p curve-to 0 0 0 0 d 0) (send p close) (inset (dc (lambda (dc x y) (let ([op (send dc get-pen)] [ob (send dc get-brush)]) (send dc set-pen "black" 2 'solid) (send dc set-brush "gray" 'solid) (send dc draw-path p x y) (send dc set-pen op) (send dc set-brush ob))) w h) 1))) (define (arch w) (let ([roof (new dc-path%)] [side (new dc-path%)] [w (* 1.2 w)]) (send roof move-to 20 0) (send roof line-to 100 0) (send roof line-to 80 50) (send roof line-to 0 50) (send roof close) (send roof translate -10 0) (send roof scale (/ w 100) (/ w 100)) (send side move-to 100 0) (send side line-to 80 50) (send side line-to 120 45) (send side close) (send side translate -10 0) (send side scale (/ w 100) (/ w 100)) (dc (lambda (dc x y) (let ([op (send dc get-pen)] [ob (send dc get-brush)]) (send dc set-pen "black" 2 'solid) (send dc set-brush "brown" 'solid) (send dc draw-rectangle (+ (* w 1/10) x) (+ (* w 3/10) y) (* w 1/10) (* w 5/10)) (send dc draw-rectangle (+ (* w 8/10) x) (+ (* w 3/10) y) (* w 1/10) (* w 5/10)) (send dc draw-path side x y) (send dc draw-path roof x y) (send dc set-pen op) (send dc set-brush ob))) w (* 0.8 w)))) (define (rt s) (text s `roman (current-font-size))) (define (rit s) (text s `(italic . roman) (current-font-size))) (define one-in-sign (scale (rt "1") 2)) (define sign (frame (inset (vc-append (scale (rit "Wishing Well") 0.5) (hline (* 5 gap-size) gap-size) one-in-sign (scale (rt "wish per princess") 0.5)) (/ gap-size 3)))) (define well (let* ([base (vc-append (hc-append (mk-block 50 30 1 -1 1 -1) (mk-block 30 30 0 -1 0 1) (mk-block 35 30 1 0 1 0) (mk-block 20 30 0 -1 1 -1)) (hc-append (mk-block 40 30 -1 -1 1 -1) (mk-block 25 30 0 -1 0 1) (mk-block 30 30 1 0 1 0) (mk-block 40 30 0 -1 1 -1)) (hc-append (mk-block 15 30 -1 -1 1 -1) (mk-block 55 30 1 0 1 0) (mk-block 50 30 1 0 1 0) (mk-block 15 30 0 -1 1 -1)) (hc-append (mk-block 40 30 -1 -1 1 -1) (mk-block 40 30 0 -1 0 1) (mk-block 30 30 1 0 1 0) (mk-block 25 30 0 -1 1 -1)))] [base+ledge (vc-append base (hc-append (mk-block 30 10 0 -1 0 1) (mk-block 35 10 1 0 1 0) (mk-block 30 10 0 -1 1 -1) (mk-block 80 10 1 -1 1 -1)))] [roof (arch (pict-width base))]) (vc-append roof base+ledge))) (define (well+sign* n) (vc-append (/ gap-size 2) (cellophane sign n) well)) (define well+sign (well+sign* 1.0))