-
-
Notifications
You must be signed in to change notification settings - Fork 24
/
Copy pathBLACKBOX
452 lines (405 loc) · 17.9 KB
/
BLACKBOX
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
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
(FILECREATED "10-Jan-86 08:27:39" {PHYLUM}<BOBROW>LISP>BLACKBOX.;7 17547
changes to: (FNS InitializeGuessArray BlackBoxChoices InitializeBallArray NewGame AskQuestion
BlackBoxWindowFn OnEdge ProbeBallArray FillBox DrawBlackBox RedisplayBox)
(VARS BLACKBOXCOMS HintTime)
previous date: " 3-Jan-86 19:12:57" {PHYLUM}<BOBROW>LISP>BLACKBOX.;5)
(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT BLACKBOXCOMS)
(RPAQQ BLACKBOXCOMS ((VARS BlackBoxSquare HintTime)
(FNS AskQuestion BlackBox BlackBoxChoices BlackBoxTitle FillBox InitializeBallArray
InitializeGuessArray LeftAhead LeftTurn MakeBlackBoxWindow MoveAhead MoveBall
DrawBlackBox BallAhead BallDownOrUp BBBoxNumber BlackBoxWindowFn MakeBallArray NewGame
OnEdge ProbeBallArray RedisplayBox RightAhead RightTurn SetSquareArray ShowBalls
SquareArray)))
(RPAQQ BlackBoxSquare 40)
(RPAQQ HintTime 5000)
(DEFINEQ
(AskQuestion
[LAMBDA (window xBox yBox) (* edited: "10-Jan-86 07:15")
(LET* ((boxSize (WINDOWPROP window (QUOTE BoxSize)))
(guessArray (WINDOWPROP window (QUOTE GuessArray)))
(answer (ProbeBallArray (WINDOWPROP window (QUOTE BallArray))
xBox yBox boxSize)))
(AND answer (SetSquareArray guessArray xBox boxSize yBox
(if (LISTP answer)
then (* use a number)
(LET [(g (WINDOWPROP window (QUOTE LastGuessNumber)
(PLUS (WINDOWPROP
window
(QUOTE
LastGuessNumber))
1]
(SetSquareArray guessArray (CAR answer)
(CDR answer)
boxSize g)
g)
else answer)))
answer])
(BlackBox
[LAMBDA (numRows numBalls) (* edited: " 3-Jan-86 16:19")
(* * This is a game in which one guesses where balls are hidden)
(if (NOT (NUMBERP numRows))
then (SETQ numRows 8))
(if (NOT (NUMBERP numBalls))
then (SETQ numBalls 4))
(if (GREATERP numRows 16)
then (PRINTOUT T "Too big. Using " numRows " rows.")
(SETQ numRows 16))
(if (GREATERP numBalls numRows)
then (PRINTOUT T "You chose too many balls. I will use " numRows T)
(SETQ numBalls numRows))
(LET* ((boxSize (PLUS 2 numRows))
(boxWidth (TIMES BlackBoxSquare boxSize))
(boxWindow (MakeBlackBoxWindow boxSize boxWidth numBalls)))
(MOVEW boxWindow 0 0])
(BlackBoxChoices
[LAMBDA (window) (* edited: "10-Jan-86 08:25")
(LET [(ballArray (WINDOWPROP window (QUOTE BallArray)))
(guessArray (WINDOWPROP window (QUOTE GuessArray]
(SELECTQ [MENU (create MENU
ITEMS _(QUOTE (ShowCorrect ShowAll NewGame
("New Game Using Balls Shown"
(QUOTE NewGameFrom)
"Use the balls shown to initialize game")
ChangeNumberOfBalls
ChangeNumberOfRows]
(ShowAll (ShowBalls window ballArray guessArray T)
(DISMISS HintTime)
(REDISPLAYW window))
(ShowCorrect (ShowBalls window ballArray guessArray NIL)
(DISMISS HintTime)
(REDISPLAYW window))
(NewGame (NewGame window))
(NewGameFrom (NewGame window NIL (BallsDisplayed window)))
(ChangeNumberOfBalls (LET ((numRows (DIFFERENCE (WINDOWPROP window
(QUOTE BoxSize))
2))
(numBalls (RNUMBER "How many hidden balls")))
(WINDOWPROP window (QUOTE NumBalls)
(COND
((GREATERP 1 numBalls)
(PRINTOUT T .FONT (HELVETICA 18)
"You need to hide some balls."
T)
(WINDOWPROP window (QUOTE
NumBalls)))
((GREATERP numBalls numRows)
(PRINTOUT T .FONT (HELVETICA 18)
"You are asking for too many balls. Using "
numRows T)
numRows)
(T numBalls)))
(WINDOWPROP window (QUOTE TITLE)
(CONCAT "Black Box with " numBalls
" balls")))
(NewGame window))
[ChangeNumberOfRows (LET ((numRows (RNUMBER "How many rows?")))
(CLOSEF window)
(BlackBox numRows (WINDOWPROP window (QUOTE
NumBalls]
NIL])
(BlackBoxTitle
[LAMBDA (numBalls) (* edited: "30-Dec-85 17:51")
(CONCAT "Black Box with " numBalls " balls -- Click Here For Help"])
(FillBox
[LAMBDA (window x y symbol) (* edited: "10-Jan-86 07:59")
(LET ((xPos (TIMES x BlackBoxSquare))
(yPos (TIMES y BlackBoxSquare)))
(SELECTQ symbol
(Black (DSPFILL (CREATEREGION xPos yPos BlackBoxSquare BlackBoxSquare)
BLACKSHADE NIL window))
(Ball (FILLCIRCLE (PLUS xPos (TIMES .5 BlackBoxSquare))
(PLUS yPos (TIMES .5 BlackBoxSquare))
(TIMES .45 BlackBoxSquare)
BLACKSHADE window))
(NIL (DSPFILL (CREATEREGION (PLUS xPos 2)
(PLUS yPos 2)
(DIFFERENCE BlackBoxSquare 2)
(DIFFERENCE BlackBoxSquare 2))
WHITESHADE
(QUOTE REPLACE)
window))
(PROGN (MOVETO (PLUS xPos (TIMES .25 BlackBoxSquare))
(PLUS yPos (TIMES .25 BlackBoxSquare))
window)
(PRIN1 symbol window])
(InitializeBallArray
[LAMBDA (array numBalls boxSize ballPositions) (* edited: "10-Jan-86 08:27")
(for I from 0 to (SUB1 (ARRAYSIZE array)) do (SETA array I NIL))
(for position in ballPositions do (SetSquareArray array (CAR position)
(CDR position)
boxSize
(QUOTE Ball)))
(for i from (LENGTH ballPositions) to (SUB1 numBalls)
do (PROG (randX randY)
doAgain
(SETQ randX (RAND 1 (DIFFERENCE boxSize 2)))
(SETQ randY (RAND 1 (DIFFERENCE boxSize 2)))
(if (SquareArray array randX randY boxSize)
then (GO doAgain)
else (SetSquareArray array randX randY boxSize (QUOTE Ball])
(InitializeGuessArray
[LAMBDA (guessArray boxSize) (* edited: "10-Jan-86 08:06")
(LET ((maxIndex (SUB1 boxSize)))
(for i from 0 to maxIndex
do (for j from 0 to maxIndex
do (SetSquareArray guessArray i j boxSize
(if [OR (AND (EQ i 0)
(OR (EQ j 0)
(EQ j maxIndex)))
(AND (EQ i maxIndex)
(OR (EQ j 0)
(EQ j maxIndex]
then (QUOTE Black])
(LeftAhead
[LAMBDA (array x y boxSize direction) (* edited: "29-Dec-85 18:17")
(EQ (QUOTE Ball)
(SquareArray array (SELECTQ direction
((L U)
(SUB1 x))
((D R)
(ADD1 x))
x)
(SELECTQ direction
((L D)
(SUB1 y))
((R U)
(ADD1 y))
y)
boxSize])
(LeftTurn
[LAMBDA (direction) (* edited: "29-Dec-85 18:08")
(SELECTQ direction
(U (QUOTE L))
(R (QUOTE U))
(D (QUOTE R))
(L (QUOTE D))
(ERROR "Bad Direction" direction])
(MakeBlackBoxWindow
[LAMBDA (boxSize boxWidth numBalls) (* edited: " 3-Jan-86 18:51")
(* * Draw the window, and install a buttonFunction that will make the right moves for the game)
(LET ((window (CREATEW (CREATEREGION 0 0 (WIDTHIFWINDOW boxWidth 4)
(HEIGHTIFWINDOW boxWidth T 4))
(BlackBoxTitle numBalls)
4)))
(DSPFONT (FONTCREATE (QUOTE (HELVETICA 18 BOLD)))
window)
(WINDOWPROP window (QUOTE BoxWidth)
boxWidth)
(WINDOWPROP window (QUOTE BoxSize)
boxSize)
(WINDOWPROP window (QUOTE NumBalls)
numBalls)
(WINDOWPROP window (QUOTE REPAINTFN)
(QUOTE DrawBlackBox))
(WINDOWPROP window (QUOTE BUTTONEVENTFN)
(QUOTE BlackBoxWindowFn))
(NewGame window boxSize)
window])
(MoveAhead
[LAMBDA (array x y boxSize direction) (* edited: "29-Dec-85 18:03")
(MoveBall array (SELECTQ direction
(L (SUB1 x))
(R (ADD1 x))
x)
(SELECTQ direction
(D (SUB1 y))
(U (ADD1 y))
y)
boxSize direction])
(MoveBall
[LAMBDA (array xPos yPos boxSize direction) (* edited: "29-Dec-85 18:22")
(LET ((edge (OnEdge xPos yPos boxSize)))
(if edge
then (* Coming Out)
(CONS xPos yPos)
elseif (BallAhead array xPos yPos boxSize direction)
then (QUOTE H)
elseif (LeftAhead array xPos yPos boxSize direction)
then (if (RightAhead array xPos yPos boxSize direction)
then (QUOTE R)
else (MoveAhead array xPos yPos boxSize (RightTurn direction)))
elseif (RightAhead array xPos yPos boxSize direction)
then (MoveAhead array xPos yPos boxSize (LeftTurn direction))
else (MoveAhead array xPos yPos boxSize direction])
(DrawBlackBox
[LAMBDA (window) (* edited: "10-Jan-86 07:40")
(LET* [(boxSize (WINDOWPROP window (QUOTE BoxSize)))
(boxWidth (WINDOWPROP window (QUOTE BoxWidth)))
(lastLinePos (DIFFERENCE boxWidth BlackBoxSquare))
(guessArray (WINDOWPROP window (QUOTE GuessArray]
(for bottom from BlackBoxSquare by BlackBoxSquare to boxWidth
do (DRAWLINE 0 bottom boxWidth bottom (if (OR (EQ bottom BlackBoxSquare)
(EQ bottom lastLinePos))
then 4
else 2)
NIL window)
(DRAWLINE bottom 0 bottom boxWidth (if (OR (EQ bottom BlackBoxSquare)
(EQ bottom lastLinePos))
then 4
else 2)
NIL window))
(for xPos from 0 to (SUB1 boxSize) do (for yPos from 0 to (SUB1 boxSize)
do (FillBox window xPos yPos
(SquareArray
guessArray
xPos yPos
boxSize])
(BallAhead
[LAMBDA (array x y boxSize direction) (* edited: "29-Dec-85 17:29")
(EQ (QUOTE Ball)
(SquareArray array (SELECTQ direction
(L (SUB1 x))
(R (ADD1 x))
x)
(SELECTQ direction
(D (SUB1 y))
(U (ADD1 y))
y)
boxSize])
(BallDownOrUp
[LAMBDA (window xBox yBox) (* edited: "29-Dec-85 14:33")
(LET* [(array (WINDOWPROP window (QUOTE GuessArray)))
(boxSize (WINDOWPROP window (QUOTE BoxSize]
(SetSquareArray array xBox yBox boxSize (if (SquareArray array xBox yBox boxSize)
then NIL
else (QUOTE Ball])
(BBBoxNumber
[LAMBDA (window place) (* dgb: "25-Dec-85 16:54")
(IQUOTIENT place BlackBoxSquare])
(BlackBoxWindowFn
[LAMBDA (window) (* edited: "10-Jan-86 07:49")
(LET [(buttons (DECODEBUTTONS))
(xBox (BBBoxNumber window (LASTMOUSEX window)))
(yBox (BBBoxNumber window (LASTMOUSEY window)))
(lastRow (SUB1 (WINDOWPROP window (QUOTE BoxSize]
(if (EQ yBox (WINDOWPROP window (QUOTE BoxSize)))
then (AND buttons (BlackBoxChoices window))
elseif buttons
elseif (OR (EQ xBox 0)
(EQ yBox 0)
(EQ xBox lastRow)
(EQ yBox lastRow))
then [LET ((answer (AskQuestion window xBox yBox)))
(RedisplayBox window xBox yBox)
(AND (LISTP answer)
(RedisplayBox window (CAR answer)
(CDR answer]
else (BallDownOrUp window xBox yBox)
(RedisplayBox window xBox yBox])
(MakeBallArray
[LAMBDA (numBalls) (* edited: "29-Dec-85 14:15")
(ARRAY (TIMES numBalls numBalls)
NIL NIL 0])
(NewGame
[LAMBDA (window boxSize ballPositions) (* edited: "10-Jan-86 08:27")
[OR boxSize (SETQ boxSize (WINDOWPROP window (QUOTE BoxSize]
(LET [(ballArray (OR (WINDOWPROP window (QUOTE BallArray))
(LET ((V (MakeBallArray boxSize)))
(WINDOWPROP window (QUOTE BallArray)
V)
V)))
(guessArray (OR (WINDOWPROP window (QUOTE GuessArray))
(LET ((V (MakeBallArray boxSize)))
(WINDOWPROP window (QUOTE GuessArray)
V)
V]
(InitializeGuessArray guessArray boxSize ballPositions)
(InitializeBallArray ballArray (WINDOWPROP window (QUOTE NumBalls))
boxSize ballPositions)
(WINDOWPROP window (QUOTE LastGuessNumber)
1)
(REDISPLAYW window])
(OnEdge
[LAMBDA (x y boxSize) (* edited: "10-Jan-86 06:01")
(if (EQ y 0)
then (QUOTE U)
elseif (EQ x 0)
then (QUOTE R)
elseif (EQ y (SUB1 boxSize))
then (QUOTE D)
elseif (EQ x (SUB1 boxSize))
then (QUOTE L)
else NIL])
(ProbeBallArray
[LAMBDA (array xPos yPos boxSize) (* edited: "10-Jan-86 07:06")
(* * Returns NIL if at corner, H, R, or for a detour a dotted pair of final postion for x and y)
(LET* [(lastIndex (SUB1 boxSize))
[atCorner (OR (AND (EQ xBox 0)
(OR (EQ yBox 0)
(EQ yBox lastIndex)))
(AND (EQ xBox lastIndex)
(OR (EQ yBox 0)
(EQ yBox lastIndex]
(direction (AND (NOT atCorner)
(OnEdge xPos yPos boxSize]
(AND direction (if (BallAhead array xPos yPos boxSize direction)
then (QUOTE H)
elseif (OR (LeftAhead array xPos yPos boxSize direction)
(RightAhead array xPos yPos boxSize direction))
then (QUOTE R)
else (MoveAhead array xPos yPos boxSize direction])
(RedisplayBox
[LAMBDA (window xBox yBox) (* edited: "10-Jan-86 07:48")
(FillBox window xBox yBox (SquareArray (WINDOWPROP window (QUOTE GuessArray))
xBox yBox (WINDOWPROP window (QUOTE BoxSize])
(RightAhead
[LAMBDA (array x y boxSize direction) (* edited: "29-Dec-85 17:35")
(EQ (QUOTE Ball)
(SquareArray array (SELECTQ direction
((D L)
(SUB1 x))
((U R)
(ADD1 x))
x)
(SELECTQ direction
((R D)
(SUB1 y))
((L U)
(ADD1 y))
y)
boxSize])
(RightTurn
[LAMBDA (direction) (* edited: "29-Dec-85 18:07")
(SELECTQ direction
(U (QUOTE R))
(R (QUOTE D))
(D (QUOTE L))
(L (QUOTE U))
(ERROR "Bad Direction" direction])
(SetSquareArray
[LAMBDA (array x y rowSize newValue) (* edited: "29-Dec-85 13:27")
(SETA array (PLUS x (TIMES rowSize y))
newValue])
(ShowBalls
[LAMBDA (window ballArray gameArray showAll) (* edited: "29-Dec-85 17:00")
(LET [(boxSize (WINDOWPROP window (QUOTE BoxSize]
(for xPos from 0 to (SUB1 boxSize)
do (for yPos from 0 to (SUB1 boxSize)
do (if (AND (EQ (QUOTE Ball)
(SquareArray ballArray xPos yPos boxSize))
(OR showAll (SquareArray gameArray xPos yPos boxSize)))
then (DSPFILL (CREATEREGION (PLUS (TIMES xPos BlackBoxSquare)
2)
(PLUS (TIMES yPos BlackBoxSquare)
2)
(DIFFERENCE BlackBoxSquare 2)
(DIFFERENCE BlackBoxSquare 2))
BLACKSHADE
(QUOTE INVERT)
window])
(SquareArray
[LAMBDA (array x y rowSize) (* edited: "29-Dec-85 13:26")
(ELT array (PLUS x (TIMES rowSize y])
)
(PUTPROPS BLACKBOX COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (966 17463 (AskQuestion 976 . 1847) (BlackBox 1849 . 2672) (BlackBoxChoices 2674 . 4665)
(BlackBoxTitle 4667 . 4858) (FillBox 4860 . 5816) (InitializeBallArray 5818 . 6634) (
InitializeGuessArray 6636 . 7212) (LeftAhead 7214 . 7615) (LeftTurn 7617 . 7903) (MakeBlackBoxWindow
7905 . 8852) (MoveAhead 8854 . 9164) (MoveBall 9166 . 10000) (DrawBlackBox 10002 . 11120) (BallAhead
11122 . 11469) (BallDownOrUp 11471 . 11868) (BBBoxNumber 11870 . 12020) (BlackBoxWindowFn 12022 .
12947) (MakeBallArray 12949 . 13125) (NewGame 13127 . 14008) (OnEdge 14010 . 14382) (ProbeBallArray
14384 . 15301) (RedisplayBox 15303 . 15579) (RightAhead 15581 . 15983) (RightTurn 15985 . 16272) (
SetSquareArray 16274 . 16459) (ShowBalls 16461 . 17294) (SquareArray 17296 . 17461)))))
STOP