;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; LUSH Lisp Universal Shell
;;;   Copyright (C) 2002 Leon Bottou, Yann Le Cun, AT&T Corp, NECI.
;;; Includes parts of TL3:
;;;   Copyright (C) 1987-1999 Leon Bottou and Neuristique.
;;; Includes selected parts of SN3.2:
;;;   Copyright (C) 1991-2001 AT&T Corp.
;;;
;;; 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., 59 Temple Place, Suite 330, Boston, MA 02111, USA
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; $Id: pnm.lsh,v 1.4 2002/12/18 09:45:22 leonb Exp $
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#? *** Reading/Writing PPM/PGM/PBM Image Files
;; Routines for reading and writing PBM/PGM/PPM image files 
;; into/from idx. Another set of functions built on top
;; of these is used to read/write image files in other
;; formats than PPM/PGM/PBM.

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

(libload "libc/stdio")

(de pnm-dummy () 
  (cpheader "#include <sys/types.h>")
  (cpheader "#include <sys/mman.h>")
  (cpheader "#include <stdio.h>\n")
  ())

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


#? (pnm-header <f>)
;;.VP
;; ((-gptr- "FILE *") f):
;; Return the descriptive string of a PNM image file
;; (P6, P4, or P5), and skip the file descriptor
;; past the comments.
(de pnm-header (f)
    ((-gptr- "FILE *") f)
    
    (when (not f) (error "couldn't open PNM file"))
    (rewind f)
    (let ((head (fscan-str f)))

      (when (and (<> "P6" head) (<> "P4" head) (<> "P5" head))
        (fclose f)       
        #{ fprintf(stderr, "%s\n", (char *)($head->data)); #}
        (error " not a valid binary PNM file")
        )
      
      (skip-comments 35 f) ; skip lines staring with #
      head
    ))


#? (mmap-idx3-storage <f> <u> <d0> <d1> <d2>)
;;.VP
;; ((-gptr- "FILE *") f):
;; ((-idx3- (-ubyte-)) u):
;; ((-int-) d0 d1 d2):
;; Maps file f (at the current position given by FTELL) into idx3 u
;; does not check that f size is OK.
(de mmap-idx3-storage (f u d0 d1 d2)
    ((-gptr- "FILE *") f)
    ((-idx3- (-ubyte-)) u)
    ((-int-) d0 d1 d2)
    
    (let ((ok t))
    #{{
    FILE *f=(FILE *) $f;
    int size=$d0 * $d1 * $d2;
    int offset=ftell(f);
    rewind(f);
    $u->srg->size=size;
    $u->srg->data=mmap(0,size+offset, PROT_READ,MAP_SHARED,fileno(f),0);
    if ($u->srg->data == MAP_FAILED) $ok=0;
    $u->srg->data = (char*)$u->srg->data + offset;
    $u->srg->flags = (STS_MMAP + STF_RDONLY) & ~STF_UNSIZED;
    }#}
    
    (if ok (idx-u3resize u d0 d1 d2))
    ok
))

