/usr/lib/gcl-2.6.7/xgcl-2/gcl_dwtest.lsp is in gcl 2.6.7-98.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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*) ) )
|