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
|
;;; viewit.lisp -*- Package: User -*-
;;;
;;; Example of use of pictures to draw line charts.
;;; Very much work in progress. Not really ready for
;;; prime time.
;;;
;;; try (testme (make-pt-seq '(0 1 2 3 2 3 5 6 10)))
;;;
;;; To remove graphic from display
;;; (killit)
;;;
;;; Paul Werkowski
;;;
(in-package :user)
(use-package :clue)
(use-package :pictures)
(defvar *default-host* "localhost")
;;; first some CLUE setup
(defparameter *database* (xlib:make-resource-database))
(defvar *display* (open-contact-display 'test :host "localhost"))
(eval-when (load eval)
(define-resources
(* background) :wheat
(* foreground) :black
(* highlight) :yellow
(* font) "fixed")
(when (and (boundp '*display*)(xlib:display-p *display*))
;; Grab resource values from server.
(xlib:wm-resources
*database*
(xlib:screen-root (xlib:display-default-screen *display*))))
(define-resources
(* top y) 80
(* top x) 10
(* plot background) :blue
(* tactical foreground) :red
(* tactical plane color) :red
(* tactical dish color) :green
(* gunner bg-color) :skyblue
(* gunner fg-color) :black
(* gunner ax-color) :blue))
;;; Some Pictures stuff
(defvar *top*)
(defvar *all* nil)
(defvar *view*)
(defvar *rectangle*)
(defvar *line*)
(defvar *polygon*)
(defvar *label*)
(defvar *scene*)
;;; This leaves the view active after exiting. Need to
;;; run disable-clx-event-handling when done.
;;; (showit2 (make-scene)) produces a blank display suitable
;;; for experimenting with objects,
;;; eg (scene-insert *scene* (make-line 10 10 50 50))
;;; (refresh-view *view*)
;;;
(defun showit2(&optional (scene (make-scene))
&key
(width 100)(height 100))
(let* ((top (make-contact 'top-level-shell
:parent *display*
:state :mapped
:wm-title "Demo"
:x 30
:y 30))
(scene-parent (make-scene :elements (list scene)))
;; A vew connects the graphic to the xwindow system via
;; a CLUE contact object. This lets event handlers work.
(view (make-view
:parent top
:width width
:height height
;; Seems a graphic parent is needed for proper transforming
;; so wrap the input scene in one of its own
:graphic scene-parent
)))
(setq *scene* scene
*view* view
*top* top)
(push top *all*)
;; This is needed to let labels find scale factor.
(setf (graphic-view scene-parent) view)
(loop while (process-next-event *display* 1))
(ext:enable-clx-event-handling
*display* #'(lambda(display)
(process-next-event display 0)))))
(defun killit()
(ext:disable-clx-event-handling *display*)
(do ((x (pop *all*)(pop *all*)))
((not x))
(destroy x)))
(defun make-pt-seq(seq &optional (dx 1.0))
(etypecase seq
(list
(loop
for y in seq
and x upfrom 0.0 by dx
append (list x y)))
(vector
(loop
for y across seq
and x upfrom 0.0 by dx
append (list x y)))))
(defun ensure-polypoint (seq)
(if (typep seq 'polypoint)
seq
(make-polyline seq)))
(defun get-combined-extent (list-of-graphics)
(when list-of-graphics
(let ((tmp-extent (make-extent-rect)))
(dolist (g list-of-graphics tmp-extent)
(let ((e (graphic-extent g)))
(cond ((and (valid-extent-p e)(valid-extent-p tmp-extent))
(extent-combine e tmp-extent))
((and (valid-extent-p e)(not (valid-extent-p tmp-extent)))
(extent-copy e tmp-extent))))))))
(defun make-chart (list-of-curves
&key
(width 100)(height 100)
xlow xhgh ylow yhgh)
"Lets say each curve is a polypoint in the same coordinate
world (forgetting for now any annotations)
The idea is to build up a scene tree that can be scaled
to the \"world-coordinate\" (really window coordinate)
system of the view.
The x/y keys are used to establish the boundaries of
our coordinate system. Else these are derived from the
max extent of the components."
(let* ((curves (mapcar 'ensure-polypoint list-of-curves))
(extent (get-combined-extent curves))
(xlow (or xlow (extent-rect-xmin extent)))
(xhgh (or xhgh (extent-rect-xmax extent)))
(ylow (or ylow (extent-rect-ymin extent)))
(yhgh (or yhgh (extent-rect-ymax extent)))
(xscale (/ width (- xhgh xlow)))
(yscale (/ height (- yhgh ylow)))
(x0 0)
(y0 0))
(declare (ignore x0 y0))
(let ((scene (make-scene :elements curves)))
(move-transform scene (- xlow) (- ylow))
(scale-transform scene xscale yscale)
scene)))
(defun testme(seq &key (width 400)(height 300) yhgh ylow)
(let* ((seq (if (and (listp seq)(numberp (first seq)))
(list seq) seq))
(ymax (reduce 'max (mapcar #'point-seq-y-max seq)))
(ymin (reduce 'min (mapcar #'point-seq-y-min seq)))
(xmin (reduce 'min (mapcar #'point-seq-x-min seq)))
(xmax (reduce 'max (mapcar #'point-seq-x-max seq)))
(xorg (and (not (zerop (- (signum ymax)(signum ymin))))
(list (list xmin 0 xmax 0))))
(scene (make-chart (append seq xorg)
:yhgh yhgh :ylow ylow
:width width :height height)))
(showit2 scene :width width :height height )))
(defun good-extents (low hgh)
(let* ((range (- hgh low))
(logr (ceiling (log range 10))))
(cond ((= logr 2)
;; 10+ -> 100
(values (* (floor low 10) 10)
(* (ceiling hgh 10) 10)))
(t (values low hgh)))))
(defun make-xgrid(xlow ylow xhgh yhgh by)
(format t "xgrid ~a ~a ~a ~a~%" xlow ylow xhgh yhgh)
(let ((res nil))
(do ((x xlow (+ x by)))
((> x xhgh))
(push (list x ylow x yhgh) res))
(nreverse res)))
(defun make-ygrid(xlow ylow xhgh yhgh by)
(format t "ygrid ~a ~a ~a ~a~%" xlow ylow xhgh yhgh)
(let ((res nil))
(do ((y ylow (+ y by)))
((> y yhgh))
(push (list xlow y xhgh y) res))
(nreverse res)))
(defun make-xy-grid (xmin ymin xmax ymax)
(multiple-value-bind (xgl xgh)(good-extents xmin xmax)
(multiple-value-bind (ygl ygh) (good-extents ymin ymax)
(let ((ygrid (make-ygrid xgl ygl xgh ygh 10))
(xgrid (make-xgrid xgl ygl xgh ygh 20)))
(nconc xgrid ygrid)))))
(defun show/grid(seq &key (width 400)(height 300) yhgh ylow)
(let* ((seq (if (and (listp seq)(numberp (first seq)))
(list seq) seq))
(ymax (reduce 'max (mapcar #'point-seq-y-max seq)))
(ymin (reduce 'min (mapcar #'point-seq-y-min seq)))
(xmin (reduce 'min (mapcar #'point-seq-x-min seq)))
(xmax (reduce 'max (mapcar #'point-seq-x-max seq)))
(xorg (and (not (zerop (- (signum ymax)(signum ymin))))
(list (list xmin 0 xmax 0))))
(grid (make-xy-grid xmin (or ylow ymin) xmax (or yhgh ymax)))
(scene (make-chart (append seq xorg grid)
:yhgh yhgh :ylow ylow
:width width :height height)))
(showit2 scene :width width :height height )))
|
