1#lang s-exp typed-racket/base-env/extra-env-lang 2 3;; Typed base-env wrapper for the pict library 4 5(require pict 6 "racket/private/gui-types.rkt" 7 (for-syntax (only-in typed-racket/rep/type-rep 8 make-Name) 9 (submod "racket/private/gui-types.rkt" #%type-decl))) 10 11(begin-for-syntax 12 (define (-improper-listof t) 13 (-mu -ilof 14 (Un (-pair t -ilof) t -Null))) 15 (define -dc 16 (-inst (parse-type #'DC<%>))) 17 (define -color 18 (-inst (parse-type #'Color%))) 19 (define -pict (-struct-name #'pict)) 20 (define -pict-path 21 (Un (-val #f) -pict (-lst -pict))) 22 (define -child (-struct-name #'child)) 23 (define -text-style 24 (-mu -text-style 25 (Un -Null (-inst (parse-type #'Font%)) (parse-type #'Font-Family) -String 26 (-pair -String (parse-type #'Font-Family)) 27 (-pair (Un (-val 'bold) (-val 'italic) (-val 'subscript) (-val 'superscript) (-val 'caps) 28 (-val 'combine) (-val 'no-combine) (-val 'aligned) (-val 'unaligned) 29 -color) 30 -text-style)))) 31 (define -linestyle 32 (one-of/c 'transparent 'solid 'xor 'hilite 33 'dot 'long-dash 'short-dash 'dot-dash 34 'xor-dot 'xor-long-dash 'xor-short-dash 35 'xor-dot-dash)) 36 (define -pin-arrow-line 37 (->key -Real 38 -pict 39 -pict-path 40 (-> -pict -pict-path (-values (list -Real -Real))) 41 -pict-path 42 (-> -pict -pict-path (-values (list -Real -Real))) 43 #:start-angle (-opt -Real) #f 44 #:end-angle (-opt -Real) #f 45 #:start-pull -Real #f 46 #:end-pull -Real #f 47 #:line-width (-opt -Real) #f 48 #:color (-opt (Un -String -color)) #f 49 #:alpha -Real #f 50 #:style -linestyle #f 51 #:under? Univ #f 52 #:solid? Univ #f 53 #:hide-arrowhead? Univ #f 54 -pict)) 55 (define -pict-finder 56 (-> -pict -pict-path (-values (list -Real -Real)))) 57 (define -append-type 58 (cl->* 59 (->* (list -Real -pict) -pict -pict) 60 (->* (list -pict) -pict -pict))) 61 (define -superimpose-type 62 (->* (list -pict) -pict -pict))) 63 64(type-environment 65 ; 1 Pict Datatype 66 [#:struct pict ([draw : Univ] 67 [width : -Real] 68 [height : -Real] 69 [ascent : -Real] 70 [descent : -Real] 71 [children : (-lst -child)] 72 [panbox : Univ] 73 [last : -pict-path]) 74 #:extra-constructor-name make-pict] 75 [#:struct child ([pict : -pict] 76 [dx : -Real] 77 [dy : -Real] 78 [sx : -Real] 79 [sy : -Real] 80 [sxy : -Real] 81 [syx : -Real]) 82 #:extra-constructor-name make-child] 83 ; 2 Basic Pict Constructors 84 [dc (->opt (-> -dc -Real -Real ManyUniv) -Real -Real [-Real -Real] -pict)] 85 [blank (cl->* (-> -pict) 86 (-> -Real -pict) 87 (-> -Real -Real -pict) 88 (-> -Real -Real -Real -pict) 89 (-> -Real -Real -Real -Real -pict))] 90 [text (->opt -String [-text-style -Index -Real] -pict)] 91 [hline (->key -Real -Real #:segment (-opt -Real) #f -pict)] 92 [vline (->key -Real -Real #:segment (-opt -Real) #f -pict)] 93 [frame (->key -pict 94 #:segment (-opt -Real) #f 95 #:color (-opt (Un -String -color)) #f 96 #:line-width (-opt -Real) #f 97 -pict)] 98 [ellipse (->key -Real -Real 99 #:border-color (-opt (Un -String -color)) #f 100 #:border-width (-opt -Real) #f 101 -pict)] 102 [circle (->key -Real 103 #:border-color (-opt (Un -String -color)) #f 104 #:border-width (-opt -Real) #f 105 -pict)] 106 [filled-ellipse 107 (->key -Real -Real 108 #:draw-border? Univ #f 109 #:color (-opt (Un -String -color)) #f 110 #:border-color (-opt (Un -String -color)) #f 111 #:border-width (-opt -Real) #f 112 -pict)] 113 [disk 114 (->key -Real 115 #:draw-border? Univ #f 116 #:color (-opt (Un -String -color)) #f 117 #:border-color (-opt (Un -String -color)) #f 118 #:border-width (-opt -Real) #f 119 -pict)] 120 [rectangle (->key -Real -Real 121 #:border-color (-opt (Un -String -color)) #f 122 #:border-width (-opt -Real) #f 123 -pict)] 124 [filled-rectangle 125 (->key -Real -Real 126 #:draw-border? Univ #f 127 #:color (-opt (Un -String -color)) #f 128 #:border-color (-opt (Un -String -color)) #f 129 #:border-width (-opt -Real) #f 130 -pict)] 131 [rounded-rectangle 132 (->optkey -Real -Real [-Real] 133 #:angle -Real #f 134 #:border-color (-opt (Un -String -color)) #f 135 #:border-width (-opt -Real) #f 136 -pict)] 137 [filled-rounded-rectangle 138 (->optkey -Real -Real [-Real] 139 #:angle -Real #f 140 #:draw-border? Univ #f 141 #:color (-opt (Un -String -color)) #f 142 #:border-color (-opt (Un -String -color)) #f 143 #:border-width (-opt -Real) #f 144 -pict)] 145 ;; FIXME: add image-snip% 146 [bitmap (-> (Un -Pathlike (-inst (parse-type #'Bitmap%))) -pict)] 147 [arrow (-> -Real -Real -pict)] 148 [arrowhead (-> -Real -Real -pict)] 149 [pip-line (-> -Real -Real -Real -pict)] 150 [pip-arrow-line (-> -Real -Real -Real -pict)] 151 [pip-arrows-line (-> -Real -Real -Real -pict)] 152 [pin-line 153 (->key -pict 154 -pict-path 155 (-> -pict -pict-path (-values (list -Real -Real))) 156 -pict-path 157 (-> -pict -pict-path (-values (list -Real -Real))) 158 #:start-angle (-opt -Real) #f 159 #:end-angle (-opt -Real) #f 160 #:start-pull -Real #f 161 #:end-pull -Real #f 162 #:line-width (-opt -Real) #f 163 #:color (-opt (Un -String -color)) #f 164 #:alpha -Real #f 165 #:style -linestyle #f 166 #:under? Univ #f 167 -pict)] 168 [pin-arrow-line -pin-arrow-line] 169 [pin-arrows-line -pin-arrow-line] 170 [bitmap-draft-mode (-Param Univ -Boolean)] 171 172 ;; 3 Pict Combiners 173 [vl-append -append-type] 174 [vc-append -append-type] 175 [vr-append -append-type] 176 [ht-append -append-type] 177 [htl-append -append-type] 178 [hc-append -append-type] 179 [hbl-append -append-type] 180 [hb-append -append-type] 181 182 [lt-superimpose -superimpose-type] 183 [ltl-superimpose -superimpose-type] 184 [lc-superimpose -superimpose-type] 185 [lbl-superimpose -superimpose-type] 186 [lb-superimpose -superimpose-type] 187 [ct-superimpose -superimpose-type] 188 [ctl-superimpose -superimpose-type] 189 [cc-superimpose -superimpose-type] 190 [cbl-superimpose -superimpose-type] 191 [cb-superimpose -superimpose-type] 192 [rt-superimpose -superimpose-type] 193 [rtl-superimpose -superimpose-type] 194 [rc-superimpose -superimpose-type] 195 [rbl-superimpose -superimpose-type] 196 [rb-superimpose -superimpose-type] 197 198 [pin-over 199 (cl->* 200 (-> -pict -Real -Real -pict -pict) 201 (-> -pict -pict-path 202 (-> -pict -pict-path (-values (list -Real -Real))) 203 -pict 204 -pict))] 205 [pin-under 206 (cl->* 207 (-> -pict -Real -Real -pict -pict) 208 (-> -pict -pict 209 (-> -pict -pict (-values (list -Real -Real))) 210 -pict 211 -pict))] 212 213 [table 214 (-> -PosInt 215 (-pair -pict (-lst -pict)) 216 (-improper-listof (-> -pict -pict -pict)) 217 (-improper-listof (-> -pict -pict -pict)) 218 (-improper-listof -Real) 219 (-improper-listof -Real) 220 -pict)] 221 222 ;; 4 Pict Drawing Adjusters 223 [scale 224 (cl->* (-> -pict -Real -pict) 225 (-> -pict -Real -Real -pict))] 226 [scale-to-fit 227 (cl->* (-> -pict -Real -pict) 228 (-> -pict -Real -Real -pict))] 229 [rotate (-> -pict -Real -pict)] 230 [ghost (-> -pict -pict)] 231 [linewidth (-> (-opt -Real) -pict -pict)] 232 [linestyle (-> -linestyle -pict -pict)] 233 [colorize (-> -pict (Un -String (-lst* -Byte -Byte -Byte) -color) -pict)] 234 [cellophane (-> -pict -Real -pict)] 235 [clip (-> -pict -pict)] 236 [inset/clip 237 (cl->* (-> -pict -Real -pict) 238 (-> -pict -Real -Real -pict) 239 (-> -pict -Real -Real -Real -Real -pict))] 240 [black-and-white (-Param Univ -Boolean)] 241 [freeze (-> -pict -pict)] 242 243 ;; 5 Bounding Box Adjusters 244 [inset 245 (cl->* (-> -pict -Real -pict) 246 (-> -pict -Real -Real -pict) 247 (-> -pict -Real -Real -Real -Real -pict))] 248 [clip-descent (-> -pict -pict)] 249 [lift-above-baseline (-> -pict -Real -pict)] 250 [drop-below-ascent (-> -pict -Real -pict)] 251 [baseless (-> -pict -pict)] 252 [refocus (-> -pict -pict -pict)] 253 [panorama (-> -pict -pict)] 254 [use-last (-> -pict -pict-path -pict)] 255 [use-last* (-> -pict -pict-path -pict)] 256 257 ;; 6 Pict Finders 258 [lt-find -pict-finder] 259 [ltl-find -pict-finder] 260 [lc-find -pict-finder] 261 [lbl-find -pict-finder] 262 [lb-find -pict-finder] 263 [ct-find -pict-finder] 264 [ctl-find -pict-finder] 265 [cbl-find -pict-finder] 266 [cb-find -pict-finder] 267 [rt-find -pict-finder] 268 [rtl-find -pict-finder] 269 [rc-find -pict-finder] 270 [rbl-find -pict-finder] 271 [rb-find -pict-finder] 272 [pict-path? (make-pred-ty -pict-path)] 273 [launder (-> -pict -pict)] 274 275 ;; 7.1 Dingbats 276 [cloud (->opt -Real -Real [(Un -String -color)] -pict)] 277 [file-icon (->opt -Real -Real Univ [Univ] -pict)] 278 [standard-fish 279 (->key -Real -Real 280 #:direction (one-of/c 'left 'right) #f 281 #:color (Un -String -color) #f 282 #:eye-color (-opt -String) #f 283 #:open-mouth (Un -Boolean -Real) #f 284 -pict)] 285 [jack-o-lantern (->opt -Real [-String (Un -String -color)] -pict)] 286 [angel-wing (-> -Real -Real Univ -pict)] 287 [desktop-machine (->opt -Real [(-lst (one-of/c 'plt 'binary 'devil))] -pict)] 288 ;; thermometer 289 290 ;; 8 Animation Helpers 291 [fade-pict (->key -Real -pict -pict 292 #:combine (-> -pict -pict -pict) #f 293 -pict)] 294 [fade-around-pict (-> -Real -pict (-> -pict -pict) -pict)] 295 [slide-pict (-> -pict -pict -pict -pict -Real -pict)] 296 [sequence-animations (->* '() (-> -Real -pict) (-> -Real -pict))] 297 [reverse-animations (->* '() (-> -Real -pict) (-> -Real -pict))] 298 [fast-start (-> -Real -Real)] 299 [fast-end (-> -Real -Real)] 300 [fast-edges (-> -Real -Real)] 301 [fast-middle (-> -Real -Real)] 302 [split-phase (-> -Real (-values (list -Real -Real)))] 303 304 ;; 10 Miscellaneous 305 [hyperlinkize (-> -pict -pict)] 306 [scale-color (-> -Real (Un -String -color) -color)] 307 [color-series (-> -dc -Nat -PosRat 308 (Un -String -color) (Un -String -color) 309 (-> -Rat ManyUniv) 310 Univ Univ 311 -Void)] 312 313 ;; 11 Rendering 314 [dc-for-text-size (-Param (-opt -dc) (-opt -dc))] 315 [convert-bounds-padding (-Param (-lst* -PosReal -PosReal -PosReal -PosReal) 316 (-lst* -PosReal -PosReal -PosReal -PosReal))] 317 [draw-pict (-> -pict -dc -Real -Real -Void)] 318 [pict->bitmap (->opt -pict [(Un (-val 'unsmoothed) (-val 'smoothed) (-val 'aligned))] 319 (-inst (parse-type #'Bitmap%)))] 320 [pict->argb-pixels (->opt -pict [(Un (-val 'unsmoothed) (-val 'smoothed) (-val 'aligned))] 321 -Bytes)] 322 [argb-pixels->pict (-> -Bytes -Nat -pict)] 323 [make-pict-drawer (-> -pict (-> -dc -Real -Real -Void))] 324 [show-pict (->optkey -pict [(-opt -Nat) (-opt -Nat)] 325 #:frame-x -Integer #t #:frame-y -Integer #t 326 #:frame-style (-lst (Un (-val 'no-resize-border) (-val 'no-caption) 327 (-val 'no-system-menu) (-val 'hide-menu-bar) 328 (-val 'toolbar-button) (-val 'float) 329 (-val 'metal))) #t 330 -Void)] 331 [current-expected-text-scale (-Param (-lst* -Real -Real) (-lst* -Real -Real))] 332 ) 333