;;;---	HBASE >		-*- package: user; mode: lisp; base: 10. -*-

; DECLARATIONS:

;(setq BASE 10. IBASE 10. *NOPOINT nil)

; General System Variables:
(special DEBUGGING? XGP-COUNT SKIP-FLAG DONE RUN-NUMBER PRINT-MODE TWOPI HALFPI PI
	 TOTAL-EXTEND-USAGE DATA-AREA TEMPORARY-AREA SIGNAL-AREA LATEST ITS DIR AREA-NUMBER
	 GRAPHICS-WINDOW GRAPHICS-WINDOW-ARRAY SCOPEN-TEMPLIST G-PRINLEVEL G-PRINLENGTH
	 G-PRINENDLINE SCREEN-ARRAY GRAPHICS-SCREEN-HEIGHT BREAK-ON-ERROR?)

; Debugging Utility Variables:
(special SYMBOL-SELECT SYMBOL-ACTION SEARCH-VAL-LIST DEBUG-FILE-LIST PF31415 PF31416
	 PF31417 PF31418 LD31415 LD31416 LD31417 LD31418 DRIBBLE-FILE DRIBBLE-IO-UNRCHF
	 FOUND-FILES-LIST ROD-ARRAY-COMPONENTS COMPILE-FILE-LIST INITIAL-MEMORY-SIZE)

; Frames:
(special ROBOT-FRAME CONTROL-FRAME ROD1 ROD2)

; Control Parameters:
(special DISPLAY-TIME ERASE-COUNT DISPLAY-MODE SCOPE-TOP FLOOR-ELASTICITY FLOOR-DAMPING
	 SHOW-EVAL? PRINT-VAL? FREERUN? STEPPING? SCREEN-CLEARED? NORMALIZATION-LIST
	 ROBOT-SCALE MOUSE-SCALE MOUSELIST-MODE JOINT-ELASTICITY JOINT-DAMPING MDV-LIST1
	 MDV-LIST2 NUMBER-SET-LIST SERVO)

; General Simulator Variables:
(special FRICTION ONE TWO THREE FOUR FIVE SIX SEVEN EIGHT NINE ZERO GRATE SHOW-LIST TIMESTEP
	 GRAVITY HCENTER SIM-TIME GRAPH-SIZE DISPLAY-LIST GPOS WIND JUMP-FLAG POWER
	 MOUSE-VERT MOUSE-HORIZ MOUSELIST MOUSELIST-PTR MOUSELIST-COUNT ENERGY
	 STATE-SPACE-GRAPH-LIST STATE-SPACE-GRAPH-LIST-LEN)

; Learning System Variables:
(special TEST-FCN-LIST TOP-LINE-ARRAY FACTOR CONVOLVE-ARRAY CONVOLVE-PATTERN CYCLES
	 BREAK-ON-INCONSISTENT? TOLERANCE TOLERANCE2 SAVED-AUGMATRIX)

; Miscellaneous and Temporary Variables:
(special X1 Y1 X2 Y2 F1 F2 F3 F4)


; FUNCTION DEFINITIONS FOR EDITOR EVALUATION:

