;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; class definitions and specification for databases of images
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; class definitions and specification for databases of images
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(libload "libidx/idx-macros")
(libload "libidx/idx-io")
(libload "libimage/pnm")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#? * image-db
;; This db-like class represents a data-base of examples
;; which are pairs of images (of any size and depth) and classes. 
;; The images may have different dimensions, but are returned
;; as idx3 of ubytes (the last dimension being the depth).
;;.P
;; This is not a subclass of base-db, but it implements the interface
;; and can be used as a base db for a narrow-db or perturb-db
;; as well as fed directly to a trainer object.
(defclass image-db object
  ((-int-) current)
  ((-idx1- (-ubyte-)) images) ;; [n-pixels-per-image*n-images*depth] 
  ((-idx1- (-int-)) starts) ;; starting position within 
                            ;; the images matrix of each image
  ((-idx2- (-int-)) sizes) ;; size of each image: (n-rows, n-columns, depth)
  ((-idx1- (-int-)) classes) ;; class label of each image 
  ;; infos
)

#? (new image-db)
;; creates an empty image-db. The images can be subsequently
;; loaded through the load-ppms, load-pgms, load or map methods.
(defmethod image-db image-db ()
  (setq current 0)
  (setq images (ubyte-matrix 1))
  (setq starts (int-matrix 1))
  (setq sizes (int-matrix 1 1))
  (setq classes (int-matrix 1)) 
  ;; (setq infos (array 1)) ()
  )

#? (==> <image-db load-ppms <flist> <clist>)
;; fills up the database with images
;; from a bunch of PPM files
;; <clist> is a list of labels (one integer for each image)
;; or a single category, in which case all the loaded images 
;; will be in that category.
(defmethod image-db load-ppms (flist clist)
  (when (and (consp clist) (<> (length flist) (length clist)))
      (error "file list and category list have different lengths"))
  (let* ((ims (all ((f flist)) (pnm-read-rgbim f)))
         (n (length ims))
         (nbytes (let ((r 0)) (each ((m ims)) (incr r (apply * (bound m)))) r)))
    (idx-u1resize images nbytes)
    (idx-i1resize starts n)
    (idx-i1resize sizes n 3)
    (idx-i1resize classes n)
    ;; (setq infos (array n))
    (let ((p 0) (s 0) (i 0))
      (each ((m ims) (f flist))
        ;; (infos i f)
        (setq s (apply * (bound m)))
        (copy-any-matrix m (narrow images 0 s p))
        (starts i p)
        (sizes i 0 (idx-dim m 0))
        (sizes i 1 (idx-dim m 1))
        (sizes i 2 (idx-dim m 2))
        (incr p s)
        (incr i)))
    (if (consp clist)
        (classes () clist)
      (idx-i1fill classes clist)) n))


#? (==> <image-db load-pgms <flist> <clist>)
;; fills up the database with images
;; from a bunch of PGM files
;; <clist> is a list of labels (one integer for each image)
;; or a single category, in which case all the loaded images 
;; will be in that category.
(defmethod image-db load-pgms (flist clist)
  (when (and (consp clist) (<> (length flist) (length clist)))
      (error "file list and category list have different lengths"))
  (let* ((ims (all ((f flist)) (pnm-read-ubim f)))
         (n (length ims))
         (nbytes (let ((r 0)) (each ((m ims)) (incr r (apply * (bound m)))) r)))
    (idx-u1resize images nbytes)
    (idx-i1resize starts n)
    (idx-i2resize sizes n 3)
    (idx-i1resize classes n)
    (let ((p 0) (s 0) (i 0))
      (each ((m ims))
        (setq s (apply * (bound m)))
        (copy-any-matrix m (narrow images 0 s p))
        (starts i p)
        (sizes i 0 (idx-dim m 0))
        (sizes i 1 (idx-dim m 1))
        (sizes i 2 (if (= 2 (idx-ndim m)) 1 (idx-dim m 2)))
        (incr p s)
        (incr i)))
    (if (consp clist)
        (classes () clist)
      (idx-i1fill classes clist)) n))


