diff --git a/pkgs/typed-racket-pkgs/typed-racket-more/typed/pict.rkt b/pkgs/typed-racket-pkgs/typed-racket-more/typed/pict.rkt index 4150696a45..ec5436057a 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-more/typed/pict.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-more/typed/pict.rkt @@ -1,5 +1,7 @@ #lang s-exp typed-racket/base-env/extra-env-lang +;; Typed base-env wrapper for the pict library + (require pict (for-syntax (only-in typed-racket/rep/type-rep make-Name @@ -10,6 +12,11 @@ (define -pict-path (make-Union (list (-val #f) -pict (-lst -pict)))) (define -child (make-Name #'child null #f #t)) + (define -linestyle + (one-of/c 'transparent 'solid 'xor 'hilite + 'dot 'long-dash 'short-dash 'dot-dash + 'xor-dot 'xor-long-dash 'xor-short-dash + 'xor-dot-dash)) (define -pin-arrow-line (->key -Real -pict @@ -25,17 +32,19 @@ ;; FIXME: color% #:color (-opt (Un -String)) #f #:alpha -Real #f - #:style (one-of/c 'transparent 'solid 'xor 'hilite - 'dot 'long-dash 'short-dash 'dot-dash - 'xor-dot 'xor-long-dash 'xor-short-dash - 'xor-dot-dash) - #f + #:style -linestyle #f #:under? Univ #f #:solid? Univ #f #:hide-arrowhead? Univ #f -pict)) (define -pict-finder - (-> -pict -pict-path (-values (list -Real -Real))))) + (-> -pict -pict-path (-values (list -Real -Real)))) + (define -append-type + (cl->* + (->* (list -Real -pict) -pict -pict) + (->* (list -pict) -pict -pict))) + (define -superimpose-type + (->* (list -pict) -pict -pict))) (type-environment [#:struct pict ([draw : Univ] @@ -107,18 +116,89 @@ ;; FIXME: color% #:color (-opt (Un -String)) #f #:alpha -Real #f - #:style (one-of/c 'transparent 'solid 'xor 'hilite - 'dot 'long-dash 'short-dash 'dot-dash - 'xor-dot 'xor-long-dash 'xor-short-dash - 'xor-dot-dash) - #f + #:style -linestyle #f #:under? Univ #f -pict)] [pin-arrow-line -pin-arrow-line] [pin-arrows-line -pin-arrow-line] [bitmap-draft-mode (-Param Univ Univ)] - ;; 6 Pict Fingers + ;; 3 Pict Combiners + [vl-append -append-type] + [vc-append -append-type] + [vr-append -append-type] + [ht-append -append-type] + [htl-append -append-type] + [hc-append -append-type] + [hbl-append -append-type] + [hb-append -append-type] + + [lt-superimpose -superimpose-type] + [ltl-superimpose -superimpose-type] + [lc-superimpose -superimpose-type] + [lbl-superimpose -superimpose-type] + [lb-superimpose -superimpose-type] + [ct-superimpose -superimpose-type] + [ctl-superimpose -superimpose-type] + [cc-superimpose -superimpose-type] + [cbl-superimpose -superimpose-type] + [cb-superimpose -superimpose-type] + [rt-superimpose -superimpose-type] + [rtl-superimpose -superimpose-type] + [rc-superimpose -superimpose-type] + [rbl-superimpose -superimpose-type] + [rb-superimpose -superimpose-type] + + [pin-over + (cl->* + (-> -pict -Real -Real -pict) + (-> -pict -pict-path + (-> -pict -pict-path (-values (list -Real -Real))) + -pict))] + [pin-under + (cl->* + (-> -pict -Real -Real -pict) + (-> -pict -pict + (-> -pict -pict (-values (list -Real -Real))) + -pict))] + + ;; FIXME: table has a weird type + + ;; 4 Pict Drawing Adjusters + [scale + (cl->* (-> -pict -Real -pict) + (-> -pict -Real -Real -pict))] + [scale-to-fit + (cl->* (-> -pict -Real -pict) + (-> -pict -Real -Real -pict))] + [rotate (-> -pict -Real -pict)] + [ghost (-> -pict -pict)] + [linewidth (-> (-opt -Real) -pict -pict)] + [linestyle (-> -linestyle -pict -pict)] + [colorize (-> -pict (Un -String (-lst* -Integer -Integer -Integer)) -pict)] + [cellophane (-> -pict -Real -pict)] + [clip (-> -pict -pict)] + [inset/clip + (cl->* (-> -pict -Real -pict) + (-> -pict -Real -Real -pict) + (-> -pict -Real -Real -Real -Real -pict))] + [black-and-white (-Param Univ Univ)] + + ;; 5 Bounding Box Adjusters + [inset + (cl->* (-> -pict -Real -pict) + (-> -pict -Real -Real -pict) + (-> -pict -Real -Real -Real -Real -pict))] + [clip-descent (-> -pict -pict)] + [lift-above-baseline (-> -pict -Real -pict)] + [drop-below-ascent (-> -pict -Real -pict)] + [baseless (-> -pict -pict)] + [refocus (-> -pict -pict -pict)] + [panorama (-> -pict -pict)] + [use-last (-> -pict -pict-path -pict)] + [use-last* (-> -pict -pict-path -pict)] + + ;; 6 Pict Finders [lt-find -pict-finder] [ltl-find -pict-finder] [lc-find -pict-finder] @@ -151,4 +231,24 @@ [angel-wing (-> -Real -Real Univ -pict)] [desktop-machine (->opt -Real [(-lst (one-of/c 'plt 'binary 'devil))] -pict)] ;; thermometer + + ;; 8 Animation Helpers + [fade-pict (->key -Real -pict -pict + #:combine (-> -pict -pict -pict) #f + -pict)] + [fade-around-pict (-> -Real -pict (-> -pict -pict) -pict)] + [slide-pict (-> -pict -pict -pict -pict -Real -pict)] + [sequence-animations (->* '() (-> -Real -pict) (-> -Real -pict))] + [reverse-animations (->* '() (-> -Real -pict) (-> -Real -pict))] + [fast-start (-> -Real -Real)] + [fast-end (-> -Real -Real)] + [fast-edges (-> -Real -Real)] + [fast-middle (-> -Real -Real)] + [split-phase (-> -Real (-values (list -Real -Real)))] + + ;; 10 Miscellaneous + [hyperlinkize (-> -pict -pict)] + ;; FIXME: + ;; scale-color + ;; color-series )