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




(defun view (filename &optional (standard-output standard-output) (interval 10) &aux packet &special exit-flag)
  (setq exit-flag nil)
  (send standard-output :clear-screen)
  (with-open-file (standard-input filename)
    (loop while (and (setq packet (get-packet))
		     (not exit-flag))
	  doing
	  (process-wait "Space or rubout"
			#'(lambda () (or (tv:key-state #o040)	  ;wait for spacebar
					 (setq exit-flag (tv:key-state #o207))))) ;or rubout
	  (put-packet packet)
	  (process-sleep interval)))
  (clear-input))

(defvar end 20)


(fdefine 'put-packet (let* ((width (send standard-output :width))
			    (half-width (quotient width 2))
			    (height (send standard-output :height))
			    (half-height (quotient height 2))
			    (font (send standard-output :current-font)))
		       (declare (special width height half-width half-height font))
		       (closure '(width height half-width half-height font) 'put-packet3))
	 t t)



(fdefine 'get-packet (let* ((maxlen 20)
			    (packet-string (make-sequence '(string) maxlen)))
		       (declare (special maxlen packet-string))
		       (closure '(maxlen packet-string) 'get-packet1))
	 t t)




(defun get-packet1 (&optional (stream standard-input) &aux eof-flag )
  (declare (special maxlen packet-string))
  "Must return NIL on EOF"
  ;(read-char stream nil))

  (when (< end maxlen) (replace packet-string packet-string :start2 end))

  (multiple-value-setq (end eof-flag) (send stream :string-in nil
					     packet-string		
					     (- maxlen end)		
					     maxlen))
  
  (setq packet-string (canonicalize-whitespace packet-string))

  (multiple-value-setq (end eof-flag) (send stream :string-in nil
					    packet-string		
					    (1+ end)
					    maxlen))

  (setq end (position #\Space packet-string			
	       :start 0
	       :end end
	       :from-end t))
  
  (if eof-flag nil packet-string))




(defun canonicalize-whitespace (string)
  
  "Translates tabs and cr's to spaces, and then compresses all multiple spaces into one space."
  
  (let* ((one-space nil)
	(tempindex 0)
	(len (length string))
	(temp (make-sequence '(string) len))
	char)
    (loop for index from 0 to (1- len) doing
	  (setf char (elt string index))
	  (if (or (= char #\Space) (=  char #\Tab) (= char #\Return))
	      (progn (unless one-space
		       (setf (elt temp tempindex) #\Space)
		       (incf tempindex))
		     (setf one-space t))
	    (setq one-space nil)
	    (setf (elt temp tempindex) char)
	    (incf tempindex)))
    (setq end (1- tempindex))
    temp))




(defun put-packet1 (packet &optional (stream standard-output))
;  (format t "~%str:~a~%start:~a end:~a~%" packet start end)
  (format t "~%str:~a~%end:~a~%" packet end)
)




(defun put-packet2 (packet &optional (stream standard-output))
  (declare (special half-width half-height font))
  (send (fdefinition stream) :string-out-explicit
	packet
	half-width half-height
	2000 2000
	font
	tv:alu-setz)
  (send (fdefinition stream) :string-out-explicit
	packet
	half-width half-height
	2000 2000
	font
	tv:alu-ior))



(defun put-packet3 (packet &optional (stream standard-output))
  (declare (special half-width half-height))
  (tv:sheet-line-out (fdefinition stream)
		     packet
		     0 end
		     (- half-width (quotient (length packet) 2))
		     half-height
		     nil))