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

;;;Keith's LISPM init file

;;;Use CommonLISP (almost) everywhere

(COMMON-LISP T T)

;;;Who I am

(login-setq fs:user-personal-name-first-name-first "Keith M. Corbett")
(fs:file-host-user-id "keith" (si:parse-host "angel"))


;;;Various personal system settings

(when (< (si:get-system-version) 124)
  (import 'format:y-or-n-p-with-timeout))

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

(let((boost-p (y-or-n-p-with-timeout (* 10 60) T   "Boost all quanta?"))
     (goose-p (y-or-n-p-with-timeout (* 10 60) NIL "Goose up GC?"))
     (patch-p (y-or-n-p-with-timeout (* 10 60) T   "Load patches and/or site info?"))
     (tcp-p   (y-or-n-p-with-timeout (* 10 60) T   "Use TCP to access mail server?"))
     )
  (and  boost-p
        (set-all-quanta 6.))
  (and goose-p
       (gc:gc-on :degree 2))
  (and patch-p
       (load-patches :noselective))
  (and tcp-p
       ;;;Use FTP to Unix mail server, not Chaosnet
       (let ((hosts '("angel")))
	 (fs:reset-file-access hosts 'fs:ftp-access)
	 (pushnew `(fs:reset-file-access ',hosts) logout-list)))
  )

;;;Make WHO-LINE DOC window readable

(SEND TV:WHO-LINE-DOCUMENTATION-WINDOW :SET-FONT-MAP '(HL10B))
(pushnew '(send tv:who-line-documentation-window :set-font-map '(cptfont)) logout-list)

;;;Make initial windows friendlier

(send tv:initial-lisp-listener :set-deexposed-typeout-action :permit)

(let((supdup (tv:find-window-of-flavor 'supdup)))
  (when supdup
    (send supdup :set-deexposed-typeout-action :permit)))

;;;Zwei

(load (merge-pathnames "zwei-stuff" (fs:user-homedir)))

;;;ZMail

(zwei:load-zmail-init-file)

;;;Tiger stuff

(when (find-package "TIGER")
  (let((*package* (find-package "TIGER")))
    (tv:add-escape-key #\ctrl-L
		       #'(lambda(&rest ignore)
			   (start-tiger)
			   (send *tiger-operator-window* :select))
		       "Select the Tiger Operator Window")
    (login-setq *laser1+-orientation* :portrait)
    (login-setq *laser1-orientation* :portrait)))

;;;TV stuff

(defun pop-up-prompt (prompt &optional (sup tv:mouse-sheet) (pop-up-near '(:mouse)))
  (let ((message (string-append prompt " ")))
    (let ((pop-up-message-window (make-instance 'tv:pop-up-text-window :superior sup)))
      (send pop-up-message-window :set-label nil)
      (send pop-up-message-window :set-size-in-characters message message)
      (send pop-up-message-window :clear-input)
      (tv:expose-window-near pop-up-message-window pop-up-near nil)
      (tv:window-call (pop-up-message-window :deactivate)
	(send pop-up-message-window :string-out message)
	;(send pop-up-message-window :tyo #\space)
	;; Back up the cursor by one.  This is easier than trying to make the window
	;; come out wider, because of the interface to :set-size-in-characters.
	(multiple-value-bind (x-pos y-pos)
	    (send pop-up-message-window :read-cursorpos :character)
	(send pop-up-message-window :set-cursorpos (1- x-pos) y-pos :character))
	(let ((response (send pop-up-message-window :any-tyi)))
	  (typecase response
		 (list response)
		 ((or number character)
		  (send pop-up-message-window :tyo response)
		  (tv:blinker-set-visibility (first (last (send pop-up-message-window :blinker-list))) nil)
		  (sleep 1.)
		  (character response))
		 (t (beep))))))))