;;; Lisplab, level3-io.lisp
;;; Input output operations

;;; Copyright (C) 2009 Joern Inge Vestgaarden
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License along
;;; with this program; if not, write to the Free Software Foundation, Inc.,
;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.


;;; TODO: make a generic function for bitmap export 
;;;       (mexport 'eps "filname.eps" m :keys ...)
;;;       Leave dlmread and dlmwrite as they are.


(in-package :lisplab)

(defmethod dlmwrite (out (x number) &key (printer #'prin1) dlm)
  (declare (ignore dlm))
  (dlmwrite (dcol x) out :printer printer))

(defmethod dlmwrite ((stream stream)
		     (a matrix-base) 		     
		     &key 
		     (dlm " ")
		     (printer #'prin1))
  (dotimes (i (rows a))
    (format stream "~&")
    (dotimes (j (cols a))
      (funcall printer (mref a i j) stream)
      (when (< j (1- (cols a)))
	(princ dlm stream)))))

(defmethod dlmwrite ((name pathname)
		     (a matrix-base) 		     
		     &key 
		     (dlm " ")
		     (printer #'prin1))
  (with-open-file (stream name :direction :output :if-exists :supersede)
    (dlmwrite stream a :dlm dlm :printer printer)))

(defmethod dlmwrite ((name string)
		     (a matrix-base) 		     
		     &key 
		     (dlm " ")
		     (printer #'prin1))
  (dlmwrite (pathname name) a :dlm dlm :printer printer))

(defun dlmread-list (in)
  "Helper function that reads a delimited file as a list of lists."
  ;; TODO: Fixit. Non-space formated matrices
  (let* ((end (gensym))
	 (rows nil))
    (labels ((line () (let ((line (read-line in nil end nil)))
			(if (eq line end)
			    end
			    (if (eql (char line 0) #\#)
				  (line) 
				  line)))))
      (do ((line (line) (line)))
	  ((eq line end))
	(let ((s (make-string-input-stream line))
	      (cols nil))
	(flet ((element () (read s nil end nil)))
	  (do ((elm (element) (element)))
	      ((eq elm end))
	    (push elm cols))
	  (push (nreverse cols) rows))))
      (nreverse rows))))

(defmethod dlmread (class (in stream))
  (convert (dlmread-list in)
	   class))

(defmethod dlmread (class (name pathname))
  (with-open-file (in name :direction :input)
    (dlmread class in))) 

(defmethod dlmread (class (name string))
  (dlmread class (pathname name))) 

(defun pgmwrite (filename m
		 &key 
		 (verbose nil)
		 (max (mmax m))
		 (min (mmin m)))
  "Writes matrix as a binary pgm file."
  (let* ((rows (rows m))
         (cols (cols m))
         (scale (- max min)))
    (when (<= (- max min) 0d0)
      (setf max 1d0 min 0d0 scale 1d0))
    (with-open-file (out filename :direction :output :if-exists :supersede)
      (format out "P5~%")
      (format out "~A ~A~%" cols rows)
      (format out "255~%"))
    (with-open-file (out filename 
			 :direction :output
                         :if-exists :append :element-type 'unsigned-byte)
      (dotimes (i rows)
        (dotimes (j cols)
          (write-byte (floor (* 255  
				(- (min (max (mref m i j) min) max)  min) 
				(/ scale))) 
		      out))))
    (when verbose
       (format t "pgmwrite ~20A (~3Ax~3A)~%" filename rows cols))
    t))

(defun pswrite (filename m
		&key 
		(max (mmax m))
		(min (mmin m)))
  "Writes matrix as postscript bitmap. Port of a2ps.c by Eric Weeks."
  ;; TODO: clean up and some more lispifying.
  ;; TODO: more testing.
  ;; TOOD: change name to epswrite.
  (when (<= (- max min) 0d0)
    (setf max 1d0 min 0d0 ))
  (let* ((DTXSCALE 1d0)
	 (DTYSCALE 1d0)
	 #+nil (DTHRES 513)
	 #+nil (DTVRES 481)
	 (XOFFSET 54) ; 3/4 inch.  72 units = 1 inch.  
	 (YOFFSET 288) ; /* 4 inches.  */

	 (nbits 8)
	 (scale 1)
	 #+nil (invert 0)
	 #+nil (count 0)
	 #+nil (title nil)
	 (xsc 1d0)
	 ; (ysc 1d0 )
	 (ysc (/ (cols m) (rows m) 1d0))
	 
	 (xscale (floor (* DTXSCALE scale 432 xsc)))
	 (yscale (floor (* DTYSCALE scale 432 ysc)))
	 (xof XOFFSET)
	 (yof YOFFSET) 
	 ; (hres DTHRES)
	 (hres (rows m))
	 ; (vres DTVRES)
	 (vres (cols m)))
    (with-open-file (out filename :direction :output :if-exists :supersede)
      (format out "\%!PS-Adobe-3.0 EPSF-3.0~%")  ;; Identifies job as Postscript.
      (format out "\%\%BoundingBox: ~A ~A ~A ~A~%" xof yof (+ xscale xof) (+ yscale yof))
      (format out "gsave~%")
      #+nil (when title
	(format out "/Times-Roman findfont 30 scalefont setfont~%")
	(format out "50.0 50.0 moveto~%")
	(format out "(~A) show~%" filename))
    
      (format out "0 0 moveto~%grestore~%");
      (format out "/picstr ~A string def~%" hres) 
      (format out "~A ~A translate~%" xof yof)
      (format out "~A ~A scale~%" xscale yscale)
      (format out "~A ~A ~A~%" hres vres nbits)
      (format out "[~A 0 0 -~A 0 ~A]~%" hres vres vres)
      (format out "{currentfile~%")
      (format out " picstr readhexstring pop}~%")
      (format out "image~%")

      ;; Now write byte for byte as hex.      
      (dotimes (j vres)
	(dotimes (i hres)
	  (let ((c (floor (* 255  
			     (- (min (max (mref m i j) min) max)  min) 
			     (/ (- max min))))))
	    (format out "~2,'0X" c)))
	(format out "~%"))
      (format out "showpage~%"))))