;;; -*- Mode:LISP; Package:HL; Readtable:CL; Base:10; Patch-file: T -*-

;(defun lisp:break (&optional format-string &rest args)
;  (when format-string
;    (apply #'format *error-output* format-string args))
;  (eh:debug))
;(defun breakpoint-in-code-style-checker (form)
;  (ignore form)
;  (compiler:warn 'breakpoint-in-code ':implausible "Breakpoint in code"))
;(EVAL-WHEN (EVAL LOAD COMPILE)
;  (zl:defprop lisp:break breakpoint-in-code-style-checker 'compiler:style-checker))


(defmacro with-whostate (whostate &body body)
  (let ((^old-whostate (compiler:gensymbol "OLD-WHOSTATE"))
	(^whostate (compiler:gensymbol "WHOSTATE")))
    `(let ((,^old-whostate (si:process-run-whostate si:current-process))
	   (,^whostate ,whostate))
       (unwind-protect
	   (progn
	     (setf (si:process-run-whostate si:current-process) ,whostate)
	     ,@body)
	 (setf (si:process-run-whostate si:current-process) ,^old-whostate)))))


(defmacro printing-package-names (&body body)
  `(let ((*package* nil))
     ,@body))


TV:
(DEFUN OLD-NWATCH-WHO-FUNCTION (WHO-SHEET &AUX LEFTX)
  (DECLARE (:SELF-FLAVOR WHO-LINE-SHEET))
  (OR WHO-LINE-EXTRA-STATE
      (LET ((DEFAULT-CONS-AREA WHO-LINE-AREA))
	(SETQ WHO-LINE-EXTRA-STATE (STRING-APPEND "MM/DD/YY HH:MM:SS"))))
						  ; Errgghhh! Krazy Backwards Amerikan dates.
  (MULTIPLE-VALUE-BIND (SECONDS MINUTES HOURS DAY MONTH YEAR)
      (TIME:GET-TIME)
    (COND ((NULL SECONDS)			       
	   (SHEET-CLEAR WHO-SHEET)
	   (COPY-ARRAY-CONTENTS "MM/DD/YY HH:MM:SS" WHO-LINE-EXTRA-STATE))
	  (T
	   (SETQ YEAR (MOD YEAR 100.))
	   (SETQ LEFTX (MIN (NWATCH-N MONTH WHO-LINE-EXTRA-STATE 0)
			    (NWATCH-N DAY WHO-LINE-EXTRA-STATE 3)
			    (NWATCH-N YEAR WHO-LINE-EXTRA-STATE 6)
			    (NWATCH-N HOURS WHO-LINE-EXTRA-STATE 9)
			    (NWATCH-N MINUTES WHO-LINE-EXTRA-STATE 12.)
			    (NWATCH-N SECONDS WHO-LINE-EXTRA-STATE 15.)))
	   (UNLESS WHO-LINE-ITEM-STATE (SETQ LEFTX 0))	;was clobbered, redisplay all
	   (SHEET-SET-CURSORPOS WHO-SHEET (* LEFTX CHAR-WIDTH) 0)
	   (SHEET-CLEAR-EOL WHO-SHEET)
	   (SHEET-STRING-OUT WHO-SHEET WHO-LINE-EXTRA-STATE LEFTX)
	   (SETQ WHO-LINE-ITEM-STATE T)))))

(defun am-or-pm (hours minutes seconds)
  (cond ((and (zerop seconds)
	      (zerop minutes))
	 (if (= hours 0) "M " "N "))
	((>= hours 12.) "pm")
	(t "am")))

(defun hours-mod-12 (hours)
  (if (or (= hours 12) (= hours 0))
      12
    (mod hours 12)))


TV:
(defun new-nwatch-who-function (who-sheet)
  (declare (:self-flavor who-line-sheet))
  (or who-line-extra-state
      (let ((si:default-cons-area who-line-area))
	(setq who-line-extra-state (si:string-append "mon dd hh:mm:ssAM"))))
  (multiple-value-bind (seconds minutes hours day month)
      (time:get-time)
    (cond ((null seconds)			       
	   (sheet-clear who-sheet)
	   (zl:copy-array-contents "mon dd hh:mm:ssAM" who-line-extra-state))
	  (t
	   (let ((leftx (min (hl:nwatch-delta (time:month-string month ':short)
					      who-line-extra-state 0)
			     (hl:nwatch-delta day who-line-extra-state 4)
			     (hl:nwatch-delta (hl:hours-mod-12 hours)
					      who-line-extra-state 7)
			     (hl:nwatch-delta minutes who-line-extra-state 10.)
			     (hl:nwatch-delta seconds who-line-extra-state 13.)
			     (hl:nwatch-delta (hl:am-or-pm hours minutes seconds)
					      who-line-extra-state 15.))))
	     (unless who-line-item-state
	       (setq leftx 0))
	     (sheet-set-cursorpos who-sheet (* leftx char-width) 0)
	     (sheet-clear-eol who-sheet)
	     (sheet-string-out who-sheet who-line-extra-state leftx)
	     (setq who-line-item-state t))))))

(defun nwatch-delta (new str idx)
  (cond ((numberp new)
	 (let ((dig1 (int-char (+ (zl:truncate new 10.) (char-int #\0))))
	       (dig2 (int-char (+ (rem new 10.) (char-int #\0)))))
	   (prog1 (cond ((not (equal (char str idx) dig1))
			 idx)
			((not (equal (char str (1+ idx)) dig2))
			 (1+ idx))
			(t (si:array-length str)))
		  (setf (char str idx) dig1)
		  (setf (char str (1+ idx)) dig2))))
	(t
	 (loop with delta
	       finally (return (or delta 0))
	       for i from 0 below (length new)
	       do
	       (when (not (char= (char str (+ idx i))
				 (char new i)))
		 (setf (char str (+ idx i)) (char new i)))))))


(defvar TV:*who-line-clock-style* ':old)
(defvar TV:*reset-who-line-clock-style* nil)

TV:
(defun nwatch-who-function (who-sheet)
  (declare (:self-flavor who-line-sheet))
  (funcall (case *who-line-clock-style*
	     (:old 'tv:old-nwatch-who-function)
	     (:new 'new-nwatch-who-function)
	     (otherwise 'tv:bash-nwatch))
	   who-sheet))

(defun set-who-line-clock-style (style)
  (assert (member style '(:old :new)))
    (setq tv:*who-line-clock-style* nil)
    (sleep 1)
    (setq tv:*who-line-clock-style* style)
    (zl:send tv:nwatch-who-line-sheet ':clobbered))

TV:
(defun bash-nwatch (who-sheet)
  (declare (:self-flavor who-line-sheet))
  (setq who-line-item-state nil
	who-line-extra-state nil)
  (sheet-set-cursorpos who-sheet 0 0)
  (sheet-clear-eol who-sheet)
  (sheet-string-out who-sheet who-line-extra-state 0))



;;;; Edit history for HUNLA:L;LISP-PATCHES.LISP.22
;;;
;;; [10/27/88 03:30 CStacy] Macro WITH-WHOSTATE: Added.
;;; [10/27/88 03:30 CStacy] Macro PRINTING-PACKAGE-NAMES: Added.
;;; [11/17/88 23:05 CStacy] NWATCH hacks for prettier who-line.