diff --git a/pkgs/unstable-pkgs/unstable-doc/scribblings/gui/pict.scrbl b/pkgs/unstable-pkgs/unstable-doc/scribblings/gui/pict.scrbl index 4a2dcc7af4..40a2f36492 100644 --- a/pkgs/unstable-pkgs/unstable-doc/scribblings/gui/pict.scrbl +++ b/pkgs/unstable-pkgs/unstable-doc/scribblings/gui/pict.scrbl @@ -589,3 +589,21 @@ Adds a background highlighted with @racket[color] to @(close-eval the-eval) +@section{Alignment} + +@(require (for-label unstable/gui/pict/align)) +@defmodule[unstable/gui/pict/align] + +@defthing[align/c contract?]{A contract for the values @racket['(lt ct rt lc cc rc lb cb rb)].} +@defthing[halign/c contract?]{A contract for the values @racket['(l c r)].} +@defthing[valign/c contract?]{A contract for the values @racket['(t c b)].} + +@defproc[(align->h [a align/c]) halign/c]{Extracts the @racket[halign/c] part from @racket[a].} +@defproc[(align->v [a align/c]) valign/c]{Extracts the @racket[valign/c] part from @racket[a].} + +@defproc[(align->frac [a (or/c halign/c valign/c)]) real?]{Computes the fraction corresponding to an alignment where the top-left is @racket[0].} + +@defproc[(halign->vcompose [ha halign/c]) procedure?]{Returns the @racket[h*-append] function for horizontal alignment.} +@defproc[(valign->hcompose [va valign/c]) procedure?]{Returns the @racket[v*-append] function for vertical alignment.} + +@defproc[(pin-over/align [scene pict?] [x real?] [y real?] [halign halign/c] [valign valign/c] [pict pict?]) pict?]{Pins @racket[pict] over @racket[scene] centered at @racket[x]x@racket[y] aligned as specified in @racket[halign] and @racket[valign].} diff --git a/pkgs/unstable-pkgs/unstable-lib/gui/pict.rkt b/pkgs/unstable-pkgs/unstable-lib/gui/pict.rkt index 57a1a26d37..bd7427c7c3 100644 --- a/pkgs/unstable-pkgs/unstable-lib/gui/pict.rkt +++ b/pkgs/unstable-pkgs/unstable-lib/gui/pict.rkt @@ -526,3 +526,4 @@ [arch (-> real? real? real? real? pict?)]) + diff --git a/pkgs/unstable-pkgs/unstable-lib/gui/pict/align.rkt b/pkgs/unstable-pkgs/unstable-lib/gui/pict/align.rkt new file mode 100644 index 0000000000..e3b5270411 --- /dev/null +++ b/pkgs/unstable-pkgs/unstable-lib/gui/pict/align.rkt @@ -0,0 +1,60 @@ +#lang racket/base +(require pict + racket/contract/base) + +(define (pin-over/align scene x y halign valign pict) + (let ([localrefx (* (pict-width pict) (align->frac halign))] + [localrefy (* (pict-height pict) (align->frac valign))]) + (pin-over scene (- x localrefx) (- y localrefy) pict))) + +(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) 'b))) + +(define (halign->vcompose halign) + (case halign + ((l) vl-append) + ((c) vc-append) + ((r) vr-append))) + +(define (valign->hcompose align) + (case align + ((t) ht-append) + ((c) hc-append) + ((b) hb-append))) + +(define align/c + (or/c 'lt 'ct 'rt + 'lc 'cc 'rc + 'lb 'cb 'rb)) +(define halign/c + (or/c 'l 'c 'r)) +(define valign/c + (or/c 't 'c 'b)) + +(provide + (contract-out + ;; xxx more specific + [halign->vcompose (-> halign/c procedure?)] + [valign->hcompose (-> valign/c procedure?)] + [pin-over/align (-> pict? real? real? halign/c valign/c pict? pict?)] + [align->frac (-> (or/c halign/c valign/c) real?)] + [align/c contract?] + [halign/c contract?] + [align->h (-> align/c halign/c)] + [valign/c contract?] + [align->v (-> align/c valign/c)])) diff --git a/pkgs/unstable-pkgs/unstable-lib/gui/ppict.rkt b/pkgs/unstable-pkgs/unstable-lib/gui/ppict.rkt index 4627a360c8..4c2fe5266b 100644 --- a/pkgs/unstable-pkgs/unstable-lib/gui/ppict.rkt +++ b/pkgs/unstable-pkgs/unstable-lib/gui/ppict.rkt @@ -5,6 +5,7 @@ "private/ppict-syntax.rkt") racket/contract/base pict + unstable/gui/pict/align "private/ppict.rkt" "private/tag-pict.rkt") diff --git a/pkgs/unstable-pkgs/unstable-lib/gui/private/ppict.rkt b/pkgs/unstable-pkgs/unstable-lib/gui/private/ppict.rkt index 5dcfa0fbd1..20b6211f8e 100644 --- a/pkgs/unstable-pkgs/unstable-lib/gui/private/ppict.rkt +++ b/pkgs/unstable-pkgs/unstable-lib/gui/private/ppict.rkt @@ -5,6 +5,7 @@ racket/stxparam racket/contract/base pict + unstable/gui/pict/align "tag-pict.rkt") #| @@ -273,11 +274,6 @@ In a placer function's arguments: (find p pict-path)))) (halign halign) (valign valign) (compose compose))) -(define (pin-over/align scene x y halign valign pict) - (let ([localrefx (* (pict-width pict) (align->frac halign))] - [localrefy (* (pict-height pict) (align->frac valign))]) - (pin-over scene (- x localrefx) (- y localrefy) pict))) - ;; ---- ;; apply-compose : compose real (listof (U #f pict real)) -> (values pict real) @@ -303,47 +299,10 @@ In a placer function's arguments: ;; ---- -(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) 'b))) - -(define (halign->vcompose halign) - (case halign - ((l) vl-append) - ((c) vc-append) - ((r) vr-append))) - -(define (valign->hcompose align) - (case align - ((t) ht-append) - ((c) hc-append) - ((b) hb-append))) - -;; ---- - (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))