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