diff --git a/typed-racket-more/typed/pict.rkt b/typed-racket-more/typed/pict.rkt index ffb15231..eb444e12 100644 --- a/typed-racket-more/typed/pict.rkt +++ b/typed-racket-more/typed/pict.rkt @@ -3,15 +3,32 @@ ;; Typed base-env wrapper for the pict library (require pict + "racket/private/gui-types.rkt" (for-syntax (only-in typed-racket/rep/type-rep make-Name - make-Union))) + make-Union) + (submod "racket/private/gui-types.rkt" #%type-decl))) (begin-for-syntax + (define (-improper-listof t) + (-mu -ilof + (Un (-pair t -ilof) t -Null))) + (define -dc + (-inst (parse-type #'DC<%>))) + (define -color + (-inst (parse-type #'Color%))) (define -pict (-struct-name #'pict)) (define -pict-path (make-Union (list (-val #f) -pict (-lst -pict)))) (define -child (-struct-name #'child)) + (define -text-style + (-mu -text-style + (Un -Null (-inst (parse-type #'Font%)) (parse-type #'Font-Family) -String + (-pair -String (parse-type #'Font-Family)) + (-pair (Un (-val 'bold) (-val 'italic) (-val 'subscript) (-val 'superscript) (-val 'caps) + (-val 'combine) (-val 'no-combine) (-val 'aligned) (-val 'unaligned) + -color) + -text-style)))) (define -linestyle (one-of/c 'transparent 'solid 'xor 'hilite 'dot 'long-dash 'short-dash 'dot-dash @@ -29,8 +46,7 @@ #:start-pull -Real #f #:end-pull -Real #f #:line-width (-opt -Real) #f - ;; FIXME: color% - #:color (-opt (Un -String)) #f + #:color (-opt (Un -String -color)) #f #:alpha -Real #f #:style -linestyle #f #:under? Univ #f @@ -47,6 +63,7 @@ (->* (list -pict) -pict -pict))) (type-environment + ; 1 Pict Datatype [#:struct pict ([draw : Univ] [width : -Real] [height : -Real] @@ -63,20 +80,19 @@ [sxy : -Real] [syx : -Real]) #:extra-constructor-name make-child] - - ;; dc + ; 2 Basic Pict Constructors + [dc (->opt (-> -dc -Real -Real ManyUniv) -Real -Real [-Real -Real] -pict)] [blank (cl->* (-> -pict) (-> -Real -pict) (-> -Real -Real -pict) (-> -Real -Real -Real -pict) (-> -Real -Real -Real -Real -pict))] - ;; text + [text (->opt -String [-text-style -Index -Real] -pict)] [hline (->key -Real -Real #:segment (-opt -Real) #f -pict)] [vline (->key -Real -Real #:segment (-opt -Real) #f -pict)] [frame (->key -pict #:segment (-opt -Real) #f - ;; FIXME: add color% with class support - #:color (-opt -String) #f + #:color (-opt (Un -String -color)) #f #:line-width (-opt -Real) #f -pict)] [ellipse (-> -Real -Real -pict)] @@ -95,8 +111,8 @@ #:angle -Real #f #:draw-border? Univ #f -pict)] - ;; FIXME: add bitmap% and image-snip% - [bitmap (-> (Un -Pathlike) -pict)] + ;; FIXME: add image-snip% + [bitmap (-> (Un -Pathlike (-inst (parse-type #'Bitmap%))) -pict)] [arrow (-> -Real -Real -pict)] [arrowhead (-> -Real -Real -pict)] [pip-line (-> -Real -Real -Real -pict)] @@ -113,15 +129,14 @@ #:start-pull -Real #f #:end-pull -Real #f #:line-width (-opt -Real) #f - ;; FIXME: color% - #:color (-opt (Un -String)) #f + #:color (-opt (Un -String -color)) #f #:alpha -Real #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)] + [bitmap-draft-mode (-Param Univ -Boolean)] ;; 3 Pict Combiners [vl-append -append-type] @@ -162,7 +177,14 @@ (-> -pict -pict (-values (list -Real -Real))) -pict))] - ;; FIXME: table has a weird type + [table + (-> -PosInt + (-pair -pict (-lst -pict)) + (-improper-listof (-> -pict -pict -pict)) + (-improper-listof (-> -pict -pict -pict)) + (-improper-listof -Real) + (-improper-listof -Real) + -pict)] ;; 4 Pict Drawing Adjusters [scale @@ -175,14 +197,14 @@ [ghost (-> -pict -pict)] [linewidth (-> (-opt -Real) -pict -pict)] [linestyle (-> -linestyle -pict -pict)] - [colorize (-> -pict (Un -String (-lst* -Integer -Integer -Integer)) -pict)] + [colorize (-> -pict (Un -String (-lst* -Byte -Byte -Byte) -color) -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)] + [black-and-white (-Param Univ -Boolean)] ;; 5 Bounding Box Adjusters [inset @@ -217,17 +239,16 @@ [launder (-> -pict -pict)] ;; 7.1 Dingbats - ;; FIXME: color% for many of these - [cloud (->opt -Real -Real [-String] -pict)] - [file-icon (->opt -Real -Real -String [Univ] -pict)] + [cloud (->opt -Real -Real [(Un -String -color)] -pict)] + [file-icon (->opt -Real -Real Univ [Univ] -pict)] [standard-fish (->key -Real -Real #:direction (one-of/c 'left 'right) #f - #:color -String #f + #:color (Un -String -color) #f #:eye-color (-opt -String) #f #:open-mouth (Un -Boolean -Real) #f -pict)] - [jack-o-lantern (->opt -Real [-String -String] -pict)] + [jack-o-lantern (->opt -Real [-String (Un -String -color)] -pict)] [angel-wing (-> -Real -Real Univ -pict)] [desktop-machine (->opt -Real [(-lst (one-of/c 'plt 'binary 'devil))] -pict)] ;; thermometer @@ -248,7 +269,30 @@ ;; 10 Miscellaneous [hyperlinkize (-> -pict -pict)] - ;; FIXME: - ;; scale-color - ;; color-series + [scale-color (-> -Real (Un -String -color) -color)] + [color-series (-> -dc -Nat -PosRat + (Un -String -color) (Un -String -color) + (-> -Rat ManyUniv) + Univ Univ + -Void)] + + ;; 11 Rendering + [dc-for-text-size (-Param (-opt -dc) (-opt -dc))] + [convert-bounds-padding (-Param (-lst* -PosReal -PosReal -PosReal -PosReal) + (-lst* -PosReal -PosReal -PosReal -PosReal))] + [draw-pict (-> -pict -dc -Real -Real -Void)] + [pict->bitmap (->opt -pict [(Un (-val 'unsmoothed) (-val 'smoothed) (-val 'aligned))] + (-inst (parse-type #'Bitmap%)))] + [pict->argb-pixels (->opt -pict [(Un (-val 'unsmoothed) (-val 'smoothed) (-val 'aligned))] + -Bytes)] + [argb-pixels->pict (-> -Bytes -Nat -pict)] + [make-pict-drawer (-> -pict (-> -dc -Real -Real -Void))] + [show-pict (->optkey -pict [(-opt -Nat) (-opt -Nat)] + #:frame-x -Integer #t #:frame-y -Integer #t + #:frame-style (-lst (Un (-val 'no-resize-border) (-val 'no-caption) + (-val 'no-system-menu) (-val 'hide-menu-bar) + (-val 'toolbar-button) (-val 'float) + (-val 'metal))) #t + -Void)] + [current-expected-text-scale (-Param (-lst* -Real -Real) (-lst* -Real -Real))] )