;;; -*- Mode:LISP; Package:USER; Lowercase:T; Readtable:CL -*-
;;; Don't add Base attribute.

;;; RPK: The fine art of firewalling:
(unless (lisp:member :lispm *features*)
  (error "Do you really expect this to work on a ~A ?" (machine-type)))

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

(DEFUN BASH-FUNCTION (NAME VALUE)
  (PUSH (FSYMEVAL NAME) (GET NAME 'OLD-FUNCTIONS))
  (FSET NAME VALUE))

(DEFUN BASH-VARIABLE (NAME VALUE)
  (PUSH (SYMEVAL NAME) (GET NAME 'OLD-VARIABLES))
  (SET NAME VALUE))

(DEFUN UNBASH-FUNCTION (NAME)
  (FSET NAME (CAR (OR (LAST (GET NAME 'OLD-FUNCTIONS)) (ERROR "NOT BEEN BASHED")))))

(DEFUN UNBASH-VARIABLE (NAME)
  (SET NAME (CAR (OR (LAST (GET NAME 'OLD-VARIABLES)) (ERROR "NOT BEEN BASHED")))))

(chaos:eval-server-on nil)
(push '(chaos:eval-server-on t) logout-list)
(bash-function 'chaos:eval-server-on #'true)
(push '(unbash-function 'chaos:eval-server-on) logout-list)

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

;;; JRM: I prefer a black screen.
(tv:white-on-black)
(send tv:who-line-documentation-window :set-reverse-video-p nil)
;(push '(tv:black-on-white) logout-list)
;(push '(send tv:who-line-documentation-window :set-reverse-video-p t) logout-list)

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

;;; JRM: Fancy mouse blinkers for zwei
(unless (fboundp 'user:logo-blinker)
  (load "lad:pld;bobhack"))
;(logo-blinker) ;cons cell

;;; DG: Make WHO-LINE DOC window readable
(SEND TV:WHO-LINE-DOCUMENTATION-WINDOW :SET-FONT-MAP '(HL10B))
(push '(send tv:who-line-documentation-window :set-font-map '(cptfont)) logout-list)

;;; RPK:
(login-setq *read-base* 10.			; Human bases
	    *print-base* 10.
	    fs:user-personal-name "DeWolf, Peter"
	    fs:user-personal-name-first-name-first "Peter L. DeWolf")

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

;;; PACE:
;zwei:
;(zwei:defcom com-skip-to-next-defun "" ()
;  (move-bp (point) (zwei:zwei-search (point) #.(format nil "~%(") nil t))
;  (move-bp (point) (zwei:beg-line (point))) 
;  (zwei:com-reposition-window))

;(zwei:set-comtab zwei:*zmacs-comtab* '(#\hand-right zwei:com-skip-to-next-defun))

;;; Random
(load "lad:pld;disable-page-out-words")

(defun pld-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))
       (if (fboundp 'tv::fancy-landscape)
	   (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 2)
    (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))

(defvar zwei:zwei-line-area)

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

(defvar *new-region-volatilities*
   (list (list zwei:zwei-line-area 1)
	 (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)

;;; JRM:
(defun mail-watch ()
  (tagbody
      wait-for-mail
	 (multiple-value-bind (mail? ignore)
	     (ignore-errors
	       (probef "ANGEL:/usr/spool/mail/pld"))
	   (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/pld"))
	   (cond (mail? (sleep (* 60. 5.)) (go wait-for-no-mail))
		 (t (go wait-for-mail))))))

(defvar mail-process nil "process of pld's mail watcher")
;(if (setq mail-process (process-run-function "Mail Watcher" #'mail-watch))
;    (push '(send mail-process :kill) logout-list))

(defun backup-files ()
  (dolist (source-host '("aza:"))
    (dolist (dest-host '("lad:" "jb:"))
      (dolist (directory '("pld.network;" "pld.network.old-tcp-user;" "pld.network.old-tcp-server;"))
	(let ((source (string-append source-host directory))
	      (dest (string-append dest-host directory)))
	  (format t "~&~S -> ~S" source dest)
	  (fs:balance-directories source dest :direction :1->2))))))

(pld-query-terminal)

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