Changeset 287

Show
Ignore:
Timestamp:
08/18/11 11:26:42 (21 months ago)
Author:
rjs
Message:

Update from System 78.

Files:
1 modified

Legend:

Unmodified
Added
Removed

  • trunk/lisp/lmdemo/ohacks.lisp

    r286 r287  
    1 ;-*-MODE: LISP; PACKAGE: USER; BASE: 8-*- 
     1;-*-MODE:LISP; PACKAGE:HACKS; BASE: 8-*- 
    22;       ** (c) Copyright 1980 Massachusetts Institute of Technology ** 
    33 
    … …  
    55(SETQ MASTER-DURATION 5000) 
    66(SETQ TEMPER  
    7       '((A 200.) (W 189.) (S 178.) (E 168.) (D 159.) (F 150.) (T 141.) 
    8         (G 133.) (Y 126.) (H 119.) (U 112.) (J 106.) (K 100.) (O 94.) 
    9         (L 89.) (P 84.) (/; 79.) (/: 75.) (/] 71.) 
    10         (/a 200.) (/w 189.) (/s 178.) (/e 168.) (/d 159.) (/f 150.) (/t 141.) 
    11         (/g 133.) (/y 126.) (/h 119.) (/u 112.) (/j 106.) (/k 100.) (/o 94.) 
    12         (/l 89.) (/p 84.) (/; 79.) (/: 75.) (/] 71.))) 
     7      '((#/A 200.) (#/W 189.) (#/S 178.) (#/E 168.) (#/D 159.) (#/F 150.) (#/T 141.) 
     8        (#/G 133.) (#/Y 126.) (#/H 119.) (#/U 112.) (#/J 106.) (#/K 100.) (#/O 94.) 
     9        (#/L 89.) (#/P 84.) (#/; 79.) (#/: 75.) (#/] 71.) 
     10        (#/a 200.) (#/w 189.) (#/s 178.) (#/e 168.) (#/d 159.) (#/f 150.) (#/t 141.) 
     11        (#/g 133.) (#/y 126.) (#/h 119.) (#/u 112.) (#/j 106.) (#/k 100.) (#/o 94.) 
     12        (#/l 89.) (#/p 84.) (#/; 79.) (#/: 75.) (#/] 71.))) 
    1313 
    1414(DECLARE (SPECIAL SINE-EPSILON TEMPER TEMPER-ARRAY)) 
    … …  
    2626    (%UNIBUS-READ LOC))) 
    2727 
    28 (DEFUN PLAY (NNOTES INITIAL-NOTE DECREMENT DURATION) 
     28(DEFUN OLD-PLAY (NNOTES INITIAL-NOTE DECREMENT DURATION) 
    2929  (DO ((K 0 (1+ K)) 
    3030       (NOTE INITIAL-NOTE (- NOTE DECREMENT))) 
    … …  
    3434(DECLARE (SPECIAL MASTER-DURATION)) 
    3535 
    36 (DEFUN ORGAN (&OPTIONAL RETUNE) 
    37     (COND ((NOT (BOUNDP 'TEMPER-ARRAY)) 
    38            (SETQ TEMPER-ARRAY (MAKE-ARRAY 
    39                                NIL 'ART-Q-LIST 
    40                                '(220))) 
    41            (SETQ RETUNE T))) 
    42     (COND (RETUNE 
    43            (DO N 0 (1+ N) (= N 220) 
     36(DEFUN SETUP-TEMPER-ARRAY (&OPTIONAL RETUNE) 
     37  (COND ((NOT (BOUNDP 'TEMPER-ARRAY)) 
     38         (SETQ TEMPER-ARRAY (MAKE-ARRAY NIL 'ART-Q-LIST 220)) 
     39         (SETQ RETUNE T))) 
     40  (COND (RETUNE 
     41         (DO N 0 (1+ N) (= N 220) 
    4442             (AS-1 10 TEMPER-ARRAY N)) 
    45            (DO X TEMPER (CDR X) (NULL X) 
    46              (AS-1 (CADAR X) TEMPER-ARRAY 
    47                    (GETCHARN (CAAR X) 1))))) 
    48     (DO ((A (KBD-TYI) (KBD-TYI))) 
     43         (DO X TEMPER (CDR X) (NULL X) 
     44             (AS-1 (CADAR X) TEMPER-ARRAY (CAAR X)))))) 
     45 
     46(DEFUN OLD-ORGAN (&OPTIONAL RETUNE) 
     47 (WITH-REAL-TIME 
     48    (SETUP-TEMPER-ARRAY RETUNE) 
     49    (DO ((A (FUNCALL TERMINAL-IO ':TYI) (FUNCALL TERMINAL-IO ':TYI))) 
    4950        ((= (SETQ A (LOGAND A 377)) 202) 
    5051         (RETURN "End of sonata in Q minor")) 
    5152        ((LAMBDA (WAVELENGTH) 
    5253                 (BUZZ (// MASTER-DURATION WAVELENGTH) WAVELENGTH)) 
    53          (AR-1 TEMPER-ARRAY A)))) 
     54         (AR-1 TEMPER-ARRAY A))))) 
    5455 
    5556(DEFUN ZOWIE (&OPTIONAL RETUNE &AUX (MASTER-DURATION 5600)) 
    56     (COND ((NOT (BOUNDP 'TEMPER-ARRAY)) 
    57            (SETQ TEMPER-ARRAY (MAKE-ARRAY 
    58                                NIL 'ART-Q-LIST 
    59                                '(220))) 
    60            (SETQ RETUNE T))) 
    61     (COND (RETUNE 
    62            (DO N 0 (1+ N) (= N 220) 
    63              (AS-1 10 TEMPER-ARRAY N)) 
    64            (DO X TEMPER (CDR X) (NULL X) 
    65              (AS-1 (CADAR X) TEMPER-ARRAY 
    66                    (GETCHARN (CAAR X) 1))))) 
     57 (WITH-REAL-TIME 
     58   (SETUP-TEMPER-ARRAY RETUNE) 
    6759    (DO ((W '(150. 150. 150. 159. 150. 133. 150. 133. 119. 133. 150. 159. 178. 159. 150.) 
    6860            (CDR W)) 
    … …  
    7264      (SETQ TEM (// (CAR W) 2)) 
    7365      (DO I 0 (1+ I) (= I 1000)) 
    74       (BUZZ (// (* (CAR D) MASTER-DURATION) TEM) TEM))) 
    75  
    76 (comment 
    77  
    78 (DEFUN SINE (A) 
    79   (COND ((< (ABS A) SINE-EPSILON) A) 
    80         (T 
    81          (SETQ A (SINE (RESCALE (* A -333.) 1000.))) 
    82          (RESCALE (* A (- (* 4 (RESCALE (* A A) 1000.)) 3000.)) 1000.)))) 
    83  
    84 (DEFUN RESCALE (X Y) 
    85   (COND ((> X 0.) 
    86          (// (+ X (// Y 2.)) Y)) 
    87         ((// (- X (// Y 2.)) Y)))) 
    88  
    89 (DEFUN WAVE NIL 
    90   (DO I 0. (1+ I) 
    91     (= I 400.) 
    92     (AS-2 1. TV-BUFFER I (+ 200. (// (SINE (* I 15.)) 10.))))) 
    93  
    94 (DEFUN CIRCLE NIL 
    95   (DO I 0. (+ I 100.) 
    96     (> I 6300.) 
    97     (AS-2 1. 
    98           TV-BUFFER 
    99           (+ 250. (// (SINE I) 5.)) 
    100           (+ 250. (// (SINE (+ I 1571.)) 5.))))) 
     66      (BUZZ (// (* (CAR D) MASTER-DURATION) TEM) TEM)))) 
     67 
     68(DEFDEMO "Zowie" "Demonstration of Lisp Machine music-generation facilities." (ZOWIE)) 
    10169 
    10270;TRY THIS WITH ARGUMENTS OF 20. AND 500. 
    10371(DEFUN MARV (&OPTIONAL (MARV-E 259.) (N 200.) (X 50.) (Y 0)) 
    104   (PROG NIL 
    105    A    (AS-2 1. TV-BUFFER (+ X 200.) (+ Y 200.)) 
     72  (PROG NIL  
     73    A   ;(AS-2 1. TV-BUFFER (+ X 200.) (+ Y 200.)) 
     74        (FUNCALL TERMINAL-IO ':DRAW-POINT (+ X 200.) (+ Y 200.) 1) 
    10675        (AND (ZEROP (SETQ N (1- N))) 
    10776             (RETURN T)) 
    … …  
    10978              Y (+ Y (// (* MARV-E X) 1000.))) 
    11079        (GO A))) 
    111 );end of comment 
    11280 
    11381 
    11482;INPUT CHARACTER WITH DDT STYLE ECHOING 
    115 (DEFUN CARPET-TYI (&AUX CH) 
     83(DEFUN CARPET-TYI (&AUX CH)                     ; 
    11684  (SETQ CH (FUNCALL TERMINAL-IO ':TYI)) 
    11785  (AND (< CH 200) 
    118        (FUNCALL TERMINAL-IO ':TYO)) 
     86       (FUNCALL TERMINAL-IO ':TYO CH)) 
    11987  CH) 
    12088 
    … …  
    147115     (GO RNUM) 
    148116 
    149 CMD  (COND ((= CH 57) 
     117CMD  (COND ((= CH #//) 
    150118            (SETQ BYTEP NIL LOC (LOGAND 777776 NUM) OPENP T) 
    151119            (GO OPN1)) 
    152            ((= CH 201) 
     120           ((= CH #\ABORT) 
    153121            (RETURN T)) 
    154            ((= CH 56) 
     122           ((= CH #/.) 
    155123            (SETQ SOME T 
    156124                  NUM LOC) 
    157125            (GO RNUM)) 
    158            ((= CH 134) 
     126           ((= CH #/\) 
    159127            (SETQ BYTEP T LOC NUM OPENP T) 
    160128            (GO OPN1)) 
    161            ((= CH 40) 
     129           ((= CH #\SPACE) 
    162130            (GO READ)) 
    163            ((= CH 215) 
     131           ((= CH #\CR) 
    164132            (AND OPENP SOME (CARPET-BAG LOC NUM BYTEP)) 
    165133            (GO TOP)) 
    166            ((= CH 212) 
     134           ((= CH #\LF) 
    167135            (AND OPENP SOME (CARPET-BAG LOC NUM BYTEP)) 
    168136            (SETQ LOC (+ LOC (COND (BYTEP 1) (T 2))))) 
    169            ((= CH 136) 
     137           ((= CH #/^) 
    170138            (AND OPENP SOME (CARPET-BAG LOC NUM BYTEP)) 
    171139            (SETQ LOC (- LOC (COND (BYTEP 1) (T 2))))) 
    172            ((= CH 211) 
     140           ((= CH #\TAB) 
    173141            (AND OPENP SOME (CARPET-BAG LOC NUM BYTEP)) 
    174142            (SETQ LOC (COND (SOME NUM) (T CLOC)))) 
    … …  
    187155     (GO READ) 
    188156)) 
    189  
    190 (DECLARE (SPECIAL MUNCH MUNCH-SWITCHES KBD-SUPER-IMAGE-P)) 
    191  
    192 (SETQ MUNCH '401) 
    193 ;TRY ALSO 1, 10421, 11111, 100001, ETC. 
    194  
    195 (DEFMACRO BIND-FONT ((FONT) . BODY) 
    196   `(LET ((OLD-FONT (TV:SHEET-CURRENT-FONT TERMINAL-IO))) 
    197      (FUNCALL TERMINAL-IO ':SET-CURRENT-FONT ,FONT) 
    198      (UNWIND-PROTECT (PROGN ,@BODY) 
    199        (FUNCALL TERMINAL-IO ':SET-CURRENT-FONT OLD-FONT)))) 
    200              
    201 (DEFMACRO BIND-FONT-MAP ((FONT-LIST) . BODY) 
    202   `(LET ((OLD-FONT-MAP (TV:SHEET-FONT-MAP TERMINAL-IO))) 
    203      (FUNCALL TERMINAL-IO ':SET-FONT-MAP ,FONT-LIST) 
    204      (UNWIND-PROTECT (PROGN ,@BODY) 
    205         (FUNCALL TERMINAL-IO ':SET-FONT-MAP OLD-FONT-MAP)))) 
    206  
    207 (DEFUN MUNCH (&OPTIONAL M &AUX CHC TEM FLAG TVB) 
    208   (AND M (SETQ MUNCH M)) 
    209   (BIND-FONT-MAP ('(FONTS:CPTFONT FONTS:43VXMS)) 
    210    (OR (BOUNDP 'MUNCH) 
    211        (SETQ MUNCH 1)) 
    212    (SETQ TVB (TV:SHEET-SCREEN-ARRAY TERMINAL-IO)) 
    213    (FUNCALL TERMINAL-IO ':CLEAR-SCREEN) 
    214    (OR (BOUNDP 'MUNCH-SWITCHES) 
    215        (SETQ MUNCH-SWITCHES 
    216              (CREATE-SWITCH-REGISTER TERMINAL-IO 20 NIL (* 3 (// 1100 4))))) 
    217    (FUNCALL MUNCH-SWITCHES NIL) 
    218    (FUNCALL MUNCH-SWITCHES MUNCH) 
    219    (BIND-FONT (FONTS:43VXMS) 
    220         (FUNCALL TERMINAL-IO ':SET-CURSORPOS 0 0) 
    221         (FUNCALL TERMINAL-IO ':CLEAR-EOL) 
    222         (PRINC MUNCH)) 
    223    (DO 
    224     ((AB 0) (X) (Y) (CH) (NEW-KBD-P) 
    225      (XOFF (+ (TV:SHEET-INSIDE-LEFT TERMINAL-IO) 
    226               (// (TV:SHEET-INSIDE-WIDTH TERMINAL-IO) 2) 
    227               -128.)) 
    228      (YOFF (+ 143 (TV:SHEET-INSIDE-TOP TERMINAL-IO)))) 
    229     (NIL) 
    230     L (MULTIPLE-VALUE (CH NEW-KBD-P)    ;this doesnt really get returnned yet 
    231         (KBD-TYI-NO-HANG)) 
    232     (COND ((NULL CH) (GO DIS))) 
    233     (SETQ CHC (CHAR-UPCASE (LOGAND 377 CH))) 
    234     (COND ((= CHC #\BREAK) 
    235            (RETURN NIL)) 
    236           ((= CHC #\ESCAPE) 
    237            (SETQ FLAG T) 
    238            (SETQ MUNCH (NHNWSNOOB MUNCH))) 
    239           ((MEMQ CHC '(#/0 #/1 #/2 #/3 #/4 #/5 #/6 #/7 #/8 #/9)) 
    240            (SETQ FLAG T) 
    241            (SETQ MUNCH (+ (LSH MUNCH 3) (- CHC #/0)))) 
    242           ((= CHC #\CLEAR) 
    243            (SETQ FLAG T) 
    244            (SETQ MUNCH 0)) 
    245           ((= CHC #/+) 
    246            (SETQ FLAG T) 
    247            (SETQ MUNCH (1+ MUNCH))) 
    248           ((= CHC #/) 
    249            (SETQ FLAG T) 
    250            (SETQ MUNCH (1+ (LSH MUNCH 1)))) 
    251           ((= CHC #/<) 
    252            (SETQ FLAG T) 
    253            (SETQ MUNCH (LSH MUNCH 1))) 
    254           ((= CHC #/>) 
    255            (SETQ FLAG T) 
    256            (SETQ MUNCH (LSH MUNCH -1))) 
    257           ((= CHC #\FORM) 
    258            (SETQ FLAG T)) 
    259           ((= CHC #/?) 
    260            (SETQ FLAG T) 
    261            (FUNCALL TERMINAL-IO 'SET-CURSORPOS 0 0) 
    262            (PRINC "SPACE increments, ESC does NHNWSNOOB, < is a left shift,") 
    263            (PRINC "M shift left, but shift in a 1 bit,") 
    264            (PRINC "> is a right shift, FORM clears the AC, CLEAR is like form but") 
    265            (PRINC "zeroes the switches, the center row of keys toggles the switches,") 
    266            (PRINC "CIRCLE-PLUS single steps,") 
    267            (PRINC "BREAK exits.") 
    268            (KBD-TYI) 
    269            (FUNCALL MUNCH-SWITCHES NIL)) 
    270           ((SETQ TEM (FIND-POSITION-IN-LIST 
    271                        CHC  
    272                        (COND (NEW-KBD-P '(#/\ #\LF #\CR #/' #/; #/L #/K #/J #/H #/G 
    273                                           #/F #/D #/S #/A #/W #/Q)) 
    274                              (T '(#\BACK-NEXT #\LF #\CR #/: #/; #/L #/K #/J #/H #/G 
    275                                   #/F #/D #/S #/A #\RUBOUT #\VT))))) 
    276            (SETQ FLAG T) 
    277            (SETQ MUNCH (LOGXOR MUNCH (LSH 1 TEM))))) 
    278     (COND (FLAG 
    279            (SETQ FLAG NIL) 
    280            (SETQ AB 0) 
    281            (SETQ MUNCH (LOGAND 177777 MUNCH)) 
    282            (FUNCALL TERMINAL-IO ':DRAW-RECTANGLE 256. 256. XOFF YOFF 
    283                     (TV:SHEET-ERASE-ALUF TERMINAL-IO)) 
    284            (FUNCALL MUNCH-SWITCHES MUNCH) 
    285            (BIND-FONT (FONTS:43VXMS) 
    286                       (FUNCALL TERMINAL-IO ':SET-CURSORPOS 0 0) 
    287                       (FUNCALL TERMINAL-IO ':CLEAR-EOL) 
    288                       (PRINC MUNCH)))) 
    289     (GO L) 
    290  DIS 
    291     (TV:PREPARE-SHEET (TERMINAL-IO) 
    292        (DO () ((SI:KBD-HARDWARE-CHAR-AVAILABLE)) 
    293          (SETQ AB (LOGAND 177777 (+ AB MUNCH))) 
    294          (SETQ X (LOGAND AB 377)) 
    295          (SETQ Y (+ YOFF (LOGXOR X (LDB 1010 AB)))) 
    296          (SETQ X (+ X XOFF)) 
    297          (AS-2 (LOGXOR 1 (AR-2 TVB X Y)) TVB X Y))) 
    298     (GO L)))) 
    299  
    300 (DEFUN NHNWSNOOB (A)    ;NEXT HIGHER NUMBER WITH SAME NUMBER OF ONE BITS (SEE HAKMEM) 
    301   (PROG (B C) 
    302         (AND (= A 0) (RETURN 0)) 
    303         (SETQ C (LOGAND A (- 0 A))) 
    304         (SETQ B (+ A C)) 
    305         (RETURN (LOGIOR B (// (LSH (LOGXOR A B) -2) C))))) 
    306  
    307157(LOCAL-DECLARE ((SPECIAL SR-SHEET SR-SIZE 
    308158                         X-ORG Y-ORG 
    … …  
    363213 
    364214(DEFUN MUNCHING-TUNES (&OPTIONAL (N 1001) (A 0) (M 30000) (O 3)) 
     215 (WITH-REAL-TIME 
    365216  (DO ((ACC (REMAINDER A 1000000) (REMAINDER (+ ACC N) 1000000)) 
    366217       (FREQ (LOGXOR (\ A 1000) 
    … …  
    368219             (LOGXOR (\ ACC 1000) 
    369220                     (// ACC 1000)))) 
    370       ((KBD-TYI-NO-HANG) ACC) 
    371     (SI:%BEEP (LSH FREQ O) M))) 
    372      
    373  
    374  
    375 (DEFUN HIST (L &AUX AR N) 
    376   (SETQ N (APPLY 'MAX L)) 
    377   (SETQ AR (MAKE-ARRAY NIL 
    378                        'ART-Q-LIST 
    379                        (LIST (1+ N)))) 
    380   (DO I 0 (1+ I) (> I N) 
    381     (AS-1 0 AR I)) 
    382   (DO L L (CDR L) (NULL L) 
    383     (AS-1 (1+ (AR-1 AR (CAR L))) AR (CAR L))) 
    384   (GRAPH (SETQ L (G-L-P AR)) 
    385          (MAX 1 (// 764 N)) 
    386          (MAX 1 (// 310 (APPLY 'MAX L))))) 
    387  
    388 (DEFUN GRAPH (L &OPTIONAL (XF 2) (YF 10)) 
    389   (TV-CLEAR-PC-PPR CONSOLE-IO-PC-PPR) 
    390   (TV-SET-CURSORPOS CONSOLE-IO-PC-PPR 
    391                     0 
    392                     (* 3 (// (SCREEN-HEIGHT TV-DEFAULT-SCREEN) 4))) 
    393   (PRINT -) 
    394   (DO ((I 0 (+ I XF)) 
    395        (L L (CDR L))) 
    396       ((NULL L)) 
    397     (DRAW-LINE (- I 372) 0 (- I 372) (* (CAR L) YF)))) 
    398  
    399 (DEFUN /:LISTF (DIR &AUX STR) 
    400     (SETQ DIR (STRING-TRIM '(40 73) (STRING DIR))) 
    401     (SETQ STR (OPEN (STRING-APPEND DIR ";.FILE. (DIR)") '(READ))) 
    402     (TV-CLEAR-PC-PPR CONSOLE-IO-PC-PPR) 
    403     (STREAM-COPY-UNTIL-EOF STR STANDARD-OUTPUT) 
    404     (CLOSE STR) 
    405     T) 
    406  
    407 (DEFUN /:PRINT (FILENAME &AUX S) 
    408     (SETQ S (OPEN FILENAME '(READ))) 
    409     (TV-CLEAR-PC-PPR CONSOLE-IO-PC-PPR) 
    410     (STREAM-COPY-UNTIL-EOF S STANDARD-OUTPUT) 
    411     (CLOSE S) 
    412     T) 
     221      ((FUNCALL TERMINAL-IO ':TYI-NO-HANG) 
     222       ACC) 
     223    (SI:%BEEP (LSH FREQ O) M)))) 
     224 
     225(DEFDEMO "Munching Tunes" "Computer-composed music, based on the Munching Squares algorithm." 
     226  "Munching Tunes" 
     227  ("From the beginning" "Play the whole thing from the beginning." (MUNCHING-TUNES 1001 0)) 
     228  ("Interesting" "Start in the middle at an interesting point." (MUNCHING-TUNES 1001 571565))) 
    413229 
    414230(DECLARE (SPECIAL LIVE-BOUNCE-LL)) 
    415231 
    416232(DEFUN LIVE-BOUNCE (&OPTIONAL (DELAY 0)) 
     233 (WITH-REAL-TIME 
    417234  (OR (BOUNDP 'LIVE-BOUNCE-LL) 
    418       (SETQ LIVE-BOUNCE-LL (CREATE-SWITCH-REGISTER (// 576. 2) 50. 25 T))) 
     235      (SETQ LIVE-BOUNCE-LL (CREATE-SWITCH-REGISTER TERMINAL-IO 20. 50. 25 T))) 
     236  (FUNCALL LIVE-BOUNCE-LL NIL) 
    419237  (DO ((NB 1) 
    420238       (DNB 1) 
    … …  
    422240       (LT 1) 
    423241       (COMP 0)) 
    424       ((KBD-TYI-NO-HANG)) 
     242      ((FUNCALL TERMINAL-IO ':TYI-NO-HANG)) 
    425243    (FUNCALL LIVE-BOUNCE-LL (LOGXOR LT COMP)) 
    426244    (SETQ LT (LSH LT DIR)) 
    … …  
    448266           (SETQ LT (LSH (1- (LSH 1 NB)) (- 25 NB))))) 
    449267    (DO I DELAY (1- I) (= I 0) 
    450     ))) 
    451  
    452 (DEFUN GREEN-HORNET () 
    453     (TV-CLEAR-SCREEN) 
    454     (TV-SET-CURSORPOS CONSOLE-IO-PC-PPR 560. 0) 
    455     (DO I 310 (1- I) (= I 5) 
    456       (DRAW-CIRCLE (COND ((ZEROP (LOGAND 20 I)) I) (T (- 0 I)))0 I 'XOR)) 
    457     (KBD-TYI) 
    458     T) 
    459  
    460 (DEFUN CIRCLES () 
    461     (TV-CLEAR-SCREEN) 
    462     (TV-SET-CURSORPOS CONSOLE-IO-PC-PPR 560. 0) 
    463     (DO I 200. (1- I) (= I 5) 
    464       (DRAW-CIRCLE 0 0 I)) 
    465     (KBD-TYI) 
    466     T) 
    467  
    468  
    469  
    470 (DECLARE (SPECIAL LEXIPHAGE-PC-PPR FONTS:43VXMS LEXIPHAGE-ARRAY TV-BUFFER) 
    471          (SPECIAL DRAW-SWAP-X-Y DRAW-NEGATE-Y DRAW-NEGATE-X 
    472                   DRAW-X0 DRAW-Y0 DRAW-X-OFFSET DRAW-Y-OFFSET)) 
    473  
    474 (DEFUN LEXIPHAGE (&OPTIONAL (TEXT "LEXIPHAGE") &AUX RIGHT) 
     268    )))) 
     269 
     270(DEFDEMO "Live Bounce" "A light-hack based on a program for the late SIPB PDP8/S." 
     271  (LIVE-BOUNCE)) 
     272 
     273(COMMENT 
     274;;; commented out 
     275(DEFUN GREEN-HORNET (&OPTIONAL (WINDOW TERMINAL-IO) (SEPARATION 40)) 
     276 (WITH-REAL-TIME 
     277  (FUNCALL WINDOW ':CLEAR-SCREEN) 
     278  (FUNCALL WINDOW ':HOME-DOWN) 
     279  (MULTIPLE-VALUE-BIND (IW IH) 
     280      (FUNCALL WINDOW ':INSIDE-SIZE) 
     281    (LET ((CENTER-X1 (- (// IW 2) (// SEPARATION 2))) 
     282          (CENTER-X2 (+ (// IW 2) (// SEPARATION 2))) 
     283          (CENTER-Y (// IH 2))) 
     284      (DO I (- (MIN CENTER-Y CENTER-X1) 10.) (1- I) ( 
     285 I 5) 
     286          (FUNCALL WINDOW ':DRAW-CIRCLE 
     287                   (IF (BIT-TEST 20 I) CENTER-X1 CENTER-X2) 
     288                   CENTER-Y 
     289                   I)))) 
     290  (FUNCALL WINDOW ':TYI) 
     291  T)) 
     292 
     293;;; commented out 
     294(DEFUN CIRCLES (&OPTIONAL (WINDOW TERMINAL-IO)) 
     295 (WITH-REAL-TIME 
     296  (FUNCALL WINDOW ':CLEAR-SCREEN) 
     297  (FUNCALL WINDOW ':HOME-DOWN) 
     298  (MULTIPLE-VALUE-BIND (IW IH) 
     299      (FUNCALL WINDOW ':INSIDE-SIZE) 
     300    (LET ((CENTER-X (// IW 2)) 
     301          (CENTER-Y (// IH 2))) 
     302      (DO I (- (MIN CENTER-X CENTER-Y) 40) (- I 5) ( 
     303 I 5) 
     304          (FUNCALL WINDOW ':DRAW-CIRCLE CENTER-X CENTER-Y I)))) 
     305  (FUNCALL WINDOW ':TYI) 
     306  T)) 
     307);end comment 
     308 
     309;;; The following are so boring that they should not show up on the menu. - DLW 
     310;; ;These are here to demonstrate how absurdly slow the :DRAW-CIRCLE message is 
     311;; ;Also the hornet isn't green any more, it's white 
     312;(DEFDEMO "Green Hornet" (GREEN-HORNET)) 
     313;(DEFDEMO "Circles" (CIRCLES)) 
     314 
     315(DEFCONST *LEXIPHAGE-INITIAL-DELAY* 50000.)     ; Initial delay to read string. 
     316(DEFCONST *LEXIPHAGE-PERIOD* 2000.)             ; Slowness of the phage. 
     317(DEFCONST *LEXIPHAGE-MOUTH-X* 40.)              ; Width of the whole mouth. 
     318(DEFCONST *LEXIPHAGE-MOUTH-Y* 4.)               ; Width of one jaw at right end. 
     319(DEFCONST *LEXIPHAGE-TOOTH-Y* 10.)              ; Width of tooth at right end. 
     320 
     321(DEFUN LEXIPHAGE (&OPTIONAL (STRING "LEXIPHAGE")) 
    475322  (OR (BOUNDP 'FONTS:43VXMS) 
    476       (FERROR NIL "Please load LMFONT; 43VXMS QFASL")) 
    477   (OR (BOUNDP 'LEXIPHAGE-PC-PPR) 
    478       (SETQ LEXIPHAGE-PC-PPR (TV-DEFINE-PC-PPR 'LEXIPHAGE-PC-PPR (LIST FONTS:43VXMS) 
    479                                                'BOTTOM 200. 'BLINKER-P NIL 'MORE-P NIL))) 
    480   (OR (BOUNDP 'LEXIPHAGE-ARRAY) 
    481       (SETQ LEXIPHAGE-ARRAY (MAKE-ARRAY NIL 'ART-16B '(136)))) 
    482   (TV-CLEAR-PC-PPR LEXIPHAGE-PC-PPR) 
    483   (TV-SET-CURSORPOS LEXIPHAGE-PC-PPR 140 60) 
    484   (TV-STRING-OUT LEXIPHAGE-PC-PPR TEXT) 
    485   (SETQ RIGHT (PC-PPR-CURRENT-X LEXIPHAGE-PC-PPR)) 
    486   (DO I 0 (1+ I) (= I 136) (AS-1 0 LEXIPHAGE-ARRAY I)) 
    487   (BIND (FUNCTION-CELL-LOCATION 'DRAW-PLOT) 'LEXIPHAGE-1) 
    488   (DO ((X 0 (1+ X)) 
    489        (DX 10)) 
    490       ((>= X RIGHT)) 
    491     (DRAW-LINE X 104 (+ X DX) (+ 44 DX)) 
    492     (DRAW-LINE X 104 (+ X DX) (- 144 DX)) 
    493     (DO I 0 (1+ I) (= I 1000)) 
    494     (DO I 0 (1+ I) (= I 136) (AS-2 0 TV-BUFFER (AR-1 LEXIPHAGE-ARRAY I) I)) 
    495     (SETQ DX (+ DX 1)) 
    496     (AND (>= DX 32) (SETQ DX 10))) 
    497   "LEXIPHAGE!") 
    498  
    499 (DEFUN LEXIPHAGE-1 (X Y) 
    500   (AND DRAW-SWAP-X-Y (SETQ X (PROG2 NIL Y (SETQ Y X)))) 
    501   (AND DRAW-NEGATE-Y (SETQ Y (MINUS Y))) 
    502   (AND DRAW-NEGATE-X (SETQ X (MINUS X))) 
    503   (SETQ X (+ X DRAW-X0)) 
    504   (SETQ Y (+ Y DRAW-Y0)) 
    505   (AND (>= X 0) (< X (SCREEN-WIDTH TV-DEFAULT-SCREEN)) 
    506        (>= Y 0) (< Y (SCREEN-HEIGHT TV-DEFAULT-SCREEN)) 
    507        (PROGN (AND (> X (AR-1 LEXIPHAGE-ARRAY Y)) 
    508                    (DO XX (AR-1 LEXIPHAGE-ARRAY Y) (1+ XX) (>= XX X) 
    509                      (AS-2 0 TV-BUFFER XX Y))) 
    510               (AND (< X (AR-1 LEXIPHAGE-ARRAY Y)) 
    511                    (AS-2 0 TV-BUFFER (AR-1 LEXIPHAGE-ARRAY Y) Y)) 
    512               (AS-1 X LEXIPHAGE-ARRAY Y) 
    513               (AS-2 1 TV-BUFFER X Y)))) 
    514  
    515  
     323      (LOAD "SYS:FONTS;43VXMS" "FONTS")) 
     324  (LET ((WINDOW (TV:MAKE-WINDOW 'TV:WINDOW ':BOTTOM 300. ':FONT-MAP (LIST FONTS:43VXMS) 
     325                                ':BLINKER-P NIL ':MORE-P NIL ':SAVE-BITS T ':LABEL NIL))) 
     326    (MULTIPLE-VALUE-BIND (WIDTH HEIGHT) 
     327        (FUNCALL WINDOW ':INSIDE-SIZE) 
     328      (LET* ((STRING-WIDTH (FUNCALL WINDOW ':STRING-LENGTH STRING)) 
     329             (CENTER-Y (// HEIGHT 2)) 
     330             (HALF-STRING-HEIGHT 30) 
     331             (LEFT-EDGE (MAX 0 (// (- WIDTH STRING-WIDTH) 2))) 
     332             (TOP-EDGE (MAX 0 (- CENTER-Y HALF-STRING-HEIGHT))) 
     333             (CHAR-ALUF (TV:SHEET-CHAR-ALUF WINDOW)) 
     334             (ERASE-ALUF (TV:SHEET-ERASE-ALUF WINDOW)) 
     335             ) 
     336        (TV:SHEET-FORCE-ACCESS (WINDOW) 
     337           (FUNCALL WINDOW ':CLEAR-SCREEN) 
     338           (FUNCALL WINDOW ':SET-CURSORPOS LEFT-EDGE TOP-EDGE) 
     339           (FUNCALL WINDOW ':STRING-OUT STRING)) 
     340        (TV:WINDOW-CALL (WINDOW :DEACTIVATE) 
     341          (WITH-REAL-TIME 
     342            ;; Initial delay, so user can read the string. 
     343            (DOTIMES (I *LEXIPHAGE-INITIAL-DELAY*)) 
     344            (DO ((X (- LEFT-EDGE 100) (1+ X)) 
     345                 (DY 0) 
     346                 (END-X (- (+ LEFT-EDGE STRING-WIDTH 30)        ; Fudge by 30 
     347                           *LEXIPHAGE-MOUTH-X*))) 
     348                (( 
     349 X END-X)) 
     350              (SETQ DY (IF (ZEROP DY) HALF-STRING-HEIGHT (1- DY))) 
     351              (FUNCALL WINDOW ':DRAW-TRIANGLE 
     352                       X CENTER-Y 
     353                       (+ X *LEXIPHAGE-MOUTH-X*) (+ CENTER-Y DY) 
     354                       (+ X *LEXIPHAGE-MOUTH-X*) (+ CENTER-Y (- DY *LEXIPHAGE-MOUTH-Y*)) 
     355                       CHAR-ALUF) 
     356              (FUNCALL WINDOW ':DRAW-TRIANGLE 
     357                       X CENTER-Y 
     358                       (+ X *LEXIPHAGE-MOUTH-X*) (- CENTER-Y DY) 
     359                       (+ X *LEXIPHAGE-MOUTH-X*) (- CENTER-Y (- DY *LEXIPHAGE-MOUTH-Y*)) 
     360                       CHAR-ALUF) 
     361              (FUNCALL WINDOW ':DRAW-TRIANGLE 
     362                       (+ X *LEXIPHAGE-MOUTH-X*) (+ CENTER-Y (- DY *LEXIPHAGE-MOUTH-Y*)) 
     363                       (+ X *LEXIPHAGE-MOUTH-X*) (+ CENTER-Y (- DY *LEXIPHAGE-TOOTH-Y*)) 
     364                       (+ X (FIX (* 0.9S0 *LEXIPHAGE-MOUTH-X*))) 
     365                       (+ CENTER-Y (FIX (* 0.9S0 (- DY *LEXIPHAGE-MOUTH-Y*)))) 
     366                       CHAR-ALUF) 
     367              (FUNCALL WINDOW ':DRAW-TRIANGLE 
     368                       (+ X *LEXIPHAGE-MOUTH-X*) (- CENTER-Y (- DY *LEXIPHAGE-MOUTH-Y*)) 
     369                       (+ X *LEXIPHAGE-MOUTH-X*) (- CENTER-Y (- DY *LEXIPHAGE-TOOTH-Y*)) 
     370                       (+ X (FIX (* 0.9S0 *LEXIPHAGE-MOUTH-X*))) 
     371                       (- CENTER-Y (FIX (* 0.9S0 (- DY *LEXIPHAGE-MOUTH-Y*)))) 
     372                       CHAR-ALUF) 
     373              (DOTIMES (I *LEXIPHAGE-PERIOD*)) 
     374              (FUNCALL WINDOW ':DRAW-TRIANGLE 
     375                       X CENTER-Y 
     376                       (+ X *LEXIPHAGE-MOUTH-X*) (+ CENTER-Y DY) 
     377                       (+ X *LEXIPHAGE-MOUTH-X*) (+ CENTER-Y (- DY *LEXIPHAGE-MOUTH-Y*)) 
     378                       ERASE-ALUF) 
     379              (FUNCALL WINDOW ':DRAW-TRIANGLE 
     380                       X CENTER-Y 
     381                       (+ X *LEXIPHAGE-MOUTH-X*) (+ CENTER-Y DY) 
     382                       X (+ CENTER-Y DY) 
     383                       ERASE-ALUF) 
     384              (FUNCALL WINDOW ':DRAW-TRIANGLE 
     385                       (+ X *LEXIPHAGE-MOUTH-X*) (+ CENTER-Y (- DY *LEXIPHAGE-MOUTH-Y*)) 
     386                       (+ X *LEXIPHAGE-MOUTH-X*) (+ CENTER-Y (- DY *LEXIPHAGE-TOOTH-Y*)) 
     387                       (+ X (FIX (* 0.8S0 *LEXIPHAGE-MOUTH-X*))) 
     388                       (+ CENTER-Y (FIX (* 0.8S0 (- DY *LEXIPHAGE-MOUTH-Y*)))) 
     389                       ERASE-ALUF) 
     390              (FUNCALL WINDOW ':DRAW-TRIANGLE 
     391                       (+ X *LEXIPHAGE-MOUTH-X*) (- CENTER-Y (- DY *LEXIPHAGE-MOUTH-Y*)) 
     392                       (+ X *LEXIPHAGE-MOUTH-X*) (- CENTER-Y (- DY *LEXIPHAGE-TOOTH-Y*)) 
     393                       (+ X (FIX (* 0.8S0 *LEXIPHAGE-MOUTH-X*))) 
     394                       (- CENTER-Y (FIX (* 0.8S0 (- DY *LEXIPHAGE-MOUTH-Y*)))) 
     395                       ERASE-ALUF) 
     396              (FUNCALL WINDOW ':DRAW-TRIANGLE 
     397                       X CENTER-Y 
     398                       (+ X *LEXIPHAGE-MOUTH-X*) (- CENTER-Y DY) 
     399                       (+ X *LEXIPHAGE-MOUTH-X*) (- CENTER-Y (- DY *LEXIPHAGE-MOUTH-Y*)) 
     400                       ERASE-ALUF) 
     401              (FUNCALL WINDOW ':DRAW-TRIANGLE 
     402                       X CENTER-Y 
     403                       (+ X *LEXIPHAGE-MOUTH-X*) (- CENTER-Y DY) 
     404                       X (- CENTER-Y DY) 
     405                       ERASE-ALUF))))))) 
     406  "Lexiphage!") 
     407 
     408(DEFDEMO "Lexiphage" "The word eater, based on a hack by John Doty." (LEXIPHAGE)) 
    516409 
    517410(DECLARE (SPECIAL MF10-HACK5-BAR)) 
    518411 
    519 (DEFUN MF10-HACK5 (&OPTIONAL (ZAP 100) (13357ALIAS 13357)) 
    520    (OR (BOUNDP 'MF10-HACK5-BAR) 
    521        (SETQ MF10-HACK5-BAR (CREATE-SWITCH-REGISTER (// 576. 2) 100 20 T))) 
    522    (DO I 13357ALIAS (ROT I 1) (KBD-TYI-NO-HANG) 
    523      (FUNCALL MF10-HACK5-BAR I) 
    524      (DO J 0 (+ J 1) (= J ZAP) 
    525          ))) 
    526  
    527 (DEFVAR PRINT-BIG-PREVIOUS) 
     412(DEFUN MF10-HACK5 (&OPTIONAL (ZAP 1000) (13357ALIAS 13357)) 
     413 (WITH-REAL-TIME 
     414  (FUNCALL TERMINAL-IO ':CLEAR-SCREEN) 
     415  (FUNCALL TERMINAL-IO ':HOME-DOWN) 
     416  (OR (BOUNDP 'MF10-HACK5-BAR) 
     417      (SETQ MF10-HACK5-BAR (CREATE-SWITCH-REGISTER TERMINAL-IO 20 100 20 T))) 
     418  (FUNCALL MF10-HACK5-BAR NIL) 
     419  (DO I 13357ALIAS (ROT I 1) (FUNCALL TERMINAL-IO ':TYI-NO-HANG) 
     420      (FUNCALL MF10-HACK5-BAR I) 
     421      (DO J 0 (+ J 1) (= J ZAP) 
     422          )))) 
     423 
     424(DEFVAR PRINT-BIG-PREVIOUS NIL) 
    528425 
    529426(DEFUN PRINT-BIG (&OPTIONAL (FONT PRINT-BIG-PREVIOUS)) 
    … …  
    604501                       FREE-QS))) 
    605502 
    606 ;(own-closure ((foo nil) (baz (gos hawk))) (function rumplestiltskin)) 
    607 ; 
    608 ;(defmacro own-closure (vars-and-inits fcn) 
    609 ;  `((lambda ,(mapcar (function car) vars-and-inits) 
    610 ;       (closure ',(mapcar (function car) vars-and-inits) fcn)) 
    611 ;    ,@(mapcar (function cadr) vars-and-inits))) 
    612  
    613  
    614 (DEFUN TV-DEMO () 
    615     (TV-CLEAR-ALL) 
    616     (TV-SET-CURSORPOS CONSOLE-IO-PC-PPR 0 0) 
    617     (DO ((CHANNEL 0 (1+ CHANNEL)) 
    618          (BIT 1 (LSH BIT 1))) 
    619         ((>= CHANNEL 4) (TV-SELECT 0) NIL) 
    620       (TV-SELECT CHANNEL) 
    621       (DO ((SEC 0 (1+ SEC)) 
    622            (SEC2 0 (+ 2 SEC2)) 
    623            (X)) 
    624           ((= SEC 20)) 
    625         (SETQ X (COND ((ZEROP (LOGAND BIT SEC)) 0) 
    626                       (T -1))) 
    627         (DO I 0 (+ I 44) (>= I 37000) 
    628           (AS-1 X TV-BUFFER-WORDS (+ I SEC2)) 
    629           (AS-1 X TV-BUFFER-WORDS (1+ (+ I SEC2)))))) 
    630     (KBD-TYI) 
    631     NIL) 
    632  
    633  
    634 (DEFUN TV-SELECT (&OPTIONAL (CHANNEL 0)) 
    635        (%UNIBUS-WRITE 776660 
    636                       (DPB CHANNEL 1003 (%UNIBUS-READ 776660)))) 
    637  
    638 (DEFUN FLASH ( &AUX (SCREEN-HEIGHT (SCREEN-HEIGHT TV-DEFAULT-SCREEN)) 
    639                     (SCREEN-WIDTH (SCREEN-WIDTH TV-DEFAULT-SCREEN)) 
    640                     (SIZE (MIN SCREEN-WIDTH SCREEN-HEIGHT))) 
    641     (TV-CLEAR-SCREEN) 
    642     (DO ((LEFT 0 (1+ LEFT)) 
    643          (WIDTH SIZE (- WIDTH 2)) 
    644          (TOP 0 (1+ TOP)) 
    645          (HEIGHT SIZE (- HEIGHT 2))) 
    646         ((<= HEIGHT 1) (KBD-TYI) NIL) 
    647       (TV-ERASE WIDTH HEIGHT LEFT TOP TV-ALU-XOR))) 
    648  
    649 (DEFUN FLOSH ( &AUX (SCREEN-HEIGHT (SCREEN-HEIGHT TV-DEFAULT-SCREEN)) 
    650                     (SCREEN-WIDTH (SCREEN-WIDTH TV-DEFAULT-SCREEN)) 
    651                     (SIZE (MIN SCREEN-WIDTH SCREEN-HEIGHT))) 
    652     (TV-CLEAR-SCREEN) 
    653     (DO ((LEFT (// SIZE 2) (1- LEFT)) 
    654          (WIDTH 0 (+ WIDTH 2)) 
    655          (TOP (// SIZE 2) (1- TOP)) 
    656          (HEIGHT 0 (+ HEIGHT 2))) 
    657         ((>= HEIGHT SIZE) (KBD-TYI) NIL) 
    658       (TV-ERASE WIDTH HEIGHT LEFT TOP TV-ALU-XOR))) 
    659  
    660  
    661 (DECLARE (SPECIAL DISPLAY-LOCATION-EXAMINE-LIGHTS)) 
    662503 
    663504(DEFUN DISPLAY-MOUSE-REGS NIL 
    664505  (DISPLAY-UNIBUS-LOCATION TV:MOUSE-REG1 TV:MOUSE-REG2)) 
    665506 
    666 (DEFUN DISPLAY-UNIBUS-LOCATION (&REST ADDRESS-LIST &AUX (N (LENGTH ADDRESS-LIST))) 
    667        (COND ((NOT (BOUNDP 'DISPLAY-LOCATION-EXAMINE-LIGHTS)) 
    668               (SETQ DISPLAY-LOCATION-EXAMINE-LIGHTS (MAKE-ARRAY NIL ART-Q 12.)) 
    669               (DO I 0 (1+ I) (>= I 12.) 
    670                   (AS-1 (CREATE-SWITCH-REGISTER TERMINAL-IO 16. NIL  (+ (* I 44) 40) T) 
    671                         DISPLAY-LOCATION-EXAMINE-LIGHTS  
    672                         I)))) 
    673        (FUNCALL TERMINAL-IO ':CLEAR-SCREEN) 
    674        (DO I 0 (1+ I) (>= I N) 
    675          (FUNCALL (AR-1 DISPLAY-LOCATION-EXAMINE-LIGHTS I) NIL)) 
    676        (DO NIL ((EQ 203 (KBD-TYI-NO-HANG))) 
    677          (DO ((I 0 (1+ I)) 
    678               (L ADDRESS-LIST (CDR L))) 
    679              ((>= I N)) 
    680            (FUNCALL (AR-1 DISPLAY-LOCATION-EXAMINE-LIGHTS I) 
    681                     (%UNIBUS-READ (CAR L)))))) 
    682  
    683 (DEFUN RANDOM-TEST (&AUX TEM) 
    684     (TV-CLEAR-SCREEN) 
     507(DEFUN DISPLAY-UNIBUS-LOCATION (&REST ADDRESS-LIST) 
     508  (LEXPR-FUNCALL 'DISPLAY-LOCATION '%UNIBUS-READ 16. ADDRESS-LIST)) 
     509 
     510(DEFUN DISPLAY-CC-KEYBOARD-REGS NIL 
     511  (DISPLAY-CC-UNIBUS-LOCATION 764112 764102 764100)) 
     512 
     513(DEFUN DISPLAY-CC-MOUSE-REGS NIL 
     514  (DISPLAY-CC-UNIBUS-LOCATION TV:MOUSE-REG1 TV:MOUSE-REG2)) 
     515 
     516(DEFUN DISPLAY-CC-UNIBUS-LOCATION (&REST ADDRESS-LIST) 
     517  (LEXPR-FUNCALL 'DISPLAY-LOCATION 'CADR:DBG-READ 16. ADDRESS-LIST)) 
     518 
     519(DEFUN DISPLAY-XBUS-LOCATION (&REST ADDRESS-LIST) 
     520  (LEXPR-FUNCALL 'DISPLAY-LOCATION '%XBUS-READ 32. ADDRESS-LIST)) 
     521 
     522(DEFUN DISPLAY-LOCATION (FCTN BITS &REST ADDRESS-LIST) 
     523  (LET* ((N (LENGTH ADDRESS-LIST)) 
     524         (LITES (MAKE-ARRAY NIL ART-Q N))) 
     525    (DOTIMES (I N) 
     526      (AS-1 (CREATE-SWITCH-REGISTER TERMINAL-IO BITS NIL  (+ (* I 44) 40) T) 
     527            LITES 
     528            I)) 
     529    (FUNCALL TERMINAL-IO ':CLEAR-SCREEN) 
     530    (DOTIMES (I N) 
     531      (FUNCALL (AR-1 LITES I) NIL)) 
     532    (DO NIL ((EQ 203 (FUNCALL TERMINAL-IO ':TYI-NO-HANG))) 
     533      (DO ((I 0 (1+ I)) 
     534           (L ADDRESS-LIST (CDR L))) 
     535          ((>= I N)) 
     536        (FUNCALL (AR-1 LITES I) 
     537                 (FUNCALL FCTN (CAR L))))))) 
     538 
     539(DEFUN RANDOM-TEST (&OPTIONAL (WINDOW TERMINAL-IO) &AUX TEM) 
     540    (FUNCALL WINDOW ':CLEAR-SCREEN) 
    685541    (DO () (()) 
    686542      (SETQ TEM (RANDOM)) 
    687       (AND (KBD-TYI-NO-HANG) (RETURN NIL)) 
    688       (AS-2 1 TV-BUFFER (LDB 2010 TEM) (LDB 1010 TEM)))) 
    689  
    690 ;; Print "Random Numerals", used in ancient Rand.   DLW 1/8/78  
    691  
    692 (DECLARE (SPECIAL ROMAN-STREAM ROMAN-OLD)) 
    693 (SETQ ROMAN-OLD NIL) 
    694  
    695 (DEFUN ROMAN-STEP (X N) 
    696     (COND ((> X 9.) 
    697            (ROMAN-STEP (// X 10.) (1+ N)) 
    698            (SETQ X (\ X 10.)))) 
    699     (COND ((AND (= X 9) (NOT ROMAN-OLD)) 
    700            (ROMAN-CHAR 0 N) 
    701            (ROMAN-CHAR 0 (1+ N))) 
    702           ((= X 5) 
    703            (ROMAN-CHAR 1 N)) 
    704           ((AND (= X 4) (NOT ROMAN-OLD)) 
    705            (ROMAN-CHAR 0 N) 
    706            (ROMAN-CHAR 1 N)) 
    707           (T (COND ((> X 5) 
    708                     (ROMAN-CHAR 1 N) 
    709                     (SETQ X (- X 5)))) 
    710              (DO I 0 (1+ I) (>= I X) 
    711                (ROMAN-CHAR 0 N))))) 
    712  
    713 (DEFUN ROMAN-CHAR (I X) 
    714     (FUNCALL ROMAN-STREAM 'TYO (NTH (+ I X X) '(#/I #/V #/X #/L #/C #/D #/M)))) 
    715  
    716 (DEFUN ROMAN-PRINC (X ROMAN-STREAM) 
    717     (SETQ X (- X)) 
    718     (COND ((AND (< X 4000.) 
    719                 (> X 0)) 
    720            (ROMAN-STEP X 0)) 
    721           (T (LET ((BASE 10.)) 
    722                   (PRINC X ROMAN-STREAM))))) 
    723  
    724 (DEFPROP ROMAN ROMAN-PRINC PRINC-FUNCTION) 
    725  
    726 ;; (SETQ BASE 'ROMAN-OLD) will print out in old-style Roman numerals. 
    727 (DEFUN ROMAN-OLD-PRINC (X ROMAN-STREAM) 
    728    (LET ((ROMAN-OLD T)) 
    729      (ROMAN-PRINC X ROMAN-STREAM))) 
    730  
    731 (DEFPROP ROMAN-OLD ROMAN-OLD-PRINC PRINC-FUNCTION) 
    732  
    733 (comment 
    734 (DEFUN STACKS ( &AUX SG RP SP) 
    735     (SETQ SG SI:%CURRENT-STACK-GROUP-PREVIOUS-STACK-GROUP) 
    736     (DO ((STACK (SG-REGULAR-PDL SG) (SG-SPECIAL-PDL SG)) 
    737          (START (SG-REGULAR-PDL-POINTER SG) (SG-SPECIAL-PDL-POINTER SG)) 
    738          (MESS "Regular PDL" "Special PDL") 
    739          (KLUDGE 0 (1+ KLUDGE))) 
    740         ((>= KLUDGE 2) T) 
    741       (TERPRI) (TERPRI) (PRINC MESS) (TERPRI) 
    742       (DO I 0 (1+ I) (> I START) 
    743         (COND ((= 1 (%P-FLAG-BIT (AP-1-CAREFUL STACK I))) 
    744                (TYO #/*)) 
    745               (T (TYO 40))) 
    746         (PRINC I) (TYO 40) 
    747         (PRIN1-C-LOCATIVE-CAREFUL (AP-1-CAREFUL STACK I)) (TERPRI)))) 
    748  
    749 (DEFUN SKIP-INTERNAL ( &AUX RP SFP SFP1 PTR1 OFFSET) 
    750     (SETQ RP (SG-REGULAR-PDL SI:%CURRENT-STACK-GROUP)) 
    751     (SETQ SFP (- (%POINTER-DIFFERENCE (%STACK-FRAME-POINTER) RP) 2)) 
    752     (SETQ SFP1 (- SFP (RP-DELTA-TO-ACTIVE-BLOCK RP SFP))) 
    753     (SETQ SFP1 (- SFP1 (RP-DELTA-TO-ACTIVE-BLOCK RP SFP1))) 
    754     (SETQ SFP1 (- SFP1 (RP-DELTA-TO-ACTIVE-BLOCK RP SFP1))) 
    755     (SETQ PTR1 (AP-1 RP SFP1)) 
    756     (SETQ OFFSET (+ 3 (RP-LOCAL-BLOCK-ORIGIN RP SFP1))) 
    757     (%P-STORE-CONTENTS-OFFSET (CDR (%P-CONTENTS-OFFSET PTR1 OFFSET)) PTR1 OFFSET)) 
    758  
    759 (DEFUN SKIPA (&QUOTE VAR FORM) 
    760    (SET VAR (EVAL FORM)) 
    761    (SKIP-INTERNAL)) 
    762  
    763 (DEFUN SKIPE (&QUOTE VAR FORM) 
    764    (SET VAR (EVAL FORM)) 
    765    (AND (ZEROP (SYMEVAL VAR)) 
    766         (SKIP-INTERNAL))) 
    767  
    768 (DEFUN SKIPN (&QUOTE VAR FORM) 
    769    (SET VAR (EVAL FORM)) 
    770    (OR (ZEROP (SYMEVAL VAR)) 
    771        (SKIP-INTERNAL))) 
    772 );end comment 
    773  
    774 (defun dance (&optional (mina 100) (maxa 456) (minb 200) (maxb 565) 
     543      (AND (FUNCALL TERMINAL-IO ':TYI-NO-HANG) (RETURN NIL)) 
     544      (FUNCALL WINDOW ':DRAW-POINT (LDB 2010 TEM) (LDB 1010 TEM)))) 
     545 
     546(defun dance (&optional (WINDOW TERMINAL-IO) 
     547                        (mina 100) (maxa 456) (minb 200) (maxb 565) 
    775548                        (minc 60) (maxc 1076) (mind 300) (maxd 1100)) 
    776        (tv-draw-line mina minb maxc maxd tv-alu-xor tv-default-screen) 
     549 (WITH-REAL-TIME 
     550       (FUNCALL WINDOW ':DRAW-LINE mina minb maxc maxd tv:alu-xor) 
    777551       (do ((a mina) 
    778552            (b minb) 
    … …  
    784558            (dc -1) 
    785559            (dd -1)) 
    786          ((kbd-tyi-no-hang)) 
    787          (setq oa a ob b oc c od d) 
    788          (setq a (+ a da)) 
    789          (cond ((= da 1) 
    790                 (cond (( 
     560         ((funcall terminal-io ':tyi-no-hang) 
     561          (FUNCALL WINDOW ':draw-line a b c d tv:alu-xor)) 
     562       (setq oa a ob b oc c od d) 
     563       (setq a (+ a da)) 
     564       (cond ((= da 1) 
     565              (cond (( 
    791566 a maxa) 
    792                        (setq da -1)))) 
    793                (( 
     567                     (setq da -1)))) 
     568             (( 
    794569 a mina) 
    795                 (setq da 1))) 
    796          (setq b (+ b db)) 
    797          (cond ((= db 1) 
    798                 (cond (( 
     570              (setq da 1))) 
     571       (setq b (+ b db)) 
     572       (cond ((= db 1) 
     573              (cond (( 
    799574 b maxb) 
    800                        (setq db -1)))) 
    801                (( 
     575                     (setq db -1)))) 
     576             (( 
    802577 b minb) 
    803                 (setq db 1))) 
    804          (setq c (+ c dc)) 
    805          (cond ((= dc 1) 
    806                 (cond (( 
     578              (setq db 1))) 
     579       (setq c (+ c dc)) 
     580       (cond ((= dc 1) 
     581              (cond (( 
    807582 c maxc) 
    808                        (setq dc -1)))) 
    809                (( 
     583                     (setq dc -1)))) 
     584             (( 
    810585 c minc) 
    811                 (setq dc 1))) 
    812          (setq d (+ d dd)) 
    813          (cond ((= dd 1) 
    814                 (cond (( 
     586              (setq dc 1))) 
     587       (setq d (+ d dd)) 
     588       (cond ((= dd 1) 
     589              (cond (( 
    815590 d maxd) 
    816                        (setq dd -1)))) 
    817                (( 
     591                     (setq dd -1)))) 
     592             (( 
    818593 d mind) 
    819                 (setq dd 1))) 
    820          (tv-draw-line a b c d tv-alu-xor tv-default-screen) 
    821          (tv-draw-line oa ob oc od tv-alu-xor tv-default-screen))) 
    822  
    823 (defun spazz (&aux (mina (random (screen-x2 tv-default-screen))) 
    824                    (minc (random (screen-x2 tv-default-screen))) 
    825                    (minb (random (screen-y2 tv-default-screen))) 
    826                    (mind (random (screen-y2 tv-default-screen))) 
    827                    (awid (random (- (screen-x2 tv-default-screen) mina))) 
    828                    (cwid (random (- (screen-x2 tv-default-screen) minc))) 
    829                    (bwid (random (- (screen-y2 tv-default-screen) minb))) 
    830                    (dwid (random (- (screen-y2 tv-default-screen) mind)))) 
    831   (dance mina (+ mina awid) minb (+ minb bwid) minc (+ minc cwid) mind (+ mind dwid))) 
    832  
    833 (declare (special rcavic-saved-array rcavic-hacked-array rcavic-hacked-16b-array)) 
    834 (defun rcavic (&optional (screen tv-default-screen) (interval 3000000) &aux array 
    835                        16b-array len) 
    836     (setq array (screen-buffer-pixel-array screen) 
    837           16b-array (screen-buffer-halfword-array screen) 
    838           len (array-length 16b-array)) 
    839     (or (boundp 'rcavic-saved-array) 
    840         (let ((dims (arraydims (screen-buffer-pixel-array screen)))) 
    841          (setq rcavic-saved-array (make-array nil (car dims) (cdr dims)) 
    842                rcavic-hacked-array (make-array nil (car dims) (cdr dims)) 
    843                rcavic-hacked-16b-array (make-array nil 'art-16b len rcavic-hacked-array)))) 
    844     (do ((i 0 (1+ i)) 
    845          (j (1- len) (1- j))) 
    846         ((< j 0)) 
    847         (do ((arg (ar-1 16b-array i) (lsh arg -1)) 
    848              (val 0) 
    849              (bit 100000 (lsh bit -1))) 
    850             ((zerop arg) (as-1 val rcavic-hacked-16b-array j)) 
    851             (and (bit-test arg 1) 
    852                  (setq val (logior val bit))))) 
    853     (bitblt tv-alu-seta (screen-width screen) (screen-height screen) 
    854              array 0 0 rcavic-saved-array 0 0) 
    855     (do i 0 (1+ i) ( 
    856  i 3) (tv-beep)) 
    857     (bitblt tv-alu-seta (screen-width screen) (screen-height screen) 
    858              rcavic-hacked-array 0 0 array 0 0) 
    859     (do i 0 (1+ i) ( 
    860  i interval)) 
    861     (bitblt tv-alu-seta (screen-width screen) (screen-height screen) 
    862             rcavic-saved-array 0 0 array 0 0)) 
     594              (setq dd 1))) 
     595       (FUNCALL WINDOW ':draw-line a b c d tv:alu-xor) 
     596       (FUNCALL WINDOW ':draw-line oa ob oc od tv:alu-xor)))) 
     597 
     598(defun spazz (&OPTIONAL (WINDOW TERMINAL-IO)) 
     599  (MULTIPLE-VALUE-BIND (X2 Y2) 
     600      (FUNCALL WINDOW ':INSIDE-SIZE) 
     601    (LET* ((mina (random x2)) 
     602           (minc (random x2)) 
     603           (minb (random y2)) 
     604           (mind (random y2)) 
     605           (awid (random (- x2 mina))) 
     606           (cwid (random (- x2 minc))) 
     607           (bwid (random (- y2 minb))) 
     608           (dwid (random (- y2 mind)))) 
     609      (dance WINDOW 
     610             mina (+ mina awid) minb (+ minb bwid) minc (+ minc cwid) mind (+ mind dwid))))) 
     611 
     612(COMMENT ;This is not really very interesting by today's standards. 
     613(DEFDEMO "Dance" "An animated line moving around on the screen." "Dance" 
     614         ("Normal" "" (DANCE)) 
     615         ("Spastic" "" (SPAZZ))) 
     616) 
     617