;;;; z3.scm

(module z3

	(z3:decode-init z3:decode
	  z3:encode-init z3:encode
	  z3:handle?
	  z3:open-compressed-input-file z3:open-compressed-output-file
	  z3:file-handle? z3:file-handle-fileno
	  z3:encode-buffer z3:decode-buffer
	  z3:encode-buffer-to-blob
	  z3:encode-file z3:write-encoded
	  z3:decode-file z3:read-decoded)

(import scheme)
(import chicken)
(import (except foreign foreign-declare))
(require-extension data-structures ports posix bind)

#>
#include <unistd.h>

#include "z3blib.c"
#include "z3dlib.c"
#include "z3flib.c"

#define copy_dbuffer(ptr, buf, size)   (C_memcpy(C_data_pointer(buf), C_c_pointer_nn(ptr), C_unfix(size)), C_SCHEME_UNDEFINED)
#define free_dbuffer(ptr)              (C_free(C_c_pointer_nn(ptr)), C_SCHEME_UNDEFINED)
<#

(bind-rename "z3err_none" "z3:error-none")
(bind-rename/pattern "z3err_bd_(.+)" "z3:error-\\1")

(bind #<<EOF

enum {
  z3err_none,
  z3err_bd_notbfinal,
//  z3err_bd_malloc,
//  z3err_bd_free,
  z3err_bd_btype3,
  z3err_bd_nlenmismatch,
  z3err_bd_hlitexceed,
  z3err_bd_hdistexceed,
  z3err_bd_codelengthtable,
  z3err_bd_codeliteralundefined,
  z3err_bd_codeliteralexceed,
  z3err_bd_codeliteralnoprevious,
  z3err_bd_codeliteraltoomany,
  z3err_bd_codeliteraltable,
  z3err_bd_codedistancesundefined,
  z3err_bd_codedistancesexceed,
  z3err_bd_codedistancesnoprevious,
  z3err_bd_codedistancestoomany,
  z3err_bd_codedistancestable,
  z3err_bd_dataundefined,
  z3err_bd_distanceundefined
//  z3err_dd_malloc,
//  z3err_dd_free
};

struct z3dd_handle *z3d_decode_init(unsigned int pending_bits, int pending_nb, ___scheme_pointer memory, unsigned int memsize);
struct z3dd_handle *z3d_decode_relative(___scheme_pointer zh, ___out int *error,
                        ___inout unsigned int *pending_bits, ___inout int *pending_nb,
                        ___scheme_pointer code, unsigned int codesize, ___out unsigned int *taken,
                        ___out unsigned int *index, ___out unsigned int *given);

struct z3de_handle *z3d_encode_init(___scheme_pointer memory, unsigned int memsize,
                        unsigned int tellwhen,
                        int thrmin, int thrmax, int initialgrant,
                        ___bool preferlonger, ___bool limitlength3);

struct z3de_handle *z3d_encode(___scheme_pointer zh,
                        ___scheme_pointer data, unsigned int datasize, ___out unsigned int *taken,
                        ___scheme_pointer code, unsigned int codesize, ___out unsigned int *given);

___fixnum z3f_encode_init(int filedescr, ___scheme_pointer zh, ___fixnum level,
                        long mtime, ___fixnum os,
                        ___fixnum xlen, ___scheme_pointer fextra,
                        char *fname, char *fcomment);

___fixnum z3f_encode_header(___scheme_pointer zh, ___fixnum xlen, ___scheme_pointer fextra,
					      char *fname, char *fcomment);
___fixnum z3f_encode_write(___scheme_pointer zh, ___scheme_pointer data, long count);
___fixnum z3f_decode_init(___fixnum filedescr, ___scheme_pointer zh);
___fixnum z3f_decode_read(___scheme_pointer zh, ___scheme_pointer data, long count);
EOF
)

(define-foreign-variable Z3DD_MEMSIZE int)
(define-foreign-variable Z3DE_SLICE_MIN int)
(define-foreign-variable Z3DE_MEMSIZE_MIN int)
(define-foreign-variable Z3DE_THRESHOLD_ONE int)
(define-foreign-variable Z3BE_MEMSIZE_EXTRA3 int)

(define errors
  `((,z3:error-none . "none")
    (,z3:error-notbfinal . "notbfinal")
    (,z3:error-btype3 . "btype3")
    (,z3:error-nlenmismatch . "nlenmismatch")
    (,z3:error-hlitexceed . "hlitexceed")
    (,z3:error-hdistexceed . "hdistexceed")
    (,z3:error-codelengthtable . "codelengthtable")
    (,z3:error-codeliteralundefined . "codeliteralundefined")
    (,z3:error-codeliteralexceed . "codeliteralexceed")
    (,z3:error-codeliteralnoprevious . "codeliteralnoprevious")
    (,z3:error-codeliteraltoomany . "codeliteraltoomany")
    (,z3:error-codeliteraltable . "codeliteratable")
    (,z3:error-codedistancesundefined . "codedistanceundefined")
    (,z3:error-codedistancesexceed . "codedistanceexceed")
    (,z3:error-codedistancesnoprevious . "codedistancenoprevious")
    (,z3:error-codedistancestoomany . "codedistancetoomany")
    (,z3:error-codedistancestable . "codedistancetable")
    (,z3:error-dataundefined . "dataundefined")
    (,z3:error-distanceundefined . "distanceundefined") ) )

(define-record z3:handle buffer decoded encode?)

(define (z3:error loc code msg . args)
  (signal
   (make-composite-condition
    (make-property-condition 
     'exn 'location loc 
     'message (string-append msg " [" (alist-ref code errors eqv? "unknown") "]") 
     'arguments args)
    (make-property-condition 'z3 'code code) ) ) )

(define (z3:decode-init)
  (let ((buffer (make-string Z3DD_MEMSIZE)))
    (unless (z3d_decode_init 0 0 buffer Z3DD_MEMSIZE)
      (z3:error 'z3:decode-init z3:error-none "initialization failed") )
    (make-z3:handle buffer #f #f) ) )

(define (z3:decode handle receiver zbuf #!optional (len (string-length zbuf)))
  (assert (not (z3:handle-encode? handle)) "not a decoding handle" handle)
  (let-values (((r err pbits pnb taken index given) (z3d_decode_relative (z3:handle-buffer handle) 0 0 zbuf len)))
    ;(pp (list err r index taken given))
    (cond (r (when (fx> given 0)
	       (receiver (substring (z3:handle-buffer handle) index (+ index given))) )
	     taken)
	  ((= err z3:error-none) #f)
	  (else (z3:error 'z3:decode err "can not decode data") ) ) ) )

(define (z3:encode-init #!key 
			(buffer (make-string 4096))
			(buffer-size (string-length buffer))
			(memsize (+ Z3DE_MEMSIZE_MIN 65402 Z3BE_MEMSIZE_EXTRA3)) ;???
			(tellwhen Z3DE_SLICE_MIN)
			(thrmin 77)
			(thrmax 77) 
			(initialgrant 13)
			preferlonger)
  (let ((zbuf (make-string memsize)))
    (unless (z3d_encode_init zbuf memsize tellwhen thrmin thrmax initialgrant preferlonger #t)
      (z3:error 'z3:encode-init z3:error-none "initialization failed"))
    (make-z3:handle zbuf buffer #t) ) )

(define (z3:encode handle receiver data #!optional (datasize (string-length data)))
  (assert (z3:handle-encode? handle) "not an encoding handle" handle)
  (let ((cbuf (z3:handle-decoded handle)))
    (let-values (((r taken given) (z3d_encode (z3:handle-buffer handle) data datasize cbuf (string-length cbuf))))
      (when (fx> given 0)
	(receiver (substring cbuf 0 given)) )
      (and r taken) ) ) )

(define strerror (foreign-lambda c-string "strerror" int))
(define -EAGAIN (foreign-value "-EAGAIN" int))

(define-record z3:file-handle z3 fileno)

(define (z3:encode-file fd #!key (level 6) (filename #f) (comment #f) (ostype -1) (extra #f))
  (define (err r) 
    (error 'z3:encode-file (string-append "can not encode file - " (strerror (fxneg r))) fd) )
  (let* ((z3 (make-string (foreign-value "sizeof(struct z3fe_handle)" int)))
	 (xlen (if extra (string-length extra) 0))
	 (r (z3f_encode_init fd z3 level (current-seconds) ostype xlen extra filename comment)) )
    (when (fx< r 0) (err r))
    (let loop ()
      (let ((r (z3f_encode_header z3 xlen extra filename comment)))
	(cond ((eq? -EAGAIN r) (loop))
	      ((fx< r 0) (err r))
	      (else (make-z3:file-handle z3 fd) ) ) ) ) ) )

(define (z3:write-encoded z3h data #!optional (len (and data (string-length data))))
  (define (err r)
    (error 'z3:write-encoded (string-append "can not write encoded data - " (strerror (fxneg r)))) )
  (let ((z3 (z3:file-handle-z3 z3h)))
    (if (not data)
	(let loop ()
	  (let ((r (z3f_encode_write z3 #f 0)))
	    (cond ((eq? r -EAGAIN) (loop))
		  ((eq? r 0))
		  (else (err r)) ) ) )
	(let loop ((len len)
		   (data data) )
	  (when (fx> len 0)
	    (let ((r (z3f_encode_write z3 data len)))
	      (cond ((eq? r -EAGAIN) (loop len data))
		    ((fx<= r 0) (err r))
		    (else (loop (fx- len r) (substring data r))))))) ) ) )

(define (z3:decode-file fd)
  (let* ((z3 (make-string (foreign-value "sizeof(struct z3fd_handle)" int)))
	 (r (z3f_decode_init fd z3)) )
    (if (fx< r 0)
	(error 'z3:decode-file (string-append "can not decode file - " (strerror (fxneg r))))
	(make-z3:file-handle z3 fd) ) ) )

(define-constant +read-block-size+ 4096)

(define (z3:read-decoded z3 #!optional (len +read-block-size+))
  (let ((buf (make-string len))
	(z3 (z3:file-handle-z3 z3)) )
    (let loop ((n len))
      (let ((r (z3f_decode_read z3 buf n)))
	(cond ((eq? r -EAGAIN) (loop n))
	      ((fx< r 0) 
	       (error 'z3:read-decoded (string-append "can not read encoded data - " (strerror (fxneg r)))) )
	      ((eq? r 0) #!eof)
	      ((eq? r n) buf)
	      (else (substring buf 0 r)) ) ) ) ) )

(define (z3:open-compressed-input-file filename)
  (let* ((fd (file-open filename (bitwise-ior open/read open/binary)))
	 (z3 (z3:decode-file fd)) 
	 (eof #f)
	 (buf #f) 
	 (len 0)
	 (pos 0) )
    (define (read-next)
      (if eof
	#!eof
	(let ((b (z3:read-decoded z3)))
	  (cond ((eof-object? b)
		 (set! eof #t)
		 b)
		(else
		 (set! buf b)
		 (set! len (string-length b)) ) ) ) ) )
    (make-input-port
     (lambda ()
       (cond ((fx>= pos len)
	      (if (eof-object? (read-next))
		  #!eof
		  (begin
		    (set! pos 1)
		    (string-ref buf 0) ) ) )
	     (else
	      (let ((c (string-ref buf pos)))
		(set! pos (fx+ pos 1))
		c) ) ) )
     (lambda () (fx< pos len))
     (lambda () (file-close fd)) ) ) )

(define (z3:open-compressed-output-file filename #!key (level 6) (comment #f) (astype -1) (extra #f))
  (let* ((fd (file-open filename (bitwise-ior open/creat open/binary open/write)))
	 (z3 (z3:encode-file fd level: level comment: comment filename: filename astype: astype extra: extra)) )
    (make-output-port
     (lambda (s) 
       (z3:write-encoded z3 s) )
     (lambda () 
       (z3:write-encoded z3 #f)
       (file-close fd)) ) ) )

(bind* #<<EOF
int encode_all(___scheme_pointer zh, ___scheme_pointer str, unsigned int start, unsigned int end,
	       ___scheme_pointer dest, unsigned int destlen)
{
  struct z3de_handle *z = (struct z3de_handle *)zh;
  int len = end - start;
  char *ptr = dest;
  unsigned int taken, given;

  do {
    z = z3d_encode(z, str + start, len, &taken, ptr, destlen, &given);
    start += taken;
    destlen -= given;
    ptr += given;
    len -= taken;
  } while(z != NULL);

  return (unsigned char *)ptr - (unsigned char *)dest;
}
EOF
)

(define (z3:encode-buffer str #!optional (start 0) (end (string-length str)) odest)
  (let* ((dest (or odest (make-string (+ 4096 (- end start)))))
	 (dlen (string-length dest))
	 (r (encode_all (z3:handle-buffer (z3:encode-init)) str start end dest dlen)) )
    (if odest
	r
	(substring dest 0 r) ) ) )
(define (z3:encode-buffer-to-blob str #!optional (start 0) (end (string-length str)))
  (let ((bv (z3:encode-buffer str start end)))
    (##core#inline "C_string_to_bytevector" bv)
    bv))

(bind* #<<EOF
void *decode_all(___scheme_pointer zh, ___scheme_pointer str, unsigned int start, 
	         unsigned int end, ___out int *err, ___out int *count)
{
  struct z3dd_handle *z = (struct z3dd_handle *)zh;
  int len = end - start;
  int dlen = 4096;
  int dcount = 0;
  char *dest = (char *)C_malloc(dlen);
  char *ptr;
  unsigned int taken, given;
  __u32 pb;
  int pbnb;
  __u8 *data;

  if(dest == NULL) return NULL;

  ptr = dest;
  *err = z3err_none;
  str += start;

  for(;;) {
    z = z3d_decode(z, err, &pb, &pbnb, str, len, &taken, &data, &given);

    if(z == NULL) {
      if(*err != z3err_none) {
        free(dest);
        return NULL;
      }
      
      *count = dcount;
      return dest;
    }

    str += taken;
    len -= taken;
    
    while(dcount + given > dlen) {
      char *d2 = (char *)realloc(dest, dlen *= 2);

      if(d2 == NULL) {
	C_free(d2);
        return NULL;
      }
      else dest = d2;
    }

    if(given > 0) C_memcpy(dest + dcount, data, given);

    dcount += given;
  }
}
EOF
)

(define (z3:decode-buffer str #!optional (start 0) (end (if (blob? str) (blob-size str) (string-length str))))
  (let-values (((ptr err size) (decode_all (z3:handle-buffer (z3:decode-init)) str start end)))
    (cond ((= err z3:error-none) 
	   (if ptr
	       (let ((buf (make-string size)))
		 (##core#inline "copy_dbuffer" ptr buf size) 
		 (##core#inline "free_dbuffer" ptr)
		 buf)
	       (error 'z3:decode-buffer "out of memory - can not allocate decompression buffer")) )
	  (else (z3:error 'z3:decode-buffer err "can not decode data") ) ) ) )

)