Changeset 287


Ignore:
Timestamp:
08/18/11 18:26:42 (3 years ago)
Author:
rjs
Message:

Update from System 78.

File:
1 edited

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))
     
    605502                       FREE-QS)))
    606503
    607 ;(own-closure ((foo nil) (baz (gos hawk))) (function rumplestiltskin))
    608 ;
    609 ;(defmacro own-closure (vars-and-inits fcn)
    610 ;  `((lambda ,(mapcar (function car) vars-and-inits)
    611 ;       (closure ',(mapcar (function car) vars-and-inits) fcn))
    612 ;    ,@(mapcar (function cadr) vars-and-inits)))
    613 
    614 
    615 (DEFUN TV-DEMO ()
    616     (TV-CLEAR-ALL)
    617     (TV-SET-CURSORPOS CONSOLE-IO-PC-PPR 0 0)
    618     (DO ((CHANNEL 0 (1+ CHANNEL))
    619          (BIT 1 (LSH BIT 1)))
    620         ((>= CHANNEL 4) (TV-SELECT 0) NIL)
    621       (TV-SELECT CHANNEL)
    622       (DO ((SEC 0 (1+ SEC))
    623            (SEC2 0 (+ 2 SEC2))
    624            (X))
    625           ((= SEC 20))
    626         (SETQ X (COND ((ZEROP (LOGAND BIT SEC)) 0)
    627                       (T -1)))
    628         (DO I 0 (+ I 44) (>= I 37000)
    629           (AS-1 X TV-BUFFER-WORDS (+ I SEC2))
    630           (AS-1 X TV-BUFFER-WORDS (1+ (+ I SEC2))))))
    631     (KBD-TYI)
    632     NIL)
    633 
    634 
    635 (DEFUN TV-SELECT (&OPTIONAL (CHANNEL 0))
    636        (%UNIBUS-WRITE 776660
    637                       (DPB CHANNEL 1003 (%UNIBUS-READ 776660))))
    638 
    639 (DEFUN FLASH ( &AUX (SCREEN-HEIGHT (SCREEN-HEIGHT TV-DEFAULT-SCREEN))
    640                     (SCREEN-WIDTH (SCREEN-WIDTH TV-DEFAULT-SCREEN))
    641                     (SIZE (MIN SCREEN-WIDTH SCREEN-HEIGHT)))
    642     (TV-CLEAR-SCREEN)
    643     (DO ((LEFT 0 (1+ LEFT))
    644          (WIDTH SIZE (- WIDTH 2))
    645          (TOP 0 (1+ TOP))
    646          (HEIGHT SIZE (- HEIGHT 2)))
    647         ((<= HEIGHT 1) (KBD-TYI) NIL)
    648       (TV-ERASE WIDTH HEIGHT LEFT TOP TV-ALU-XOR)))
    649 
    650 (DEFUN FLOSH ( &AUX (SCREEN-HEIGHT (SCREEN-HEIGHT TV-DEFAULT-SCREEN))
    651                     (SCREEN-WIDTH (SCREEN-WIDTH TV-DEFAULT-SCREEN))
    652                     (SIZE (MIN SCREEN-WIDTH SCREEN-HEIGHT)))
    653     (TV-CLEAR-SCREEN)
    654     (DO ((LEFT (// SIZE 2) (1- LEFT))
    655          (WIDTH 0 (+ WIDTH 2))
    656          (TOP (// SIZE 2) (1- TOP))
    657          (HEIGHT 0 (+ HEIGHT 2)))
    658         ((>= HEIGHT SIZE) (KBD-TYI) NIL)
    659       (TV-ERASE WIDTH HEIGHT LEFT TOP TV-ALU-XOR)))
    660 
    661 
    662 (DECLARE (SPECIAL DISPLAY-LOCATION-EXAMINE-LIGHTS))
    663504
    664505(DEFUN DISPLAY-MOUSE-REGS NIL
    665506  (DISPLAY-UNIBUS-LOCATION TV:MOUSE-REG1 TV:MOUSE-REG2))
    666507
    667 (DEFUN DISPLAY-UNIBUS-LOCATION (&REST ADDRESS-LIST &AUX (N (LENGTH ADDRESS-LIST)))
    668        (COND ((NOT (BOUNDP 'DISPLAY-LOCATION-EXAMINE-LIGHTS))
    669               (SETQ DISPLAY-LOCATION-EXAMINE-LIGHTS (MAKE-ARRAY NIL ART-Q 12.))
    670               (DO I 0 (1+ I) (>= I 12.)
    671                   (AS-1 (CREATE-SWITCH-REGISTER TERMINAL-IO 16. NIL  (+ (* I 44) 40) T)
    672                         DISPLAY-LOCATION-EXAMINE-LIGHTS
    673                         I))))
    674        (FUNCALL TERMINAL-IO ':CLEAR-SCREEN)
    675        (DO I 0 (1+ I) (>= I N)
    676          (FUNCALL (AR-1 DISPLAY-LOCATION-EXAMINE-LIGHTS I) NIL))
    677        (DO NIL ((EQ 203 (KBD-TYI-NO-HANG)))
    678          (DO ((I 0 (1+ I))
    679               (L ADDRESS-LIST (CDR L)))
    680              ((>= I N))
    681            (FUNCALL (AR-1 DISPLAY-LOCATION-EXAMINE-LIGHTS I)
    682                     (%UNIBUS-READ (CAR L))))))
    683 
    684 (DEFUN RANDOM-TEST (&AUX TEM)
    685     (TV-CLEAR-SCREEN)
     508(DEFUN DISPLAY-UNIBUS-LOCATION (&REST ADDRESS-LIST)
     509  (LEXPR-FUNCALL 'DISPLAY-LOCATION '%UNIBUS-READ 16. ADDRESS-LIST))
     510
     511(DEFUN DISPLAY-CC-KEYBOARD-REGS NIL
     512  (DISPLAY-CC-UNIBUS-LOCATION 764112 764102 764100))
     513
     514(DEFUN DISPLAY-CC-MOUSE-REGS NIL
     515  (DISPLAY-CC-UNIBUS-LOCATION TV:MOUSE-REG1 TV:MOUSE-REG2))
     516
     517(DEFUN DISPLAY-CC-UNIBUS-LOCATION (&REST ADDRESS-LIST)
     518  (LEXPR-FUNCALL 'DISPLAY-LOCATION 'CADR:DBG-READ 16. ADDRESS-LIST))
     519
     520(DEFUN DISPLAY-XBUS-LOCATION (&REST ADDRESS-LIST)
     521  (LEXPR-FUNCALL 'DISPLAY-LOCATION '%XBUS-READ 32. ADDRESS-LIST))
     522
     523(DEFUN DISPLAY-LOCATION (FCTN BITS &REST ADDRESS-LIST)
     524  (LET* ((N (LENGTH ADDRESS-LIST))
     525         (LITES (MAKE-ARRAY NIL ART-Q N)))
     526    (DOTIMES (I N)
     527      (AS-1 (CREATE-SWITCH-REGISTER TERMINAL-IO BITS NIL  (+ (* I 44) 40) T)
     528            LITES
     529            I))
     530    (FUNCALL TERMINAL-IO ':CLEAR-SCREEN)
     531    (DOTIMES (I N)
     532      (FUNCALL (AR-1 LITES I) NIL))
     533    (DO NIL ((EQ 203 (FUNCALL TERMINAL-IO ':TYI-NO-HANG)))
     534      (DO ((I 0 (1+ I))
     535           (L ADDRESS-LIST (CDR L)))
     536          ((>= I N))
     537        (FUNCALL (AR-1 LITES I)
     538                 (FUNCALL FCTN (CAR L)))))))
     539
     540(DEFUN RANDOM-TEST (&OPTIONAL (WINDOW TERMINAL-IO) &AUX TEM)
     541    (FUNCALL WINDOW ':CLEAR-SCREEN)
    686542    (DO () (())
    687543      (SETQ TEM (RANDOM))
    688       (AND (KBD-TYI-NO-HANG) (RETURN NIL))
    689       (AS-2 1 TV-BUFFER (LDB 2010 TEM) (LDB 1010 TEM))))
    690 
    691 ;; Print "Random Numerals", used in ancient Rand.   DLW 1/8/78
    692 
    693 (DECLARE (SPECIAL ROMAN-STREAM ROMAN-OLD))
    694 (SETQ ROMAN-OLD NIL)
    695 
    696 (DEFUN ROMAN-STEP (X N)
    697     (COND ((> X 9.)
    698            (ROMAN-STEP (// X 10.) (1+ N))
    699            (SETQ X (\ X 10.))))
    700     (COND ((AND (= X 9) (NOT ROMAN-OLD))
    701            (ROMAN-CHAR 0 N)
    702            (ROMAN-CHAR 0 (1+ N)))
    703           ((= X 5)
    704            (ROMAN-CHAR 1 N))
    705           ((AND (= X 4) (NOT ROMAN-OLD))
    706            (ROMAN-CHAR 0 N)
    707            (ROMAN-CHAR 1 N))
    708           (T (COND ((> X 5)
    709                     (ROMAN-CHAR 1 N)
    710                     (SETQ X (- X 5))))
    711              (DO I 0 (1+ I) (>= I X)
    712                (ROMAN-CHAR 0 N)))))
    713 
    714 (DEFUN ROMAN-CHAR (I X)
    715     (FUNCALL ROMAN-STREAM 'TYO (NTH (+ I X X) '(#/I #/V #/X #/L #/C #/D #/M))))
    716 
    717 (DEFUN ROMAN-PRINC (X ROMAN-STREAM)
    718     (SETQ X (- X))
    719     (COND ((AND (< X 4000.)
    720                 (> X 0))
    721            (ROMAN-STEP X 0))
    722           (T (LET ((BASE 10.))
    723                   (PRINC X ROMAN-STREAM)))))
    724 
    725 (DEFPROP ROMAN ROMAN-PRINC PRINC-FUNCTION)
    726 
    727 ;; (SETQ BASE 'ROMAN-OLD) will print out in old-style Roman numerals.
    728 (DEFUN ROMAN-OLD-PRINC (X ROMAN-STREAM)
    729    (LET ((ROMAN-OLD T))
    730      (ROMAN-PRINC X ROMAN-STREAM)))
    731 
    732 (DEFPROP ROMAN-OLD ROMAN-OLD-PRINC PRINC-FUNCTION)
    733 
    734 (comment
    735 (DEFUN STACKS ( &AUX SG RP SP)
    736     (SETQ SG SI:%CURRENT-STACK-GROUP-PREVIOUS-STACK-GROUP)
    737     (DO ((STACK (SG-REGULAR-PDL SG) (SG-SPECIAL-PDL SG))
    738          (START (SG-REGULAR-PDL-POINTER SG) (SG-SPECIAL-PDL-POINTER SG))
    739          (MESS "Regular PDL" "Special PDL")
    740          (KLUDGE 0 (1+ KLUDGE)))
    741         ((>= KLUDGE 2) T)
    742       (TERPRI) (TERPRI) (PRINC MESS) (TERPRI)
    743       (DO I 0 (1+ I) (> I START)
    744         (COND ((= 1 (%P-FLAG-BIT (AP-1-CAREFUL STACK I)))
    745                (TYO #/*))
    746               (T (TYO 40)))
    747         (PRINC I) (TYO 40)
    748         (PRIN1-C-LOCATIVE-CAREFUL (AP-1-CAREFUL STACK I)) (TERPRI))))
    749 
    750 (DEFUN SKIP-INTERNAL ( &AUX RP SFP SFP1 PTR1 OFFSET)
    751     (SETQ RP (SG-REGULAR-PDL SI:%CURRENT-STACK-GROUP))
    752     (SETQ SFP (- (%POINTER-DIFFERENCE (%STACK-FRAME-POINTER) RP) 2))
    753     (SETQ SFP1 (- SFP (RP-DELTA-TO-ACTIVE-BLOCK RP SFP)))
    754     (SETQ SFP1 (- SFP1 (RP-DELTA-TO-ACTIVE-BLOCK RP SFP1)))
    755     (SETQ SFP1 (- SFP1 (RP-DELTA-TO-ACTIVE-BLOCK RP SFP1)))
    756     (SETQ PTR1 (AP-1 RP SFP1))
    757     (SETQ OFFSET (+ 3 (RP-LOCAL-BLOCK-ORIGIN RP SFP1)))
    758     (%P-STORE-CONTENTS-OFFSET (CDR (%P-CONTENTS-OFFSET PTR1 OFFSET)) PTR1 OFFSET))
    759 
    760 (DEFUN SKIPA (&QUOTE VAR FORM)
    761    (SET VAR (EVAL FORM))
    762    (SKIP-INTERNAL))
    763 
    764 (DEFUN SKIPE (&QUOTE VAR FORM)
    765    (SET VAR (EVAL FORM))
    766    (AND (ZEROP (SYMEVAL VAR))
    767         (SKIP-INTERNAL)))
    768 
    769 (DEFUN SKIPN (&QUOTE VAR FORM)
    770    (SET VAR (EVAL FORM))
    771    (OR (ZEROP (SYMEVAL VAR))
    772        (SKIP-INTERNAL)))
    773 );end comment
    774 
    775 (defun dance (&optional (mina 100) (maxa 456) (minb 200) (maxb 565)
     544      (AND (FUNCALL TERMINAL-IO ':TYI-NO-HANG) (RETURN NIL))
     545      (FUNCALL WINDOW ':DRAW-POINT (LDB 2010 TEM) (LDB 1010 TEM))))
     546
     547(defun dance (&optional (WINDOW TERMINAL-IO)
     548                        (mina 100) (maxa 456) (minb 200) (maxb 565)
    776549                        (minc 60) (maxc 1076) (mind 300) (maxd 1100))
    777        (tv-draw-line mina minb maxc maxd tv-alu-xor tv-default-screen)
     550 (WITH-REAL-TIME
     551       (FUNCALL WINDOW ':DRAW-LINE mina minb maxc maxd tv:alu-xor)
    778552       (do ((a mina)
    779553            (b minb)
     
    785559            (dc -1)
    786560            (dd -1))
    787          ((kbd-tyi-no-hang))
    788          (setq oa a ob b oc c od d)
    789          (setq a (+ a da))
    790          (cond ((= da 1)
    791                 (cond ((
     561         ((funcall terminal-io ':tyi-no-hang)
     562          (FUNCALL WINDOW ':draw-line a b c d tv:alu-xor))
     563       (setq oa a ob b oc c od d)
     564       (setq a (+ a da))
     565       (cond ((= da 1)
     566              (cond ((
    792567 a maxa)
    793                        (setq da -1))))
    794                ((
     568                     (setq da -1))))
     569             ((
    795570 a mina)
    796                 (setq da 1)))
    797          (setq b (+ b db))
    798          (cond ((= db 1)
    799                 (cond ((
     571              (setq da 1)))
     572       (setq b (+ b db))
     573       (cond ((= db 1)
     574              (cond ((
    800575 b maxb)
    801                        (setq db -1))))
    802                ((
     576                     (setq db -1))))
     577             ((
    803578 b minb)
    804                 (setq db 1)))
    805          (setq c (+ c dc))
    806          (cond ((= dc 1)
    807                 (cond ((
     579              (setq db 1)))
     580       (setq c (+ c dc))
     581       (cond ((= dc 1)
     582              (cond ((
    808583 c maxc)
    809                        (setq dc -1))))
    810                ((
     584                     (setq dc -1))))
     585             ((
    811586 c minc)
    812                 (setq dc 1)))
    813          (setq d (+ d dd))
    814          (cond ((= dd 1)
    815                 (cond ((
     587              (setq dc 1)))
     588       (setq d (+ d dd))
     589       (cond ((= dd 1)
     590              (cond ((
    816591 d maxd)
    817                        (setq dd -1))))
    818                ((
     592                     (setq dd -1))))
     593             ((
    819594 d mind)
    820                 (setq dd 1)))
    821          (tv-draw-line a b c d tv-alu-xor tv-default-screen)
    822          (tv-draw-line oa ob oc od tv-alu-xor tv-default-screen)))
    823 
    824 (defun spazz (&aux (mina (random (screen-x2 tv-default-screen)))
    825                    (minc (random (screen-x2 tv-default-screen)))
    826                    (minb (random (screen-y2 tv-default-screen)))
    827                    (mind (random (screen-y2 tv-default-screen)))
    828                    (awid (random (- (screen-x2 tv-default-screen) mina)))
    829                    (cwid (random (- (screen-x2 tv-default-screen) minc)))
    830                    (bwid (random (- (screen-y2 tv-default-screen) minb)))
    831                    (dwid (random (- (screen-y2 tv-default-screen) mind))))
    832   (dance mina (+ mina awid) minb (+ minb bwid) minc (+ minc cwid) mind (+ mind dwid)))
    833 
    834 (declare (special rcavic-saved-array rcavic-hacked-array rcavic-hacked-16b-array))
    835 (defun rcavic (&optional (screen tv-default-screen) (interval 3000000) &aux array
    836                        16b-array len)
    837     (setq array (screen-buffer-pixel-array screen)
    838           16b-array (screen-buffer-halfword-array screen)
    839           len (array-length 16b-array))
    840     (or (boundp 'rcavic-saved-array)
    841         (let ((dims (arraydims (screen-buffer-pixel-array screen))))
    842          (setq rcavic-saved-array (make-array nil (car dims) (cdr dims))
    843                rcavic-hacked-array (make-array nil (car dims) (cdr dims))
    844                rcavic-hacked-16b-array (make-array nil 'art-16b len rcavic-hacked-array))))
    845     (do ((i 0 (1+ i))
    846          (j (1- len) (1- j)))
    847         ((< j 0))
    848         (do ((arg (ar-1 16b-array i) (lsh arg -1))
    849              (val 0)
    850              (bit 100000 (lsh bit -1)))
    851             ((zerop arg) (as-1 val rcavic-hacked-16b-array j))
    852             (and (bit-test arg 1)
    853                  (setq val (logior val bit)))))
    854     (bitblt tv-alu-seta (screen-width screen) (screen-height screen)
    855              array 0 0 rcavic-saved-array 0 0)
    856     (do i 0 (1+ i) (
    857  i 3) (tv-beep))
    858     (bitblt tv-alu-seta (screen-width screen) (screen-height screen)
    859              rcavic-hacked-array 0 0 array 0 0)
    860     (do i 0 (1+ i) (
    861  i interval))
    862     (bitblt tv-alu-seta (screen-width screen) (screen-height screen)
    863             rcavic-saved-array 0 0 array 0 0))
     595              (setq dd 1)))
     596       (FUNCALL WINDOW ':draw-line a b c d tv:alu-xor)
     597       (FUNCALL WINDOW ':draw-line oa ob oc od tv:alu-xor))))
     598
     599(defun spazz (&OPTIONAL (WINDOW TERMINAL-IO))
     600  (MULTIPLE-VALUE-BIND (X2 Y2)
     601      (FUNCALL WINDOW ':INSIDE-SIZE)
     602    (LET* ((mina (random x2))
     603           (minc (random x2))
     604           (minb (random y2))
     605           (mind (random y2))
     606           (awid (random (- x2 mina)))
     607           (cwid (random (- x2 minc)))
     608           (bwid (random (- y2 minb)))
     609           (dwid (random (- y2 mind))))
     610      (dance WINDOW
     611             mina (+ mina awid) minb (+ minb bwid) minc (+ minc cwid) mind (+ mind dwid)))))
     612
     613(COMMENT ;This is not really very interesting by today's standards.
     614(DEFDEMO "Dance" "An animated line moving around on the screen." "Dance"
     615         ("Normal" "" (DANCE))
     616         ("Spastic" "" (SPAZZ)))
     617)
     618
Note: See TracChangeset for help on using the changeset viewer.