unstable: better ppict-do, absorbed code from pslide
This commit is contained in:
Ryan Culpepper
parent
77a89b8d83
commit
e38843618d
|
|
@ -1,227 +1,37 @@
|
|||
#lang racket/base
|
||||
(require racket/list
|
||||
(require (for-syntax racket/base
|
||||
syntax/parse
|
||||
syntax/parse/experimental/contract
|
||||
"private/ppict-syntax.rkt")
|
||||
racket/contract
|
||||
slideshow/pict)
|
||||
slideshow/pict
|
||||
"private/ppict.rkt")
|
||||
|
||||
#|
|
||||
TODO
|
||||
(define-syntax (ppict-do stx)
|
||||
(syntax-parse stx
|
||||
[(_ base p ...)
|
||||
#:declare base (expr/c #'pict?)
|
||||
#:declare p (fragment 'ppict-do)
|
||||
#'(let-values ([(final _picts)
|
||||
(internal-ppict-do 'ppict-do base.c (list p.code ...))])
|
||||
final)]))
|
||||
|
||||
- need a way to express "dependent" additions, when need to find a
|
||||
pict within a ppict, eg for lines, balloons, etc.
|
||||
|
||||
- [lcr]bl alignments... not sure about [lcr]tl
|
||||
|
||||
- make ppict-do macro, move functionality from pslide to ppict-do
|
||||
eg require #:go for placers, use #:next to return multiple picts
|
||||
|#
|
||||
|
||||
;; ============================================================
|
||||
;; Progressive Picts
|
||||
|
||||
#|
|
||||
A ppict contains a pict and a placer (or #f).
|
||||
A placer = (placer (pict (listof (U pict real #f)) -> ppict))
|
||||
In a placer function's arguments:
|
||||
a number means to change the separation spacing
|
||||
a #f is just ignored
|
||||
FIXME: clarify, for following or including current gap?
|
||||
|#
|
||||
(struct ppict pict (placer))
|
||||
(struct placer (fun))
|
||||
|
||||
(define (mk-ppict p placer)
|
||||
(ppict (pict-draw p)
|
||||
(pict-width p)
|
||||
(pict-height p)
|
||||
(pict-ascent p)
|
||||
(pict-descent p)
|
||||
(list (make-child p 0 0 1 1))
|
||||
#f
|
||||
(pict-last p)
|
||||
placer))
|
||||
|
||||
(define (ppict-pict dp)
|
||||
(child-pict (car (pict-children dp))))
|
||||
(define-syntax (ppict-do* stx)
|
||||
(syntax-parse stx
|
||||
[(_ base p ...)
|
||||
#:declare base (expr/c #'pict?)
|
||||
#:declare p (fragment 'ppict-do)
|
||||
#'(internal-ppict-do 'ppict-do* base.c (list p.code ...))]))
|
||||
|
||||
;; ----
|
||||
|
||||
;; ppict-do : pict (U pict real #f placer) ... -> pict
|
||||
(define (ppict-do base . elems)
|
||||
(define (loop elems rchunks)
|
||||
(cond [(and (pair? elems) (placer? (car elems)))
|
||||
(loop (cdr elems) (cons (car elems) rchunks))]
|
||||
[(and (pair? elems))
|
||||
(loop* (cdr elems) rchunks (list (car elems)))]
|
||||
[(null? elems)
|
||||
(reverse rchunks)]))
|
||||
(define (loop* elems rchunks rchunk)
|
||||
(cond [(and (pair? elems) (placer? (car elems)))
|
||||
(loop elems (cons (reverse rchunk) rchunks))]
|
||||
[(and (pair? elems))
|
||||
(loop* (cdr elems) rchunks (cons (car elems) rchunk))]
|
||||
[(null? elems)
|
||||
(loop elems (cons (reverse rchunk) rchunks))]))
|
||||
(let ([chunks (loop elems null)])
|
||||
(for/fold ([acc base]) ([chunk (in-list chunks)])
|
||||
(cond [(placer? chunk)
|
||||
(ppict-go acc chunk)]
|
||||
[(list? chunk)
|
||||
(apply ppict-add acc chunk)]))))
|
||||
|
||||
;; ppict-add : ppict (U pict real #f) ... -> ppict
|
||||
(define (ppict-add dp . picts)
|
||||
(let ([pl (ppict-placer dp)])
|
||||
((placer-fun pl) (ppict-pict dp) picts)))
|
||||
|
||||
;; ppict-go : pict placer -> ppict
|
||||
(define (ppict-go dp pl)
|
||||
(cond [(ppict? dp)
|
||||
(mk-ppict (ppict-pict dp) pl)]
|
||||
[(pict? dp)
|
||||
(mk-ppict dp pl)]))
|
||||
|
||||
;; ----
|
||||
|
||||
;; row, column indexes are 0-based
|
||||
(define (grid cols rows col row [align 'cc]
|
||||
#:compose [composer (align->vcomposer align)]
|
||||
#:sep [sep 0])
|
||||
(define halign (align->h align))
|
||||
(define valign (align->v align))
|
||||
(define refxfrac (/ (+ col (align->frac halign)) cols))
|
||||
(define refyfrac (/ (+ row (align->frac valign)) rows))
|
||||
(coord refxfrac refyfrac align #:compose composer #:sep sep))
|
||||
|
||||
(define (coord refxfrac refyfrac [align 'cc]
|
||||
#:compose [composer (align->vcomposer align)]
|
||||
#:sep [sep 0]
|
||||
#:internal:skip [skip #f])
|
||||
(define halign (align->h align))
|
||||
(define valign (align->v align))
|
||||
(placer
|
||||
(lambda (scene picts)
|
||||
(define scene-w (pict-width scene))
|
||||
(define scene-h (pict-height scene))
|
||||
(define refx (* scene-w refxfrac))
|
||||
(define refy (* scene-h refyfrac))
|
||||
(define-values (newpict newsep)
|
||||
(apply-composer composer sep (cons skip picts)))
|
||||
(define newpict-w (pict-width newpict))
|
||||
(define newpict-h (pict-height newpict))
|
||||
(define localrefx (* newpict-w (align->frac halign)))
|
||||
(define localrefy (* newpict-h (align->frac valign)))
|
||||
(define newscene
|
||||
(lt-superimpose scene (inset newpict (- refx localrefx) (- refy localrefy) 0 0)))
|
||||
(let ([result-pict (refocus newscene scene)])
|
||||
(cond [(and (eq? valign 't) (eq? composer (align->vcomposer align)))
|
||||
;; ie, going top-down and composer is the natural composer for this align
|
||||
(mk-ppict result-pict
|
||||
(coord refxfrac refyfrac align
|
||||
#:compose composer
|
||||
#:sep newsep
|
||||
#:internal:skip (blank 0 newpict-h)))]
|
||||
[(and (eq? halign 'l) (eq? composer (align->hcomposer align)))
|
||||
(mk-ppict result-pict
|
||||
(coord refxfrac refyfrac align
|
||||
#:compose composer
|
||||
#:sep newsep
|
||||
#:internal:skip (blank newpict-w 0)))]
|
||||
[else result-pict])))))
|
||||
|
||||
;; ----
|
||||
|
||||
;; apply-composer : composer real (listof (U #f pict real)) -> (values pict real)
|
||||
;; Returns composed pict and last given separator num in elems (or init-sep, if none)
|
||||
(define (apply-composer composer init-sep elems)
|
||||
(define (start-loop sep elems)
|
||||
(cond [(and (pair? elems) (real? (car elems)))
|
||||
(start-loop (car elems) (cdr elems))]
|
||||
[(and (pair? elems) (pict? (car elems)))
|
||||
(join-loop (car elems) sep (cdr elems))]
|
||||
[(null? elems)
|
||||
(blank 0)]))
|
||||
(define (join-loop base sep elems)
|
||||
(cond [(and (pair? elems) (real? (car elems)))
|
||||
(join-loop base (car elems) (cdr elems))]
|
||||
[(and (pair? elems) (pict? (car elems)))
|
||||
(join-loop (composer sep base (car elems))
|
||||
sep
|
||||
(cdr elems))]
|
||||
[(null? elems) base]))
|
||||
(values (start-loop init-sep (filter values elems))
|
||||
(last (cons init-sep (filter real? elems)))))
|
||||
|
||||
;; ----
|
||||
|
||||
(define (align->frac align)
|
||||
(case align
|
||||
((t l) 0)
|
||||
((c) 1/2)
|
||||
((b r) 1)))
|
||||
|
||||
(define (align->h align)
|
||||
(case align
|
||||
((lt lc lb) 'l)
|
||||
((ct cc cb) 'c)
|
||||
((rt rc rb) 'r)))
|
||||
|
||||
(define (align->v align)
|
||||
(case align
|
||||
((lt ct rt) 't)
|
||||
((lc cc rc) 'c)
|
||||
((lb cb rb) 'r)))
|
||||
|
||||
(define (align->vcomposer align)
|
||||
(case align
|
||||
((lt lc lb) vl-append)
|
||||
((ct cc cb) vc-append)
|
||||
((rt rc rb) vr-append)))
|
||||
|
||||
(define (align->hcomposer align)
|
||||
(case align
|
||||
((lt ct rt) ht-append)
|
||||
((lc cc rc) hc-append)
|
||||
((lb cb rb) hb-append)))
|
||||
|
||||
;; ==== Some examples ====
|
||||
|
||||
#|
|
||||
(slide
|
||||
(let* ([dp (colorize (rectangle 200 200) "gray")]
|
||||
[dp (ppict-go dp (grid 2 2 1 0 'ct))]
|
||||
[dp (ppict-add dp (circle 20) (circle 20) (circle 20))])
|
||||
(vc-append gap-size
|
||||
(shframe dp)
|
||||
(shframe
|
||||
(ppict-add dp (colorize (circle 20) "red"))))))
|
||||
|
||||
(slide
|
||||
(let* ([dp (colorize (rectangle 200 200) "gray")]
|
||||
[dp (ppict-go dp (grid 2 2 0 0 'lb #:compose hbl-append))]
|
||||
[dp (ppict-add dp (circle 20) (circle 20) (circle 20))])
|
||||
(vc-append gap-size
|
||||
(shframe dp)
|
||||
(shframe
|
||||
(ppict-add dp (colorize (circle 20) "red"))))))
|
||||
|#
|
||||
|
||||
;; ============================================================
|
||||
;; Exports
|
||||
|
||||
(define align/c
|
||||
(or/c 'lt 'ct 'rt
|
||||
'lc 'cc 'rc
|
||||
'lb 'cb 'rb))
|
||||
(provide ppict-do
|
||||
ppict-do*)
|
||||
|
||||
(provide ppict?
|
||||
placer?)
|
||||
|
||||
(provide/contract
|
||||
[ppict-do
|
||||
(->* (pict?)
|
||||
()
|
||||
#:rest (listof (or/c pict? real? #f placer?))
|
||||
pict?)]
|
||||
[ppict-go
|
||||
(-> pict? placer? ppict?)]
|
||||
[ppict-add
|
||||
|
|
|
|||
18
collects/unstable/gui/private/ppict-syntax.rkt
Normal file
18
collects/unstable/gui/private/ppict-syntax.rkt
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
#lang racket/base
|
||||
(require syntax/parse syntax/parse/experimental/contract
|
||||
(for-template racket/base
|
||||
racket/contract
|
||||
slideshow/pict
|
||||
"ppict.rkt"))
|
||||
(provide fragment)
|
||||
|
||||
(define-splicing-syntax-class (fragment who)
|
||||
#:description (format "~a fragment" who)
|
||||
(pattern (~seq #:go pl)
|
||||
#:declare pl (expr/c #'placer? #:name "argument to #:go")
|
||||
#:with code #'(p:go pl.c))
|
||||
(pattern (~seq #:next)
|
||||
#:with code #'(p:out))
|
||||
(pattern (~seq e)
|
||||
#:declare e (expr/c #'(or/c pict? real? #f) #:name "element")
|
||||
#:with code #'(p:elem e.c)))
|
||||
284
collects/unstable/gui/private/ppict.rkt
Normal file
284
collects/unstable/gui/private/ppict.rkt
Normal file
|
|
@ -0,0 +1,284 @@
|
|||
#lang racket/base
|
||||
(require racket/list
|
||||
racket/contract
|
||||
slideshow/pict)
|
||||
|
||||
#|
|
||||
TODO
|
||||
|
||||
- need a way to express "dependent" additions, when need to find a
|
||||
pict within a ppict, eg for lines, balloons, etc.
|
||||
|
||||
- [lcr]bl alignments... not sure about [lcr]tl
|
||||
|#
|
||||
|
||||
;; ============================================================
|
||||
;; Progressive Picts
|
||||
|
||||
#|
|
||||
A ppict contains a pict and a placer (or #f).
|
||||
A placer = (placer (pict (listof (U pict real #f)) -> ppict))
|
||||
In a placer function's arguments:
|
||||
a number means to change the separation spacing
|
||||
a #f is just ignored
|
||||
FIXME: clarify, for following or including current gap?
|
||||
|#
|
||||
(struct ppict pict (placer))
|
||||
(struct placer (fun))
|
||||
|
||||
(define (mk-ppict p placer)
|
||||
(ppict (pict-draw p)
|
||||
(pict-width p)
|
||||
(pict-height p)
|
||||
(pict-ascent p)
|
||||
(pict-descent p)
|
||||
(list (make-child p 0 0 1 1))
|
||||
#f
|
||||
(pict-last p)
|
||||
placer))
|
||||
|
||||
(define (ppict-pict dp)
|
||||
(child-pict (car (pict-children dp))))
|
||||
|
||||
;; ----
|
||||
|
||||
;; ppict-add : ppict (U pict real #f) ... -> ppict
|
||||
(define (ppict-add dp . picts)
|
||||
(let ([pl (ppict-placer dp)])
|
||||
((placer-fun pl) (ppict-pict dp) picts)))
|
||||
|
||||
;; ppict-go : pict placer -> ppict
|
||||
(define (ppict-go dp pl)
|
||||
(cond [(ppict? dp)
|
||||
(mk-ppict (ppict-pict dp) pl)]
|
||||
[(pict? dp)
|
||||
(mk-ppict dp pl)]))
|
||||
|
||||
;; ----
|
||||
|
||||
;; row, column indexes are 0-based
|
||||
(define (grid cols rows col row [align 'cc]
|
||||
#:compose [composer (align->vcomposer align)]
|
||||
#:sep [sep 0])
|
||||
(define halign (align->h align))
|
||||
(define valign (align->v align))
|
||||
(define refxfrac (/ (+ col (align->frac halign)) cols))
|
||||
(define refyfrac (/ (+ row (align->frac valign)) rows))
|
||||
(coord refxfrac refyfrac align #:compose composer #:sep sep))
|
||||
|
||||
(define (coord refxfrac refyfrac [align 'cc]
|
||||
#:compose [composer (align->vcomposer align)]
|
||||
#:sep [sep 0]
|
||||
#:internal:skip [skip #f])
|
||||
(define halign (align->h align))
|
||||
(define valign (align->v align))
|
||||
(placer
|
||||
(lambda (scene picts)
|
||||
(define scene-w (pict-width scene))
|
||||
(define scene-h (pict-height scene))
|
||||
(define refx (* scene-w refxfrac))
|
||||
(define refy (* scene-h refyfrac))
|
||||
(define-values (newpict newsep)
|
||||
(apply-composer composer sep (cons skip picts)))
|
||||
(define newpict-w (pict-width newpict))
|
||||
(define newpict-h (pict-height newpict))
|
||||
(define localrefx (* newpict-w (align->frac halign)))
|
||||
(define localrefy (* newpict-h (align->frac valign)))
|
||||
(define newscene
|
||||
(lt-superimpose scene (inset newpict (- refx localrefx) (- refy localrefy) 0 0)))
|
||||
(let ([result-pict (refocus newscene scene)])
|
||||
(cond [(and (eq? valign 't) (eq? composer (align->vcomposer align)))
|
||||
;; ie, going top-down and composer is the natural composer for this align
|
||||
(mk-ppict result-pict
|
||||
(coord refxfrac refyfrac align
|
||||
#:compose composer
|
||||
#:sep newsep
|
||||
#:internal:skip (blank 0 newpict-h)))]
|
||||
[(and (eq? halign 'l) (eq? composer (align->hcomposer align)))
|
||||
(mk-ppict result-pict
|
||||
(coord refxfrac refyfrac align
|
||||
#:compose composer
|
||||
#:sep newsep
|
||||
#:internal:skip (blank newpict-w 0)))]
|
||||
[else result-pict])))))
|
||||
|
||||
;; ----
|
||||
|
||||
;; apply-composer : composer real (listof (U #f pict real)) -> (values pict real)
|
||||
;; Returns composed pict and last given separator num in elems (or init-sep, if none)
|
||||
(define (apply-composer composer init-sep elems)
|
||||
(define (start-loop sep elems)
|
||||
(cond [(and (pair? elems) (real? (car elems)))
|
||||
(start-loop (car elems) (cdr elems))]
|
||||
[(and (pair? elems) (pict? (car elems)))
|
||||
(join-loop (car elems) sep (cdr elems))]
|
||||
[(null? elems)
|
||||
(blank 0)]))
|
||||
(define (join-loop base sep elems)
|
||||
(cond [(and (pair? elems) (real? (car elems)))
|
||||
(join-loop base (car elems) (cdr elems))]
|
||||
[(and (pair? elems) (pict? (car elems)))
|
||||
(join-loop (composer sep base (car elems))
|
||||
sep
|
||||
(cdr elems))]
|
||||
[(null? elems) base]))
|
||||
(values (start-loop init-sep (filter values elems))
|
||||
(last (cons init-sep (filter real? elems)))))
|
||||
|
||||
;; ----
|
||||
|
||||
(define (align->frac align)
|
||||
(case align
|
||||
((t l) 0)
|
||||
((c) 1/2)
|
||||
((b r) 1)))
|
||||
|
||||
(define (align->h align)
|
||||
(case align
|
||||
((lt lc lb) 'l)
|
||||
((ct cc cb) 'c)
|
||||
((rt rc rb) 'r)))
|
||||
|
||||
(define (align->v align)
|
||||
(case align
|
||||
((lt ct rt) 't)
|
||||
((lc cc rc) 'c)
|
||||
((lb cb rb) 'r)))
|
||||
|
||||
(define (align->vcomposer align)
|
||||
(case align
|
||||
((lt lc lb) vl-append)
|
||||
((ct cc cb) vc-append)
|
||||
((rt rc rb) vr-append)))
|
||||
|
||||
(define (align->hcomposer align)
|
||||
(case align
|
||||
((lt ct rt) ht-append)
|
||||
((lc cc rc) hc-append)
|
||||
((lb cb rb) hb-append)))
|
||||
|
||||
;; ----
|
||||
|
||||
#|
|
||||
(define (ppict-do* base elems)
|
||||
(define (loop elems rchunks)
|
||||
(cond [(and (pair? elems) (placer? (car elems)))
|
||||
(loop (cdr elems) (cons (car elems) rchunks))]
|
||||
[(and (pair? elems))
|
||||
(loop* (cdr elems) rchunks (list (car elems)))]
|
||||
[(null? elems)
|
||||
(reverse rchunks)]))
|
||||
(define (loop* elems rchunks rchunk)
|
||||
(cond [(and (pair? elems) (placer? (car elems)))
|
||||
(loop elems (cons (reverse rchunk) rchunks))]
|
||||
[(and (pair? elems))
|
||||
(loop* (cdr elems) rchunks (cons (car elems) rchunk))]
|
||||
[(null? elems)
|
||||
(loop elems (cons (reverse rchunk) rchunks))]))
|
||||
(let ([chunks (loop elems null)])
|
||||
(for/fold ([acc base]) ([chunk (in-list chunks)])
|
||||
(cond [(placer? chunk)
|
||||
(ppict-go acc chunk)]
|
||||
[(list? chunk)
|
||||
(apply ppict-add acc chunk)]))))
|
||||
|#
|
||||
|
||||
;; ----
|
||||
|
||||
(struct p:elem (value))
|
||||
(struct p:out ())
|
||||
(struct p:go (placer))
|
||||
|
||||
;; internal-ppict-do : pict (listof (U p:go p:out p:elem)) -> (values pict (listof pict))
|
||||
(define (internal-ppict-do who base parts)
|
||||
(let* ([init-go
|
||||
(cond [(ppict? base) (p:go (ppict-placer base))]
|
||||
[else #f])]
|
||||
[gochunks (get-gochunks who init-go parts)])
|
||||
(do-gochunks base gochunks)))
|
||||
|
||||
;; ----
|
||||
|
||||
;; A gochunk is (cons p:go (listof (U p:elem p:next)))
|
||||
|
||||
;; get-gochunks : (U p:go #f) (listof (U p:elem p:out p:go)) -> (listof gochunk)
|
||||
(define (get-gochunks who init-go elems)
|
||||
(define (loop init-go elems)
|
||||
(cond [(and (pair? elems) (p:go? (car elems)))
|
||||
(loop (car elems) (cdr elems))]
|
||||
[(pair? elems)
|
||||
(unless init-go
|
||||
(error who "missing initial placer"))
|
||||
(let-values ([(chunk tail) (split-until p:go? elems)])
|
||||
(cons (cons init-go chunk)
|
||||
(if (pair? tail)
|
||||
(loop (car tail) (cdr tail))
|
||||
null)))]
|
||||
[(null? elems) null]))
|
||||
(loop init-go elems))
|
||||
|
||||
;; do-gochunks : pict (listof gochunk) -> (values pict (listof pict))
|
||||
(define (do-gochunks base gochunks)
|
||||
(let-values ([(pict rpictss)
|
||||
(for/fold ([base base] [rpictss null]) ([gochunk (in-list gochunks)])
|
||||
(let* ([placer (p:go-placer (car gochunk))]
|
||||
[chunk (cdr gochunk)]
|
||||
[base (ppict-go base placer)])
|
||||
(let-values ([(pict picts)
|
||||
(do-chunk base chunk)])
|
||||
(values pict (cons picts rpictss)))))])
|
||||
(values pict (apply append (reverse rpictss)))))
|
||||
|
||||
;; A chunk is (listof (U p:elem p:out))
|
||||
|
||||
;; do-chunk : ppict (listof (U p:elem p:out)) -> (values ppict (listof pict))
|
||||
;; In second return value, one pict per p:out occurrence.
|
||||
;; FIXME: avoid applying ghost to previously ghosted pict?
|
||||
(define (do-chunk base chunk)
|
||||
(let ([elem-chunks
|
||||
;; (listof (listof pict?))
|
||||
;; length is N+1, where N is number of (p:out) in chunk
|
||||
;; ghosted before visible
|
||||
(let elab ([chunk chunk])
|
||||
(cond [(and (pair? chunk) (p:out? (car chunk)))
|
||||
(let ([elab-rest (elab (cdr chunk))])
|
||||
(cons (map ghost* (car elab-rest))
|
||||
elab-rest))]
|
||||
[(and (pair? chunk) (p:elem? (car chunk)))
|
||||
(for/list ([elem-chunk (in-list (elab (cdr chunk)))])
|
||||
(cons (p:elem-value (car chunk))
|
||||
elem-chunk))]
|
||||
[(null? chunk)
|
||||
(list null)]))])
|
||||
(let out-loop ([chunks elem-chunks] [rpicts null])
|
||||
(cond [(null? (cdr chunks))
|
||||
(values (apply ppict-add base (car chunks))
|
||||
(reverse rpicts))]
|
||||
[else
|
||||
(out-loop (cdr chunks)
|
||||
(cons (apply ppict-add base (car chunks))
|
||||
rpicts))]))))
|
||||
|
||||
;; ----
|
||||
|
||||
(define (split-until stop? elems)
|
||||
(let loop ([elems elems] [rprefix null])
|
||||
(cond [(and (pair? elems) (stop? (car elems)))
|
||||
(values (reverse rprefix) elems)]
|
||||
[(pair? elems)
|
||||
(loop (cdr elems) (cons (car elems) rprefix))]
|
||||
[(null? elems)
|
||||
(values (reverse rprefix) null)])))
|
||||
|
||||
(define (ghost* x)
|
||||
(if (pict? x) (ghost x) x))
|
||||
|
||||
;; ============================================================
|
||||
;; Exports
|
||||
|
||||
(define align/c
|
||||
(or/c 'lt 'ct 'rt
|
||||
'lc 'cc 'rc
|
||||
'lb 'cb 'rb))
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
|
@ -1,21 +1,18 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base
|
||||
syntax/parse
|
||||
syntax/parse/experimental/contract)
|
||||
syntax/parse/experimental/contract
|
||||
"private/ppict-syntax.rkt")
|
||||
racket/list
|
||||
racket/contract
|
||||
racket/gui/base
|
||||
slideshow/base
|
||||
slideshow/pict
|
||||
"ppict.rkt")
|
||||
"private/ppict.rkt")
|
||||
|
||||
;; ============================================================
|
||||
;; Progressive Slides
|
||||
|
||||
(struct p:elem (value))
|
||||
(struct p:out ())
|
||||
(struct p:go (placer))
|
||||
|
||||
(define pslide-base-pict
|
||||
(make-parameter (lambda () (blank client-w client-h))))
|
||||
|
||||
|
|
@ -23,109 +20,22 @@
|
|||
(make-parameter (coord 1/2 1/2 'cc)))
|
||||
|
||||
;; pslide* : (U p:elem p:out p:go) ... -> void
|
||||
(define (pslide* . elems)
|
||||
(let ([gochunks
|
||||
(get-gochunks (p:go (pslide-default-placer))
|
||||
(append elems (list (p:out))))])
|
||||
(do-gochunks ((pslide-base-pict)) gochunks)
|
||||
(void)))
|
||||
|
||||
;; ----
|
||||
|
||||
;; A gochunk is (cons p:go (listof (U p:elem p:next)))
|
||||
|
||||
;; get-gochunks : p:go (listof (U p:elem p:out p:go)) -> (listof gochunk)
|
||||
(define (get-gochunks init-go elems)
|
||||
(define (loop init-go elems)
|
||||
(cond [(and (pair? elems) (p:go? (car elems)))
|
||||
(loop (car elems) (cdr elems))]
|
||||
[(pair? elems)
|
||||
(let-values ([(chunk tail) (split-until p:go? elems)])
|
||||
(cons (cons init-go chunk)
|
||||
(if (pair? tail)
|
||||
(loop (car tail) (cdr tail))
|
||||
null)))]
|
||||
[(null? elems) null]))
|
||||
(loop init-go elems))
|
||||
|
||||
(define (do-gochunks base gochunks)
|
||||
(for/fold ([base base]) ([gochunk (in-list gochunks)])
|
||||
(let* ([placer (p:go-placer (car gochunk))]
|
||||
[chunk (cdr gochunk)]
|
||||
[base (ppict-go base placer)])
|
||||
(do-chunk base chunk))))
|
||||
|
||||
;; do-chunk : ppict (listof (U p:elem p:out)) -> ppict
|
||||
(define (do-chunk base chunk)
|
||||
(let ([elem-chunks
|
||||
;; (listof (listof pict?))
|
||||
;; length is N+1, where N is number of (p:out) in chunk
|
||||
;; ghosted before visible
|
||||
(let elab ([chunk chunk])
|
||||
(cond [(and (pair? chunk) (p:out? (car chunk)))
|
||||
(let ([elab-rest (elab (cdr chunk))])
|
||||
(cons (map ghost* (car elab-rest))
|
||||
elab-rest))]
|
||||
[(and (pair? chunk) (p:elem? (car chunk)))
|
||||
(for/list ([elem-chunk (in-list (elab (cdr chunk)))])
|
||||
(cons (p:elem-value (car chunk))
|
||||
elem-chunk))]
|
||||
[(null? chunk)
|
||||
(list null)]))])
|
||||
(let out-loop ([chunks elem-chunks])
|
||||
(cond [(null? (cdr chunks))
|
||||
(apply ppict-add base (car chunks))]
|
||||
[else
|
||||
(slide (apply ppict-add base (car chunks)))
|
||||
(out-loop (cdr chunks))]))))
|
||||
|
||||
;; ----
|
||||
|
||||
(define (split-until stop? elems)
|
||||
(let loop ([elems elems] [rprefix null])
|
||||
(cond [(and (pair? elems) (stop? (car elems)))
|
||||
(values (reverse rprefix) elems)]
|
||||
[(pair? elems)
|
||||
(loop (cdr elems) (cons (car elems) rprefix))]
|
||||
[(null? elems)
|
||||
(values (reverse rprefix) null)])))
|
||||
|
||||
(define (ghost* x)
|
||||
(if (pict? x) (ghost x) x))
|
||||
(define (pslide* who parts)
|
||||
(let* ([init-go (p:go (pslide-default-placer))]
|
||||
[init-pict ((pslide-base-pict))]
|
||||
[gochunks
|
||||
(get-gochunks who init-go (append parts (list (p:out))))])
|
||||
(let-values ([(final picts) (do-gochunks init-pict gochunks)])
|
||||
(for-each slide picts)
|
||||
(void))))
|
||||
|
||||
;; ----
|
||||
|
||||
(define-syntax (pslide stx)
|
||||
|
||||
(define-splicing-syntax-class fragment
|
||||
#:description "pslide fragment"
|
||||
(pattern (~seq #:go pl)
|
||||
#:declare pl (expr/c #'placer? #:name "argument to #:go")
|
||||
#:with code #'(p:go pl.c))
|
||||
(pattern (~seq #:next)
|
||||
#:with code #'(p:out))
|
||||
(pattern (~seq e)
|
||||
#:declare e (expr/c #'(or/c pict? real? #f) #:name "element")
|
||||
#:with code #'(p:elem e.c)))
|
||||
|
||||
(syntax-parse stx
|
||||
[(_ p:fragment ...)
|
||||
#'(pslide* p.code ...)]))
|
||||
|
||||
;; ---- Example ----
|
||||
|
||||
#|
|
||||
(pslide* (p:elem (t "this is the time to remember"))
|
||||
(p:out)
|
||||
(p:elem (t "because it will not last forever"))
|
||||
(p:out)
|
||||
(p:go (coord 1 0 'rt))
|
||||
(p:elem 50)
|
||||
(p:elem #f)
|
||||
(p:elem (t "this is the time"))
|
||||
(p:elem (t "because it will")))
|
||||
|#
|
||||
|
||||
[(_ p ...)
|
||||
#:declare p (fragment 'pslide)
|
||||
#'(pslide* 'pslide (list p.code ...))]))
|
||||
|
||||
;; ============================================================
|
||||
;; Exports
|
||||
|
|
|
|||
|
|
@ -22,20 +22,20 @@ A @deftech{progressive pict} or ``ppict'' is a kind of @racket[pict]
|
|||
that has an associated ``pict placer,'' which generally represents a
|
||||
position and alignment. New picts can be placed on the progressive
|
||||
pict by calling @racket[ppict-add], and the placer can be updated by
|
||||
calling @racket[ppict-go]. The @racket[ppict-do] function provides a
|
||||
calling @racket[ppict-go]. The @racket[ppict-do] form provides a
|
||||
compact notation for sequences of those two operations.
|
||||
|
||||
@examples[#:eval the-eval
|
||||
(define base
|
||||
(ppict-do (colorize (rectangle 200 200) "gray")
|
||||
(coord 1/2 1/2 'cc)
|
||||
#:go (coord 1/2 1/2 'cc)
|
||||
(colorize (hline 200 1) "gray")
|
||||
(coord 1/2 1/2 'cc)
|
||||
#:go (coord 1/2 1/2 'cc)
|
||||
(colorize (vline 1 200) "gray")))
|
||||
base
|
||||
(define circles-down-1
|
||||
(ppict-do base
|
||||
(grid 2 2 1 0 'ct)
|
||||
#:go (grid 2 2 1 0 'ct)
|
||||
10
|
||||
(circle 20)
|
||||
(circle 20)
|
||||
|
|
@ -58,14 +58,28 @@ Returns @racket[#t] if @racket[x] is a @tech{progressive pict},
|
|||
@racket[#f] otherwise.
|
||||
}
|
||||
|
||||
@defproc[(ppict-do [p pict?]
|
||||
[cmd (or/c pict? real? #f placer?)] ...)
|
||||
pict?]{
|
||||
@deftogether[[
|
||||
@defform[(ppict-do base-expr ppict-do-fragment ...)]
|
||||
@defform/subs[(ppict-do* base-expr do-fragment ...)
|
||||
([ppict-do-fragment (code:line #:go placer-expr)
|
||||
(code:line #:next)
|
||||
(code:line elem-expr)])
|
||||
#:contracts ([base-expr pict?]
|
||||
[placer-expr placer?]
|
||||
[elem-expr (or/c pict? real? #f)])]]]{
|
||||
|
||||
Starting with @racket[p], applies @racket[ppict-go] for every
|
||||
@racket[cmd] that is a placer and @racket[ppict-add] for every
|
||||
sequence of @racket[cmd]s that are picts, real numbers, and
|
||||
@racket[#f].
|
||||
Starting with @racket[base-expr], applies @racket[ppict-go] for every
|
||||
@racket[#:go] directive and @racket[ppict-add] for every sequence of
|
||||
@racket[elem-expr]s. If @racket[base-expr] is not a @tech{progressive
|
||||
pict}, a use of @racket[#:go] must precede the first
|
||||
@racket[elem-expr]. The @racket[#:next] directive saves a pict
|
||||
including only the contents emitted so far (but whose alignment takes
|
||||
into account picts yet to come).
|
||||
|
||||
The @racket[ppict-do] form returns only the final pict; any uses of
|
||||
@racket[#:next] are ignored. The @racket[ppict-do*] form returns two
|
||||
values: the final pict and a list of all partial picts emitted due to
|
||||
@racket[#:next] (the final pict is not included).
|
||||
|
||||
A spacing change, represented by a real number, only affects added
|
||||
picts up until the next placer is installed; when a placer is
|
||||
|
|
@ -74,9 +88,9 @@ installed, the spacing is reset to @racket[0].
|
|||
For example, the following code
|
||||
@racketblock[
|
||||
(ppict-do (colorize (rectangle 200 200) "gray")
|
||||
(coord 1/2 1/2 'cc)
|
||||
#:go (coord 1/2 1/2 'cc)
|
||||
(colorize (hline 200 1) "gray")
|
||||
(coord 1/2 1/2 'cc)
|
||||
#:go (coord 1/2 1/2 'cc)
|
||||
(colorize (vline 1 200) "gray"))
|
||||
]
|
||||
is equivalent to
|
||||
|
|
@ -89,6 +103,7 @@ is equivalent to
|
|||
pp)
|
||||
]
|
||||
}
|
||||
}
|
||||
|
||||
@defproc[(ppict-go [p pict?] [pl placer?]) ppict?]{
|
||||
|
||||
|
|
@ -149,17 +164,17 @@ another progressive pict only if
|
|||
|
||||
@examples[#:eval the-eval
|
||||
(ppict-do base
|
||||
(coord 1/3 3/4 'cc)
|
||||
#:go (coord 1/3 3/4 'cc)
|
||||
(circle 20))
|
||||
(ppict-do base
|
||||
(coord 1 0 'rt)
|
||||
#:go (coord 1 0 'rt)
|
||||
50 (code:comment "change spacing")
|
||||
(text "abc")
|
||||
(text "12345")
|
||||
0 (code:comment "and again")
|
||||
(text "ok done"))
|
||||
(ppict-do base
|
||||
(coord 0 0 'lt #:compose ht-append)
|
||||
#:go (coord 0 0 'lt #:compose ht-append)
|
||||
(circle 10)
|
||||
(circle 20)
|
||||
(circle 30))
|
||||
|
|
@ -186,12 +201,12 @@ but @racket[(grid 2 2 0 0 'rt)] is equivalent to @racket[(coord 1/2 0 'rt)].
|
|||
@examples[#:eval the-eval
|
||||
(define none-for-me-thanks
|
||||
(ppict-do base
|
||||
(grid 2 2 0 0 'lt)
|
||||
#:go (grid 2 2 0 0 'lt)
|
||||
(text "You do not like")
|
||||
(colorize (text "green eggs and ham?") "darkgreen")))
|
||||
none-for-me-thanks
|
||||
(ppict-do none-for-me-thanks
|
||||
(grid 2 2 1 0 'rb)
|
||||
#:go (grid 2 2 1 0 'rb)
|
||||
(colorize (text "I do not like them,") "red")
|
||||
(text "Sam-I-am."))
|
||||
]
|
||||
|
|
@ -209,11 +224,15 @@ none-for-me-thanks
|
|||
#:contracts ([placer-expr placer?]
|
||||
[elem-expr (or/c pict? real? #f)])]{
|
||||
|
||||
Constructs a slide using the @tech{progressive pict} mechanism. A
|
||||
@racket[#:go] directive updates the current placer; a @racket[#:next]
|
||||
directive causes a slide to be emitted with the contents thus far (but
|
||||
whose alignment takes into account contents yet to be added); and
|
||||
other elements have the same meaning as in @racket[ppict-add].
|
||||
Produce slide(s) using @tech{progressive picts}. A @racket[#:go]
|
||||
directive updates the current placer; a @racket[#:next] directive
|
||||
causes a slide to be emitted with the contents thus far (but whose
|
||||
alignment takes into account contents yet to be added); and other
|
||||
elements have the same meaning as in @racket[ppict-add].
|
||||
|
||||
Note that like @racket[slide] but unlike @racket[ppict-do*], the
|
||||
number of slides produced is one greater than the number of
|
||||
@racket[#:next] uses; a slide is created for the final pict.
|
||||
|
||||
Remember to include @racket[gap-size] after updating the current
|
||||
placer if you want @racket[slide]-like spacing.
|
||||
|
|
@ -226,28 +245,32 @@ placer if you want @racket[slide]-like spacing.
|
|||
#:go (coord 1 1 'rb)
|
||||
(colorize (t "I do not like them,") "red")
|
||||
(t "Sam-I-am."))
|
||||
(let* ([slide1
|
||||
(ppict-do (colorize (filled-rectangle 200 150) "white")
|
||||
(coord 1/20 1/20 'lt) ;; for margins
|
||||
(text "You do not like")
|
||||
(colorize (text "green eggs and ham?")
|
||||
"darkgreen"))]
|
||||
[slide2
|
||||
(ppict-do slide1
|
||||
(coord 19/20 19/20 'rb) ;; for margins
|
||||
(colorize (text "I do not like them,") "red")
|
||||
(text "Sam-I-am."))]
|
||||
[slides
|
||||
(inset
|
||||
(vl-append -5
|
||||
(colorize (text "slides" '(bold . roman)) "white")
|
||||
(inset (hc-append 20 slide1 slide2) 15))
|
||||
5)])
|
||||
(cc-superimpose
|
||||
(colorize (filled-rectangle (pict-width slides) (pict-height slides))
|
||||
"darkgray")
|
||||
slides)))
|
||||
(let-values ([(final slides0)
|
||||
(ppict-do* (colorize (filled-rectangle 200 150) "white")
|
||||
#:go (coord 1/20 1/20 'lt) ;; for margins
|
||||
(text "You do not like")
|
||||
(colorize (text "green eggs and ham?")
|
||||
"darkgreen")
|
||||
#:next
|
||||
#:go (coord 19/20 19/20 'rb) ;; for margins
|
||||
(colorize (text "I do not like them,") "red")
|
||||
(text "Sam-I-am.")
|
||||
#:next)])
|
||||
(let ([slides
|
||||
(inset
|
||||
(vl-append -10
|
||||
(colorize (text "slides" '(bold . roman)) "white")
|
||||
(inset (apply hc-append 20 slides0) 15))
|
||||
5)])
|
||||
(cc-superimpose
|
||||
(colorize (filled-rectangle (pict-width slides) (pict-height slides))
|
||||
"darkgray")
|
||||
slides))))
|
||||
]
|
||||
|
||||
Note that the text is not flush against the sides of the slide,
|
||||
because @racket[pslide] uses a base pict the size of the client
|
||||
area, excluding the margins.
|
||||
}
|
||||
|
||||
@defparam[pslide-base-pict make-base-pict (-> pict)]{
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user