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
|
; dwtest.lsp Gordon S. Novak Jr. 10 Jan 96
; Some examples for testing the window interface in dwindow.lsp / dwtrans.lsp
; Copyright (c) 1996 Gordon S. Novak Jr. and The University of Texas at Austin.
; See the file gnu.license .
; This program is free software; you can redistribute it and/or modify
; it under the terms of the GNU General Public License as published by
; the Free Software Foundation; either version 1, or (at your option)
; any later version.
; This program is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
; GNU General Public License for more details.
; You should have received a copy of the GNU General Public License
; along with this program; if not, write to the Free Software
; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
; Written by: Gordon S. Novak Jr., Department of Computer Sciences,
; University of Texas at Austin 78712. novak@cs.utexas.edu
(use-package :xlib)
(defun user::xgcl-demo nil
(wtesta)
(wtestb)
(format t "Try (wtestc) ... (wtestk) for more examples."))
(defmacro while (test &rest forms)
`(loop (unless ,test (return)) ,@forms) )
(defvar *myw*) ; my window
(defvar myw)
; Make a window to play in.
(defun wtesta ()
(setq myw (setq *myw* (window-create 300 300 "test window"))) )
; 15 Aug 91; 12 Sep 91; 05 Oct 94; 06 Oct 94
; Draw some basic things in the window
(defun wtestb ()
(window-clear *myw*)
(window-draw-box-xy *myw* 50 50 50 20 1)
(window-printat *myw* "howdy" '(58 55))
(window-draw-line *myw* '(100 70) '(200 170))
(window-draw-arrow-xy *myw* 200 170 165 205)
(window-draw-circle-xy *myw* 200 170 50 2)
(window-draw-ellipse-xy *myw* 100 170 40 20 1)
(window-printat-xy *myw* "ellipse" 70 165)
(window-draw-arc-xy *myw* 100 250 20 20 0 90 1)
(window-draw-arc-xy *myw* 100 250 20 20 0 -90 1)
(window-printat-xy *myw* "arcs" 80 244)
(window-printat-xy *myw* "invert" 54 200)
(window-invert-area-xy *myw* 50 160 60 60)
(window-copy-area-xy *myw* 40 150 200 50 60 40)
(window-printat-xy *myw* "copy" 210 100)
(window-set-color-rgb *myw* 65535 0 0) ; red foreground
(window-printat-xy *myw* "Red" 20 20)
(window-draw-rcbox-xy *myw* 15 15 32 20 5)
(window-set-color-rgb *myw* 0 0 65535 t) ; blue background
(window-set-color-rgb *myw* 0 65535 0) ; green foreground
(window-printat-xy *myw* "Green" 120 20)
(window-set-color-rgb *myw* 0 65535 0 t) ; green background
(window-set-color-rgb *myw* 0 0 65535) ; blue foreground
(window-printat-xy *myw* "Blue" 220 20)
(window-reset-color *myw*)
(window-force-output *myw*) )
; 15 Aug 91; 19 Aug 91; 03 Sep 91; 21 Apr 95
; Illustrate mouse interaction:
; click in window *myw* (2 times for line, 3 times for region).
(defun wtestc ()
(let (mymenu result start done)
(setq mymenu (menu-create '(quit point line box region) "Choose One:"))
(while (not done)
(setq result
(case (menu-select mymenu)
(quit (setq done t))
(point (window-get-point *myw*))
(line (setq start (window-get-point *myw*))
(list start
(window-get-line-position *myw* (car start)
(cadr start))))
(box (window-get-box-position *myw* 40 20))
(region (window-get-region *myw*)) ))
(format t "Result: ~A~%" result) )
(menu-destroy mymenu) ))
; 09 Sep 91
; Illustrate icons in menus
(defun wtestd ()
(menu '(("Triangle" . triangle)
(dwtest-square . square)
(dwtest-circle . circle)
hexagon)
"Icons in Menu") )
(defun dwtest-square (w x y) (window-draw-box-xy w x y 20 20 1))
(setf (get 'dwtest-square 'display-size) '(20 20))
(defun dwtest-circle (w x y) (window-draw-circle-xy w (+ x 10) (+ y 10) 10 1))
(setf (get 'dwtest-circle 'display-size) '(20 20))
(defvar mypms nil)
; 09 Sep 91; 11 Sep 91; 12 Sep 91; 14 Sep 91
; Illustrate a diagrammatic menu-like object: square with sensitive spots
(defun wteste ()
(let (pm val)
(or mypms (mypms-init))
(setq pm (picmenu-create-from-spec mypms "Points on Square"))
(setq val (picmenu-select pm))
(picmenu-destroy pm)
val ))
; 14 Sep 91
(defun mypms-init ()
(setq mypms (picmenu-create-spec
'((bottom-left ( 20 20))
(center-left ( 20 70))
(top-left ( 20 120))
(bottom-center ( 70 20))
(center ( 70 70) (20 20)) ; larger
(top-center ( 70 120))
(bottom-right (120 20))
(center-right (120 70))
(top-right (120 120)))
140 140 'wteste-draw-square t)) )
(defvar mypm nil)
; 10 Sep 91; 11 Sep 91; 12 Sep 91; 14 Sep 91; 17 Sep 91
; A picmenu that is "flat" within another window, in this case *myw*.
; Must do (wtesta) first.
(defun wtestf ()
(or mypms (mypms-init))
(or mypm (setq mypm (picmenu-create-from-spec mypms "Points on Square"
*myw* 50 50 nil t t)))
(picmenu-select mypm))
(defun wteste-draw-square (w x y)
(window-draw-box-xy w (+ x 20) (+ y 20) 100 100 1))
(defvar mym nil)
; 10 Sep 91; 17 Sep 91
; A menu that is "flat" within another window, in this case *myw*.
; Must do (wtesta) first.
(defun wtestg ()
(or mym (setq mym (menu-create '(red white blue) "Flag" *myw* 50 50 nil t)))
(menu-select mym))
; 09 Oct 91
; Demonstrate arrows. Optional arg is line width.
(defun wtesth ( &optional (lw 1))
(window-clear *myw*)
(dotimes (i 5) (window-draw-arrow-xy *myw* 100 100 (+ 40 (* i 30)) 160 lw))
(dotimes (i 5) (window-draw-arrow-xy *myw* 100 100 (+ 40 (* i 30)) 40 lw))
(dotimes (i 5) (window-draw-arrow-xy *myw* 100 100 40 (+ 40 (* i 30)) lw))
(dotimes (i 5) (window-draw-arrow-xy *myw* 100 100 160 (+ 40 (* i 30)) lw))
(dotimes (i 5) (window-draw-arrow-xy *myw* 200 (+ 40 (* i 30))
240 (+ 40 (* i 30))
(1+ i) ))
(window-force-output *myw*) )
; 04 Jan 94
; Redo some of the arrows from wtesth in color
(defun wtesti ()
(window-set-color-rgb *myw* 65535 0 0)
(window-draw-arrow-xy *myw* 200 70 240 70 2)
(window-set-color-rgb *myw* 0 65535 0)
(window-draw-arrow-xy *myw* 200 100 240 100 3)
(window-set-color-rgb *myw* 0 0 65535)
(window-draw-arrow-xy *myw* 200 130 240 130 4)
(window-reset-color *myw*)
(window-force-output *myw*) )
; 04 Jan 94
; Get text from a window. Move mouse pointer into test window.
; Add characters and/or backspace, Return.
; Note: it might be necessary to change the keyboard mapping, using
; (window-init-keyboard-mapping *myw*) and (window-print-keyboard-mapping)
(defun wtestj () (window-input-string *myw* "Foo" 50 200 200))
; 04 Jan 94
; Change foreground and background colors and input a string
(defun wtestk ()
(window-set-color-rgb *myw* 0 65535 0) ; green foreground
(window-set-color-rgb *myw* 0 0 65535 t) ; blue background
(prog1 (window-input-string *myw* "Foo" 50 200 200)
(window-reset-color *myw*)
(window-force-output *myw*) ) )
|