449 lines
15 KiB
Racket
449 lines
15 KiB
Racket
#lang racket/base
|
|
(require slideshow/pict
|
|
racket/contract/base racket/match
|
|
racket/splicing racket/stxparam racket/draw
|
|
racket/block racket/class
|
|
(for-syntax racket/base)
|
|
"private/blur.rkt")
|
|
(provide (all-from-out "private/blur.rkt"))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Picture Manipulation
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; ryanc: 'inset-to' might be a better name than 'fill'
|
|
(define (fill pict w h)
|
|
(cc-superimpose
|
|
pict
|
|
(blank (or w (pict-width pict))
|
|
(or h (pict-height pict)))))
|
|
|
|
(define (color c p) (colorize p c))
|
|
|
|
(define color/c
|
|
(or/c string? ;; might be faster
|
|
;;(and/c string? (lambda (s) (send the-color-database find-color s)))
|
|
(is-a?/c color%)
|
|
(list/c byte? byte? byte?)))
|
|
|
|
(define-syntax-rule (define-colors name ...)
|
|
(begin (define (name pict) (color (symbol->string 'name) pict)) ...))
|
|
|
|
(define-colors
|
|
red orange yellow green blue purple
|
|
black brown gray white cyan magenta)
|
|
|
|
(define (light c) (scale-color 2 c))
|
|
(define (dark c) (scale-color 1/2 c))
|
|
|
|
(provide/contract
|
|
[color/c flat-contract?]
|
|
[red (-> pict? pict?)]
|
|
[orange (-> pict? pict?)]
|
|
[yellow (-> pict? pict?)]
|
|
[green (-> pict? pict?)]
|
|
[blue (-> pict? pict?)]
|
|
[purple (-> pict? pict?)]
|
|
[black (-> pict? pict?)]
|
|
[brown (-> pict? pict?)]
|
|
[gray (-> pict? pict?)]
|
|
[white (-> pict? pict?)]
|
|
[cyan (-> pict? pict?)]
|
|
[magenta (-> pict? pict?)]
|
|
[light (-> color/c color/c)]
|
|
[dark (-> color/c color/c)]
|
|
[color (-> color/c pict? pict?)]
|
|
[fill
|
|
(-> pict?
|
|
(or/c (real-in 0 +inf.0) #f)
|
|
(or/c (real-in 0 +inf.0) #f)
|
|
pict?)])
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Space-smart picture selection
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-syntax-parameter pict-combine #'ltl-superimpose)
|
|
|
|
(define-syntax-rule (with-pict-combine combine body ...)
|
|
(splicing-syntax-parameterize
|
|
([pict-combine #'combine])
|
|
body ...))
|
|
|
|
(define-syntax (pict-if stx)
|
|
(syntax-case stx ()
|
|
[(_ #:combine combine test success failure)
|
|
(syntax/loc stx
|
|
(let* ([result test])
|
|
(combine (show success result)
|
|
(hide failure result))))]
|
|
[(_ test success failure)
|
|
(quasisyntax/loc stx
|
|
(pict-if #:combine #,(syntax-parameter-value #'pict-combine)
|
|
test success failure))]))
|
|
|
|
(define-syntax (pict-cond stx)
|
|
(syntax-case stx (else)
|
|
[(_ #:combine combine [test expr] ... [else default])
|
|
(with-syntax ([(pict ...) (generate-temporaries #'(expr ...))])
|
|
(syntax/loc stx
|
|
(let ([pict expr] ... [final default])
|
|
(combine (cond [test pict] ... [else final])
|
|
(ghost pict) ... (ghost final)))))]
|
|
[(_ #:combine combine [test pict] ...)
|
|
(syntax/loc stx
|
|
(pict-cond #:combine combine [test pict] ... [else (blank 0 0)]))]
|
|
[(_ [test expr] ...)
|
|
(quasisyntax/loc stx
|
|
(pict-cond #:combine #,(syntax-parameter-value #'pict-combine)
|
|
[test expr] ...))]))
|
|
|
|
(define-syntax (pict-case stx)
|
|
(syntax-case stx (else)
|
|
[(_ test #:combine combine [literals expr] ... [else default])
|
|
(with-syntax ([(pict ...) (generate-temporaries #'(expr ...))])
|
|
(syntax/loc stx
|
|
(let ([pict expr] ... [final default])
|
|
(combine (case test [literals pict] ... [else final])
|
|
(ghost pict) ... (ghost final)))))]
|
|
[(_ test #:combine combine [literals expr] ...)
|
|
(syntax/loc stx
|
|
(pict-case test #:combine combine
|
|
[literals expr] ... [else (blank 0 0)]))]
|
|
[(_ test [literals expr] ...)
|
|
(quasisyntax/loc stx
|
|
(pict-case test #:combine #,(syntax-parameter-value #'pict-combine)
|
|
[literals expr] ...))]))
|
|
|
|
(define-syntax (pict-match stx)
|
|
(syntax-case stx ()
|
|
[(_ test #:combine combine [pattern expr] ...)
|
|
(with-syntax ([(pict ...) (generate-temporaries #'(expr ...))])
|
|
(syntax/loc stx
|
|
(let ([pict expr] ...)
|
|
(combine (match test [pattern pict] ... [_ (blank 0 0)])
|
|
(ghost pict) ...))))]
|
|
[(_ test [pattern expr] ...)
|
|
(quasisyntax/loc stx
|
|
(pict-match test #:combine #,(syntax-parameter-value #'pict-combine)
|
|
[pattern expr] ...))]))
|
|
|
|
(provide/contract
|
|
[hide (->* [pict?] [any/c] pict?)]
|
|
[show (->* [pict?] [any/c] pict?)]
|
|
[strike (->* [pict?] [any/c] pict?)]
|
|
[shade (->* [pict?] [any/c #:ratio (real-in 0 1)] pict?)])
|
|
(provide staged stage stage-name
|
|
before at after before/at at/after
|
|
pict-if pict-cond pict-case pict-match
|
|
pict-combine with-pict-combine)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Slide Staging
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-for-syntax (stage-keyword stx)
|
|
(raise-syntax-error #f "not in the body of a staged slide" stx))
|
|
|
|
(define-syntax-parameter stage stage-keyword)
|
|
(define-syntax-parameter stage-name stage-keyword)
|
|
|
|
(define-syntax (staged stx)
|
|
(syntax-case stx ()
|
|
[(_ [name ...] body ...)
|
|
(let* ([ids (syntax->list #'(name ...))])
|
|
|
|
(for ([id (in-list ids)] #:unless (identifier? id))
|
|
(raise-syntax-error #f "expected an identifier" stx id))
|
|
|
|
(with-syntax ([(num ...)
|
|
(for/list ([i (in-naturals 1)] [id (in-list ids)])
|
|
(datum->syntax #'here i id))])
|
|
|
|
(syntax/loc stx
|
|
(let* ([name num] ...)
|
|
(define (staged-computation number symbol)
|
|
(syntax-parameterize
|
|
([stage (make-rename-transformer #'number)]
|
|
[stage-name (make-rename-transformer #'symbol)])
|
|
(block body ...)))
|
|
(begin (staged-computation name 'name) ...)))))]))
|
|
|
|
(define-syntax-rule (before name) (< stage name))
|
|
(define-syntax-rule (before/at name) (<= stage name))
|
|
(define-syntax-rule (at/after name) (>= stage name))
|
|
(define-syntax-rule (after name) (> stage name))
|
|
(define-syntax-rule (before/after name) (not (= stage name)))
|
|
(define-syntax-rule (at name ...) (or (= stage name) ...))
|
|
|
|
(define (hide pict [hide? #t])
|
|
(if hide? (ghost pict) pict))
|
|
|
|
(define (show pict [show? #t])
|
|
(if show? pict (ghost pict)))
|
|
|
|
(define (shade pict [shade? #t] #:ratio [ratio 0.5])
|
|
(if shade? (cellophane pict ratio) pict))
|
|
|
|
(define (strike pict [strike? #t])
|
|
(if strike?
|
|
(pin-over pict
|
|
0
|
|
(/ (pict-height pict) 2)
|
|
(pip-line (pict-width pict) 0 0))
|
|
pict))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Misc
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; the following has been added by stamourv
|
|
|
|
;; borders may be of slightly uneven width, sadly
|
|
(define-values (ellipse/border
|
|
rectangle/border)
|
|
(let ()
|
|
(define ((mk shape) w h
|
|
#:color (color "white")
|
|
#:border-color (border-color "black")
|
|
#:border-width (border-width 2))
|
|
(cc-superimpose
|
|
(colorize (shape w h) border-color)
|
|
(colorize (shape (- w (* 2 border-width))
|
|
(- h (* 2 border-width)))
|
|
color)))
|
|
(values (mk filled-ellipse)
|
|
(mk filled-rectangle))))
|
|
|
|
(define (rounded-rectangle/border
|
|
w h
|
|
#:color (color "white")
|
|
#:border-color (border-color "black")
|
|
#:border-width (border-width 2)
|
|
#:corner-radius (radius -0.25)
|
|
#:angle (angle 0))
|
|
(cc-superimpose
|
|
(colorize (filled-rounded-rectangle w h radius #:angle angle) border-color)
|
|
(colorize (filled-rounded-rectangle
|
|
(- w (* 2 border-width))
|
|
(- h (* 2 border-width)) radius #:angle angle)
|
|
color)))
|
|
|
|
(define (circle/border d
|
|
#:color (color "white")
|
|
#:border-color (border-color "black")
|
|
#:border-width (border-width 2))
|
|
(cc-superimpose
|
|
(colorize (disk d) border-color)
|
|
(colorize (disk (- d (* 2 border-width)))
|
|
color)))
|
|
|
|
(define shape/border-contract
|
|
(->* [real? real?]
|
|
[#:color color/c #:border-color color/c #:border-width real?]
|
|
pict?))
|
|
(provide/contract
|
|
[ellipse/border shape/border-contract]
|
|
[rectangle/border shape/border-contract]
|
|
[rounded-rectangle/border
|
|
(->* [real? real?]
|
|
[#:color color/c #:border-color color/c #:border-width real? #:corner-radius real? #:angle real?]
|
|
pict?)]
|
|
[circle/border
|
|
(->* [real?]
|
|
[#:color color/c #:border-color color/c #:border-width real?]
|
|
pict?)])
|
|
|
|
;; the following has been written by Scott Owens
|
|
;; and updated and added by stamourv
|
|
|
|
(define (label-line label pict src-pict src-coord-fn dest-pict dest-coord-fn
|
|
#:x-adjust (x-adjust 0) #:y-adjust (y-adjust 0))
|
|
(let-values (((src-x src-y) (src-coord-fn pict src-pict))
|
|
((dest-x dest-y) (dest-coord-fn pict dest-pict)))
|
|
(let* ((src (make-rectangular src-x src-y))
|
|
(dest (make-rectangular dest-x dest-y))
|
|
(adjust (make-rectangular x-adjust y-adjust))
|
|
(v (- dest src))
|
|
(h2 (pict-height label)))
|
|
;; Ensure that the src is left of dest
|
|
(when (< (real-part v) 0)
|
|
(set! v (- v))
|
|
(set! src dest))
|
|
(let ((p (+ src
|
|
;; Move the label to sit atop the line.
|
|
(/ (* h2 -i v) (magnitude v) 2)
|
|
;; Center the label in the line.
|
|
(/ (- v (make-rectangular (pict-width label)
|
|
(pict-height label)))
|
|
2)
|
|
adjust)))
|
|
(pin-over
|
|
pict
|
|
(real-part p)
|
|
(imag-part p)
|
|
label)))))
|
|
|
|
(define (pin-label-line label pict
|
|
src-pict src-coord-fn
|
|
dest-pict dest-coord-fn
|
|
#:start-angle (start-angle #f)
|
|
#:end-angle (end-angle #f)
|
|
#:start-pull (start-pull 1/4)
|
|
#:end-pull (end-pull 1/4)
|
|
#:line-width (line-width #f)
|
|
#:color (color #f)
|
|
#:under? (under? #f)
|
|
#:x-adjust (x-adjust 0)
|
|
#:y-adjust (y-adjust 0))
|
|
(label-line
|
|
label
|
|
(pin-line
|
|
pict src-pict src-coord-fn dest-pict dest-coord-fn
|
|
#:start-angle start-angle #:end-angle end-angle
|
|
#:start-pull start-pull #:end-pull end-pull
|
|
#:line-width line-width #:color color #:under? under?)
|
|
src-pict src-coord-fn dest-pict dest-coord-fn
|
|
#:x-adjust x-adjust #:y-adjust y-adjust))
|
|
|
|
(define-values (pin-arrow-label-line
|
|
pin-arrows-label-line)
|
|
(let ()
|
|
(define ((mk fn)
|
|
label arrow-size pict
|
|
src-pict src-coord-fn
|
|
dest-pict dest-coord-fn
|
|
#:start-angle (start-angle #f)
|
|
#:end-angle (end-angle #f)
|
|
#:start-pull (start-pull 1/4)
|
|
#:end-pull (end-pull 1/4)
|
|
#:line-width (line-width #f)
|
|
#:color (color #f)
|
|
#:under? (under? #f)
|
|
#:solid? (solid? #t)
|
|
#:hide-arrowhead? (hide-arrowhead? #f)
|
|
#:x-adjust (x-adjust 0)
|
|
#:y-adjust (y-adjust 0))
|
|
(label-line
|
|
label
|
|
(fn
|
|
arrow-size pict src-pict src-coord-fn dest-pict dest-coord-fn
|
|
#:start-angle start-angle #:end-angle end-angle
|
|
#:start-pull start-pull #:end-pull end-pull
|
|
#:line-width line-width #:color color #:under? under?
|
|
#:hide-arrowhead? hide-arrowhead?)
|
|
src-pict src-coord-fn dest-pict dest-coord-fn
|
|
#:x-adjust x-adjust #:y-adjust y-adjust))
|
|
(values (mk pin-arrow-line)
|
|
(mk pin-arrows-line))))
|
|
(define pin-arrow-label-line-contract
|
|
(->* [pict? real? pict?
|
|
pict-path? (-> pict? pict-path? (values real? real?))
|
|
pict-path? (-> pict? pict-path? (values real? real?))]
|
|
[#:start-angle (or/c real? #f) #:end-angle (or/c real? #f)
|
|
#:start-pull real? #:end-pull real?
|
|
#:line-width (or/c real? #f)
|
|
#:color (or/c #f string? (is-a?/c color%))
|
|
#:under? any/c #:hide-arrowhead? any/c
|
|
#:x-adjust real? #:y-adjust real?]
|
|
pict?))
|
|
|
|
(provide/contract
|
|
[pin-label-line
|
|
(->* [pict? pict?
|
|
pict-path? (-> pict? pict-path? (values real? real?))
|
|
pict-path? (-> pict? pict-path? (values real? real?))]
|
|
[#:start-angle (or/c real? #f) #:end-angle (or/c real? #f)
|
|
#:start-pull real? #:end-pull real?
|
|
#:line-width (or/c real? #f)
|
|
#:color (or/c #f string? (is-a?/c color%))
|
|
#:under? any/c
|
|
#:x-adjust real? #:y-adjust real?]
|
|
pict?)]
|
|
[pin-arrow-label-line pin-arrow-label-line-contract]
|
|
[pin-arrows-label-line pin-arrow-label-line-contract])
|
|
|
|
;; the following are by ryanc
|
|
|
|
(define (scale-to p w h #:mode [mode 'preserve])
|
|
(let* ([w0 (pict-width p)]
|
|
[h0 (pict-height p)]
|
|
[wfactor0 (if (zero? w0) 1 (/ w w0))]
|
|
[hfactor0 (if (zero? h0) 1 (/ h h0))])
|
|
(let-values ([(wfactor hfactor)
|
|
(case mode
|
|
((preserve inset)
|
|
(let ([factor (min wfactor0 hfactor0)])
|
|
(values factor factor)))
|
|
((distort)
|
|
(values wfactor0 hfactor0)))])
|
|
(let ([scaled-pict (scale p wfactor hfactor)])
|
|
(case mode
|
|
((inset)
|
|
(cc-superimpose (blank w h) scaled-pict))
|
|
(else
|
|
scaled-pict))))))
|
|
|
|
(provide/contract
|
|
[scale-to
|
|
(->* (pict? real? real?)
|
|
(#:mode (or/c 'preserve 'inset 'distort))
|
|
pict?)])
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Tagged picts
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(require "private/tag-pict.rkt")
|
|
|
|
(provide/contract
|
|
[tag-path?
|
|
(-> any/c boolean?)]
|
|
[tag-pict
|
|
(-> pict? symbol? pict?)]
|
|
[pict-tag
|
|
(-> pict? (or/c symbol? #f))]
|
|
[find-tag
|
|
(-> pict? tag-path? (or/c pict-path? #f))]
|
|
[find-tag*
|
|
(-> pict? tag-path?
|
|
(listof pict-path?))])
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Shadow frame
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(require "private/shframe.rkt")
|
|
|
|
(provide/contract
|
|
[shadow-frame
|
|
(->* ()
|
|
(#:background-color (or/c string? (is-a?/c color%))
|
|
#:frame-color (or/c string? (is-a?/c color%))
|
|
#:frame-line-width (or/c real? #f)
|
|
#:shadow-side-length real?
|
|
#:shadow-top-y-offset real?
|
|
#:shadow-bottom-y-offset real?
|
|
#:shadow-descent (and/c real? (not/c negative?))
|
|
#:shadow-alpha-factor real?
|
|
#:blur (and/c real? (not/c negative?))
|
|
#:margin real?
|
|
#:sep real?)
|
|
#:rest (listof pict?)
|
|
pict?)]
|
|
[arch
|
|
(-> real? real? real? real?
|
|
pict?)])
|