;;;	UTILS > -*- Mode:LISP; Package:USER; Base:10.; readtable: CL -*-

;;; This file contains miscellaneous functions of general utility.

(defsubst skip-to (col)
  (send *TERMINAL-IO* :set-cursorpos col nil :character))


;;; DISPLAY VARIOUS INFORMATION ON MEMORY USAGE.

(defvar *AREA-TEST-ALREADY-PRINTED-THIS*)

(defun area-test (object &aux *AREA-TEST-ALREADY-PRINTED-THIS*)
  (area-test2 object "Object: ")
  (terpri)
  (values))

(defun area-test2 (object &rest strings)
  (cond ((memq object *AREA-TEST-ALREADY-PRINTED-THIS*))
	(t (push object *AREA-TEST-ALREADY-PRINTED-THIS*)
	   (apply #'TERPRINC2 strings)
	   (prin1 object)
	   (let ((type (type-of object)))
	     (princ-rest "  Type: " type)
	     (let ((area (%area-number object)))
	       (terprinc "Area: " area
			 " (" (if (integerp area)
				  (area-name area)
				"NO AREA!!")
			 ")"))
	     (cond ((memq type '(SYMBOL FIXNUM BIGNUM CHARACTER SINGLE-FLOAT SHORT-FLOAT)))
		   ((consp object)
		    (area-test2 (car object) "Car: ")
		    (area-test2 (cdr object) "Cdr: "))
		   ((and (si:named-structure-p object)
			 (cond ((and (get (si:named-structure-p object)
					  'SI:NAMED-STRUCTURE-INVOKE)
				     (memq ':DESCRIBE
					   (si:named-structure-invoke object :WHICH-OPERATIONS)))
				(terpri)
				(si:named-structure-invoke object :DESCRIBE)
				t)
			       ((get (si:named-structure-p object) 'SI:DEFSTRUCT-DESCRIPTION)
				(my-describe-defstruct object)
				t)
			       (t nil))))
		   ((arrayp object) (my-describe-array object))
		   ((instancep object) (my-describe-instance object))
		   (t (describe object)))))))


(proclaim '(special LAM:%%ARRAY-LONG-LENGTH-FLAG))

(defun my-describe-array (array)
  (fresh-line)
  (let ((rank (array-rank array))
	(long-length-flag (%p-ldb-offset LAM:%%ARRAY-LONG-LENGTH-FLAG array 0)))
    (format t "This is an ~S type array. (element-type ~S)~%"
	    (array-type array) (array-element-type array))
    (case rank
      (0 (format T "It is of zero rank."))
      (1 (format t "It is a vector, with a total size of ~S elements" (array-total-size array))
	 (unless (stringp array)
	   (dotimes (i (array-total-size array))
	     (area-test2 (aref array i) "Element " i ": "))))
      (t (format T "It is ~S-dimensional, with dimensions " rank)
	 (dotimes (d rank) (format t "~S " (array-dimension array d)))
	 (format t ". Total size ~S elements" (array-total-size array))))
    (when (array-has-leader-p array)
      (let ((length (array-leader-length array)))
	(if (and (= rank 1)
		 (= length 1)
		 (fixnump (array-leader array 0)))
	    (format t "~%It has a fill-pointer: ~S" (fill-pointer array))
	  (format t "~%It has a leader, of length ~S.  Contents:" length)
	  (dotimes (i length)
	    (area-test2 (array-leader array i) "Leader " i ": ")))))
    (when (array-displaced-p array)
      (cond ((array-indirect-p array)
	     (format t "~%The array is indirected to ~S"
		     (%p-contents-offset array (+ rank long-length-flag)))
	     (and (array-indexed-p array)
		  (format T ", with index-offset ~S"
			  (%p-contents-offset array (+ rank long-length-flag 2))))
	     (format t "~%Description of that array:")
	     (si:describe-1 (%p-contents-offset array (+ rank long-length-flag))))
	    (t (format t "~%The array is displaced to ~S"
		       (%p-contents-offset array (+ rank long-length-flag))))))))

(DEFUN my-DESCRIBE-DEFSTRUCT (X)
  (fresh-line)
  (LET ((DESCRIPTION (GET (IF (CONSP X) (CAR X) (NAMED-STRUCTURE-P X))
			  'si:DEFSTRUCT-DESCRIPTION)))
    (FORMAT T "~S is a ~S~%" X (si:DEFSTRUCT-DESCRIPTION-NAME DESCRIPTION))
    (DO ((slots (si:DEFSTRUCT-DESCRIPTION-SLOT-ALIST DESCRIPTION) (cdr slots))
	 (index 0 (1+ index)))
	((null slots))
      (let* ((L (car slots))
	     (value (EVAL `(,(si:DEFSTRUCT-SLOT-DESCRIPTION-REF-MACRO-NAME (CDR L)) ',X))))
	(area-test2 value "Slot " index ", " (CAR L) ", Value:
 ")))))

(defun my-describe-instance (instance)
  "Prints out each of the slots of INSTANCE.
This bypasses the :DESCRIBE method of the instance."
  (fresh-line)
  (let* ((flavor (si:%instance-flavor instance))
	 (ivars (si:flavor-all-instance-variables flavor)))
    (format t "~S is an instance of flavor ~S" instance flavor)
    (loop for v in ivars
	  for n from 1
	  do (let ((value (si:%instance-ref instance n)))
	       (area-test2 value "Instance Variable " n ", " v ", Value:
 ")))))


;;; GENERAL "OPERATING SYSTEM" UTILITIES:

(defun purge (&rest directories)
  (when (y-or-n-p "Purge RSG ?")
    (filesystem-purge :directory "RSG" :versions-to-keep 2))
  (when (y-or-n-p "Purge MZWEI ?")
    (filesystem-purge :directory "MZWEI" :versions-to-keep 2))
  (do ((dirs directories (cdr dirs))
       (dir))
      ((null dirs))
    (setq dir (string-upcase (car dirs)))
    (when (y-or-n-p "Purge ~A ?" dir)
      (print (filesystem-purge :directory dir :versions-to-keep 2))))
  (terpri)
  (values))

(defun flavor-ops (object string)
  (do ((items (send object :which-operations) (cdr items))
       (outputlist))
      ((null items)
       (mapc #'PRINT outputlist)
       (terpri)
       (values))
    (when (search string (string (car items)) :test #'CHAR-EQUAL)
      (push (car items) outputlist))))


;;; GENERAL-PURPOSE UTILITY FUNCTIONS.

(defun cl (system &optional recompile?)
  (sa)
  (make-system system (if recompile? :recompile :compile)))

(defun halt ( )
  (sa)
  (when (y-or-n-p "Are you sure you want to halt ?")
    (logout)
    (si:%halt)))

(defun sa ( )
  (let ((ZWEI:*WINDOW* t)
	(ZWEI:*NUMERIC-ARG-P* nil))
    (zwei:com-save-all-files)
    (values)))

(defun ma (&rest args)				; Avoids garbage printout of
  (apply #'MAPC args)				; MAPC's return value.
  (terpri)
  (values))

(defun change (index new-value change-list)
  (when (fixp index)
    (setf (nth index change-list)
	  (cond ((floatp new-value) (small-float new-value))
		(t new-value))))
  change-list)

(defun mult (list num)
  (map #'(lambda (x)
	   (rplaca x (* (car x) (small-float num))))
       list)
  list)


;;; CHANGES ALL FLOATS IN A TREE (OR LIST) TO SMALL-FLOAT.

(defun make-small-float (tree &optional copy?)
  (when copy?
    (setq tree (copy-tree tree)))
  (when (numberp (car tree))
    (rplaca tree (small-float (car tree))))
  (when (numberp (cdr tree))
    (rplacd tree (small-float (cdr tree))))
  (unless (atom (car tree))
    (make-small-float (car tree)))
  (unless (atom (cdr tree))
    (make-small-float (cdr tree)))
  tree)


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

(defun terprinc (&rest things)
  (fresh-line)
  (apply #'PRINC-REST things))

(defun terprinc2 (&rest things)
  (fresh-line)
  (terpri)
  (apply #'PRINC-REST things))

(defun princ-rest (&rest things)
  (do ((item things (cdr item)))
      ((null item))
    (princ (car item))))

(defun soft-print (line col item)
  (cursorset line col item)
  (princ item))

(defun print-line (line col &rest things)
  (cursorset line col)
  (apply #'PRINC-REST things))

(defun line-print (col &rest things)
  (skip-to col)
  (apply #'PRINC-REST things))

(defun cursorset (line col &optional (item '*NOT-SUPPLIED*) keyword &aux length)
  (setq col (* col 8.)
	line (* line 14.))
  (cursorpoint col line)
  (cond ((eq item '*NOT-SUPPLIED*) (tv:sheet-clear-eol *TERMINAL-IO*))
	(t (cond ((and (fixp item) (eq keyword 'CHARS))
		  (setq length item))
		 (t (setq length (+ (flatc item) 2.))))
	   (do ((i 0. (1+ i)))
	       ((>= i length))
	     (tv:sheet-clear-char *TERMINAL-IO*)
	     (write-char #\SPACE))
	   (cursorpoint col line))))

(defun cursorpoint (x y)
  (when (or (< x 0.) (> x *MAX-SCREEN-X*) (< y 0.) (> y *MAX-SCREEN-Y*))
    (ferror nil "Off-screen coordinates."))
  (tv:sheet-set-cursorpos *TERMINAL-IO* x y))


;;; Initializations:

(globalize "AREA-TEST")
(globalize "FLAVOR-OPS")
(globalize "SA")
(globalize "MA")
(globalize "HALT")


;;; End.