#? (==> <image-db> save <basename>)
;; save database into pre-cooked IDX files.
;; These files can be subsequently loaded quickly
;; using the load or map methods.
;; The database is saved in four files named
;; <basename>images.idx, <basename>starts.idx,
;; <basename>sizes.idx, and <basename>classes.idx
(defmethod image-db save (basename)
  ((-str-) basename)
  (save-idx1-ubyte (concat basename "images.idx") images)
  (save-idx1-int (concat basename "starts.idx") starts)
  (save-idx2-int (concat basename "sizes.idx") sizes)
  (save-idx1-int (concat basename "classes.idx") classes)
  ())

#? (==> <image-db> load <basename>)
;; load database from pre-cooked IDX files
;; produced through the <save> method.
;; The database will be loaded from four files named
;; <basename>images.idx, <basename>starts.idx,
;; <basename>sizes.idx, and <basename>classes.idx
(defmethod image-db load (basename)
  ((-str-) basename)
  (load-idx1-ubyte (concat basename "images.idx") images)
  (load-idx1-int (concat basename "starts.idx") starts)
  (load-idx2-int (concat basename "sizes.idx") sizes)
  (load-idx1-int (concat basename "classes.idx") classes)
  ())

#? (==> <image-db> map <basename>)
;; memory-map database from pre-cooked IDX files
;; produced through the <save> method.
;; This is MUCH faster than load, and consumes
;; fewer memory/disk bandwidth.
;; The database will be mapped from four files named
;; <basename>images.idx, <basename>starts.idx,
;; <basename>sizes.idx, and <basename>classes.idx
(defmethod image-db map (basename)
  (setq images (map-idx1-ubyte (concat basename "images.idx") ))
  (setq starts (map-idx1-int (concat basename "starts.idx") ))
  (setq sizes (map-idx2-int (concat basename "sizes.idx") ))
  (setq classes (map-idx1-int (concat basename "classes.idx") ))
  ())


#? (==> <image-db> size)
;; reutnrs the size of the database
(defmethod image-db size () (let ((z (idx-dim starts 0))) ((-int-) z) z))

#? (==> <image-db> get-input <n> <dest>)
;; copies <n>-th item as a [n-rows,n-columns,3] RBG 
;; ubyte image into the x slot of <dest>. <dest> must be
;; an <idx3-state> or a subclass thereof.
;; It is resized if necessary.
(defmethod image-db get-input (n dest)
  ((-int-) n)
  ((-obj- (idx3-state)) dest)
  (let* ((ni (sizes n 0))
         (nj (sizes n 1))
         (nk (sizes n 2))
         (np (* ni nj nk))
         (start (starts n))
         (flat-image (narrow images 0 np start))
         (image (redim flat-image ni nj nk)))
    (idx-changeoffset image start)
    (==> dest resize ni nj nk)
    (idx-copy image :dest:x)))

#? (==> <image-db> get-label <n> <dest>)
;; returns labels  of <n>-th example as an int.
(defmethod image-db get-label (n dest) 
  ((-int-) n) 
  ((-idx0- (-int-)) dest)
  (dest (classes n)))

(defmethod image-db get-info (n) ((-int-) n) ())

#? (==> <base-db> seek <i>) 
;; set pointer to <i>-th item
(defmethod image-db seek (i) 
  ((-int-) i) 
  (if (or (< i 0) (> i (1- (==> this size))))
      (error "database item number out of bound")
    (setq current i)))

#? (==> <image-db> tell <i>) 
;; set pointer to <i>-th item
(defmethod image-db tell () current)

#? (==> <base-db> next)
;; move pointer to next item
(defmethod image-db next ()
  (incr current)
  (when (>= current (==> this size)) (setq current 0))
  current)

#? (==> <image-db> get-input-current <dest>)
;; get current pattern.
(defmethod image-db get-input-current (dest) 
  ((-obj- (idx3-state)) dest)
  (==> this get-input current dest))

#? (==> <image-db> get-label-current)
;; get current label.
(defmethod image-db get-label-current (dest) 
  ((-idx0- (-int-)) dest)
  (==> this get-label current dest))

#? (==> <image-db> get-info-current)
;; get current info.
(defmethod image-db get-info-current () (==> this get-info current))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(dhc-make () (image-db image-db load save size 
	      get-input get-label get-info seek tell next 
              get-input-current get-label-current get-info-current))



