1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
|
#lang typed/racket/base
;; Renderers for intervals between functions.
(require typed/racket/class racket/match racket/math racket/list
(only-in typed/pict pict)
plot/utils
"../common/type-doc.rkt"
"../common/utils.rkt")
(provide (all-defined-out))
;; ===================================================================================================
;; Lines, parametric, polar
(: lines-interval-render-proc (-> (Listof (Vectorof Real)) (Listof (Vectorof Real))
Plot-Color Plot-Brush-Style
Plot-Color Nonnegative-Real Plot-Pen-Style
Plot-Color Nonnegative-Real Plot-Pen-Style
Nonnegative-Real
2D-Render-Proc))
(define ((lines-interval-render-proc v1s v2s color style
line1-color line1-width line1-style
line2-color line2-width line2-style
alpha)
area)
(send area put-alpha alpha)
(send area put-pen 0 0 'transparent)
(send area put-brush color style)
(send area put-polygon (append v1s (reverse v2s)))
(send area put-pen line1-color line1-width line1-style)
(send area put-lines v1s)
(send area put-pen line2-color line2-width line2-style)
(send area put-lines v2s))
(:: lines-interval
(->* [(Sequenceof (Sequenceof Real))
(Sequenceof (Sequenceof Real))]
[#:x-min (U Real #f) #:x-max (U Real #f)
#:y-min (U Real #f) #:y-max (U Real #f)
#:color Plot-Color
#:style Plot-Brush-Style
#:line1-color Plot-Color
#:line1-width Nonnegative-Real
#:line1-style Plot-Pen-Style
#:line2-color Plot-Color
#:line2-width Nonnegative-Real
#:line2-style Plot-Pen-Style
#:alpha Nonnegative-Real
#:label (U String pict #f)]
renderer2d))
(define (lines-interval v1s v2s
#:x-min [x-min #f] #:x-max [x-max #f]
#:y-min [y-min #f] #:y-max [y-max #f]
#:color [color (interval-color)]
#:style [style (interval-style)]
#:line1-color [line1-color (interval-line1-color)]
#:line1-width [line1-width (interval-line1-width)]
#:line1-style [line1-style (interval-line1-style)]
#:line2-color [line2-color (interval-line2-color)]
#:line2-width [line2-width (interval-line2-width)]
#:line2-style [line2-style (interval-line2-style)]
#:alpha [alpha (interval-alpha)]
#:label [label #f])
(define fail/kw (make-raise-keyword-error 'lines-interval))
(cond
[(and x-min (not (rational? x-min))) (fail/kw "#f or rational" '#:x-min x-min)]
[(and x-max (not (rational? x-max))) (fail/kw "#f or rational" '#:x-max x-max)]
[(and y-min (not (rational? y-min))) (fail/kw "#f or rational" '#:y-min y-min)]
[(and y-max (not (rational? y-max))) (fail/kw "#f or rational" '#:y-max y-max)]
[(not (rational? line1-width)) (fail/kw "rational?" '#:line1-width line1-width)]
[(not (rational? line2-width)) (fail/kw "rational?" '#:line2-width line2-width)]
[(or (> alpha 1) (not (rational? alpha))) (fail/kw "real in [0,1]" '#:alpha alpha)]
[else
(let ([v1s (sequence->listof-vector 'lines-interval v1s 2)]
[v2s (sequence->listof-vector 'lines-interval v2s 2)])
(define rvs (filter vrational? (append v1s v2s)))
(cond
[(empty? rvs) empty-renderer2d]
[else
(match-define (list (vector #{rxs : (Listof Real)} #{rys : (Listof Real)}) ...) rvs)
(let ([x-min (if x-min x-min (apply min* rxs))]
[x-max (if x-max x-max (apply max* rxs))]
[y-min (if y-min y-min (apply min* rys))]
[y-max (if y-max y-max (apply max* rys))])
(renderer2d (vector (ivl x-min x-max) (ivl y-min y-max)) #f default-ticks-fun
(and label (λ (_)
(interval-legend-entry label color style 0 0 'transparent
line1-color line1-width line1-style
line2-color line2-width line2-style)))
(lines-interval-render-proc v1s v2s color style
line1-color line1-width line1-style
line2-color line2-width line2-style
alpha)))]))]))
(:: parametric-interval
(->* [(-> Real (Sequenceof Real)) (-> Real (Sequenceof Real)) Real Real]
[#:x-min (U Real #f) #:x-max (U Real #f)
#:y-min (U Real #f) #:y-max (U Real #f)
#:samples Positive-Integer
#:color Plot-Color
#:style Plot-Brush-Style
#:line1-color Plot-Color
#:line1-width Nonnegative-Real
#:line1-style Plot-Pen-Style
#:line2-color Plot-Color
#:line2-width Nonnegative-Real
#:line2-style Plot-Pen-Style
#:alpha Nonnegative-Real
#:label (U String pict #f)]
renderer2d))
(define (parametric-interval
f1 f2 t-min t-max
#:x-min [x-min #f] #:x-max [x-max #f]
#:y-min [y-min #f] #:y-max [y-max #f]
#:samples [samples (line-samples)]
#:color [color (interval-color)]
#:style [style (interval-style)]
#:line1-color [line1-color (interval-line1-color)]
#:line1-width [line1-width (interval-line1-width)]
#:line1-style [line1-style (interval-line1-style)]
#:line2-color [line2-color (interval-line2-color)]
#:line2-width [line2-width (interval-line2-width)]
#:line2-style [line2-style (interval-line2-style)]
#:alpha [alpha (interval-alpha)]
#:label [label #f])
(define fail/pos (make-raise-argument-error 'parametric-interval f1 f2 t-min t-max))
(define fail/kw (make-raise-keyword-error 'parametric-interval))
(cond
[(not (rational? t-min)) (fail/pos "rational?" 2)]
[(not (rational? t-max)) (fail/pos "rational?" 3)]
[(and x-min (not (rational? x-min))) (fail/kw "#f or rational" '#:x-min x-min)]
[(and x-max (not (rational? x-max))) (fail/kw "#f or rational" '#:x-max x-max)]
[(and y-min (not (rational? y-min))) (fail/kw "#f or rational" '#:y-min y-min)]
[(and y-max (not (rational? y-max))) (fail/kw "#f or rational" '#:y-max y-max)]
[(< samples 2) (fail/kw "Integer >= 2" '#:samples samples)]
[(not (rational? line1-width)) (fail/kw "rational?" '#:line1-width line1-width)]
[(not (rational? line2-width)) (fail/kw "rational?" '#:line2-width line2-width)]
[(or (> alpha 1) (not (rational? alpha))) (fail/kw "real in [0,1]" '#:alpha alpha)]
[else
(let ([f1 (λ ([t : Real]) (sequence-head-vector 'parametric-interval (f1 t) 2))]
[f2 (λ ([t : Real]) (sequence-head-vector 'parametric-interval (f2 t) 2))])
(lines-interval
(map f1 (linear-seq t-min t-max samples))
(map f2 (linear-seq t-min t-max samples))
#:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max
#:color color #:style style
#:line1-color line1-color #:line1-width line1-width #:line1-style line1-style
#:line2-color line2-color #:line2-width line2-width #:line2-style line2-style
#:alpha alpha #:label label))]))
(:: polar-interval
(->* [(-> Real Real) (-> Real Real)]
[Real Real
#:x-min (U Real #f) #:x-max (U Real #f)
#:y-min (U Real #f) #:y-max (U Real #f)
#:samples Positive-Integer
#:color Plot-Color
#:style Plot-Brush-Style
#:line1-color Plot-Color
#:line1-width Nonnegative-Real
#:line1-style Plot-Pen-Style
#:line2-color Plot-Color
#:line2-width Nonnegative-Real
#:line2-style Plot-Pen-Style
#:alpha Nonnegative-Real
#:label (U String pict #f)]
renderer2d))
(define (polar-interval
f1 f2 [θ-min 0] [θ-max (* 2 pi)]
#:x-min [x-min #f] #:x-max [x-max #f]
#:y-min [y-min #f] #:y-max [y-max #f]
#:samples [samples (line-samples)]
#:color [color (interval-color)]
#:style [style (interval-style)]
#:line1-color [line1-color (interval-line1-color)]
#:line1-width [line1-width (interval-line1-width)]
#:line1-style [line1-style (interval-line1-style)]
#:line2-color [line2-color (interval-line2-color)]
#:line2-width [line2-width (interval-line2-width)]
#:line2-style [line2-style (interval-line2-style)]
#:alpha [alpha (interval-alpha)]
#:label [label #f])
(define fail/pos (make-raise-argument-error 'polar-interval f1 f2 θ-min θ-max))
(define fail/kw (make-raise-keyword-error 'polar-interval))
(cond
[(not (rational? θ-min)) (fail/pos "rational?" 2)]
[(not (rational? θ-max)) (fail/pos "rational?" 3)]
[(and x-min (not (rational? x-min))) (fail/kw "#f or rational" '#:x-min x-min)]
[(and x-max (not (rational? x-max))) (fail/kw "#f or rational" '#:x-max x-max)]
[(and y-min (not (rational? y-min))) (fail/kw "#f or rational" '#:y-min y-min)]
[(and y-max (not (rational? y-max))) (fail/kw "#f or rational" '#:y-max y-max)]
[(< samples 2) (fail/kw "Integer >= 2" '#:samples samples)]
[(not (rational? line1-width)) (fail/kw "rational?" '#:line1-width line1-width)]
[(not (rational? line2-width)) (fail/kw "rational?" '#:line2-width line2-width)]
[(or (> alpha 1) (not (rational? alpha))) (fail/kw "real in [0,1]" '#:alpha alpha)]
[else
(define θs (linear-seq θ-min θ-max samples))
(lines-interval
(map polar->cartesian θs (map f1 θs))
(map polar->cartesian θs (map f2 θs))
#:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max
#:color color #:style style
#:line1-color line1-color #:line1-width line1-width #:line1-style line1-style
#:line2-color line2-color #:line2-width line2-width #:line2-style line2-style
#:alpha alpha #:label label)]))
;; ===================================================================================================
;; Function
(: function-interval-render-proc (-> Sampler Sampler Positive-Integer
Plot-Color Plot-Brush-Style
Plot-Color Nonnegative-Real Plot-Pen-Style
Plot-Color Nonnegative-Real Plot-Pen-Style
Nonnegative-Real
2D-Render-Proc))
(define ((function-interval-render-proc f1 f2 samples color style
line1-color line1-width line1-style
line2-color line2-width line2-style
alpha)
area)
(match-define (vector x-ivl y-ivl) (send area get-bounds-rect))
(match-define (sample x1s y1s _ _) (f1 x-ivl samples))
(match-define (sample x2s y2s _ _) (f2 x-ivl samples))
(define v1s (map (λ ([x : Real] [y : Real]) (vector x y)) x1s y1s))
(define v2s (map (λ ([x : Real] [y : Real]) (vector x y)) x2s y2s))
((lines-interval-render-proc v1s v2s color style
line1-color line1-width line1-style
line2-color line2-width line2-style
alpha)
area))
(:: function-interval
(->* [(-> Real Real) (-> Real Real)]
[(U Real #f) (U Real #f)
#:y-min (U Real #f) #:y-max (U Real #f)
#:samples Positive-Integer
#:color Plot-Color
#:style Plot-Brush-Style
#:line1-color Plot-Color
#:line1-width Nonnegative-Real
#:line1-style Plot-Pen-Style
#:line2-color Plot-Color
#:line2-width Nonnegative-Real
#:line2-style Plot-Pen-Style
#:alpha Nonnegative-Real
#:label (U String pict #f)]
renderer2d))
(define (function-interval
f1 f2 [x-min #f] [x-max #f]
#:y-min [y-min #f] #:y-max [y-max #f]
#:samples [samples (line-samples)]
#:color [color (interval-color)]
#:style [style (interval-style)]
#:line1-color [line1-color (interval-line1-color)]
#:line1-width [line1-width (interval-line1-width)]
#:line1-style [line1-style (interval-line1-style)]
#:line2-color [line2-color (interval-line2-color)]
#:line2-width [line2-width (interval-line2-width)]
#:line2-style [line2-style (interval-line2-style)]
#:alpha [alpha (interval-alpha)]
#:label [label #f])
(define fail/pos (make-raise-argument-error 'function-interval f1 f2 x-min x-max))
(define fail/kw (make-raise-keyword-error 'function-interval))
(cond
[(and x-min (not (rational? x-min))) (fail/pos "#f or rational" 2)]
[(and x-max (not (rational? x-max))) (fail/pos "#f or rational" 3)]
[(and y-min (not (rational? y-min))) (fail/kw "#f or rational" '#:y-min y-min)]
[(and y-max (not (rational? y-max))) (fail/kw "#f or rational" '#:y-max y-max)]
[(< samples 2) (fail/kw "Integer >= 2" '#:samples samples)]
[(not (rational? line1-width)) (fail/kw "rational?" '#:line1-width line1-width)]
[(not (rational? line2-width)) (fail/kw "rational?" '#:line2-width line2-width)]
[(or (> alpha 1) (not (rational? alpha))) (fail/kw "real in [0,1]" '#:alpha alpha)]
[else
(define x-ivl (ivl x-min x-max))
(define y-ivl (ivl y-min y-max))
(define g1 (function->sampler f1 x-ivl))
(define g2 (function->sampler f2 x-ivl))
(renderer2d (vector x-ivl y-ivl)
(function-interval-bounds-fun g1 g2 samples)
default-ticks-fun
(and label (λ (_)
(interval-legend-entry label color style 0 0 'transparent
line1-color line1-width line1-style
line2-color line2-width line2-style)))
(function-interval-render-proc g1 g2 samples color style
line1-color line1-width line1-style
line2-color line2-width line2-style
alpha))]))
;; ===================================================================================================
;; Inverse function
(: inverse-interval-render-proc (-> Sampler Sampler Positive-Integer
Plot-Color Plot-Brush-Style
Plot-Color Nonnegative-Real Plot-Pen-Style
Plot-Color Nonnegative-Real Plot-Pen-Style
Nonnegative-Real
2D-Render-Proc))
(define ((inverse-interval-render-proc f1 f2 samples color style
line1-color line1-width line1-style
line2-color line2-width line2-style
alpha)
area)
(match-define (vector x-ivl y-ivl) (send area get-bounds-rect))
(match-define (sample y1s x1s _ _) (f1 y-ivl samples))
(match-define (sample y2s x2s _ _) (f2 y-ivl samples))
(define v1s (map (λ ([x : Real] [y : Real]) (vector x y)) x1s y1s))
(define v2s (map (λ ([x : Real] [y : Real]) (vector x y)) x2s y2s))
((lines-interval-render-proc v1s v2s color style
line1-color line1-width line1-style
line2-color line2-width line2-style
alpha)
area))
(:: inverse-interval
(->* [(-> Real Real) (-> Real Real)]
[(U Real #f) (U Real #f)
#:x-min (U Real #f) #:x-max (U Real #f)
#:samples Positive-Integer
#:color Plot-Color
#:style Plot-Brush-Style
#:line1-color Plot-Color
#:line1-width Nonnegative-Real
#:line1-style Plot-Pen-Style
#:line2-color Plot-Color
#:line2-width Nonnegative-Real
#:line2-style Plot-Pen-Style
#:alpha Nonnegative-Real
#:label (U String pict #f)]
renderer2d))
(define (inverse-interval
f1 f2 [y-min #f] [y-max #f]
#:x-min [x-min #f] #:x-max [x-max #f]
#:samples [samples (line-samples)]
#:color [color (interval-color)]
#:style [style (interval-style)]
#:line1-color [line1-color (interval-line1-color)]
#:line1-width [line1-width (interval-line1-width)]
#:line1-style [line1-style (interval-line1-style)]
#:line2-color [line2-color (interval-line2-color)]
#:line2-width [line2-width (interval-line2-width)]
#:line2-style [line2-style (interval-line2-style)]
#:alpha [alpha (interval-alpha)]
#:label [label #f])
(define fail/pos (make-raise-argument-error 'inverse-interval f1 f2 y-min y-max))
(define fail/kw (make-raise-keyword-error 'inverse-interval))
(cond
[(and y-min (not (rational? y-min))) (fail/pos "#f or rational" 2)]
[(and y-max (not (rational? y-max))) (fail/pos "#f or rational" 3)]
[(and x-min (not (rational? x-min))) (fail/kw "#f or rational" '#:x-min x-min)]
[(and x-max (not (rational? x-max))) (fail/kw "#f or rational" '#:x-max x-max)]
[(< samples 2) (fail/kw "Integer >= 2" '#:samples samples)]
[(not (rational? line1-width)) (fail/kw "rational?" '#:line1-width line1-width)]
[(not (rational? line2-width)) (fail/kw "rational?" '#:line2-width line2-width)]
[(or (> alpha 1) (not (rational? alpha))) (fail/kw "real in [0,1]" '#:alpha alpha)]
[else
(define x-ivl (ivl x-min x-max))
(define y-ivl (ivl y-min y-max))
(define g1 (inverse->sampler f1 y-ivl))
(define g2 (inverse->sampler f2 y-ivl))
(renderer2d (vector x-ivl y-ivl)
(inverse-interval-bounds-fun g1 g2 samples)
default-ticks-fun
(and label (λ (_)
(interval-legend-entry label color style 0 0 'transparent
line1-color line1-width line1-style
line2-color line2-width line2-style)))
(inverse-interval-render-proc g1 g2 samples color style
line1-color line1-width line1-style
line2-color line2-width line2-style
alpha))]))
|
