;;; Lisplab, saveload.lisp
;;; Input output operations in lisplab-specific format

;;; 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.

;;; Some simple home made protocol for saving and loading matrices.
;;; So far it only works for double float matrices.
;;; 
;;; The file format is simply
;;; 
;;; (nonce type header-length (metadata) rows cols (data))
;;;
;;; nonce, type, header-length, rows, and cols are 32 bit unsigned integers 
;;; the rest of the hearder is for metadata and is currently skipped 
;;; The data is 64 bit floats, in row major order
;;; (and hopefully the numbers are stored as ieee compatible, big endian.)

;;; In principle, lisplab should store and save matrices in some standard data format, 
;;; but thats a lot of work to implement. 


(in-package :lisplab)

;;;; First some general stuff

(defgeneric msave (stream-or-file matrix)
  (:documentation "Writes the matrix in a lisplab-specific format."))
(defgeneric mload (stream-or-file)
  (:documentation "Reads a matrix coded in a lisplab-specific format."))

(defmethod msave ((name pathname)
		   (a matrix-base))
  (with-open-file (stream name 
			  :direction :output 
			  :if-exists :supersede
			  :element-type 'unsigned-byte)
    (msave stream a)))

(defmethod msave ((name string)
		   (a matrix-base))
  (msave (pathname name) a))

(defmethod mload ((name pathname))
  (with-open-file (stream name 
			  :direction :input
			  :element-type 'unsigned-byte)
    (mload stream)))

(defmethod mload ((name string))		  
  (mload (pathname name)))

;;;; Some helper functions

(defun encode-ui32 (a i off)
  "Writes four bytes to the byte array in big endian format."
  (setf (aref a off) (ldb (byte 8 24) i)
	(aref a (+ off 1)) (ldb (byte 8 16) i)
	(aref a (+ off 2)) (ldb (byte 8 8) i)
	(aref a (+ off 3)) (ldb (byte 8 0) i)))

(defun decode-ui32 (a off)
  "Reads a four byte integer from the byte array in big endian format."
  (logior (ash (aref a off) 24)
	  (ash (aref a (+ off 1)) 16)
	  (ash (aref a (+ off 2)) 8)
	  (aref a (+ off 3))))

(defun encode-ui64 (a i off)
  "Writes eight bytes to the byte array in big endian format."
  (setf (aref a off) (ldb '(8 . 56) i)
	(aref a (+ off 1)) (ldb '(8 . 48) i)
	(aref a (+ off 2)) (ldb '(8 . 40) i)
	(aref a (+ off 3)) (ldb '(8 . 32) i)
	(aref a (+ off 4)) (ldb '(8 . 24) i)
	(aref a (+ off 5)) (ldb '(8 . 16) i)
	(aref a (+ off 6)) (ldb '(8 . 8) i)
	(aref a (+ off 7)) (ldb '(8 . 0) i)))

(defun decode-ui64 (a off)
  "Reads a eight byte integer from the byte array in big endian format."  
  (logior (ash (aref a off) 56)
	  (ash (aref a (+ off 1)) 48)
	  (ash (aref a (+ off 2)) 40)
	  (ash (aref a (+ off 3)) 32)
	  (ash (aref a (+ off 4)) 24)
	  (ash (aref a (+ off 5)) 16)
	  (ash (aref a (+ off 6)) 8)
	  (aref a (+ off 7))))

(defun encode-ui64le (a i off)
  "Writes eight bytes to the byte array in little endian format."
  (setf (aref a (+ off 0)) (ldb '(8 . 0) i)
	(aref a (+ off 1)) (ldb '(8 . 8) i)
	(aref a (+ off 2)) (ldb '(8 . 16) i)
	(aref a (+ off 3)) (ldb '(8 . 24) i)
	(aref a (+ off 4)) (ldb '(8 . 32) i)
	(aref a (+ off 5)) (ldb '(8 . 40) i)
	(aref a (+ off 6)) (ldb '(8 . 48) i)
	(aref a (+ off 7)) (ldb '(8 . 56) i)))

(defun decode-ui64le (a off)
  "Reads a eight byte integer from the byte array in little endian format."  
  (logior (aref a (+ off 0)) 
	  (ash (aref a (+ off 1)) 8)
	  (ash (aref a (+ off 2)) 16)
	  (ash (aref a (+ off 3)) 24)
	  (ash (aref a (+ off 4)) 32)
	  (ash (aref a (+ off 5)) 40)
	  (ash (aref a (+ off 6)) 48)
	  (ash (aref a (+ off 7)) 56)))


(defun read-ui32 (stream)
  (let ((x (make-array 4 :element-type 'unsigned-byte)))
    (read-sequence x stream)
    (decode-ui32 x 0)))

;;;; Encoding double float matrices

(define-constant +lisplab-dump-nonce+ 154777230)

;; I choos a very stupid number for the type,
;; just because there is no systematics yet.
(define-constant +lisplab-dump-dge+ 10000042) 

(defun encode-dge-hdr (rows cols)
  ;; nonce type skip .... rows cols 
  (let ((x (make-array (* 5 4) :element-type 'unsigned-byte)))
    (encode-ui32 x +lisplab-dump-nonce+ 0)
    (encode-ui32 x +lisplab-dump-dge+ 4)
    (encode-ui32 x 0 8)
    (encode-ui32 x rows 12)
    (encode-ui32 x cols 16)
    x))

(defun encode-dge-bulk (x)
  (let* ((len (length x))
	 (a (make-array (* 8 len) :element-type 'unsigned-byte)))
    (dotimes (i len)
      (encode-ui64le a (ieee-floats:encode-float64 (aref x i)) (* i 8)))
    a))
    
(defmethod msave ((s stream) (a matrix-base-dge))
  ;; Only for binary streams
  (let ((store (vector-store a)))
    (write-sequence (encode-dge-hdr (rows a) (cols a)) s)
    (write-sequence (encode-dge-bulk store) s))
  (values))

;;; Decoding  double float matrices 

(defmethod mload ((stream stream))
  (if (/= (read-ui32 stream) +lisplab-dump-nonce+)
      (error "Unknown file format for mload.")
      (if (/= (read-ui32 stream) +lisplab-dump-dge+)	  
	  (error "Unknown file format for mload.")
	  (progn 
	    (let ((len (read-ui32 stream)))
	      (dotimes (i len) (read-byte stream)))
	    (let* ((rows (read-ui32 stream))
		   (cols (read-ui32 stream))
		   (len (* rows cols))
		   (data (make-array (* 8 len) :element-type 'unsigned-byte))
		   (store (allocate-real-store len)))
	      (read-sequence data stream)
	      (dotimes (i len)
		(setf (aref store i) (ieee-floats:decode-float64 
				      (decode-ui64le data (* 8 i)))))
	      (make-instance 'matrix-dge :dim (list rows cols) :store store  ))))))