;;; -*- Mode:LISP; Package:USER; Base:10; Readtable:ZL -*- 


;;;SAZ's LISPM init file
(format t "~%~%~\date\~%~%" (time:get-universal-time))	;What the hell day is it, anyway?
(login-setq fs:user-id "saz")				;ensure lower case
(login-setq si:system-additional-info "126.100 10/4")	;just until multi-line bug in WRITE-RESPONSIBILITY gets fixed
(load "dj:saz;mass-millions")

(login-setq ZWEI:*CONVERSE-BEEP-COUNT* 1)
(login-setq ZWEI:*NOTIFY-ON-NEW-MAIL-IN-BACKGROUND* ':converse)
(login-setq ZWEI:*FIND-FILE-EARLY-SELECT* T)	;where has this one been all my life?

(login-setq zwei:*zmail-init-loaded* t)
(load "dj:saz;zmail.init")			;don't wait for me to fire up zmail to get my init file read in...

(login-setq zwei:*from-host* "gsi-cam")         ;don't wait for me to fire up zmail to enable me to send mail from
						;Zwei without header canonicalization problems...

(tv:map-over-sheets #'(lambda (win) (send win :set-deexposed-typeout-action ':permit)))

(tv:kbd-esc-more 0)				;turn it off until lispm.init is done loading


(defun boost-all-quanta (amt)			;efficiency hack
  (login-setq si::default-quantum amt)
  (mapcar #'(lambda (proc)
	      (send proc :set-quantum amt))
	  si::all-processes))

(defmacro with-fdefine-warnings-inhibited ((&body body))
  `(let ((inhibit-fdefine-warnings t))
     ,body))

(defmacro ndelq (object list &optional (times -1))
  ;;really delete object from list regardless of position...
  `(if (mem #'eq ,object ,list)
       (if (zerop (find-position-in-list ,object ,list))
	   (setq ,list (delq ,object ,list ,times))
	 (delq ,object ,list ,times))))

(defmacro watch-vars (vars form)
  ;; indicates any mutations of variables specified in vars which arose
  ;; as a result of evaluating form...
  ;; E.g., (watch-vars (foo bar) (setq foo 3 bar 4))
  ;;   ==> foo: NIL --> 3
  ;;       bar: NIL --> 4
  ;;       4
  ;; ...assuming of course that the two variables were unbound before
  ;; calling watchvars...
  `(let ((vars-before (mapcar #'(lambda (var) (if (boundp var) (symeval var)))
			      ',vars)))
     (let ((return-me (si:eval-special-ok ',form)))
       (loop for var in ',vars and old-val in vars-before do
	     (format t "~%~A: ~S --> ~S" var old-val (symeval var)))
       return-me)))
 
(defun zwei:wops (thing)
  ;;It is not a good idea to send messages to anything other than instances and named-structures,
  ;;as send employs funcall on its arguments.  For example, if destructive-function is a function
  ;;which ignores its first argument, then doing a (send #'fs:destructive-function :message) will
  ;;trigger the execution of destructive-function in all its destructive glory.
  (etypecase thing
    ((or instance named-structure)
     (condition-case ()
	 (let ((ops (send-if-handles thing :which-operations)))
	   (if (null ops)
	       (format t "~%No :which-operations method defined for ~A ~A"
		       (string-downcase (type-of thing)) thing)
	     (pprint ops)
	     ops))
       ((sys:undefined-function si:invalid-function)
	(format t "~%~A,~
	           ~%an object of type ~A, does not support messages." thing (type-of thing)))))))

(defun STOPWATCH ()
  (let ((foo (time:get-universal-time))) 
    (progn (tyi)
	   (format t "~2%Seconds elapsed: ~A~%" (- (time:get-universal-time) foo)))))   

#+regression-testing
(cl-tests:deftest-seq
  (zwei:wops zwei:wops-1 :simple)
  (((zwei:wops-1 :is-error) (zwei:wops nil))
   ((zwei:wops-2 :is-error) (zwei:wops t))
   ((zwei:wops-3 :is-error) (zwei:wops 5))
   ((zwei:wops-4 :is-error) (zwei:wops #'si:print-disk-label))
   ((zwei:wops-5) (zwei:wops (zl:make-instance 'si:vanilla-flavor)))))

(defvar *JUST-EXECUTE-EVERYTHING* nil)

(defmacro ASK-WAIT-AND-EXECUTE (prompt timeout-secs response-if-no-answer
				value-if-no-user-answer &body body)
  ;;;prompt and response-if-no-answer are strings, timeout-secs a fixnum.
  `(*catch 'RESULT
     (if *just-execute-everything*
	 (progn (format query-io ,response-if-no-answer)
		;; Automatically use the defalut for this and all other calls to this function.
		(if ,value-if-no-user-answer ,@body)	       
		(*throw 'result ,value-if-no-user-answer))
       (if (with-timeout ((* ,timeout-secs 60) 
			  (format query-io ,response-if-no-answer)
			  ;; only if user did not respond
			  ;; within the time allotted by the top-level call
			  (*throw 'RESULT ,value-if-no-user-answer)) 
	     (y-or-n-p ,prompt))
	   (progn ,@body			;do it
		  (*throw 'result t))		;only if user responded, affirmatively
	 (*throw 'result nil)))))		;only if user responded, negatively

(login-setq *JUST-EXECUTE-EVERYTHING*
      (ask-wait-and-execute "Shall I default automatically during init file loading?"
			    10
			    "... OK, I'll default: ~%"
			    t			;yes if user is not around...
	nil))					;this value is unimportant...


(ask-wait-and-execute "~&Boost all quanta? " 10 "~& ... all quanta boosted." t (boost-all-quanta 6.))

;;;This will work after fquery gets fixed...!
;(defun SET-GC-DEGREE-OR-TURN-IT-OFF (max-response-time)
;  (let* ((response-seconds (* max-response-time 60.))
;	 (degree (fquery `(:type :tyi
;				:timeout ,response-seconds
;				:default-value no-answer
;				:choices ((0 "~&0") (1 "~&1") (2 "~&2") (3 "~&3") :any))
;			 "~&Turn GC on with degree: ")))
;    (cond ((and (fixp degree)
;		( degree 0)
;		( degree 3))
;	   (progn (gc:gc-on :degree degree)
;		  (format t "~&~%GC turned on at level ~A" degree)))
;	  ((eq degree 'no-answer)			;timed out; what we usually want
;	   (progn
;	     (gc:gc-on :degree 0)
;	     (format t "~&~%GC turned on at level 1")))
;	  (t (progn (gc:gc-off)
;		    (format t "~&~%GC turned off"))))))

;(SET-GC-DEGREE-OR-TURN-IT-OFF 5.)
    
(ask-wait-and-execute (format nil "~&Load system patches and//or site
configuration information? ")
		      			   20 "~& ... loading system patches now ..." t   (load-patches :noselective))

;(ask-wait-and-execute "~&Make a BUGMAN system?" 20 "~& ... making the BUGMAN system now ... "
;  		       t (make-system 'bugman :noconfirm))
;(ask-wait-and-execute "~&Make a WINDOW-MAKER system?" 20 "~& ... making the WINDOW-MAKER system now ... "
;		       t (make-system 'window-maker :noconfirm))
(ask-wait-and-execute "~&Make a VALID system?" 20 "~& ... Ok, making the VALID system now ... "
		      t (make-system 'valid :noconfirm))
(ask-wait-and-execute "~&Load LISP macros?" 10 "~& ... loading LISP macros now ... "
		      t (load "dj:saz;macros"))
(load "dj:saz;pathname")
(ask-wait-and-execute "~&Load ZMacs enhancement file?" 10 "~& ... loading ZMacs enhancement file now ... "
		      t (load "dj:saz;zmacs"))


(export 'zwei:wops 'global)

(setq fs:*load-set-default-pathname* t)
(setq *just-execute-everything* nil)
(tv:kbd-esc-more 1)