;-*-MODE:LISP; PACKAGE:HACKS; BASE: 8-*-
;	** (c) Copyright 1980 Massachusetts Institute of Technology **

(SETQ SINE-EPSILON '30.)
(SETQ MASTER-DURATION 5000)
(SETQ TEMPER 
      '((#/A 200.) (#/W 189.) (#/S 178.) (#/E 168.) (#/D 159.) (#/F 150.) (#/T 141.)
	(#/G 133.) (#/Y 126.) (#/H 119.) (#/U 112.) (#/J 106.) (#/K 100.) (#/O 94.)
	(#/L 89.) (#/P 84.) (#/; 79.) (#/: 75.) (#/] 71.)
        (#/a 200.) (#/w 189.) (#/s 178.) (#/e 168.) (#/d 159.) (#/f 150.) (#/t 141.)
	(#/g 133.) (#/y 126.) (#/h 119.) (#/u 112.) (#/j 106.) (#/k 100.) (#/o 94.)
	(#/l 89.) (#/p 84.) (#/; 79.) (#/: 75.) (#/] 71.)))

(DECLARE (SPECIAL SINE-EPSILON TEMPER TEMPER-ARRAY))

(DEFUN BUZZ (DURATION WAVELENGTH &OPTIONAL (WAVELENGTH2 WAVELENGTH)
             &AUX (LOC 764110))
  (AND (MINUSP WAVELENGTH)
       (SETQ WAVELENGTH (MINUS WAVELENGTH)))
  (AND (MINUSP WAVELENGTH2)
       (SETQ WAVELENGTH2 (MINUS WAVELENGTH2)))
  (DO I 0 (1+ I) (= I DURATION)
    (DO J 0 (1+ J) (= J WAVELENGTH))
    (%UNIBUS-READ LOC)
    (DO J 0 (1+ J) (= J WAVELENGTH2))
    (%UNIBUS-READ LOC)))

(DEFUN OLD-PLAY (NNOTES INITIAL-NOTE DECREMENT DURATION)
  (DO ((K 0 (1+ K))
       (NOTE INITIAL-NOTE (- NOTE DECREMENT)))
      ((= K NNOTES))
    (BUZZ DURATION NOTE)))

(DECLARE (SPECIAL MASTER-DURATION))

(DEFUN SETUP-TEMPER-ARRAY (&OPTIONAL RETUNE)
  (COND ((NOT (BOUNDP 'TEMPER-ARRAY))
	 (SETQ TEMPER-ARRAY (MAKE-ARRAY NIL 'ART-Q-LIST 220))
	 (SETQ RETUNE T)))
  (COND (RETUNE
	 (DO N 0 (1+ N) (= N 220)
	     (AS-1 10 TEMPER-ARRAY N))
	 (DO X TEMPER (CDR X) (NULL X)
	     (AS-1 (CADAR X) TEMPER-ARRAY (CAAR X))))))

(DEFUN OLD-ORGAN (&OPTIONAL RETUNE)
 (WITH-REAL-TIME
    (SETUP-TEMPER-ARRAY RETUNE)
    (DO ((A (FUNCALL TERMINAL-IO ':TYI) (FUNCALL TERMINAL-IO ':TYI)))
	((= (SETQ A (LOGAND A 377)) 202)
	 (RETURN "End of sonata in Q minor"))
	((LAMBDA (WAVELENGTH)
		 (BUZZ (// MASTER-DURATION WAVELENGTH) WAVELENGTH))
	 (AR-1 TEMPER-ARRAY A)))))

(DEFUN ZOWIE (&OPTIONAL RETUNE &AUX (MASTER-DURATION 5600))
 (WITH-REAL-TIME
   (SETUP-TEMPER-ARRAY RETUNE)
    (DO ((W '(150. 150. 150. 159. 150. 133. 150. 133. 119. 133. 150. 159. 178. 159. 150.)
            (CDR W))
	 (D '(1 1 2 1 1 2 1 1 2 1 1 2 1 1 2) (CDR D))
	 (TEM))
	((NULL W))
      (SETQ TEM (// (CAR W) 2))
      (DO I 0 (1+ I) (= I 1000))
      (BUZZ (// (* (CAR D) MASTER-DURATION) TEM) TEM))))

(DEFDEMO "Zowie" "Demonstration of Lisp Machine music-generation facilities." (ZOWIE))

;TRY THIS WITH ARGUMENTS OF 20. AND 500.
(DEFUN MARV (&OPTIONAL (MARV-E 259.) (N 200.) (X 50.) (Y 0))
  (PROG NIL 
    A   ;(AS-2 1. TV-BUFFER (+ X 200.) (+ Y 200.))
        (FUNCALL TERMINAL-IO ':DRAW-POINT (+ X 200.) (+ Y 200.) 1)
        (AND (ZEROP (SETQ N (1- N)))
             (RETURN T))
        (SETQ X (- X (// (* MARV-E Y) 1000.))
              Y (+ Y (// (* MARV-E X) 1000.)))
        (GO A)))


;INPUT CHARACTER WITH DDT STYLE ECHOING
(DEFUN CARPET-TYI (&AUX CH)			;
  (SETQ CH (FUNCALL TERMINAL-IO ':TYI))
  (AND (< CH 200)
       (FUNCALL TERMINAL-IO ':TYO CH))
  CH)

;BAG THE BYTE OR WORD
(DEFUN CARPET-BAG (LOC NUM BYTEP)
  (COND ((NOT BYTEP)
	 (%UNIBUS-WRITE LOC NUM))
	(T
	 (SETQ BYTEP (COND ((= 0 (LOGAND 1 LOC)) 0010)
			   (T 1010)))
	 (%UNIBUS-WRITE LOC (DPB NUM BYTEP (%UNIBUS-READ LOC))))))

;UNIBUS OCTAL DEBUGGER
(DEFUN CARPET ()
  (PROG ((LOC 0) OPENP (BYTEP NIL) NUM SOME CH (CLOC 0))
TOP  (TERPRI)
     (PRINC '/!)
     (SETQ OPENP NIL)
READ (SETQ NUM 0 SOME NIL)
RNUM (SETQ CH (CARPET-TYI))
     (COND ((= CH #\BACKSPACE)
	    (TV:SHEET-BACKSPACE TERMINAL-IO)
	    (TV:SHEET-CLEAR-CHAR TERMINAL-IO)
	    (SETQ NUM (// NUM 8))
	    (GO RNUM))
	   ((NOT (AND (>= CH 60) (<= CH 71)))
	    (GO CMD)))
     (SETQ NUM (+ (* NUM 8) (- CH 60)))
     (SETQ SOME T)
     (GO RNUM)

CMD  (COND ((= CH #//)
	    (SETQ BYTEP NIL LOC (LOGAND 777776 NUM) OPENP T)
	    (GO OPN1))
	   ((= CH #\ABORT)
	    (RETURN T))
	   ((= CH #/.)
	    (SETQ SOME T
		  NUM LOC)
	    (GO RNUM))
	   ((= CH #/\)
	    (SETQ BYTEP T LOC NUM OPENP T)
	    (GO OPN1))
	   ((= CH #\SPACE)
	    (GO READ))
	   ((= CH #\CR)
	    (AND OPENP SOME (CARPET-BAG LOC NUM BYTEP))
	    (GO TOP))
	   ((= CH #\LF)
	    (AND OPENP SOME (CARPET-BAG LOC NUM BYTEP))
	    (SETQ LOC (+ LOC (COND (BYTEP 1) (T 2)))))
	   ((= CH #/^)
	    (AND OPENP SOME (CARPET-BAG LOC NUM BYTEP))
	    (SETQ LOC (- LOC (COND (BYTEP 1) (T 2)))))
	   ((= CH #\TAB)
	    (AND OPENP SOME (CARPET-BAG LOC NUM BYTEP))
	    (SETQ LOC (COND (SOME NUM) (T CLOC))))
	   (T (PRINC "??  ")
	      (GO READ)))
     (TERPRI)
     (PRIN1 (SETQ LOC (LOGAND 777777 LOC)))
     (PRINC (COND (BYTEP '\) (T '//)))
OPN1 (PRINC " ")
     (PRIN1 (SETQ CLOC (LDB (COND ((NULL BYTEP) 0020)
				   ((= 0 (LOGAND 1 LOC)) 0010)
				   (T 1010))
			     (%UNIBUS-READ LOC))))
     (PRINC "   ")
     (SETQ OPENP T)
     (GO READ)
))
(LOCAL-DECLARE ((SPECIAL SR-SHEET SR-SIZE
			 X-ORG Y-ORG
			 COLOR CHAR-ORIGIN CURRENT-SWITCHES FONTS:TOG))
(DEFUN CREATE-SWITCH-REGISTER (SR-SHEET SR-SIZE X-ORG Y-ORG
			       &OPTIONAL LIGHTSP (COLOR 7070707)
			       &AUX CHAR-ORIGIN CURRENT-SWITCHES)
  (IF (NOT (BOUNDP 'FONTS:TOG))
      (LOAD "lmfont;tog" "fonts"))
  (IF (NULL Y-ORG) (SETQ Y-ORG (- (// (TV:SHEET-INSIDE-HEIGHT SR-SHEET) 2) 15.)))
  (IF (NULL X-ORG) (SETQ X-ORG (- (// (TV:SHEET-INSIDE-WIDTH SR-SHEET) 2)
				  (// (* 23. SR-SIZE) 2))))
  (SETQ CHAR-ORIGIN (COND (LIGHTSP 101) (T 60)))
  (CLOSURE '(SR-SHEET SR-SIZE X-ORG Y-ORG
	     COLOR CHAR-ORIGIN CURRENT-SWITCHES)
     #'(LAMBDA (ARG &AUX NUM)
	 (SETQ NUM (IF (NUMBERP ARG) ARG 0))
	 (DO ((M (- 1 SR-SIZE) (1+ M))
	      (X X-ORG (+ X 23.)))
	     ((> M 0) NIL)
	   (IF (OR (NULL ARG)
		   (BIT-TEST 1 (LSH (LOGXOR NUM CURRENT-SWITCHES) M)))
	       (SHEET-PLUNK-CHAR SR-SHEET FONTS:TOG 
			(+ CHAR-ORIGIN
			   (+ (* 2 (LOGAND 1 (LSH COLOR M)))
			      (LOGAND 1 (LSH NUM M))))
			X Y-ORG)))
	 (SETQ CURRENT-SWITCHES NUM)))))


(DEFUN SHEET-PLUNK-CHAR (SHEET FONT CHAR X-BITPOS Y-BITPOS
			 &AUX TEM (FIT (FONT-INDEXING-TABLE FONT)))
  (TV:PREPARE-SHEET (SHEET)
    (SETQ X-BITPOS (+ X-BITPOS (TV:SHEET-INSIDE-LEFT SHEET))
	  Y-BITPOS (+ Y-BITPOS (TV:SHEET-INSIDE-TOP SHEET)))
    (TV:%DRAW-RECTANGLE
       (COND ((SETQ TEM (FONT-CHAR-WIDTH-TABLE FONT)) (AREF TEM CHAR))
	     (T (FONT-CHAR-WIDTH FONT)))
       (FONT-CHAR-HEIGHT FONT)
       X-BITPOS Y-BITPOS
       (TV:SHEET-ERASE-ALUF SHEET)
       SHEET)
    (IF (NULL FIT)
	(TV:%DRAW-CHAR FONT CHAR X-BITPOS Y-BITPOS (TV:SHEET-CHAR-ALUF SHEET) SHEET)
	;;Wide character, draw in segments
	(DO ((CH (AREF FIT CHAR) (1+ CH))
	     (LIM (AREF FIT (1+ CHAR)))
	     (BPP (TV:SHEET-BITS-PER-PIXEL SHEET))
	     (X X-BITPOS (+ X (// (FONT-RASTER-WIDTH FONT) BPP))))
	    ((= CH LIM))
	  (TV:%DRAW-CHAR FONT CH X Y-BITPOS  (TV:SHEET-CHAR-ALUF SHEET) SHEET)))))

     
; A 3RD ARG OF 0 STARTS AT THE BEGINNING, WHICH IS A LITTLE MECHANICAL.
; A 3RD ARG OF 571565 STARTS YOU OUT IN THE MIDDLE OF AN INTERESTING PART.
; N IS THE MAGIC CONSTANT, M IS SLOWNESS, A IS STARTING POINT.
; WHEN STOPPED THIS HACK RETURNS THE LAST VALUE OF A.

(DEFUN MUNCHING-TUNES (&OPTIONAL (N 1001) (A 0) (M 30000) (O 3))
 (WITH-REAL-TIME
  (DO ((ACC (REMAINDER A 1000000) (REMAINDER (+ ACC N) 1000000))
       (FREQ (LOGXOR (\ A 1000)
		     (// A 1000))
	     (LOGXOR (\ ACC 1000)
		     (// ACC 1000))))
      ((FUNCALL TERMINAL-IO ':TYI-NO-HANG)
       ACC)
    (SI:%BEEP (LSH FREQ O) M))))

(DEFDEMO "Munching Tunes" "Computer-composed music, based on the Munching Squares algorithm."
  "Munching Tunes"
  ("From the beginning" "Play the whole thing from the beginning." (MUNCHING-TUNES 1001 0))
  ("Interesting" "Start in the middle at an interesting point." (MUNCHING-TUNES 1001 571565)))

(DECLARE (SPECIAL LIVE-BOUNCE-LL))

(DEFUN LIVE-BOUNCE (&OPTIONAL (DELAY 0))
 (WITH-REAL-TIME
  (OR (BOUNDP 'LIVE-BOUNCE-LL)
      (SETQ LIVE-BOUNCE-LL (CREATE-SWITCH-REGISTER TERMINAL-IO 20. 50. 25 T)))
  (FUNCALL LIVE-BOUNCE-LL NIL)
  (DO ((NB 1)
       (DNB 1)
       (DIR 1)
       (LT 1)
       (COMP 0))
      ((FUNCALL TERMINAL-IO ':TYI-NO-HANG))
    (FUNCALL LIVE-BOUNCE-LL (LOGXOR LT COMP))
    (SETQ LT (LSH LT DIR))
    (COND ((= 1 (LOGAND LT 1))
           (SETQ DIR 1)
           (SETQ NB (+ NB DNB))
           (COND ((ZEROP NB)
                  (SETQ NB 1
                        DNB 1))
                 ((= NB 25)
                  (SETQ NB 1
                        COMP (LOGXOR -1 COMP)
                        DNB 1)))
           (SETQ LT (1- (LSH 1 NB))))
          ((NEQ 0 (LOGAND 4000000 LT))
           (SETQ DIR -1)
           (SETQ NB (+ NB DNB))
           (COND ((ZEROP NB)
                  (SETQ NB 1
                        DNB 1))
                 ((= NB 25)
                  (SETQ NB 1
                        COMP (LOGXOR -1 COMP)
                        DNB 1)))
           (SETQ LT (LSH (1- (LSH 1 NB)) (- 25 NB)))))
    (DO I DELAY (1- I) (= I 0)
    ))))

(DEFDEMO "Live Bounce" "A light-hack based on a program for the late SIPB PDP8/S."
  (LIVE-BOUNCE))

(COMMENT
;;; commented out
(DEFUN GREEN-HORNET (&OPTIONAL (WINDOW TERMINAL-IO) (SEPARATION 40))
 (WITH-REAL-TIME
  (FUNCALL WINDOW ':CLEAR-SCREEN)
  (FUNCALL WINDOW ':HOME-DOWN)
  (MULTIPLE-VALUE-BIND (IW IH)
      (FUNCALL WINDOW ':INSIDE-SIZE)
    (LET ((CENTER-X1 (- (// IW 2) (// SEPARATION 2)))
	  (CENTER-X2 (+ (// IW 2) (// SEPARATION 2)))
	  (CENTER-Y (// IH 2)))
      (DO I (- (MIN CENTER-Y CENTER-X1) 10.) (1- I) ( I 5)
	  (FUNCALL WINDOW ':DRAW-CIRCLE
		   (IF (BIT-TEST 20 I) CENTER-X1 CENTER-X2)
		   CENTER-Y
		   I))))
  (FUNCALL WINDOW ':TYI)
  T))

;;; commented out
(DEFUN CIRCLES (&OPTIONAL (WINDOW TERMINAL-IO))
 (WITH-REAL-TIME
  (FUNCALL WINDOW ':CLEAR-SCREEN)
  (FUNCALL WINDOW ':HOME-DOWN)
  (MULTIPLE-VALUE-BIND (IW IH)
      (FUNCALL WINDOW ':INSIDE-SIZE)
    (LET ((CENTER-X (// IW 2))
	  (CENTER-Y (// IH 2)))
      (DO I (- (MIN CENTER-X CENTER-Y) 40) (- I 5) ( I 5)
	  (FUNCALL WINDOW ':DRAW-CIRCLE CENTER-X CENTER-Y I))))
  (FUNCALL WINDOW ':TYI)
  T))
);end comment

;;; The following are so boring that they should not show up on the menu. - DLW
;; ;These are here to demonstrate how absurdly slow the :DRAW-CIRCLE message is
;; ;Also the hornet isn't green any more, it's white
;(DEFDEMO "Green Hornet" (GREEN-HORNET))
;(DEFDEMO "Circles" (CIRCLES))

(DEFCONST *LEXIPHAGE-INITIAL-DELAY* 50000.)	; Initial delay to read string.
(DEFCONST *LEXIPHAGE-PERIOD* 2000.)		; Slowness of the phage.
(DEFCONST *LEXIPHAGE-MOUTH-X* 40.)		; Width of the whole mouth.
(DEFCONST *LEXIPHAGE-MOUTH-Y* 4.)		; Width of one jaw at right end.
(DEFCONST *LEXIPHAGE-TOOTH-Y* 10.)		; Width of tooth at right end.

(DEFUN LEXIPHAGE (&OPTIONAL (STRING "LEXIPHAGE"))
  (OR (BOUNDP 'FONTS:43VXMS)
      (LOAD "SYS:FONTS;43VXMS" "FONTS"))
  (LET ((WINDOW (TV:MAKE-WINDOW 'TV:WINDOW ':BOTTOM 300. ':FONT-MAP (LIST FONTS:43VXMS)
				':BLINKER-P NIL ':MORE-P NIL ':SAVE-BITS T ':LABEL NIL)))
    (MULTIPLE-VALUE-BIND (WIDTH HEIGHT)
	(FUNCALL WINDOW ':INSIDE-SIZE)
      (LET* ((STRING-WIDTH (FUNCALL WINDOW ':STRING-LENGTH STRING))
	     (CENTER-Y (// HEIGHT 2))
	     (HALF-STRING-HEIGHT 30)
	     (LEFT-EDGE (MAX 0 (// (- WIDTH STRING-WIDTH) 2)))
	     (TOP-EDGE (MAX 0 (- CENTER-Y HALF-STRING-HEIGHT)))
	     (CHAR-ALUF (TV:SHEET-CHAR-ALUF WINDOW))
	     (ERASE-ALUF (TV:SHEET-ERASE-ALUF WINDOW))
	     )
	(TV:SHEET-FORCE-ACCESS (WINDOW)
	   (FUNCALL WINDOW ':CLEAR-SCREEN)
	   (FUNCALL WINDOW ':SET-CURSORPOS LEFT-EDGE TOP-EDGE)
	   (FUNCALL WINDOW ':STRING-OUT STRING))
	(TV:WINDOW-CALL (WINDOW :DEACTIVATE)
	  (WITH-REAL-TIME
	    ;; Initial delay, so user can read the string.
	    (DOTIMES (I *LEXIPHAGE-INITIAL-DELAY*))
	    (DO ((X (- LEFT-EDGE 100) (1+ X))
		 (DY 0)
		 (END-X (- (+ LEFT-EDGE STRING-WIDTH 30)	; Fudge by 30
			   *LEXIPHAGE-MOUTH-X*)))
		(( X END-X))
	      (SETQ DY (IF (ZEROP DY) HALF-STRING-HEIGHT (1- DY)))
	      (FUNCALL WINDOW ':DRAW-TRIANGLE
		       X CENTER-Y
		       (+ X *LEXIPHAGE-MOUTH-X*) (+ CENTER-Y DY)
		       (+ X *LEXIPHAGE-MOUTH-X*) (+ CENTER-Y (- DY *LEXIPHAGE-MOUTH-Y*))
		       CHAR-ALUF)
	      (FUNCALL WINDOW ':DRAW-TRIANGLE
		       X CENTER-Y
		       (+ X *LEXIPHAGE-MOUTH-X*) (- CENTER-Y DY)
		       (+ X *LEXIPHAGE-MOUTH-X*) (- CENTER-Y (- DY *LEXIPHAGE-MOUTH-Y*))
		       CHAR-ALUF)
	      (FUNCALL WINDOW ':DRAW-TRIANGLE
		       (+ X *LEXIPHAGE-MOUTH-X*) (+ CENTER-Y (- DY *LEXIPHAGE-MOUTH-Y*))
		       (+ X *LEXIPHAGE-MOUTH-X*) (+ CENTER-Y (- DY *LEXIPHAGE-TOOTH-Y*))
		       (+ X (FIX (* 0.9S0 *LEXIPHAGE-MOUTH-X*)))
		       (+ CENTER-Y (FIX (* 0.9S0 (- DY *LEXIPHAGE-MOUTH-Y*))))
		       CHAR-ALUF)
	      (FUNCALL WINDOW ':DRAW-TRIANGLE
		       (+ X *LEXIPHAGE-MOUTH-X*) (- CENTER-Y (- DY *LEXIPHAGE-MOUTH-Y*))
		       (+ X *LEXIPHAGE-MOUTH-X*) (- CENTER-Y (- DY *LEXIPHAGE-TOOTH-Y*))
		       (+ X (FIX (* 0.9S0 *LEXIPHAGE-MOUTH-X*)))
		       (- CENTER-Y (FIX (* 0.9S0 (- DY *LEXIPHAGE-MOUTH-Y*))))
		       CHAR-ALUF)
	      (DOTIMES (I *LEXIPHAGE-PERIOD*))
	      (FUNCALL WINDOW ':DRAW-TRIANGLE
		       X CENTER-Y
		       (+ X *LEXIPHAGE-MOUTH-X*) (+ CENTER-Y DY)
		       (+ X *LEXIPHAGE-MOUTH-X*) (+ CENTER-Y (- DY *LEXIPHAGE-MOUTH-Y*))
		       ERASE-ALUF)
	      (FUNCALL WINDOW ':DRAW-TRIANGLE
		       X CENTER-Y
		       (+ X *LEXIPHAGE-MOUTH-X*) (+ CENTER-Y DY)
		       X (+ CENTER-Y DY)
		       ERASE-ALUF)
	      (FUNCALL WINDOW ':DRAW-TRIANGLE
		       (+ X *LEXIPHAGE-MOUTH-X*) (+ CENTER-Y (- DY *LEXIPHAGE-MOUTH-Y*))
		       (+ X *LEXIPHAGE-MOUTH-X*) (+ CENTER-Y (- DY *LEXIPHAGE-TOOTH-Y*))
		       (+ X (FIX (* 0.8S0 *LEXIPHAGE-MOUTH-X*)))
		       (+ CENTER-Y (FIX (* 0.8S0 (- DY *LEXIPHAGE-MOUTH-Y*))))
		       ERASE-ALUF)
	      (FUNCALL WINDOW ':DRAW-TRIANGLE
		       (+ X *LEXIPHAGE-MOUTH-X*) (- CENTER-Y (- DY *LEXIPHAGE-MOUTH-Y*))
		       (+ X *LEXIPHAGE-MOUTH-X*) (- CENTER-Y (- DY *LEXIPHAGE-TOOTH-Y*))
		       (+ X (FIX (* 0.8S0 *LEXIPHAGE-MOUTH-X*)))
		       (- CENTER-Y (FIX (* 0.8S0 (- DY *LEXIPHAGE-MOUTH-Y*))))
		       ERASE-ALUF)
	      (FUNCALL WINDOW ':DRAW-TRIANGLE
		       X CENTER-Y
		       (+ X *LEXIPHAGE-MOUTH-X*) (- CENTER-Y DY)
		       (+ X *LEXIPHAGE-MOUTH-X*) (- CENTER-Y (- DY *LEXIPHAGE-MOUTH-Y*))
		       ERASE-ALUF)
	      (FUNCALL WINDOW ':DRAW-TRIANGLE
		       X CENTER-Y
		       (+ X *LEXIPHAGE-MOUTH-X*) (- CENTER-Y DY)
		       X (- CENTER-Y DY)
		       ERASE-ALUF)))))))
  "Lexiphage!")

(DEFDEMO "Lexiphage" "The word eater, based on a hack by John Doty." (LEXIPHAGE))

(DECLARE (SPECIAL MF10-HACK5-BAR))

(DEFUN MF10-HACK5 (&OPTIONAL (ZAP 1000) (13357ALIAS 13357))
 (WITH-REAL-TIME
  (FUNCALL TERMINAL-IO ':CLEAR-SCREEN)
  (FUNCALL TERMINAL-IO ':HOME-DOWN)
  (OR (BOUNDP 'MF10-HACK5-BAR)
      (SETQ MF10-HACK5-BAR (CREATE-SWITCH-REGISTER TERMINAL-IO 20 100 20 T)))
  (FUNCALL MF10-HACK5-BAR NIL)
  (DO I 13357ALIAS (ROT I 1) (FUNCALL TERMINAL-IO ':TYI-NO-HANG)
      (FUNCALL MF10-HACK5-BAR I)
      (DO J 0 (+ J 1) (= J ZAP)
	  ))))

(DEFVAR PRINT-BIG-PREVIOUS NIL)

(DEFUN PRINT-BIG (&OPTIONAL (FONT PRINT-BIG-PREVIOUS))
   (TERPRI)
   (COND ((NULL FONT) (SETQ FONT FONTS:BIGFNT)))
   (SETQ PRINT-BIG-PREVIOUS (TV:SHEET-CURRENT-FONT TERMINAL-IO))
   (FUNCALL TERMINAL-IO ':SET-FONT-MAP (LIST FONT))
   (FUNCALL TERMINAL-IO ':SET-CURRENT-FONT FONT))

(DEFUN PRINT-SMALL ()
   (TERPRI)
   (FUNCALL TERMINAL-IO ':SET-FONT-MAP (LIST FONTS:CPTFONT))
   (FUNCALL TERMINAL-IO ':SET-CURRENT-FONT FONTS:CPTFONT))


(DECLARE (SPECIAL FEFS ADL-QS ADL-VARS NAME-QS FREE-QS TOTAL-BOXED-LENGTH 
		 TOTAL-LENGTH))

(DEFUN COMPUTE-FEF-STATS NIL
  (PROG ((FEFS 0) (ADL-QS 0) (ADL-VARS 0) (NAME-QS 0) (FREE-QS 0) (TOTAL-BOXED-LENGTH 0) 
         (TOTAL-LENGTH 0))
        (MAPATOMS-ALL (FUNCTION (LAMBDA (X &AUX FEFP TEM)
                              (COND ((AND
                                      (FBOUNDP X)
                                      (=
                                       (%P-DATA-TYPE (SETQ FEFP (FUNCTION-CELL-LOCATION X)))
                                       DTP-FEF-POINTER))
                                     (SETQ FEFP (CDR FEFP))
                                     (SETQ FEFS (1+ FEFS))
                                     (SETQ
                                      ADL-VARS
                                      (+ ADL-VARS
                                         (%P-LDB-OFFSET SI:%%FEFHI-MS-BIND-DESC-LENGTH
                                                        FEFP
                                                        SI:%FEFHI-MISC)))
                                     (SETQ
                                      TOTAL-BOXED-LENGTH
                                      (+ TOTAL-BOXED-LENGTH
                                         (// (%P-LDB-OFFSET SI:%%FEFH-PC FEFP SI:%FEFHI-IPC) 2)))
                                     (SETQ
                                      TOTAL-LENGTH
                                      (+ TOTAL-LENGTH
                                         (%P-CONTENTS-OFFSET FEFP SI:%FEFHI-STORAGE-LENGTH)))
                                     (PROG ((LST (SI:GET-MACRO-ARG-DESC-POINTER FEFP)) 
                                            VAR-DESC)
                                           (SETQ ADL-QS (+ ADL-QS (LENGTH LST)))
                                      L    (COND ((NULL LST)
                                                  (RETURN NIL)))
                                           (SETQ VAR-DESC (CAR LST))
                                           (COND ((NOT
                                                   (ZEROP (LOGAND VAR-DESC
                                                                  SI:%FEF-NAME-PRESENT)))
                                                  (SETQ LST (CDR LST))
                                                  (SETQ NAME-QS (1+ NAME-QS))))
                                           (COND ((= (MASK-FIELD SI:%%FEF-ARG-SYNTAX
								 VAR-DESC)
                                                     SI:FEF-ARG-FREE)
                                                  (SETQ FREE-QS (1+ FREE-QS))))
                                           (COND ((OR
                                                   (= (SETQ TEM (LDB SI:%%FEF-INIT-OPTION
								     VAR-DESC))
                                                      SI:FEF-INI-PNTR)
                                                   (= TEM SI:FEF-INI-C-PNTR)
                                                   (= TEM SI:FEF-INI-OPT-SA)
                                                   (= TEM SI:FEF-INI-EFF-ADR))
                                                  (SETQ LST (CDR LST))))
                                           (SETQ LST (CDR LST))
                                           (GO L)))))))
        (FORMAT STANDARD-OUTPUT
                       "~%FEFS ~D, TOTAL LENGTH ~D, BOXED LENGTH ~D, ADL-VARS ~D,/
ADL-QS ~D, LOCAL NAME QS ~D, FREE-VARIABLE-ADL-QS ~D,"
                       FEFS
                       TOTAL-LENGTH
                       TOTAL-BOXED-LENGTH
                       ADL-VARS
                       ADL-QS
                       NAME-QS
                       FREE-QS)))


(DEFUN DISPLAY-MOUSE-REGS NIL
  (DISPLAY-UNIBUS-LOCATION TV:MOUSE-REG1 TV:MOUSE-REG2))

(DEFUN DISPLAY-UNIBUS-LOCATION (&REST ADDRESS-LIST)
  (LEXPR-FUNCALL 'DISPLAY-LOCATION '%UNIBUS-READ 16. ADDRESS-LIST))

(DEFUN DISPLAY-CC-KEYBOARD-REGS NIL
  (DISPLAY-CC-UNIBUS-LOCATION 764112 764102 764100))

(DEFUN DISPLAY-CC-MOUSE-REGS NIL
  (DISPLAY-CC-UNIBUS-LOCATION TV:MOUSE-REG1 TV:MOUSE-REG2))

(DEFUN DISPLAY-CC-UNIBUS-LOCATION (&REST ADDRESS-LIST)
  (LEXPR-FUNCALL 'DISPLAY-LOCATION 'CADR:DBG-READ 16. ADDRESS-LIST))

(DEFUN DISPLAY-XBUS-LOCATION (&REST ADDRESS-LIST)
  (LEXPR-FUNCALL 'DISPLAY-LOCATION '%XBUS-READ 32. ADDRESS-LIST))

(DEFUN DISPLAY-LOCATION (FCTN BITS &REST ADDRESS-LIST)
  (LET* ((N (LENGTH ADDRESS-LIST))
	 (LITES (MAKE-ARRAY NIL ART-Q N)))
    (DOTIMES (I N)
      (AS-1 (CREATE-SWITCH-REGISTER TERMINAL-IO BITS NIL  (+ (* I 44) 40) T)
	    LITES
	    I))
    (FUNCALL TERMINAL-IO ':CLEAR-SCREEN)
    (DOTIMES (I N)
      (FUNCALL (AR-1 LITES I) NIL))
    (DO NIL ((EQ 203 (FUNCALL TERMINAL-IO ':TYI-NO-HANG)))
      (DO ((I 0 (1+ I))
	   (L ADDRESS-LIST (CDR L)))
	  ((>= I N))
	(FUNCALL (AR-1 LITES I)
		 (FUNCALL FCTN (CAR L)))))))

(DEFUN RANDOM-TEST (&OPTIONAL (WINDOW TERMINAL-IO) &AUX TEM)
    (FUNCALL WINDOW ':CLEAR-SCREEN)
    (DO () (())
      (SETQ TEM (RANDOM))
      (AND (FUNCALL TERMINAL-IO ':TYI-NO-HANG) (RETURN NIL))
      (FUNCALL WINDOW ':DRAW-POINT (LDB 2010 TEM) (LDB 1010 TEM))))

(defun dance (&optional (WINDOW TERMINAL-IO)
			(mina 100) (maxa 456) (minb 200) (maxb 565)
                        (minc 60) (maxc 1076) (mind 300) (maxd 1100))
 (WITH-REAL-TIME
       (FUNCALL WINDOW ':DRAW-LINE mina minb maxc maxd tv:alu-xor)
       (do ((a mina)
            (b minb)
            (c maxc)
            (d maxd)
            (oa)(ob)(oc)(od)
            (da 1)
            (db 1)
            (dc -1)
            (dd -1))
         ((funcall terminal-io ':tyi-no-hang)
	  (FUNCALL WINDOW ':draw-line a b c d tv:alu-xor))
       (setq oa a ob b oc c od d)
       (setq a (+ a da))
       (cond ((= da 1)
	      (cond (( a maxa)
		     (setq da -1))))
	     (( a mina)
	      (setq da 1)))
       (setq b (+ b db))
       (cond ((= db 1)
	      (cond (( b maxb)
		     (setq db -1))))
	     (( b minb)
	      (setq db 1)))
       (setq c (+ c dc))
       (cond ((= dc 1)
	      (cond (( c maxc)
		     (setq dc -1))))
	     (( c minc)
	      (setq dc 1)))
       (setq d (+ d dd))
       (cond ((= dd 1)
	      (cond (( d maxd)
		     (setq dd -1))))
	     (( d mind)
	      (setq dd 1)))
       (FUNCALL WINDOW ':draw-line a b c d tv:alu-xor)
       (FUNCALL WINDOW ':draw-line oa ob oc od tv:alu-xor))))

(defun spazz (&OPTIONAL (WINDOW TERMINAL-IO))
  (MULTIPLE-VALUE-BIND (X2 Y2)
      (FUNCALL WINDOW ':INSIDE-SIZE)
    (LET* ((mina (random x2))
	   (minc (random x2))
	   (minb (random y2))
	   (mind (random y2))
	   (awid (random (- x2 mina)))
	   (cwid (random (- x2 minc)))
	   (bwid (random (- y2 minb)))
	   (dwid (random (- y2 mind))))
      (dance WINDOW
	     mina (+ mina awid) minb (+ minb bwid) minc (+ minc cwid) mind (+ mind dwid)))))

(COMMENT ;This is not really very interesting by today's standards.
(DEFDEMO "Dance" "An animated line moving around on the screen." "Dance"
	 ("Normal" "" (DANCE))
	 ("Spastic" "" (SPAZZ)))
)