suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

unstable: added ppict, pslide

Browse Source
This commit is contained in:
Ryan Culpepper 2011-07-03 02:01:31 -06:00
parent 5ec2fee90d
commit 77a89b8d83
4 changed files with 657 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

246
collects/unstable/gui/ppict.rkt Normal file
View File

@ -0,0 +1,246 @@
#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
- 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))))
;; ----
;; 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?
placer?)
(provide/contract
[ppict-do
(->* (pict?)
()
#:rest (listof (or/c pict? real? #f placer?))
pict?)]
[ppict-go
(-> pict? placer? ppict?)]
[ppict-add
(->* (ppict?)
()
#:rest (listof (or/c pict? real? #f))
pict?)]
[ppict-placer
(-> ppict? placer?)]
[placer
(-> any/c boolean?)]
[coord
(->* (real? real?)
(align/c
#:compose procedure?)
placer?)]
[grid
(->* (exact-positive-integer? exact-positive-integer?
exact-nonnegative-integer? exact-nonnegative-integer?)
(align/c
#:compose procedure?)
placer?)])

139
collects/unstable/gui/pslide.rkt Normal file
View File

@ -0,0 +1,139 @@
#lang racket/base
(require (for-syntax racket/base
syntax/parse
syntax/parse/experimental/contract)
racket/list
racket/contract
racket/gui/base
slideshow/base
slideshow/pict
"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))))
(define pslide-default-placer
(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-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")))
|#
;; ============================================================
;; Exports
(provide/contract
[pslide-base-pict
(parameter/c (-> pict?))]
[pslide-default-placer
(parameter/c placer?)])
(provide pslide)

1
collects/unstable/scribblings/gui.scrbl
View File

@ -11,3 +11,4 @@
@include-section["gui/notify.scrbl"]
@include-section["gui/prefs.scrbl"]
@include-section["gui/slideshow.scrbl"]
@include-section["gui/pslide.scrbl"]

271
collects/unstable/scribblings/gui/pslide.scrbl Normal file
View File

@ -0,0 +1,271 @@
#lang scribble/doc
@(require scribble/base
scribble/manual
scribble/eval
"../utils.rkt"
(for-label racket/base
slideshow
unstable/gui/ppict
unstable/gui/pslide))
@title[#:tag "ppict"]{Progressive Picts and Slides}
@unstable[@author+email["Ryan Culpepper" "ryanc@racket-lang.org"]]
@(define the-eval (make-base-eval))
@(the-eval '(require slideshow/pict unstable/gui/ppict))
@section[#:tag "ppicts"]{Progressive Picts}
@defmodule[unstable/gui/ppict]
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
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)
(colorize (hline 200 1) "gray")
(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)
10
(circle 20)
(circle 20)
30
(circle 20)))
circles-down-1
(define circles-down-2
(ppict-do circles-down-1
(colorize (circle 20) "red")
40
(colorize (circle 20) "red")))
(code:line (inset circles-down-2 20) (code:comment "draws outside its bounding box"))
(inset (clip circles-down-2) 20)
]
@defproc[(ppict? [x any/c]) boolean?]{
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?]{
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].
A spacing change, represented by a real number, only affects added
picts up until the next placer is installed; when a placer is
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)
(colorize (hline 200 1) "gray")
(coord 1/2 1/2 'cc)
(colorize (vline 1 200) "gray"))
]
is equivalent to
@racketblock[
(let ([pp (colorize (rectangle 200 200) "gray")]
[pp (ppict-go pp (coord 1/2 1/2 'cc))]
[pp (ppict-add pp (colorize (hline 200 1) "gray"))]
[pp (ppict-go pp (coord 1/2 1/2 'cc))]
[pp (ppict-add pp (colorize (vline 1 200) "gray"))])
pp)
]
}
@defproc[(ppict-go [p pict?] [pl placer?]) ppict?]{
Creates a @tech{progressive pict} with the given base pict @racket[p]
and the placer @racket[pl].
}
@defproc[(ppict-add [pp ppict?]
[elem (or/c pict? real? #f)] ...)
pict?]{
Creates a new pict by adding each @racket[elem] pict on top of
@racket[pp] according to @racket[pp]'s placer. The result pict may or
may not be a @tech{progressive pict}, depending on the placer used.
An @racket[elem] that is a real number changes the spacing for
subsequent additions. A @racket[elem] that is @racket[#f] is
discarded; it is permitted as a convenience for conditionally
including sub-picts. Note that @racket[#f] is not equivalent to
@racket[(blank 0)], since the latter will cause spacing to be added
around it.
}
@defproc[(placer? [x any/c]) boolean?]{
Returns @racket[#t] if @racket[x] is a placer, @racket[#f] otherwise.
}
@defproc[(coord [relx real?] [rely real?]
[align (or/c 'lt 'ct 'rt 'lc 'cc 'rc 'lb 'cb 'rb) 'cc]
[#:compose composer procedure? #, @elem{computed from @racket[align]}])
placer?]{
Returns a placer that places picts according to a reference point
determined by @racket[relx] and @racket[rely], which are interpeted as
fractions of the width and height of the base @tech{progressive
pict}. That is, @racket[0], @racket[0] is the top left corner of the
base's bounding box, and @racket[1], @racket[1] is the bottom right.
Additions are aligned according to @racket[align], a symbol whose name
consists of a horizontal alignment character followed by a vertical
alignment character. If @racket[align] is @racket['lt], the pict is
placed so that its left-top corner is at the reference point; if
@racket[align] is @racket['rc], the pict is placed so that the center
of its bounding box's right edge coincides with the reference point.
By default, if there are multiple picts to be placed, they are
verictally appended, aligned according to the horizontal component of
@racket[align]. For example, if @racket[align] is @racket['cc], the
default @racket[composer] is @racket[vc-append]; for @racket['lt], the
default @racket[composer] is @racket[vl-append]. The spacing is
initially @racket[0].
@;{
The result of @racket[ppict-add] using a @racket[coord] placer is
another progressive pict only if
}
@examples[#:eval the-eval
(ppict-do base
(coord 1/3 3/4 'cc)
(circle 20))
(ppict-do base
(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)
(circle 10)
(circle 20)
(circle 30))
]
}
@defproc[(grid [cols exact-positive-integer?]
[rows exact-positive-integer?]
[col exact-nonnegative-integer?]
[row exact-nonnegative-integer?]
[align (or/c 'lt 'ct 'rt 'lc 'cc 'rc 'lb 'cb 'rb) 'cc]
[#:compose composer procedure? #, @elem{computed from @racket[align]}])
placer?]{
Returns a placer that places picts according to a position in a
virtual grid. The @racket[row] and @racket[col] indexes are numbered
starting at @racket[0].
Uses of @racket[grid] can be translated into uses of @racket[coord],
but the translation depends on the alignment. For example,
@racket[(grid 2 2 0 0 'lt)] is equivalent to @racket[(coord 0 0 'lt)],
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)
(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)
(colorize (text "I do not like them,") "red")
(text "Sam-I-am."))
]
}
@section[#:tag "pslide"]{Progressive Slides}
@defmodule[unstable/gui/pslide]
@defform/subs[(pslide pslide-fragment ...)
([pslide-fragment (code:line #:go placer-expr)
(code:line #:next)
(code:line elem-expr)])
#: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].
Remember to include @racket[gap-size] after updating the current
placer if you want @racket[slide]-like spacing.
@examples[#:eval the-eval
(eval:alts (pslide #:go (coord 0 0 'lt)
(t "You do not like")
(colorize (t "green eggs and ham?") "darkgreen")
#:next
#: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)))
]
}
@defparam[pslide-base-pict make-base-pict (-> pict)]{
Controls the initial pict used by @racket[pslide]. The default value
is
@racketblock[
(lambda () (blank client-w client-h))
]
}
@defparam[pslide-default-placer placer placer?]{
Controls the initial placer used by @racket[pslide]. The default value
is
@racketblock[
(coord 1/2 1/2 'cc)
]
}
@(close-eval the-eval)