Creating unstable/gui/pict/align

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].}

pkgs/unstable-pkgs/unstable-lib/gui/pict.rkt

@@ -526,3 +526,4 @@
  [arch
   (-> real? real? real? real?
       pict?)])
+

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)]))

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")
 

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))