;-*- Mode:LISP; Package:HACKS; Base:8; Readtable:ZL -*-
;	** (c) Copyright 1980 Massachusetts Institute of Technology **

;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.) TV:ALU-XOR)
;        (AND (ZEROP (SETQ N (1- N)))
;             (RETURN T))
;        (SETQ X (- X (TRUNCATE (* MARV-E Y) 1000.))
;              Y (+ Y (TRUNCATE (* 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)
;	    (SEND TERMINAL-IO ':BACKWARD-CHAR)
;	    (SEND TERMINAL-IO ':CLEAR-CHAR)
;	    (SETQ NUM (TRUNCATE 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 (- (TRUNCATE (TV:SHEET-INSIDE-HEIGHT SR-SHEET) 2) 15.)))
;  (IF (NULL X-ORG) (SETQ X-ORG (- (TRUNCATE (TV:SHEET-INSIDE-WIDTH SR-SHEET) 2)
;				  (TRUNCATE (* 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)
;	 (if (eq arg ':get-window)
;	     sr-sheet
;	   (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 (TRUNCATE (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))
  "Plays a tune on the keyboard.  Plays an interesting tune with m = 571565. Any char stops."
 (WITH-REAL-TIME
  (DO ((ACC (REMAINDER A 1000000) (REMAINDER (+ ACC N) 1000000))
       (FREQ (LOGXOR (\ A 1000)
		     (TRUNCATE A 1000))
	     (LOGXOR (\ ACC 1000)
		     (TRUNCATE 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)))

(PROCLAIM '(SPECIAL LIVE-BOUNCE-LL))

(DEFUN LIVE-BOUNCE (&OPTIONAL (DELAY 0) &aux window)
 (WITH-REAL-TIME
  (OR (BOUNDP 'LIVE-BOUNCE-LL)
      (SETQ LIVE-BOUNCE-LL (CREATE-SWITCH-REGISTER
			     (make-instance 'tv:window
					    :edges '(122 40 1035 100)
					    :blinker-p nil
					    :borders nil
					    :label nil
					    :save-bits t)
			     20. 1 1 T)))
  (setq window (send live-bounce-ll :get-window))
  (send window :expose)
  (FUNCALL LIVE-BOUNCE-LL NIL)
  (DO ((NB 1)
       (DNB 1)
       (DIR 1)
       (LT 1)
       (COMP 0))
      ((send window :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 #o4000000 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))))
  (send window :deselect)))

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

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

(DEFUN CIRCLES (&OPTIONAL (WINDOW *TERMINAL-IO*))
  (WITH-REAL-TIME
    (SEND WINDOW :CLEAR-WINDOW)
    (SEND WINDOW :HOME-DOWN)
    (MULTIPLE-VALUE-BIND (IW IH)
	(SEND WINDOW :INSIDE-SIZE)
      (LET ((CENTER-X (// IW 2))
	    (CENTER-Y (// IH 2)))
	(DO ((I (- (MIN CENTER-X CENTER-Y) 40) (- I 5)))
	    (( I 5))
	  (SEND WINDOW :DRAW-CIRCLE CENTER-X CENTER-Y I))))
    (SEND WINDOW :TYI)
    T))

;;; 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" :PACKAGE 'FONTS))
  (LET ((WINDOW (MAKE-INSTANCE '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)
	(SEND WINDOW :INSIDE-SIZE)
      (LET* ((STRING-WIDTH (SEND WINDOW :STRING-LENGTH STRING))
	     (CENTER-Y (TRUNCATE HEIGHT 2))
	     (HALF-STRING-HEIGHT 30)
	     (LEFT-EDGE (MAX 0 (TRUNCATE (- 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)
	   (SEND WINDOW :CLEAR-WINDOW)
	   (SEND WINDOW :SET-CURSORPOS LEFT-EDGE TOP-EDGE)
	   (SEND 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)))
	      (SEND 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)
	      (SEND 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)
	      (SEND 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)
	      (SEND 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*))
	      (SEND 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)
	      (SEND WINDOW ':DRAW-TRIANGLE
		       X CENTER-Y
		       (+ X *LEXIPHAGE-MOUTH-X*) (+ CENTER-Y DY)
		       X (+ CENTER-Y DY)
		       ERASE-ALUF)
	      (SEND 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)
	      (SEND 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)
	      (SEND 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)
	      (SEND 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
;  (SEND *TERMINAL-IO* :CLEAR-WINDOW)
;  (SEND *TERMINAL-IO* :HOME-DOWN)
;  (OR (BOUNDP 'MF10-HACK5-BAR)
;      (SETQ MF10-HACK5-BAR (CREATE-SWITCH-REGISTER *TERMINAL-IO* 20 100 20 T)))
;  (SEND MF10-HACK5-BAR NIL)
;  (DO ((I 13357ALIAS (ROT I 1)))
;      ((SEND *TERMINAL-IO* :TYI-NO-HANG))
;    (SEND 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))
;   (SEND *TERMINAL-IO* :SET-FONT-MAP (LIST FONT))
;   (SEND *TERMINAL-IO* :SET-CURRENT-FONT FONT))

;(DEFUN PRINT-SMALL ()
;   (TERPRI)
;   (SEND *TERMINAL-IO* :SET-FONT-MAP (LIST FONTS:CPTFONT))
;   (SEND *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
;                                         (TRUNCATE (%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 N)))
;    (DOTIMES (I N)
;      (AS-1 (CREATE-SWITCH-REGISTER *TERMINAL-IO* BITS NIL  (+ (* I 44) 40) T)
;	    LITES
;	    I))
;    (SEND TERMINAL-IO :CLEAR-WINDOW)
;    (DOTIMES (I N)
;      (SEND (AR-1 LITES I) NIL))
;    (DO NIL ((EQ 203 (SEND TERMINAL-IO ':TYI-NO-HANG)))
;      (DO ((I 0 (1+ I))
;	   (L ADDRESS-LIST (CDR L)))
;	  ((>= I N))
;	(SEND (AR-1 LITES I)
;		 (SEND FCTN (CAR L)))))))

;(DEFUN RANDOM-TEST (&OPTIONAL (WINDOW *TERMINAL-IO*) &AUX TEM)
;    (SEND WINDOW ':CLEAR-WINDOW)
;    (DO () (())
;      (SETQ TEM (RANDOM))
;      (AND (SEND TERMINAL-IO ':TYI-NO-HANG) (RETURN NIL))
;      (SEND 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
;       (SEND 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))
;         ((send *terminal-io* :tyi-no-hang)
;	  (SEND 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)))
;       (SEND WINDOW :draw-line a b c d tv:alu-xor)
;       (SEND WINDOW :draw-line oa ob oc od tv:alu-xor))))

;(defun spazz (&OPTIONAL (WINDOW TERMINAL-IO))
;  (MULTIPLE-VALUE-BIND (X2 Y2)
;      (SEND 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)))
;)