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
|
#lang typed/racket/base
(require typed/racket/class racket/match racket/math racket/list racket/sequence
plot/utils
(only-in typed/pict pict)
"../common/type-doc.rkt"
"../common/utils.rkt")
(provide arrows-render-fun
arrows)
;; ===================================================================================================
;; Arrows
(: arrows-render-fun
(-> (Listof (Pair (Vectorof Real) (Vectorof Real)))
Plot-Color Nonnegative-Real Plot-Pen-Style
Nonnegative-Real
(U (List '= Nonnegative-Real) Nonnegative-Real) Nonnegative-Real
2D-Render-Proc))
(define ((arrows-render-fun vs
color line-width line-style
alpha
arrow-head-size-or-scale arrow-head-angle) area)
(match-define (vector (ivl x-min x-max) (ivl y-min y-max)) (send area get-bounds-rect))
(when (and x-min x-max y-min y-max)
(send area put-alpha alpha)
(send area put-pen color line-width line-style)
(send area put-arrow-head arrow-head-size-or-scale arrow-head-angle)
(for ([x (in-list vs)])
(match-define (cons (vector v1x v1y) (vector v2x v2y)) x)
(define (f [x : Real][y : Real])
(- (* (- v2x v1x) (- y v1y))
(* (- v2y v1y) (- x v1x))))
(cond
;only draw the arrow head if the endpoint is visible
;other option makes little sense since size and angle can be/is plot units-absolute
[(and (<= x-min v2x x-max) (<= y-min v2y y-max))
(send area put-arrow (car x) (cdr x) #t)]
;only draw the vector line if it is visible
[(or (<= (* (f x-min y-min) (f x-max y-max)) 0)
(<= (* (f x-min y-max) (f x-max y-min)) 0))
(send area put-lines (list (car x) (cdr x)))]))))
;(Sequenceof (Sequence (Sequenceof Real))) does not work because (sequence? 5) = #t
;and so the contract can not know if '((2 2)) is three or two nested sequences
(define-type LVof (All (A) (U (Listof A) (Vectorof A))))
(:: arrows
(->* [(U (LVof (LVof Real))
(LVof (LVof (LVof Real))))]
[#:x-min (U Real #f) #:x-max (U Real #f)
#:y-min (U Real #f) #:y-max (U Real #f)
#:color Plot-Color
#:width Nonnegative-Real
#:style Plot-Pen-Style
#:alpha Nonnegative-Real
#:arrow-head-size-or-scale (U (List '= Nonnegative-Real) Nonnegative-Real)
#:arrow-head-angle Nonnegative-Real
#:label (U String pict #f)]
renderer2d))
(define (arrows vs
#:x-min [x-min #f] #:x-max [x-max #f]
#:y-min [y-min #f] #:y-max [y-max #f]
#:color [color (arrows-color)]
#:width [width (arrows-line-width)]
#:style [style (arrows-line-style)]
#:alpha [alpha (arrows-alpha)]
#:arrow-head-size-or-scale [arrow-head-size-or-scale (arrow-head-size-or-scale)]
#:arrow-head-angle [arrow-head-angle (arrow-head-angle)]
#:label [label #f])
(define fail/kw (make-raise-keyword-error 'lines))
(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? width)) (fail/kw "rational?" '#:width width)]
[(or (> alpha 1) (not (rational? alpha))) (fail/kw "real in [0,1]" '#:alpha alpha)]
[else
(define (argument-error)
(raise-argument-error
'arrows
"(U (Sequenceof (Sequence Real Real)) (Sequenceof (Sequence (Sequence Real Real) (Sequence Real Real))))"
vs))
;; check if we have head/tail or pair vectors, and put in standard format
(define-values (S1 S2)
(for/fold ([S1 : (Listof (Vectorof Real)) '()]
[S2 : (Listof (Pair (Vectorof Real) (Vectorof Real))) '()])
([s vs])
(define l (sequence->list s))
(cond
[(not (= (length l) 2))
(argument-error)]
;order important because integers are sequence?
[(andmap real? l)
(values (cons (sequence-head-vector 'arrows l 2) S1) S2)]
[(andmap sequence? l)
(define v1 (sequence-head-vector 'arrows (car l) 2))
(define v2 (sequence-head-vector 'arrows (cadr l) 2))
(define v3 (vector (+ (vector-ref v1 0) (vector-ref v2 0))
(+ (vector-ref v1 1) (vector-ref v2 1))))
(values S1
(cons (cons v1 v3) S2))]
[else (argument-error)])))
(define vs*
(cond
[(empty? S2)
(define S1* (reverse S1))
(for/list : (Listof (Pair (Vectorof Real) (Vectorof Real)))
([v1 (in-list S1*)]
[v2 (in-list (cdr S1*))])
(cons v1 v2))]
[else S2]))
;; calculate bound and pick right render-fun
(define rvs
(let ()
(match-define (list (cons #{p1 : (Listof (Vectorof Real))}
#{p2 : (Listof (Vectorof Real))}) ...)
vs*)
(filter vrational? (append p1 p2))))
(cond
[(empty? rvs) empty-renderer2d]
[else
(define-values (x- x+ y- y+) (get-bounds x-min x-max y-min y-max rvs))
(renderer2d (vector (ivl x- x+) (ivl y- y+)) #f default-ticks-fun
(and label (λ (_) (arrow-legend-entry label color width style)))
(arrows-render-fun vs*
color width style alpha
arrow-head-size-or-scale arrow-head-angle))])]))
(define (get-bounds [x-min : (Option Real)][x-max : (Option Real)]
[y-min : (Option Real)][y-max : (Option Real)]
[rvs : (Listof (Vectorof Real))])
(match-define (list (vector #{rxs : (Listof Real)} #{rys : (Listof Real)}) ...) rvs)
(values (if x-min x-min (apply min* rxs))
(if x-max x-max (apply max* rxs))
(if y-min y-min (apply min* rys))
(if y-max y-max (apply max* rys))))
|
