;;; -*- Mode:LISP; Package:TIGER; Base:8; Fonts:(CPTFONT TR12I); Readtable:T -*-

; Copyright LISP Machine, Inc. 1984
;   See filename "Copyright" for
; licensing and release information.

(defconst aray-check-string "ARAY" "First characters of any array dump file.")
(defconst aray-version-number 1 "Current version number of ARAY file format.")
(defvar aray-serial-number 0 "Number of array files dumped to tape during this session.")

(defsubst print-word (word stream)
  (send stream :tyo (ldb #O0010 word))
  (send stream :tyo (ldb #O1010 word))
  (send stream :tyo (ldb #O2007 word))
  (send stream :tyo 0))

(defsubst read-word (stream)
  (prog1 (dpb (send stream :tyi) #O0010
	      (dpb (send stream :tyi) #O1010
		   (dpb (send stream :tyi) #O2007 0)))
	 (send stream :tyi)))

(defun dump-pixel-array-to-file (filename array &optional left top right bottom)
  (with-open-file (stream filename :direction :output :characters nil :byte-size 8.)
    (dump-pixel-array-to-stream stream array left top right bottom)))

(defflavor kount-em 
	   ((kount 0))
	   ()
  :gettable-instance-variables)

(defmethod (kount-em :tyo) (ignore)
  (incf kount))

(defmethod (kount-em :string-out) (string &optional
				   (start 0) (end (array-active-length string)))
  (incf kount (- end start)))

(defun dump-pixel-array-to-tape (filename array &optional left top right bottom)
  (let ((pathname (fs:merge-pathname-defaults filename))
	(length-in-bytes (let ((x (make-instance 'kount-em)))
			   (dump-pixel-array-to-stream x array left top right bottom)
			   (send x :kount))))
    (with-open-stream (mt (fs:make-mt-file-stream
			    :characters nil
			    :direction :output
			    :plist (list :characters nil
					  :directory (send pathname :directory)
					  :name (string-append 
						   (send pathname :name)
						   (format nil "-~D" (incf aray-serial-number)))
					  :type (send pathname :type)
					  :version (send pathname :version)
					  :author (status userid)
					  :creation-date (time:get-universal-time)
					  :length-in-bytes length-in-bytes
					  :length length-in-bytes
					  :byte-size 8.)))
      (dump-pixel-array-to-stream mt array left top right bottom))))

(defun dump-pixel-array-to-stream (stream array &optional left top right bottom)
  (cond ((typep array 'array)
	 (unless left (setq left 0))
	 (unless top (setq top 0))
	 (unless right (setq right (pixel-array-width array)))
	 (unless bottom (setq bottom (pixel-array-height array))))
	((typep array 'tv:minimum-window)
	 (multiple-value-bind (new-left new-top new-right new-bottom)
	     (send array :edges)
	   (unless (setq array (send array :screen-array))
	     (ferror nil "The array argument is a window with no screen array."))
	   (unless left (setq left new-left))
	   (unless top (setq top new-top))
	   (unless right (setq right new-right))
	   (unless bottom (setq bottom new-bottom))))
	(t (ferror nil "The array argument is not an array or window.")))
  (unless (zerop (remainder (pixel-array-width array) 32.))
    (ferror nil "The array argument has rows which are not a multiple of 32. bits long."))
  (multiple-value-bind (words-before-left new-left)
      (floor left 32.)
    (let* ((width (pixel-array-width array))
	   (height (pixel-array-height array))
	   (new-right (- right (* words-before-left 32.)))
	   (new-top 0)
	   (new-bottom (- bottom top))
	   (new-width (* (ceiling new-right 32.) 32.))
	   (new-height new-bottom)
	   (bytes-before-left (* words-before-left 4))
	   (output-bytes-per-row (floor new-width 8.))
	   (bytes-per-row (floor width 8.))
	   (array-size-in-bytes (// (* width height) 8.))
	   (array-8b (make-array array-size-in-bytes :type 'art-8b :displaced-to array)))
      (send stream :string-out aray-check-string)
      (print-word aray-version-number stream)
      (print-word new-width stream)
      (print-word new-height stream)
      (print-word new-left stream)
      (print-word new-top stream)
      (print-word new-right stream)
      (print-word new-bottom stream)
      (loop for byte from bytes-before-left below array-size-in-bytes by bytes-per-row
	    do (send stream :string-out array-8b byte (+ byte output-bytes-per-row))))))

(defun restore-pixel-array-from-file (filename &optional array &aux temp)
  (with-open-file (stream filename :direction :input)
    (setq temp (multiple-value-list (restore-pixel-array-from-stream stream array))))
  (values-list temp))

(defun restore-pixel-array-from-tape (&optional array &aux temp)
  (with-open-stream (mt (fs:make-mt-file-stream :direction :input))
    (setq temp (multiple-value-list (restore-pixel-array-from-stream mt array))))
  (values-list temp))

(defun restore-pixel-array-from-stream (stream &optional array)
  (let ((check-string (make-array 4 :type 'art-string)))
    (send stream :string-in t check-string)
    (when (not (string-equal check-string aray-check-string))
      (ferror nil "The specified file is not a dumped array file.")))
  (when (neq (read-word stream) aray-version-number)
    (ferror nil "The version number of the array file is not 1."))
  (let* ((width (read-word stream))
	 (height (read-word stream))
	 (left (read-word stream))
	 (top (read-word stream))
	 (right (read-word stream))
	 (bottom (read-word stream))
	 (array-to-use
	   (cond (array (setq array (adjust-tiger-array-size array width height)))
		 (t (tv:make-pixel-array width height :type 'art-1b))))
	 (array-8b (make-array (floor (* width height) 8.)
			       :type 'art-8b :displaced-to array-to-use)))
    (send stream :string-in t array-8b)
    (values array-to-use left top right bottom)))