(eval-when (EVAL)
	   (defun cl (&quote &rest files)
	     (zwei:save-all-files)
	     (and (equal files '(t)) (setq files COMPILE-FILE-LIST))
	     (mapc 'QC-FILE (cond (files) (t COMPILE-FILE-LIST)))
	     "Done.")
	   (defun cll (&quote &rest files)
	     (zwei:save-all-files)
	     (and (equal files '(t)) (setq files COMPILE-FILE-LIST))
	     (mapc 'QC-FILE-LOAD (cond (files) (t COMPILE-FILE-LIST)))
	     (and (eq files COMPILE-FILE-LIST) (load (fnp '(HPARAM >))))
	     "Done.")
	   (defun sa (&rest ignore)
	     (zwei:save-all-files)
	     "Done."))

(setq COMPILE-FILE-LIST '(HBASE HENUTL HSIM HCON HDATA HIGGR))


; DEFSTRUCT (MACRO) DEFINITIONS:

(defstruct (ROD (:MAKE-ARRAY (DATA-AREA 'ART-Q)))
	   CM-X CM-X-VELOC CM-X-ACCEL
	   CM-Y CM-Y-VELOC CM-Y-ACCEL
	   ANGLE ANGLE-VELOC ANGLE-ACCEL
	   LOWER-X LOWER-X-VELOC LOWER-X-ACCEL
	   LOWER-Y LOWER-Y-VELOC LOWER-Y-ACCEL
	   UPPER-X UPPER-X-VELOC UPPER-X-ACCEL
	   UPPER-Y UPPER-Y-VELOC UPPER-Y-ACCEL
	   COSANGLE SINANGLE LXF LYF UXF UYF
	   APPLIED-TORQUE
	   M1 M2 M3 MASS MOI LCM UCM LTOT
	   ROD-FRAME ROBOT-FRAME)

;;; Evaluate from Top to Here when recompiling everything. ;;;


; INITIALIZATIONS:

(or (fboundp 'G1DO-CONTINUE) (setq PRIN1 #'PRIN1))

(or (boundp 'SCOPEN-TEMPLIST)
    (setq PRINT-MODE 5. ZUNDERFLOW t
	  SHOW-LIST nil
	  DATA-AREA (make-area ':NAME ':DATA-AREA)
	  SIGNAL-AREA (make-area ':NAME ':SIGNAL-AREA)
	  TEMPORARY-AREA (make-area ':NAME ':TEMPORARY-AREA)
	  RUN-NUMBER 0. XGP-COUNT 0. TOTAL-EXTEND-USAGE 0.
	  SCOPEN-TEMPLIST (make-list WORKING-STORAGE-AREA 16.)
	  NORMALIZATION-LIST (make-list WORKING-STORAGE-AREA 201.)
	  MOUSELIST nil))

(setq BASE 10. IBASE 10. *NOPOINT nil
      SCREEN-ARRAY tv:(SHEET-SCREEN-ARRAY INITIAL-LISP-LISTENER)
      PF31415 "NONE" LD31415 "NONE"
      PF31416 ">" LD31416 "QFASL"
      PF31417 ITS LD31417 ITS
      PF31418 DIR LD31418 DIR
      DONE "Done." DEBUGGING? nil SCREEN-CLEARED? nil
      PI 3.1415926535s0 TWOPI (* 2.0s0 PI) HALFPI (// PI 2.0s0)
      DEBUG-FILE-LIST '(HSIM HCON HDATA HSIGGR))


; GENERAL MACROS:

(macro skip-this (form)
       `(unwind-protect
	  (*catch 'SKIP-THIS
		  (let ((SKIP-FLAG t)) . ,(cddr form)))
	  ,(second form)))

(defmacro gprinlong (item)
  `(let ((G-PRINENDLINE 10000.))
     (funcall PRIN1 ,item)))

(defmacro read-clear ( )
  '(prog1 (read TERMINAL-IO) (clear-input2)))

(macro setf-all (form)
       (do ((item (cdr form) (cddr item))
	    (outlist '(progn)))
	   ((null item) (reverse outlist))
	 (push `(setf ,(first item) ,(second item)) outlist)))

(macro increment (form)
       (do ((val (reverse (cdr form)) (cdr val))
	    (output ))
	   ((null val) `(setq ,@output))
	 (setq output (append `(,(car val) (1+ ,(car val))) output))))

(defmacro sleep (stime)
  `(process-sleep (round (* ,stime 60.))))

(defmacro charpos ( )
  '(// (TV:SHEET-READ-CURSORPOS TERMINAL-IO) 8.))

(defmacro clear-input2 ( )
  '(funcall TERMINAL-IO ':CLEAR-INPUT))

(defmacro listen2 ( )
  '(cond ((eq TERMINAL-IO TV:SELECTED-WINDOW) (kbd-tyi-no-hang))
	 (t nil)))

(defmacro terpri1 ( )
  '(cond ((not DEBUGGING?)
	  (funcall STANDARD-OUTPUT ':FRESH-LINE))))

(defmacro terpri2 ( )
  '(cond ((not DEBUGGING?)
	  (funcall STANDARD-OUTPUT ':FRESH-LINE)
	  (terpri))))

(defmacro not= (x y)
  `(not (= ,x ,y)))

(defmacro swap (x y)
  `(setq ,x (prog1 ,y (setq ,y ,x))))

(defmacro range (wanted limit)
  `(max (min ,wanted ,limit) (- ,limit)))

(defmacro radians (y)
  `(* (small-float ,y) ,(// PI 180.0s0)))

(defmacro degrees (y)
  `(* (small-float ,y) ,(// 180.0s0 PI)))

(defmacro square-root (n)
  `(small-float (sqrt (small-float ,n))))

(defmacro distance (ox oy nx ny)
  `(square-root (+ (square (- ,nx ,ox))
		   (square (- ,ny ,oy)))))

(defmacro polar-m (x y)
  `(square-root (+ (square ,x)
		   (square ,y))))

(defmacro vector-cross-product (x-radial y-radial x-velocity y-velocity)
  `(- (* ,x-radial ,y-velocity) (* ,x-velocity ,y-radial)))

(defmacro cosine (x)
  `(sine (+ ,x 1.570796326s0)))

(defmacro beep-tune* (beep-time wl)
  `(let ((TV:BEEP ':BEEP)
	 (TV:BEEP-DURATION ,beep-time)
	 (TV:BEEP-WAVELENGTH ,wl))
     (tv:beep)))


; GRAPHICS MACROS:

(defmacro baseline (ox oy nx ny)
  `(tv:%draw-line ,ox ,oy ,nx ,ny TV:ALU-IOR t TERMINAL-IO))

(defmacro baseline-erase (ox oy nx ny)
  `(tv:%draw-line ,ox ,oy ,nx ,ny TV:ALU-ANDCA t TERMINAL-IO))

(defmacro baseline-xor (ox oy nx ny)
  `(tv:%draw-line ,ox ,oy ,nx ,ny TV:ALU-XOR t TERMINAL-IO))

(defmacro gwpoint (x y type)
  `(aset (cond ((null ,type) 0.) (t 1.))
	 GRAPHICS-WINDOW-ARRAY ,x ,y))

(defmacro point (x y type)
  `(aset (cond ((null ,type) 0.) (t 1.))
	 SCREEN-ARRAY ,x ,y))

(defmacro gwbaseline (ox oy nx ny)
  `(tv:%draw-line ,ox ,oy ,nx ,ny 7. t GRAPHICS-WINDOW))

(defmacro xlim (x)
  `(max 8. (min 754. ,x)))

(defmacro ylim (y)
  `(max 8. (min (- GRAPHICS-SCREEN-HEIGHT 5.) ,y)))


; FUNCTION DEFINITIONS:

; WINDOW CREATION:

(defun window (&optional typeout? (more? t) (font FONTS:CPTFONT) (border 1.) (vsp 2.)
			 &aux window)
  (setq window (tv:window-create 'TV:LISP-LISTENER
				 ':BORDERS border
				 ':FONT-MAP (list font)
				 ':VSP vsp
				 ':EDGES-FROM ':MOUSE
				 ':MORE-P more?
				 ':INTEGRAL-P t))
  (and typeout? (<- window ':SET-DEEXPOSED-TYPEOUT-ACTION ':PERMIT))
  window)


; MISCELLANEOUS "SYSTEM INTERNALS" STUFF:

(defun more (&optional hang?)
  (cond ((equal (cond (hang? (message-tyi "More?"))
		      (t (listen2)))
		#\RUBOUT)
	 (beep-tune) (clear-input2)
	 (and (boundp 'SKIP-FLAG) (*throw 'SKIP-THIS nil))
	 t)))


(defun ^g (&rest msg)
  (and (fboundp 'RESET) (reset))
  (beep-tune)
  (cond (msg (terpri1) (funcall #'PRIN1 msg)))
  (*throw 'SI:TOP-LEVEL nil))


; Note that BREAK-xxx binds RUBOUT-HANDLER to NIL so that a new level of catch
; will be established.  Before returning it clears the old rubout handler's buffer.

(local-declare ((special ARGS))
  
  (defun break-error (&rest ARGS &aux (SI:RUBOUT-HANDLER NIL)
		      (EH:ERROR-HANDLER-IO (cond ((not (boundp 'DRIBBLE-FILE)) nil)
						 (t #'RSG-DRIBBLE-IO)))
		      (return-value) (DEBUGGING? nil)
		      (DEFAULT-CONS-AREA WORKING-STORAGE-AREA)
		      (EH:ERRSET-STATUS nil) (EH:CONDITION-HANDLERS nil))
    (cond (BREAK-ON-ERROR?
	   (message "BREAK-ERROR" nil) (terpri) (song)
	   (setq ARGS (cdr ARGS) return-value (cerror t nil nil "BREAK-ERROR invoked."))
	   (terpri) (princ "Returned: ") (funcall PRIN1 return-value)
	   (terpri) (clear-input2) (message "")
	   return-value)
	  (t (apply #'^g ARGS))))
  
  (defun break-loop (&rest ARGS &aux (SI:RUBOUT-HANDLER NIL)
		     (EH:ERROR-HANDLER-IO (cond ((not (boundp 'DRIBBLE-FILE)) nil)
						(t #'RSG-DRIBBLE-IO)))
		     (return-value) (DEBUGGING? nil)
		     (DEFAULT-CONS-AREA WORKING-STORAGE-AREA)
		     (EH:ERRSET-STATUS nil) (EH:CONDITION-HANDLERS nil))
    (message "BREAK-LOOP" nil) (terpri) (song)
    (or (null ARGS) (princ ARGS))
    (setq ARGS (cdr ARGS) return-value (break BREAK-LOOP))
    (terpri) (princ "Returned: ") (funcall PRIN1 return-value)
    (terpri) (clear-input2) (message "")
    return-value))


; MISCELLANEOUS MATHEMATICAL FUNCTIONS:

(defun square (x)
  (* x x))


(defun mod (x modulus &optional (count 0.))
  (cond ((> count 50.) (break-error "MOD -- Argument too large." x modulus count))
	((< x 0.) (mod (+ x modulus) modulus (1+ count)))
	((< x modulus) x)
	(t (mod (- x modulus) modulus (1+ count)))))


(setq RANDOM-NUMBER-SEED (mod (small-float (time)) 1.0s6))

(local-declare ((special RANDOM-NUMBER-SEED))

  (defun random-number (&aux temp)
    (setq RANDOM-NUMBER-SEED (mod (+ RANDOM-NUMBER-SEED (small-float (time))) 1.0s6)
	  temp (* 1.0s-4 (mod RANDOM-NUMBER-SEED 1.0s5)))
    (* 2.0s-6 (- (setq RANDOM-NUMBER-SEED (mod (* temp RANDOM-NUMBER-SEED) 1.0s6))
		 500.0s3))))


(defun pimod (a)
  (and (> (abs a) 20.0s0) (break-error "PIMOD -- Angle too large." a))
  (cond ((< a (- PI)) (pimod (+ a TWOPI)))
	((< a PI) a)
	(t (pimod (- a TWOPI)))))


(defun sine (x)
  (setq x (small-float x))
  (cond ((< (abs x) 1.0s-3) x)
	(t (min (max (let ((frac (// (abs x) 1.570796326s0))
			   (d)
			   (sign (cond ((> x 0) 1.)
				       (t -1.))))
		       (setq d (fix frac) frac (- frac d))
		       (selectq (ldb 0002 d)
			 (1 (setq sign (minus sign) frac (- frac 1)))
			 (2 (setq sign (minus sign)))
			 (3 (setq frac (- frac 1))))
		       (let ((y (* frac sign))
			     (y2 (* frac frac)))
			 (* y (+ 1.5707963185s0
				 (* y2 (+ -.6459637111s0
					  (* y2 (+ .07968967928s0
						   (* y2 (+ -.00467376557s0
							    (* y2 .00015148419s0)))))))))))
		     -1.0s0)
		1.0s0))))


(defun arctan (x y)				; returns 0.0s0 <= angle < TWOPI
   (setq x (small-float x)
	 y (small-float y))
   (prog ((absx (abs x)) (absy (abs y)) temp temp2 (ans -0.004054058s0))
	 (and (zerop x) (zerop y) (return 0.0s0))
	 (setq temp (// (- absy absx) (+ absy absx))
	       temp2 (* temp temp))
	 (do ((l '( 0.0218612288s0 -0.0559098861s0 0.0964200441s0
		   -0.139085335s0 0.1994653499s0 -0.3332985605s0 0.9999993329s0)
		 (cdr l)))
	     ((null l))
	   (setq ans (+ (* ans temp2) (car l))))
	 (setq ans (* ans temp) temp (abs ans))
	 (cond ((or (>= temp .7855s0) (< temp .7853s0))
		(setq ans (+ ans 0.7853981634s0)))
	       ((< ans 0.0s0) (setq ans (// absy absx)))
	       (t (setq ans (+ (// absx absy) 1.5707963268s0))))
	 (setq temp ans ans (- 3.1415926536s0 ans))
	 (and (>= x 0.0s0) (swap temp ans))
	 (setq temp (* temp 2.0s0))
	 (and (< y 0.0s0) (setq ans (+ ans temp)))
	 (return ans)))


; GENERAL-PURPOSE UTILITY FUNCTIONS (MOSTLY I/O):

; PRINLEVEL (default 2.) and PRINLENGTH (default 4.) control PRINC's actions when
; printing lists.  Setting them to NIL disables ellipsis.  G-PRINLENGTH and
; G-PRINLEVEL do same for GPRIN1.

(defun princ-rest (&rest strings)
  (princ-rest-internal 0. STANDARD-OUTPUT strings))

(defun princ-rest2 (&rest strings)
  (princ-rest-internal 0. TERMINAL-IO strings))

(defun princ-rest-indented (newline-col &rest strings)
  (princ-rest-internal newline-col STANDARD-OUTPUT strings))

(defun princ-rest-internal (newline-col stream strings)
  (or DEBUGGING?
      (do ((item) (column)
	   (G-PRINENDLINE 2.)
	   (STANDARD-OUTPUT stream)
	   (text strings (cdr text)))
	  ((null text))
	(setq item (car text)
	      column (+ (charpos)
			(cond ((and (fixp PRINT-MODE) (small-floatp item))
			       (+ PRINT-MODE 6.))
			      ((eq PRINT-MODE ':SLASHIFY) (flatsize item))
			      (t (flatc item)))))
	(and (> column 95.) (skip-to newline-col))
	(cond ((and (small-floatp item) (fixp PRINT-MODE))
	       (flonum-printer item))
	      ((eq PRINT-MODE ':SLASHIFY) (funcall PRIN1 item))
	      (t (princ item))))))


(defun flonum-printer (item)
  (let ((scale) (snum) (fix-part) (*NOPOINT t))
    (cond ((< item 0.0s0) (tyo #/-) (setq item (- item)))
	  (t (tyo #\SPACE)))
    (cond ((= item 0.0s0) (setq snum 0.0s0 scale 0.))
	  (t (do ((count 0. (cond ((< snum 1.0s0) (- count 3.))
				  ((>= snum 1000.0s0) (+ count 3.))
				  (t nil))))
		 ((null count))
	       (setq scale count
		     snum (cond ((zerop count) item)
				((plusp count) (// snum 1000.0s0))
				(t (* snum 1000.0s0)))))))
    (setq fix-part (fix snum))
    (princ fix-part) (tyo #/.)
    (do ((i (flatc fix-part) (1+ i))
	 (frac-part (* 10.0s0 (- snum fix-part)) (* frac-part 10.0s0))
	 (digit))
	((>= i PRINT-MODE))
      (setq digit (fix frac-part)
	    frac-part (- frac-part digit))
      (tyo (+ digit #/0)))
    (tyo #/s) (princ scale)))


(defun ask-3 (&rest msg &aux ch)
  (clear-input2)
  (bottom-line-question msg (1+ XGP-COUNT))
  (setq ch (message-tyi "Yes, No, or Q"))
  (tv:mouse-input nil)
  (cond ((or (= ch #\SPACE) (= ch #/y) (= ch #/Y))
	 (message "YES") (sleep 0.5s0) (message "" nil) t)
	((or (= ch #\RUBOUT) (= ch #/n) (= ch #/N))
	 (message "NO") (sleep 0.5s0) (message "" nil) nil)
	((or (= ch #/q) (= ch #/Q))
	 (beep-tune 1667.)
	 (setq ch (message "Type Q to verify."))
	 (and (or (= ch #/q) (= ch #/Q)) (xgp msg))
	 (apply #'ASK-3 msg))
	(t (beep-tune 1667.) (apply #'ASK-3 msg))))


(defun xgp (&optional msg)
  (song) (bottom-line-question msg (increment xgp-count))
  (screen-xgp-hardcopy) (song)
  DONE)


(defun bottom-line-question (msg count)
  (cursorpoint 3. 870. ':CLEAR-EOL)
  (princ-rest2 "XGP Page: " count)
  (cond (msg (princ  ", ") (apply #'PRINC-REST2 msg))))


(defun ask-yn (&rest text)
  (clear-input2)
  (apply #'PRINC-REST2 text)
  (prog (tem)
     repeat
	(setq tem (message-tyi "Yes or No."))
	(tv:mouse-input nil)
	(cond ((or (= tem #\SPACE) (= tem #/y) (= tem #/Y))
	       (beep-tune 1667.)
	       (princ " Yes." TERMINAL-IO) (terpri TERMINAL-IO) (return t))
	      ((or (= tem #\RUBOUT) (= tem #/n) (= tem #/N))
	       (beep-tune 2500.)
	       (princ "  No." TERMINAL-IO) (terpri TERMINAL-IO) (return nil))
	      (t (beep-tune 2000.) (go repeat)))))


(defun ask-yn-else (&rest text &aux tem)
  (clear-input2)
  (apply #'PRINC-REST2 text)
  (setq tem (message-tyi "Yes or No."))
  (tv:mouse-input nil)
  (cond ((or (= tem #\SPACE) (= tem #/y) (= tem #/Y))
	 (beep-tune 1667.)
	 (princ " Yes." TERMINAL-IO) (terpri TERMINAL-IO) t)
	((or (= tem #\RUBOUT) (= tem #/n) (= tem #/N))
	 (beep-tune 2500.)
	 (princ "  No." TERMINAL-IO) (terpri TERMINAL-IO) nil)
	(t (beep-tune 2000.)
	   (princ "  Question." TERMINAL-IO) (terpri TERMINAL-IO) '?)))


(defun ask-line-col (line col &rest text)
  (cursorset line col) (clear-input2)
  (apply #'PRINC-REST2 text)
  (prog (tem)
     repeat
	(setq tem (message-tyi "Yes or No."))
	(cond ((or (= tem #\SPACE) (= tem #/y) (= tem #/Y))
	       (beep-tune 1667.) (princ " Yes." TERMINAL-IO) (return t))
	      ((or (= tem #\RUBOUT) (= tem #/n) (= tem #/N))
	       (beep-tune 2500.) (princ "  No." TERMINAL-IO) (return nil))
	      (t (beep-tune 2000.) (go repeat)))))


(defun ask (&rest text)
  (clear-input2)
  (message "Ask: Sp, Rub, or Item")
  (prog (tem)
	(apply #'PRINC-REST text)
	(setq tem (tyipeek nil TERMINAL-IO))
	(message "" nil)
	(tv:mouse-input nil)
	(cond ((= tem 32.) (clear-input2) (beep-tune 1667.)
	       (princ " Yes.") (terpri) (return t nil))
	      ((= tem 135.) (clear-input2) (beep-tune 2500.)
	       (princ "  No.") (terpri) (return nil nil))
	      (t (return (prog1 (read-clear) (beep-tune 2000.)
				(beep-tune 2500.) (terpri))
			 t)))))


(defun message (string &optional (beep? t))
  (and beep? (beep-tune))
  (COMMENT
    (without-interrupts
      (tv:prepare-sheet (TV:WHO-LINE-WINDOW)
		      (tv:sheet-set-cursorpos TV:WHO-LINE-WINDOW 480. 0.)
		      (tv:sheet-clear-eol TV:WHO-LINE-WINDOW)
		      (tv:sheet-string-out TV:WHO-LINE-WINDOW string
					   0. (min 36. (string-length string))))))
  string)


(defun message-tyi (string &optional (beep? t))
  (message string beep?)
  (prog1 (kbd-tyi) (tv:kbd-esc-w nil)))


(defun round (x)
  (cond ((> (abs x) 1.0s6) (beep-tune 1667.)
	 (break-error "ROUND -- Overflow." x))
	(t (fix (+ 0.5s0 x)))))


(defun set-latest ( )
  (and (listp -) (symbolp (car -)) (not (null (car -))) (not (eq (car -) 'EVAL))
       (set (car -) (setq LATEST -)))
  LATEST)


(defun flushlist (item &optional value (depth 0.))
  (cond ((null item) nil)
	((listp item)
	 (do ((x item (cdr x)))
	     ((null x) item)
	   (rplaca x value)))
	((arrayp item)
	 (do ((limit (array-length item))
	      (index 0. (1+ index)))
	     ((>= index limit) item)
	   (aset value item index)))
	((and (symbolp item) (boundp item))
	 (flushlist (symeval item) value (1+ depth)))
	(t (break-error "FLUSHLIST -- Improper argument." item depth))))


(defun beep-tune (&optional (wl 2500.))
  (beep-tune* 75000. wl)
  DONE)


(defun clear ( )
  (cond ((not DEBUGGING?)
	 (funcall STANDARD-OUTPUT ':CLEAR-SCREEN)
	 (and (boundp 'GRAPHICS-WINDOW) (funcall GRAPHICS-WINDOW ':CLEAR-SCREEN))
	 (setq SCREEN-CLEARED? t))))


(defun song ( )
  (mapc #'BEEP-TUNE
	'(2500. 1667. 2500.))
  DONE)


(defun soft-print (line col text)
  (cond ((not DEBUGGING?)
	 (cursorset line col text)
	 (princ-rest2 text))))


(defun print-line (line col &rest text)
  (cond ((not DEBUGGING?)
	 (cursorset line col)
	 (apply #'PRINC-REST2 text))))


(defun line-print (col &rest text)
  (cond ((not DEBUGGING?)
	 (skip-to col)
	 (apply #'PRINC-REST text))))


(defun line-print2 (col &rest text)
  (cond ((not DEBUGGING?)
	 (skip-to col TERMINAL-IO)
	 (apply #'PRINC-REST2 text))))


(defun col-print (&rest arglist)
  (or DEBUGGING?
      (do ((arg arglist (cddr arg)))
	  ((null arg))
	(skip-to (first arg))
	(princ-rest (second arg)))))


(defun newline (topline bottomline &aux line)
  (setq line (1+ (linenum)))
  (cond ((< line topline) topline)
	((> line bottomline) topline)
	(t line)))


(defun cursorset (line col &optional (text '*NOT-SUPPLIED*) keyword &aux length)
  (cond ((or (< line 0.) (> line 62.) (< col 0.) (> col 95.))
	 (break-error "CURSORSET -- Off-screen coordinates." line col text keyword))
	((not DEBUGGING?)
	 (without-interrupts
	   (setq col (* col 8.) line (* line 14.))
	   (cursorpoint col line)
	   (cond ((eq text '*NOT-SUPPLIED*) (tv:sheet-clear-eol TERMINAL-IO))
		 (t (cond ((and (fixp PRINT-MODE) (small-floatp text))
			   (setq length (+ PRINT-MODE 8.)))
			  ((and (fixp text) (eq keyword 'CHARS))
			   (setq length text))
			  (t (setq length (+ (flatc text) 2.))))
		    (do ((i 0. (1+ i)))
			((>= i length))
		      (tv:sheet-clear-char TERMINAL-IO)
		      (tyo #\SPACE TERMINAL-IO))
		    (cursorpoint col line)))))))


(defun cursorpoint (x y &optional action)
  (cond ((or (< x 0.) (> x 767.) (< y 0.) (> y 883.))
	 (break-error "CURSORPOINT -- Off-screen coordinates." x y action))
	((not DEBUGGING?)
	 (without-interrupts
	   (tv:sheet-set-cursorpos TERMINAL-IO x y)
	   (cond ((null action))
		 ((eq action ':CLEAR-EOL) (tv:sheet-clear-eol TERMINAL-IO))
		 ((eq action ':CLEAR-CHAR) (tv:sheet-clear-char TERMINAL-IO))
		 ((eq action ':CLEAR-EOF) (tv:sheet-clear-eof TERMINAL-IO)))))))


(defun skip-to (n &optional (stream STANDARD-OUTPUT))
  (cond ((or (< n 0.) (> n 95.))
	 (break-error "SKIP-TO -- Off-screen coordinates." n stream))
	((not DEBUGGING?)
	 (let ((pos (charpos)))
	   (cond ((>= n (* 8. (1+ (// pos 8.))))
		  (tyo #\TAB stream) (skip-to n stream))
		 ((< n pos) (terpri stream) (skip-to n stream))
		 ((> n pos) (tyo #\SPACE stream) (skip-to n stream)))))))


(defun linenum ( )
  (multiple-value-bind (nil y)
      (TV:SHEET-READ-CURSORPOS TERMINAL-IO)
    (// y 14.)))


(defun fnp (file)
  (cond ((or (symbolp file) (stringp file))
	 (string-append its ": " dir "; " file " >"))
	((listp file)
	 (cond ((= (length file) 1.)
		(string-append its ": " dir "; " (first file) " >"))
	       ((= (length file) 2.)
		(string-append its ": " dir "; "
			       (first file) " " (fnp* (second file))))
	       ((= (length file) 3.)
		(string-append its ": " (third file) "; "
			       (first file) " " (fnp* (second file))))
	       ((= (length file) 4.)
		(string-append (fourth file) ": " (third file) "; "
			       (first file) " " (fnp* (second file))))
	       (t (break-error "FNP -- Screwed filename." file))))
	(t (break-error "FNP -- Screwed filename." file))))


(defun fnp* (name)
  (cond ((symbolp name) (string name))
	((stringp name) name)
	((numberp name) (format nil "~D" name))
	(t (break-error "FNP -- Screwed filename." name))))


;;; End.