source: trunk/lisp/lmdemo/worm.lisp @ 269

Last change on this file since 269 was 269, checked in by rjs, 3 years ago

Initial versions from System 78.

File size: 4.6 KB
Line 
1;;; -*- Mode:Lisp; Package:Hacks; Base:8 -*-
2
3(DECLARE (SPECIAL BITS ORDER WORMS WORM-TURNS FONTS:WORM WORM-X WORM-Y FITP X-WORM Y-WORM
4          WORM-BIG-CHAR WORM-GRAY-CHAR WORM-BLACK-CHAR WORM-STRIPE-CHAR WORM-SG))
5
6(DECLARE (SPECIAL WORM-ALU-FUNCTION CHAR ORDER WORM-X WORM-Y BITS DIR))
7       
8(SETQ WORM-BIG-CHAR 5
9      WORM-STRIPE-CHAR 4
10      WORM-GRAY-CHAR 3
11      WORM-BLACK-CHAR 2)
12
13(COND ((NOT (BOUNDP 'WORMS))
14       (SETQ WORMS (MAKE-ARRAY NIL 'ART-Q-LIST 6))
15       (DO I 0 (1+ I) (>= I 6)
16         (AS-1 (MAKE-STACK-GROUP (FORMAT NIL "WORM-~D" I)) WORMS I))))
17
18(DEFUN PRESET (SG CHAR ALU-FN N)
19       (STACK-GROUP-PRESET SG
20                           (FUNCTION FLOP)
21                           (SYMEVAL CHAR)
22                           (SYMEVAL ALU-FN)
23                           ORDER
24                           WORM-X
25                           WORM-Y
26                           BITS
27                           (* N (^ 3 (1- ORDER)))
28                           TERMINAL-IO
29                           SYS:%CURRENT-STACK-GROUP))
30
31(DEFUN WORM (&OPTIONAL (BITS 0) (ORDER 7) (WORM-X 222) (WORM-Y 777) (RUN NIL)
32             &AUX LENGTH (YPOS (- (TV:SHEET-INSIDE-HEIGHT TERMINAL-IO) 44)))
33   (OR (BOUNDP 'FONTS:WORM) (LOAD "LMDEMO;WORMCH" 'FONTS))
34   (SETQ LENGTH (^ 3 (1+ ORDER)))
35   (PRESET (AR-1 WORMS 0) 'WORM-BIG-CHAR 'TV:ALU-IOR 0)
36   (SETQ FITP NIL)
37   (DO I 0 (1+ I) (OR FITP ( I 2))                     ; Paint blackness over whole worm
38       (SETQ FITP T)
39       (FUNCALL TERMINAL-IO ':CLEAR-SCREEN)
40       (DO I 0 (1+ I) (> I LENGTH) (FUNCALL (AR-1 WORMS 0))))
41   (SETQ WORM-X X-WORM WORM-Y Y-WORM)
42   (MAPC (FUNCTION PRESET)                              ; Preset wormlets
43         (G-L-P WORMS)
44         '(WORM-GRAY-CHAR WORM-BLACK-CHAR WORM-STRIPE-CHAR WORM-BLACK-CHAR
45                          WORM-BLACK-CHAR WORM-BLACK-CHAR)
46         '(TV:ALU-XOR TV:ALU-ANDCA TV:ALU-IOR TV:ALU-IOR TV:ALU-ANDCA TV:ALU-IOR)
47         '(0 1 2 3 5 6))                                ;4 is intentionally missing!
48   (*CATCH 'WORM-EXIT
49     (DO ((I 0 (1+ I))
50          (STOP-VAL 0))
51         (NIL)
52       (COND (RUN (AND (FUNCALL TERMINAL-IO ':TYI-NO-HANG) (SETQ RUN NIL)))
53             ((< I STOP-VAL))
54             (T (FUNCALL TERMINAL-IO ':SET-CURSORPOS 40. YPOS)
55                (FUNCALL TERMINAL-IO ':CLEAR-EOL)
56                (LET ((BASE 9))
57                     (FORMAT T "~8S   " I))
58                (PROG (CH VAL)
59                      (SETQ VAL 0)
60                 LOOP (SETQ CH (CHAR-UPCASE (TYI)))
61                      (COND ((AND ( CH #/0)( CH #/9))
62                             (SETQ VAL (+ (* VAL 9) (- CH #/0)))
63                             (GO LOOP))
64                            ((EQ CH #/N) (SETQ STOP-VAL (+ VAL I)))
65                            ((EQ CH #/R) (SETQ STOP-VAL VAL))
66                            ((EQ CH #/S) (SETQ VAL (^ 3 VAL)
67                                               STOP-VAL (* VAL (1+ (// I VAL)))))
68                            ((EQ CH #/P) (SETQ RUN T))
69                            ((EQ CH #/Q) (*THROW 'WORM-EXIT  NIL))
70                            ((OR (EQ CH #/?) (EQ CH #/H))
71                             (FORMAT T "P: Run,~TnR: Run until n,~TnN: Run <n> steps")
72                             (FORMAT T "~TnS: Run until n'th order,~TQ: Quit~%")
73                             (SETQ VAL 0)
74                             (GO LOOP))
75                            ))))
76       (DO I 0 (1+ I) (>= I 6) (FUNCALL (AR-1 WORMS I)))))
77)
78
79(OR (BOUNDP 'WORM-TURNS) (SETQ WORM-TURNS (MAKE-ARRAY NIL 'ART-Q-LIST 12.)))
80
81(FillArray WORM-TURNS '( 6  0
82                         3  5
83                        -3  5
84                        -6  0
85                        -3 -5
86                         3 -5))
87
88(DEFUN FLOP (CHAR WORM-ALU-FUNCTION ORDER WORM-X WORM-Y BITS SNOOZE TERMINAL-IO WORM-SG)
89      (DO I 0 (1+ I) ( I SNOOZE)
90          (STACK-GROUP-RETURN NIL))
91      (DO ((I 0 (1+ I))
92           (DIR (BOOLE 4 (- ORDER) 1)))
93          (NIL)
94          (TERD ORDER BITS)
95          (WORM-STEP)
96          (SETQ X-WORM WORM-X Y-WORM WORM-Y)
97          (SETQ DIR (+ DIR 4))))
98
99(DEFUN TERD (N BITS)
100   (IF (PLUSP N)
101          (COND ((Bit-Test BITS 1)
102                   (TERD (1- N) (LSH BITS -1))
103                   (SETQ DIR (- DIR -2))
104                   (WORM-STEP)
105                   (SETQ DIR (- DIR 4))
106                   (TERD (1- N) (LSH BITS -1))
107                   (WORM-STEP)
108                   (SETQ DIR (+ DIR 2))
109                   (TERD (1- N) (LSH BITS -1)))
110                (T (TERD (1- N) (LSH BITS -1))
111                   (WORM-STEP)
112                   (SETQ DIR (+ DIR 4))
113                   (TERD (1- N) (LSH BITS -1))
114                   (SETQ DIR (- DIR 2))
115                   (WORM-STEP)
116                   (SETQ DIR (- DIR 2))
117                   (TERD (1- N) (LSH BITS -1))))))
118           
119(DEFUN WORM-STEP ()
120   (CLIP 'WORM-X (TV:SHEET-INSIDE-WIDTH TERMINAL-IO) (SETQ DIR (\ (+ 12. DIR) 12.)))
121   (CLIP 'WORM-Y (- (TV:SHEET-INSIDE-HEIGHT TERMINAL-IO) 55) (1+ DIR))
122   (TV:PREPARE-SHEET (TERMINAL-IO)
123      (TV:%DRAW-CHAR FONTS:WORM CHAR WORM-X WORM-Y WORM-ALU-FUNCTION TERMINAL-IO))
124   (STACK-GROUP-RETURN NIL))
125
126(DEFUN CLIP (Z N D)
127       (SELECTQ (// (+ N (SET Z (+ (SYMEVAL Z) (AR-1 WORM-TURNS D))))
128                    N)
129            (0 (SET Z 1) (SETQ FITP NIL))
130            (1)
131            (2 (SET Z (1- N)) (SETQ FITP NIL))))
132
133(DEFDEMO "Worm" "Pretty fractal patters, by Gosper and Holloway." (WORM))
Note: See TracBrowser for help on using the repository browser.