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

(send tv:initial-lisp-listener :set-more-p nil)

;;; Black characters on white background.
(send tv:who-line-documentation-window :set-reverse-video-p t)
;(push '(send tv:who-line-documentation-window :set-reverse-video-p t) logout-list)

(tv:black-on-white)
;(push '(tv:black-on-white) logout-list)

;;; Get rid of GATEWAY
(tv:remove-system-key #\g)

;;; Scheduler takes too much time.
(write-meter 'sys:%tv-clock-rate 60.)

;;; Improve paging performance (maybe)
(write-meter 'sys:%aging-depth 3.)

;;; Volatility scan on swapout.  Turned on August 18
;;; after fixing paging and hashing bugs.
(setf (ldb (byte 1 4) sys:%disk-switches) 1)

;;; Fix the world.
(load-patches :noselective)

;;;; Use OBJECT-HASH to print random frobs.

;si:
;(defun print-random-object-suffix-with-object-hash (object stream &optional no-pointer)
;  (unless no-pointer
;    (send stream :tyo (pttbl-space *readtable*))
;    (print-raw-fixnum (gc:object-hash object) si:base stream))
;  (send stream :string-out (cdr (pttbl-random *readtable*))))

;(fset 'si:print-random-object-suffix 'si:print-random-object-suffix-with-object-hash)

;;; Add some SCHEME primitives (predicates with question marks).
;(load "dj:jrm;custom.qfasl" :package 'user)

;;; Fancy mouse blinkers for zwei
;(load "dj:jrm;bobhack.qfasl")

;(logo-blinker) ;cons cell

;;; Mac style windows.
;;; Actually, I guess I don't like them.
;(setq tv:*saved-bit-arrays-wipe?* nil)

;;; Fix dumb speling mistakes!
(setq si:*enable-spelling-dwim?* t)

;;; Random
(load "dj:pace;disable-page-out-words")

(defun jrm-query-terminal ()
  (case (fquery 
	 (list
	   ':choices '(((p "Portrait")       #\P)
		       ((l "Landscape")      #\L)
		       ((f "Fancy Landscape")#\F)
		       ((n "Leave it alone") #\END))
	   ':fresh-line 't
	   ':default-value 'f
	   ':timeout (* 30. 60.)) ;30 seconds.
	"Screen type? ")
    (p (tv:portrait))
    (l (tv:landscape))
    (f (ignore-errors
	 (make-system 'fancy-landscape :noconfirm)
	 (tv:fancy-landscape)))
    (n nil)))

(defun reversible-gc-on ()
;  (let ((old-gc-state-vector #(0 0 0 0)))
;    (copy-array-contents gc:*level-control* old-gc-state-vector)
;    (push `(copy-array-contents ,old-gc-state-vector gc:*level-control*)
;	  logout-list)
    (gc:gc-on :degree 3)
    (let ((physical-memory (aref #'sys:system-communication-area sys:%sys-com-memory-size)))
      (setq physical-memory (min physical-memory (^ 2 21.)))
      (let* ((level-1-size (truncate physical-memory 2))
	     (level-2-size (truncate level-1-size    3))
	     (level-3-size (truncate level-2-size    3)))
	(setf (aref gc:*level-control* 3) level-3-size)
	(setf (aref gc:*level-control* 2) level-2-size)
	(setf (aref gc:*level-control* 1) level-1-size)
	(setf (aref gc:*level-control* 0) nil)))
    ;)
    )

(defun adjust-volatility (area new-volatility)
  (setf (ldb si:%%region-volatility (aref #'si:area-region-bits area)) new-volatility))

;;; This var should be special.
(defvar zwei:zwei-line-area)

;;; Make ZWEI swap out things in groups.
(si:set-swap-recommendations-of-area zwei:zwei-line-area 12.)

;;; Change the default volatilities of these areas.
(defvar *new-region-volatilities*
   (list (list zwei:zwei-line-area 3)
	 (list fs:pathname-area    0)
	 (list tv:sheet-area       0)))

(mapcar #'(lambda (new-region-volatility)
	    (apply #'adjust-volatility new-region-volatility))
	*new-region-volatilities*)

(reversible-gc-on)

;(defun mail-watch ()
;  (tagbody
;      wait-for-mail
;	 (multiple-value-bind (mail? ignore)
;	     (ignore-errors
;	       (probef "ANGEL:/usr/spool/mail/jrm"))
;	   (cond (mail? (tv:notify nil "You have new mail.") (go wait-for-no-mail))
;		 (t (sleep (* 60. 5.)) ;;Check every 5 minutes.
;		    (go wait-for-mail))))
;      wait-for-no-mail
;	 (multiple-value-bind (mail? ignore)
;	     (ignore-errors
;	       (probef "ANGEL:/usr/spool/mail/jrm"))
;	   (cond (mail? (sleep (* 60. 5.)) (go wait-for-no-mail))
;		 (t (go wait-for-mail))))))

;(process-run-function "Mail Watcher" #'mail-watch)

(jrm-query-terminal)

(login-forms

  ;; Customized indentation for zwei.
  (push '(IF 2 3) ;; Indent three after predicate.
	zwei:*lisp-indent-offset-alist*)
  
  )

;;; Make the package system be mean!!
(login-setq si::*read-single-colon-allow-internal-symbol* t)

;;; Common lisp mode
(common-lisp t)

(send tv:initial-lisp-listener :set-more-p t)