#? (mmap-idx2-storage <f> <u> <d0> <d1>)
;;.VP
;; ((-gptr- "FILE *") f):
;; ((-idx2- (-ubyte-)) u):
;; ((-int-) d0 d1):
;; Maps file f (at the current position given by FTELL) into idx2 u
;; does not check that f size is OK.
(de mmap-idx2-storage (f u d0 d1)
    ((-gptr- "FILE *") f)
    ((-idx2- (-ubyte-)) u)
    ((-int-) d0 d1)
    
    (let ((ok t))
    #{{
    FILE *f=(FILE *) $f;
    int size=$d0 * $d1;
    int offset=ftell(f);
    rewind(f);
    $u->srg->size=size;
    $u->srg->data=mmap(0,size+offset, PROT_READ,MAP_SHARED,fileno(f),0);
    if ($u->srg->data == MAP_FAILED) $ok=0;
    $u->srg->data = (char*)$u->srg->data + offset;
    $u->srg->flags = (STS_MMAP + STF_RDONLY) & ~STF_UNSIZED;
    }#}
    
    (if ok (idx-u2resize u d0 d1))
    ok
))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#? (pnm-fread-into-rgbx <f> <out>)
;;.VP
;; ((-gptr- "FILE *") f):
;;.PP
;; read an image from a PBM/PGM/PPM file into
;; an idx3 of ubytes (RGB or RGBA). <f> must
;; be a valid file descriptor (C pointer).
;; <out> is appropriately resized if required. 
;; The last dimension is left unchanged but must be
;; at least 3. Appropriate conversion is performed.
;; extra color components (beyond the first 3) are left 
;; untouched.
;;.SEE pnm
(de pnm-fread-into-rgbx (f out)
    ((-gptr- "FILE *") f)
    ((-idx3- (-ubyte-)) out)
    
    (let ((head (pnm-header f))
	  (nlino (idx-dim out 0))
	  (ncolo (idx-dim out 1))
	  (ncmpo (idx-dim out 2)))
      ((-int-) nlino ncolo ncmpo)
      (cond 
       ;; PBM image
       ((= head "P4")
	(let* ((ncol (fscan-int f))
	       (nlin (fscan-int f))
	       (n 0) (c 0))
	  ((-int-) ncol nlin n c)
	  (when (or (<> ncol ncolo) (<> nlin nlino) (< ncmpo 3))
	    (idx-u3resize out nlin ncol (max ncmpo 3)))
	  (getc f)
	  (cinline-idx2loop out "unsigned char" "p" "i" "j"
	    #{{ unsigned char v;
                if ((j == 0) || ($n == 0)) { $c = getc((FILE *)$f); $n=0; }
                v = ($c & 128) ? 0 : 255 ;
                p[0]= p[1]= p[2]= v ;  
                $n = ($n == 7) ? 0 : $n+1 ;
                $c = $c << 1; 
	     } #} )))
       ;; PGM image
       ((= head "P5")
	(let* ((ncol (fscan-int f))
	       (nlin (fscan-int f)))
	  ((-int-) ncol nlin)
	  (when (or (<> ncol ncolo) (<> nlin nlino) (< ncmpo 3))
	    (idx-u3resize out nlin ncol (max ncmpo 3)))
	  (fscan-int f)
	  (getc f)
	  (cinline-idx2loop out "unsigned char" "p" "i" "j"
	    #{ p[0]=p[1]=p[2]=getc((FILE *)$f) #}
	    )))
       ;; PPM image
       ((= head "P6")
	(let* ((ncol (fscan-int f))
	       (nlin (fscan-int f))
	       (size (* nlin ncol)))
	  ((-int-) ncol nlin  size)
	  (when (or (<> ncol ncolo) (<> nlin nlino) (< ncmpo 3))
	    (idx-u3resize out nlin ncol (max ncmpo 3)))
	  (fscan-int f)
	  (getc f)
	  (if (and (= 3 (idx-dim out 2)) (contiguep out))
	      (progn
		#{ if ($size != fread (IDX_PTR($out, unsigned char), 3, (size_t) $size, (FILE *)$f))
	              run_time_error("not enough items read");
                #})
            (cinline-idx2loop out "unsigned char" "p" "i" "j"
              #{ p[0]=getc((FILE *)$f) ;
  	         p[1]=getc((FILE *)$f) ;
	         p[2]=getc((FILE *)$f) ;
              #})))))) ())


#? (pnm-read-into-rgbx <f> <out>)
;; read a PBM/PGM/PPM file into an idx3 of 
;; ubytes. The output idx is appropriately 
;; resized if necessary. The last dimension must 
;; be at least 3.
(de pnm-read-into-rgbx (s out)
  ((-str-) s)
  ((-idx3- (-ubyte-)) out)
  (let ((f (fopen s "rb")))
    (when (not f) (error "couldn't open PNM file"))
    (pnm-fread-into-rgbx f out)
    (fclose f)) ())

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#? (pnm-fread-rgb <f>)
;; ((-gptr- "FILE *") f)
;; <f> must be an open file descriptor.
;; read a PBM/PGM/PPM file and return an idx3 of 
;; ubytes with the image in it. Conversion to 
;; RGB is performed if necessary.
(de pnm-fread-rgb (f)
    ((-gptr- "FILE *") f)
    (let ((u (ubyte-matrix-nc 1 1 3)))
      (pnm-fread-into-rgbx f u) u))

#? (pnm-read-rgb <s>)
;; read a PBM/PGM/PPM file and return an idx3 of 
;; ubytes with the image in it. Conversion to 
;; RGB is performed if necessary.
(de pnm-read-rgb (s)
  ((-str-) s)
  (let ((f (fopen s "rb")))
    (when (not f) (error "couldn't open PNM file"))
    (prog1 (pnm-fread-rgb f) (fclose f))))


#? (pnm-fread-rgba <f>)
;; ((-gptr- "FILE *") f)
;; <f> must be an open file descriptor.
;; read a PBM/PGM/PPM file and return an idx3 of 
;; ubytes with the image in it. Conversion to 
;; RGB is performed if necessary. The alpha
;; channel is set to 0.
(de pnm-fread-rgba (f)
  ((-gptr- "FILE *") f)

  (let ((u (ubyte-matrix-nc 1 1 4)))
    (pnm-fread-into-rgbx f u)
    (idx-clear (select u 2 3))
    u))

#? (pnm-read-rgba <s>)
;; read a PBM/PGM/PPM file and return an idx3 of 
;; ubytes with the image in it. Conversion to 
;; RGBA is performed if necessary. The alpha
;; channel is set to 0.
(de pnm-read-rgba (s)
  ((-str-) s)
  (let ((f (fopen s "rb")))
    (when (not f) (error "couldn't open PNM file"))
    (prog1 (pnm-fread-rgba f) (fclose f))))


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

#? (pnm-fread-into-ubim <f> <out>)
;;.VP
;; ((-gptr- "FILE *") f):
;; ((-idx2- (-ubyte-)) out):
;;.PP
;; read an image from a PBM/PGM/PPM file into
;; an idx2 of ubytes (one byte per pixel). <f> must
;; be a valid file descriptor (C pointer).
;; <out> is appropriately resized if required. 
;; Appropriate conversion is performed (e.g. if the 
;; file contains an RGB image).
(de pnm-fread-into-ubim (f out)
    ((-gptr- "FILE *") f)
    ((-idx2- (-ubyte-)) out)
    (let ((head (pnm-header f))
	  (nlino (idx-dim out 0))
	  (ncolo (idx-dim out 1)))
      ((-int-) nlino ncolo)
      (cond 
       ((= head "P4")
	(let* ((ncol (fscan-int f))
	       (nlin (fscan-int f))
	       (n 0) (c 0))
	  ((-int-) ncol nlin n c)
	  (when (or (<> ncol ncolo) (<> nlin nlino))
	    (idx-u2resize out nlin ncol))
	  (getc f)
	  (cinline-idx2loop out "unsigned char" "p" "i" "j"
	    #{{ unsigned char v;
	        if ((j == 0) || ($n == 0)) { $c = getc((FILE *)$f); $n=0; }
		v = ($c & 128) ? 0 : 255 ;
		*p = v;
		$n = ($n == 7) ? 0 : $n+1 ;
		$c = $c << 1; 
	     } #}
	     )))
       ((= head "P5")
	(let* ((ncol (fscan-int f))
	       (nlin (fscan-int f)))
	  ((-int-) ncol nlin)
	  (when (or (<> ncol ncolo) (<> nlin nlino))
	    (idx-u2resize out nlin ncol))
	  (fscan-int f)
	  (getc f)
	  ;; we could optimize this if the idx is contiguous
	  (cinline-idx2loop out "unsigned char" "p" "i" "j"
            #{{ *p=getc((FILE *)$f); }#}
	    )))
       ((= head "P6")
	(let* ((ncol (fscan-int f))
	       (nlin (fscan-int f)))
	  ((-int-) ncol nlin)
	  (when (or (<> ncol ncolo) (<> nlin nlino))
	    (idx-u2resize out nlin ncol))
	  (fscan-int f)
	  (getc f)
	  (cinline-idx2loop out "unsigned char" "p" "i" "j"
            #{{ register float v; 
	        v = 0.299 * (flt)(getc((FILE *)$f)) +
		    0.587 * (flt)(getc((FILE *)$f)) +
		    0.114 * (flt)(getc((FILE *)$f)) ; 
	        *p = (unsigned char)( (v>255) ? 255 : ( (v<0) ? 0 : v ));
              } #}
              ))))) ())


#? (pnm-read-into-ubim <f> <out>)
;; read a PBM/PGM/PPM file into an idx2 of 
;; ubytes (greyscale image). The output idx is 
;; appropriately resized if necessary. 
;; Appropriate conversions to greyscale are performed
(de pnm-read-into-ubim (s out)
  ((-str-) s)
  ((-idx2- (-ubyte-)) out)
  (let ((f (fopen s "rb")))
    (when (not f) (error "couldn't open PNM file"))
    (pnm-fread-into-ubim f out)
    (fclose f)) ())

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

#? (pnm-fread-ubim <f>)
;; ((-gptr- "FILE *") f)
;; <f> must be an open file descriptor.
;; read a PBM/PGM/PPM file and return an idx2 of 
;; ubytes with the image in it. Conversion to 
;; greyscale is performed if necessary.
(de pnm-fread-ubim (f)
    ((-gptr- "FILE *") f)
    (let ((u (ubyte-matrix-nc 1 1)))
      (pnm-fread-into-ubim f u) u))

#? (pnm-read-ubim <f>)
;; read a PBM/PGM/PPM file and return an idx2 of 
;; ubytes with the image in it. Conversion to 
;; greyscale is performed if necessary.
(de pnm-read-ubim (s)
  ((-str-) s)
  (let ((f (fopen s "rb")))
    (when (not f) (error "couldn't open PNM file"))
    (prog1 (pnm-fread-ubim f) (fclose f))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#? (ppm-mmap <f>)
;;.VP
;; ((-gptr- "FILE *") f):
;; maps a ppm RGB image (file descriptor <f>)
;; into memory and return an idx3 of ubytes
;; with the data.
(de ppm-mmap (f)
    ((-gptr- "FILE *") f)

    (let ((u (ubyte-matrix-nc 0 0 3))
          (head (pnm-header f))
          )
      (if (<> head "P6")
          (error "must mmap a PPM file")

        (let* ((ncol (fscan-int f))
               (nlin (fscan-int f))
               )
          ((-int-) ncol nlin)
          (fscan-int f)
          (getc f)
          (when ~(mmap-idx3-storage f u  nlin ncol 3)
                (print "Could not MMAP file, i'll just load it")
                (pnm-fread-into-rgbx f u))
          ))
      u
      ))


#? (pgm-mmap <f>)
;;.VP
;; ((-gptr- "FILE *") f):
;; maps a pgm image (file descriptor <f>)
;; into memory and return an idx2 of ubytes
;; with the data.
(de pgm-mmap (f)
    ((-gptr- "FILE *") f)

    (let ((u (ubyte-matrix-nc 0 0))
          (head (pnm-header f))
          )
      (if (<> head "P5")
          (error "must mmap a PGM file")

        (let* ((ncol (fscan-int f))
               (nlin (fscan-int f)))
          ((-int-) ncol nlin)
          (fscan-int f)
          (getc f)
          (when ~(mmap-idx2-storage f u nlin ncol)
                (print "Could not MMAP file, i'll just load it")
                (pnm-fread-into-ubim f u))
          ))
      u
      ))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#? (ppm-fwrite-rgb <f> <m>)
;; writes RGB image <m> in file descriptor <f> as a PPM/PPM file.
;; <m> is and idx3 of ubytes. <f> must be a file descriptor.
(de ppm-fwrite-rgb (f m)
    ((-gptr- "FILE *") f)
    ((-idx3- (-ubyte-)) m)
    (let ((nlin (idx-dim m 0))
          (ncol (idx-dim m 1)))
      ((-int-) nlin ncol)
      #{ fprintf((FILE *)$f,"P6 %d %d 255\n",$ncol,$nlin); #}
      (cinline-idx2loop m "unsigned char" "p" "i" "j"
        #{ putc(p[0], (FILE *)$f); 
           putc(p[1], (FILE *)$f); 
           putc(p[2], (FILE *)$f); #}
        )
      ()))

#? (ppm-write-rgb <f> <m>)
;; writes RGB image <m> in file <f> as a PPM/PPM file.
;; <m> is and idx3 of ubytes.
(de ppm-write-rgb (f m)
    ((-str-) f)
    ((-idx3- (-ubyte-)) m)
    (let ((f (fopen f "wb")))
      (when (not f) (error "couldn't open PPM file"))
      (ppm-fwrite-rgb f m)
      (fclose f)
      ()))


#? (pgm-fwrite-ubim <f> <m>)
;; writes an ubimage <m> in file <f> as a PGM file.
;; <m> is and idx2 of ubytes, and <f> is an open file
;; descriptor.
(de pgm-fwrite-ubim (f m)
    ((-gptr- "FILE *") f)
    ((-idx2- (-ubyte-)) m)
    (let ((nlin (idx-dim m 0))
          (ncol (idx-dim m 1)))
      ((-int-) nlin ncol)
      #{ fprintf((FILE *)$f,"P5 %d %d 255\n",$ncol,$nlin); #}
      (cinline-idx2loop m "unsigned char" "p" "i" "j"
        #{ putc(*p, (FILE *)$f); #}
        )
      ()))

#? (pgm-write-ubim <f> <m>)
;; writes greyscale ubimage <m> in 
;; file <f> as a PGM file.
;; <m> is and idx2 of ubytes.
(de pgm-write-ubim (f m)
    ((-str-) f)
    ((-idx2- (-ubyte-)) m)
    (let ((f (fopen f "wb")))
      (when (not f) (error "couldn't open PGM file"))
      (pgm-fwrite-ubim f m)
      (fclose f)
      ()))
          
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(dhc-make ()
	  pnm-dummy
	  pnm-header
	  mmap-idx3-storage
	  mmap-idx2-storage
	  pnm-fread-into-rgbx
	  pnm-read-into-rgbx
	  pnm-fread-rgb
	  pnm-read-rgb
	  pnm-fread-rgba
	  pnm-read-rgba
	  pnm-fread-into-ubim
	  pnm-read-into-ubim
	  pnm-fread-ubim
	  pnm-read-ubim
	  ppm-mmap
	  pgm-mmap
          ppm-fwrite-rgb
          ppm-write-rgb
	  pgm-fwrite-ubim 
	  pgm-write-ubim 
	  )
