-
-
Notifications
You must be signed in to change notification settings - Fork 24
/
Copy pathNEATICONS
307 lines (224 loc) · 17.4 KB
/
NEATICONS
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
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (PROG1 (DEFPACKAGE "NEATICONS" ( USE "LISP" "XCL") (
IMPORT bind _ first for in until unless do collect finally if then else elseif create fetch of)) (
EXPORT (CL MAPCAR (CL FUNCTION (LAMBDA (STRING) (CL INTERN STRING "NEATICONS"))) (QUOTE (
"DEFAULT-SPACING" "DEFAULT-TOLERANCE" "NEATEN" "UNNEATEN" "USERMOVEFN"))) "NEATICONS")))
(IL:FILECREATED "17-Aug-87 14:00:19" IL:{DSK}<LISPFILES>DEV>NEATICONS.\;2 17753
IL:|changes| IL:|to:| (IL:ADVICE IL:SHRINKW)
(IL:VARS IL:NEATICONSCOMS)
IL:|previous| IL:|date:| "17-Aug-87 13:51:56" IL:{DSK}<LISPFILES>DEV>NEATICONS.\;1)
; Copyright (c) 1967, 1986, 1987 by Quintus Computer Systems, Inc. All rights reserved.
(IL:PRETTYCOMPRINT IL:NEATICONSCOMS)
(IL:RPAQQ IL:NEATICONSCOMS (
(IL:* IL:|;;| "This file makes sure that all icons (shrunken windows) created after this file is loaded are neat. This means that when an icon is near another window it is neatly placed NEATICONS:DEFAULT-SPACING (defaults to 5) pixels away, or the edge of the screen flushed with the edge of the screen, or if one of its edges is near the corresponding edge of another window, the edges will be perfectly aligned. It's a lot easier to understand what this means by trying it. An icon will be moved at most NEATICONS:DEFAULT-TOLERANCE (defaults to 100) pixels horizontally or vertically in order to make it neat. So if you put an icon in the middle of nowhere, it will stay there.")
(IL:* IL:|;;| "This is done by advising SHRINKW to make newly generated icons neat. The function NEATICONS.NEATEN.WINDOW, when applied to a window, will make that window always neat. So after loading this file, newly created icons will always be neat; and users can make any window neat by calling (NEATICONS:NEATEN window). Note that existing icons can be made neat by expanding and re-shrinking them.")
(IL:* IL:|;;| "Exported variables and functions")
(IL:VARIABLES DEFAULT-SPACING DEFAULT-TOLERANCE)
(IL:FUNCTIONS NEATEN UNNEATEN)
(IL:* IL:|;;| "Private stuff")
(IL:ADVISE IL:SHRINKW)
(IL:FUNCTIONS BETWEEN MIN-ABSOLUTE MIN-SUM-SQUARES NEAT-POSITION)
(IL:PROP IL:MAKEFILE-ENVIRONMENT IL:NEATICONS)))
(IL:* IL:|;;|
"This file makes sure that all icons (shrunken windows) created after this file is loaded are neat. This means that when an icon is near another window it is neatly placed NEATICONS:DEFAULT-SPACING (defaults to 5) pixels away, or the edge of the screen flushed with the edge of the screen, or if one of its edges is near the corresponding edge of another window, the edges will be perfectly aligned. It's a lot easier to understand what this means by trying it. An icon will be moved at most NEATICONS:DEFAULT-TOLERANCE (defaults to 100) pixels horizontally or vertically in order to make it neat. So if you put an icon in the middle of nowhere, it will stay there."
)
(IL:* IL:|;;|
"This is done by advising SHRINKW to make newly generated icons neat. The function NEATICONS.NEATEN.WINDOW, when applied to a window, will make that window always neat. So after loading this file, newly created icons will always be neat; and users can make any window neat by calling (NEATICONS:NEATEN window). Note that existing icons can be made neat by expanding and re-shrinking them."
)
(IL:* IL:|;;| "Exported variables and functions")
(DEFGLOBALPARAMETER DEFAULT-SPACING 5 "Number of pixels between neat icons.")
(DEFGLOBALPARAMETER DEFAULT-TOLERANCE 100 "How far an icon will be moved to be neat.")
(DEFUN NEATEN (&OPTIONAL (WINDOW (IL:WHICHW)))
"Makes WINDOW (default: (WHICHW)) always neatly aligned with nearby windows"
(IL:* IL:|;;;| "Makes WINDOW neat, i.e., makes it neatly aligned on the screen, and makes sure that wherever it is moved, it will remain neatly placed. Also makes sure that any existing MOVEFN on the window will still get called when the window is moved, and that function has the final decision as the window's actual new position. WINDOW defaults to (WHICHW)")
(IL:* IL:|;;;| "For more on what it means to be neat, and how a neat postion for a window is determined, see NEATICONS::NEAT-POSITION")
(|if| (IL:WINDOWP WINDOW)
|then| (LET ((OLDMOVEFN (IL:WINDOWPROP WINDOW 'IL:MOVEFN 'NEAT-POSITION)))
(|if| (NOT (IL:EQMEMB 'NEAT-POSITION OLDMOVEFN))
(IL:* IL:\;
"If it's not already neat ...")
|then| (IL:WINDOWPROP WINDOW 'USERMOVEFN OLDMOVEFN)
(IL:RELMOVEW WINDOW '(0 . 0))) (IL:* IL:\;
"invokes NEAT-POSITION to neaten WINDOW")
WINDOW)))
(DEFUN UNNEATEN (&OPTIONAL (WINDOW (IL:WHICHW)))
"Makes WINDOW (default: (WHICHW)) a normal, non-neat window"
(IL:* IL:|;;;| "undoes the effect of NEATICONS:NEATEN. WINDOW becomes a normal, sloppy, window. WINDOW defaults to (WHICHW)")
(|if| (NOT (IL:WINDOWP WINDOW))
|then| (IL:ERROR "Not a window" WINDOW))
(IL:WINDOWPROP WINDOW 'IL:MOVEFN (IL:WINDOWPROP WINDOW 'USERMOVEFN NIL))
WINDOW)
(IL:* IL:|;;| "Private stuff")
(REINSTALL-ADVICE 'IL:SHRINKW :AROUND '((:LAST (LET ((IL:ICON IL:*))
(NEATEN IL:ICON)
IL:ICON))))
(IL:READVISE IL:SHRINKW)
(DEFMACRO BETWEEN (X LOWER UPPER) "X is between LOWER and UPPER?"
`(LET ((XVALUE ,X))
(AND (>= XVALUE ,LOWER)
(<= XVALUE ,UPPER))))
(DEFMACRO MIN-ABSOLUTE (ARG1 ARG2 &OPTIONAL ARG3)
"Returns whichever arg has the smallest absolute value"
`(LET* ((ARG1-VALUE ,ARG1)
(ARG2-VALUE ,ARG2)
(BEST-OF-TWO (|if| (< (ABS ARG2-VALUE)
(ABS ARG1-VALUE))
|then| ARG2-VALUE
|else| ARG1-VALUE)))
,(|if| ARG3
|then| `(LET ((ARG3-VALUE ,ARG3))
(|if| (< (ABS ARG3-VALUE)
(ABS BEST-OF-TWO))
|then| ARG3-VALUE
|else| BEST-OF-TWO))
|else| `BEST-OF-TWO)))
(DEFMACRO MIN-SUM-SQUARES (&REST PAIRS)
(IL:* IL:|;;;| "(min-sum-squares (deltax-1 deltay-1) (deltax-2 deltay-2) ...)")
(IL:* IL:|;;;| "returns the (x,y) pair (2 values) that have the smallest deltax^2 + deltay^2")
`(PROG ((BEST-DX ,(CAAR PAIRS))
(BEST-DY ,(CADAR PAIRS))
BEST-SUMSQ TEMP-SUMSQ)
(SETQ BEST-SUMSQ (+ (* BEST-DX BEST-DX)
(* BEST-DY BEST-DY)))
,@(|for| PR |in| (CDR PAIRS)
|collect| `(|if| (< (SETQ TEMP-SUMSQ (+ (* ,(CAR PR) ,(CAR PR))
(* ,(CADR PR) ,(CADR PR))))
BEST-SUMSQ)
|then| (SETQ BEST-SUMSQ TEMP-SUMSQ)
(SETQ BEST-DX ,(CAR PR))
(SETQ BEST-DY ,(CADR PR))))
(RETURN (VALUES BEST-DX BEST-DY))))
(DEFUN NEAT-POSITION (WINDOW-TO-MOVE TENTATIVE-POSITION &OPTIONAL (TOLERANCE DEFAULT-TOLERANCE)
(SPACING DEFAULT-SPACING))
"Returns the position nearest to TENTATIVE-POSITION that is neat."
(|bind|
(IL:* IL:|;;| "Variables describing the window we're moving and its new place:")
(USERMOVEFN _ (IL:WINDOWPROP WINDOW-TO-MOVE 'USERMOVEFN))
(MYREG _ (IL:WINDOWPROP WINDOW-TO-MOVE 'IL:REGION))
(MYLEFT _ (|fetch| (IL:POSITION IL:XCOORD) |of| TENTATIVE-POSITION))
(MYBOTTOM _ (|fetch| (IL:POSITION IL:YCOORD) |of| TENTATIVE-POSITION))
MYWIDTH MYHEIGHT MYRIGHT
(IL:* IL:|;;| "These describe the region WINDOW-TO-MOVE can be placed within and still meat the constraints imposed by TOLERANCE:")
MYTOP MINLEFT MAXRIGHT MINBOTTOM MAXTOP
(IL:* IL:|;;| "Variables to keep track of the best new place we've found so far:")
BEST-DELTAX BEST-DELTAY BEST-CORNER-DELTAX BEST-CORNER-DELTAY CORNER-DELTAX-WINDOW
CORNER-DELTAY-WINDOW
(IL:* IL:|;;| "Variables holding information about each window in turn:")
REGION LEFT RIGHT BOTTOM TOP
(IL:* IL:|;;|
"When we're all done, these hold information needed to compute the final value:")
BEST-POSITION USER-MOVE-VALUE |first| (SETQ MYWIDTH (|fetch| (IL:REGION IL:WIDTH)
|of| MYREG))
(SETQ MYHEIGHT (|fetch| (IL:REGION IL:HEIGHT)
|of| MYREG))
(SETQ MYRIGHT (+ MYLEFT MYWIDTH -1))
(SETQ MYTOP (+ MYBOTTOM MYHEIGHT -1))
(SETQ MINLEFT (- MYLEFT TOLERANCE))
(SETQ MAXRIGHT (+ MYRIGHT TOLERANCE))
(SETQ MINBOTTOM (- MYBOTTOM TOLERANCE))
(SETQ MAXTOP (+ MYTOP TOLERANCE))
(IL:* IL:|;;| "First guess at best position is nearest corner of the screen")
(SETQ BEST-CORNER-DELTAX
(SETQ BEST-DELTAX (MIN-ABSOLUTE (- IL:SCREENWIDTH
MYRIGHT 1)
(- MYLEFT))))
(SETQ BEST-CORNER-DELTAY
(SETQ BEST-DELTAY (MIN-ABSOLUTE (-
IL:SCREENHEIGHT
MYTOP 1)
(- MYBOTTOM))))
|for| WINDOW |in| (IL:OPENWINDOWS) |unless| (EQ WINDOW WINDOW-TO-MOVE)
|do| (SETQ REGION (IL:WINDOWPROP WINDOW 'IL:REGION))
(SETQ LEFT (|fetch| (IL:REGION IL:LEFT) |of| REGION))
(SETQ RIGHT (|fetch| (IL:REGION IL:RIGHT) |of| REGION))
(SETQ BOTTOM (|fetch| (IL:REGION IL:BOTTOM) |of| REGION))
(SETQ TOP (|fetch| (IL:REGION IL:TOP) |of| REGION))
MYLEFT-LEFT
(LET ((LEFT-MYLEFT (- LEFT MYLEFT))
(LEFT-MYRIGHT (- (- LEFT MYRIGHT)
SPACING))
(RIGHT-MYLEFT (+ (- RIGHT MYLEFT)
SPACING))
(RIGHT-MYRIGHT (- RIGHT MYRIGHT))
(BOTTOM-MYBOTTOM (- BOTTOM MYBOTTOM))
(BOTTOM-MYTOP (- (- BOTTOM MYTOP)
SPACING))
(TOP-MYBOTTOM (+ (- TOP MYBOTTOM)
SPACING))
(TOP-MYTOP (- TOP MYTOP)))
(IL:* IL:|;;| "First, see if we can align with a corner of a window")
(|if| (AND (OR (BETWEEN BOTTOM MINBOTTOM MAXTOP)
(BETWEEN TOP MINBOTTOM MAXTOP))
(OR (BETWEEN LEFT MINLEFT MAXRIGHT)
(BETWEEN RIGHT MINLEFT MAXRIGHT)))
|then| (MULTIPLE-VALUE-SETQ (BEST-CORNER-DELTAX BEST-CORNER-DELTAY)
(MIN-SUM-SQUARES (BEST-CORNER-DELTAX BEST-CORNER-DELTAY)
(LEFT-MYRIGHT TOP-MYTOP)
(LEFT-MYRIGHT BOTTOM-MYBOTTOM)
(RIGHT-MYLEFT BOTTOM-MYBOTTOM)
(RIGHT-MYLEFT TOP-MYTOP)
(LEFT-MYLEFT BOTTOM-MYTOP)
(LEFT-MYLEFT TOP-MYBOTTOM)
(RIGHT-MYRIGHT BOTTOM-MYTOP)
(RIGHT-MYRIGHT TOP-MYBOTTOM))))
(IL:* IL:|;;| "Now see if we can align with a side of a window")
(|if| (OR (BETWEEN MYBOTTOM BOTTOM TOP)
(BETWEEN MYTOP BOTTOM TOP))
|then| (SETQ BEST-DELTAX (MIN-ABSOLUTE BEST-DELTAX LEFT-MYRIGHT RIGHT-MYLEFT)))
(|if| (OR (BETWEEN MYLEFT LEFT RIGHT)
(BETWEEN MYRIGHT LEFT RIGHT))
|then| (SETQ BEST-DELTAY (MIN-ABSOLUTE BEST-DELTAY BOTTOM-MYTOP TOP-MYBOTTOM))))
|finally| (|if| (AND (IL:WINDOWP CORNER-DELTAX-WINDOW)
(EQ CORNER-DELTAX-WINDOW CORNER-DELTAY-WINDOW))
|then|
(IL:* IL:|;;| "we might be putting my window in the corner of another window. This code is meant to prevent the window from getting thrown on top of another window by preventing it from aligning two of its edges with the two corresponding edges of another window. But it doesn't work very well.")
(|if| (<= (+ (* BEST-DELTAX BEST-DELTAX)
(* BEST-CORNER-DELTAY BEST-CORNER-DELTAY))
(+ (* BEST-CORNER-DELTAX BEST-CORNER-DELTAX)
(* BEST-DELTAY BEST-DELTAY)))
|then| (SETQ BEST-DELTAY BEST-CORNER-DELTAY)
|else| (SETQ BEST-DELTAX BEST-CORNER-DELTAX))
|else| (SETQ BEST-DELTAX (MIN-ABSOLUTE BEST-DELTAX BEST-CORNER-DELTAX))
(SETQ BEST-DELTAY (MIN-ABSOLUTE BEST-DELTAY BEST-CORNER-DELTAY)))
(SETQ BEST-POSITION (|create| IL:POSITION
IL:XCOORD _ (|if| (<= (ABS BEST-DELTAX)
TOLERANCE)
|then| (+ MYLEFT BEST-DELTAX)
|else| MYLEFT)
IL:YCOORD _ (|if| (<= (ABS BEST-DELTAY)
TOLERANCE)
|then| (+ MYBOTTOM BEST-DELTAY)
|else| MYBOTTOM)))
(SETQ USER-MOVE-VALUE (IL:* IL:\;
"find result of any other MOVEFNs")
(|if| (NULL USERMOVEFN)
|then| NIL
|elseif| (EQ USERMOVEFN 'IL:DON\'T)
|then| 'IL:DON\'T
|elseif| (LISTP USERMOVEFN)
|then| (|bind| (VAL _ BEST-POSITION) |for| FN |in| USERMOVEFN
|until| (EQ VAL 'IL:DON\'T) |unless| (EQ FN 'NEAT-POSITION)
|do| (SETQ VAL (OR (FUNCALL FN WINDOW-TO-MOVE VAL)
VAL)) |finally| (RETURN VAL))
|elseif| (AND (SYMBOL-FUNCTION USERMOVEFN)
(IL:NEQ USERMOVEFN 'NEAT-POSITION))
|then| (FUNCALL USERMOVEFN WINDOW-TO-MOVE BEST-POSITION)
|else| NIL))
(RETURN (|if| (OR (EQ USER-MOVE-VALUE 'IL:DON\'T)
(IL:POSITIONP USER-MOVE-VALUE))
|then| USER-MOVE-VALUE
|else| BEST-POSITION))))
(IL:PUTPROPS IL:NEATICONS IL:MAKEFILE-ENVIRONMENT
(:READTABLE "XCL" :PACKAGE
(PROG1 (DEFPACKAGE "NEATICONS" (:USE "LISP" "XCL")
(:IMPORT |bind| _ |first| |for| |in| |until| |unless| |do|
|collect| |finally| |if| |then| |else| |elseif| |create|
|fetch| |of|))
(EXPORT (MAPCAR #'(IL:LAMBDA (STRING)
(INTERN STRING "NEATICONS"))
'("DEFAULT-SPACING" "DEFAULT-TOLERANCE" "NEATEN" "UNNEATEN"
"USERMOVEFN"))
"NEATICONS"))))
(IL:PUTPROPS IL:NEATICONS IL:COPYRIGHT ("Quintus Computer Systems, Inc" 1967 1986 1987))
(IL:DECLARE\: IL:DONTCOPY
(IL:FILEMAP (NIL)))
IL:STOP