;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; 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: compat.lsh,v 1.26 2006/08/06 12:33:32 leonb Exp $
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;; ----------------------------------------
;;; Casts

;; Yann
(defvar to-float  to-flt)
(defvar to-double to-real)

;; SN3
(defvar flt       to-flt)
(defvar float     to-float)
(defvar real      to-real)
(defvar double    to-double)
(defvar bool      to-bool)
(defvar gptr      to-gptr)
(defvar number    to-number)
(defvar obj       to-obj)
(defvar obj-super to-obj)


;;; ----------------------------------------
;;; pbloops, peloops

(defvar idx-pbloop idx-bloop)
(defvar idx-peloop idx-eloop)


;;; ----------------------------------------
;;; Scheme pseudo-compatibility

(defvar set! setq)
(defvar begin progn)
(defvar else t)
(defvar equal? =)
(defvar eqv? =)
(defvar eq? ==)
(defvar define defvar)
(defvar map mapcar)
(defvar for-each mapc)
(de boolean? (a) (or (= a ()) (= a t)))
(de null? (a) (= a ()))
(defvar pair? consp)
(defvar number? numberp)
(defvar string? stringp)
(defvar vector? indexp)
(defvar symbol? symbolp)
(defvar procedure? functionp)
(defvar set-car! rplaca)
(defvar set-cdr! rplacd)
(defvar symbol->string nameof)
(defvar string->symbol named)


;;; ----------------------------------------
;;; TL3 names for matrix creation functions

(defvar contiguep contiguousp)

(defvar pmatrix packed-matrix)
(defvar bmatrix byte-matrix)
(defvar smatrix short-matrix)
(defvar imatrix int-matrix)
(defvar dmatrix double-matrix)
(defvar fmatrix float-matrix)
(defvar array atom-matrix)
(defvar matrix float-matrix) 
(defvar submatrix sub-index)



;;; ----------------------------------------
;;; SN3 names for storages

(defvar new-f-storage    float-storage)
(defvar new-d-storage    double-storage)
(defvar new-i32-storage  int-storage)
(defvar new-i16-storage  short-storage)
(defvar new-i8-storage   byte-storage)
(defvar new-u8-storage   ubyte-storage)
(defvar new-gptr-storage gptr-storage)
(defvar new-p-storage    packed-storage)
(defvar new-at-storage   atom-storage)



;;; ----------------------------------------
;;; SN3 names for matrices

(defvar f-matrix float-matrix)
(defvar d-matrix double-matrix)
(defvar i32-matrix int-matrix)
(defvar i16-matrix short-matrix)
(defvar i8-matrix byte-matrix)
(defvar u8-matrix ubyte-matrix)
(defvar p-matrix packed-matrix)
(defvar at-matrix atom-matrix)
(defvar f-matrix-nc float-matrix-nc)
(defvar d-matrix-nc double-matrix-nc)
(defvar i32-matrix-nc int-matrix-nc)
(defvar i16-matrix-nc short-matrix-nc)
(defvar i8-matrix-nc byte-matrix-nc)
(defvar u8-matrix-nc ubyte-matrix-nc)
(defvar p-matrix-nc packed-matrix-nc)
(defvar flt-matrix float-matrix)
(defvar real-matrix double-matrix)



;;; ----------------------------------------
;;; Miscellaneous

;; From SN3
(defvar mload libload)
(defvar map-pmatrix map-matrix)
(defvar save-flt-matrix save-matrix)
(defvar save-packed-matrix save-matrix)

;; From SN1
(dm dim(f v . l) `(setq :,v (float-matrix ,@l)))

;; From SN1ATT
(defvar += incr)
(defvar << setq)
(defvar diff-lists diff-listes)
(defvar add-lists add-listes)



;;; ----------------------------------------
;;; Yann-isms

(de load-matrix-into (f x) 
  (let ((m (load-matrix f))) (idx-copy m x)))

(dmd scalar (typ v) 
  (selectq typ
    ((d -double-) `((double-matrix) ,v))
    ((f -float-) `((float-matrix) ,v))
    ((i -int-) `((int-matrix) ,v))
    ((s -short-) `((short-matrix) ,v))
    ((b -byte-) `((byte-matrix) ,v))
    ((u -ubyte-) `((ubyte-matrix) ,v))
    ((g -gptr-) `((gptr-matrix) ,v))
    (a `((atom-matrix) ,v))))

(dmd idx-m2timesm2 (a b c)
  `(let ((aa ,a)) (idx-eloop ((bi ,b) (ci ,c)) (idx_m2dotm1 aa bi ci)))))


;;; ----------------------------------------
;;; Pascal-isms

(dm c-include (fn filename)
  (when (not (stringp filename))
    (error 'c-include "Not a string" filename))
  (let ((dirs (path)))
    (when (<> file-being-loaded "$stdin")
      (setq dirs (cons (dirname file-being-loaded) dirs)) )
    (setq dirs (cons "." dirs))
    (setq filename (find-file dirs filename '("" ".h"))) )
  `(cheader ,(concat "#include \"" filename "\"\n")) )

(de cc-load(cfile &optional moreflags)
  (when (not (functionp dhc-make-o-maybe))
    (error 'cc-load "This function requires dh-compile.lsh" ()) )
  (let ((dirs (path)))
    (when (<> file-being-loaded "$stdin")
      (setq dirs (cons (dirname file-being-loaded) dirs)) )
    (setq dirs (cons "." dirs))
    (setq cfile (find-file dirs cfile '("" ".c"))) )
  (let* ((dhc-make-lushflags dhc-make-lushflags))
    (when moreflags
      (setq dhc-make-lushflags (concat dhc-make-lushflags " " moreflags)) )
    (let ((obj (dhc-make-o-maybe cfile)))
      (mod-load obj)
      obj ) ) )

(de c++-load(cfile &optional moreflags)
  (when (not (functionp dhc-make-o-maybe))
    (error 'cc-load "This function requires dh-compile.lsh" ()) )
  (let ((dirs (path)))
    (when (<> file-being-loaded "$stdin")
      (setq dirs (cons (dirname file-being-loaded) dirs)) )
    (setq dirs (cons "." dirs))
    (setq cfile (find-file dirs cfile '("" ".cpp" ".cc" ".C"))) )
  (let* ((dhc-make-lushflags dhc-make-lushflags)
         (dhc-make-overrides dhc-make-overrides) )
    (when moreflags
      (setq dhc-make-lushflags (concat dhc-make-lushflags " " moreflags)) )
    (let ((cxx (or (alist-get "CXX" dhc-make-overrides)
                   (getconf "CXX") (getenv "CXX") ) ))
      (if (and (stringp cxx) (<> cxx ""))
          (setq dhc-make-overrides (alist-add "CC" cxx dhc-make-overrides))
        (error 'c++-load "Cannot find C++ compiler" ()) ) )
    (let ((obj (dhc-make-o-maybe cfile)))
      (mod-load obj)
      obj ) ) )

(defvar gcc-load cc-load)
(defvar g++-load c++-load)



;;; ----------------------------------------
;; SN3 backquote

(progn
  (unlock-symbol |'|)
  (dmc |'|
       (backquote-subst
        (let* ((|'|
                (lambda()
                  (list (quote quote) (read)) ) )
               (|`| 
                (lambda() 
                  (printf "*** Warning\007: old style backquote macro : %l\n"
                          (basename file-being-loaded) )
                  (backquote-macro) ) ) )
          (read) ) ) )
  (lock-symbol |'|) )



;;; ----------------------------------------
;;; TL3 statistics on lists
;;; (complete source file 'classify.c')

(de y_estimate((a b r) x)
  (+ (* x a) b) )
(de x_estimate((a b r) y)
  (/ (- y b) a) )
(dm mean_sup_dist (f r1 . r2)
  `(let ((r ,r1)) (/ (sup_dist r ,@r2) (length r))) )
(dm mean_abs_dist (f r1 . r2)
  `(let ((r ,r1)) (/ (abs_dist r ,@r2) (length r))) )
(dm mean_sqr_dist (f r1 . r2)
  `(let ((r ,r1)) (/ (sqr_dist r ,@r2) (length r))) )
(dm mean_hamming_dist (f r1 . r2)
  `(let ((r ,r1)) (/ (hamming_dist r ,@r2) (length r))) )
(dm mean_quadrant_dist (f r1 . r2)
  `(let ((r ,r1)) (/ (quadrant_dist r ,@r2) (length r))) )


;;; ----------------------------------------
;;; SN3 idx-m[012a]{xxx} functions

(mapc (lambda(name)
        (let* ((pn (pname name))
               (new-name (named (concat "idx-" pn)))
               (code `(list 'progn (cons ,(list 'quote new-name) l))))
          (eval `(dmd ,(named (concat "idx-m0" pn)) l ,code))
          (eval `(dmd ,(named (concat "idx-m1" pn)) l ,code))
          (eval `(dmd ,(named (concat "idx-m2" pn)) l ,code))
          (eval `(dmd ,(named (concat "idx-ma" pn)) l ,code)) ) )
      '(clear
        copy sum sumacc sumsqrt sumsqrtacc sqrdist sqrdistacc
        dotm0 dotm0acc addm0 addmoacc
        add sub mul div
        minus abs sqrt qtanh qdtanh 
        stdsigmoid dstdsigmoid expmx dexpmx 
        sin cos atan log exp ) )

(mapc (lambda(name)
        (let* ((pn (pname name))
               (new-name (named (concat "idx-" pn)))
               (code `(list 'progn (cons ,(list 'quote new-name) l))))
          (eval `(dmd ,(named (concat "idx-m0" pn "m0")) l ,code))
          (eval `(dmd ,(named (concat "idx-m1" pn "m1")) l ,code))
          (eval `(dmd ,(named (concat "idx-m2" pn "m2")) l ,code))
          (eval `(dmd ,(named (concat "idx-ma" pn "ma")) l ,code)) ) )
      '(dot) )

(mapc (lambda(name)
        (let* ((pn (pname name))
               (new-name (named (concat "idx-" pn)))
               (code `(list 'progn (cons `(list 'quote new-name) l))))
          (eval `(dmd ,(named (concat "idx-m0" pn "m0acc")) l ,code))
          (eval `(dmd ,(named (concat "idx-m1" pn "m1acc")) l ,code))
          (eval `(dmd ,(named (concat "idx-m2" pn "m2acc")) l ,code))
          (eval `(dmd ,(named (concat "idx-ma" pn "maacc")) l ,code)) ) )
      '(dot) )



;;; ----------------------------------------
;;; SN1 SN2 and TL3 matrix functions

(defvar matrix-print index-print)
(defvar copy-any-matrix copy-matrix)

(dmd dot-product (a b)
  `(let ((r (double-matrix)))
     (idx-dot ,a ,b r)
     (r)))

(dmd sup-mat(m)
  `((idx-sup ,m)) )

(dmd inf-mat(m)
  `((idx-inf ,m)) )

(de mean-mat(m)
  (let ((r (matrix))
        (n (apply * (bound m))) )
    (idx-sum m r)
    (/ (r) n) ) )

(de sdev-mat(m)
  (let ((r (matrix))
        (r2 (matrix))
        (n (apply * (bound m))) )        
    (idx-sum m r)
    (idx-sumsqr m r2)
    (- (/ (r2) n) (let ((s (/ (r) n))) (* s s))) ) )

(de m*m (a b &optional c)
  (if (= (idx-ndim a) 1)
      (if (= (idx-ndim b) 1)
          (if (= 1 (idx-dim b 0))
              (if c (let ((-dh-b (double-matrix))
                          (-dh-a a)
                          (-dh-c c))
                      (-dh-b (b 0))
                      (idx-dotm0 -dh-a -dh-b -dh-c)
                      -dh-c)
                (let* ((-dh-b (double-matrix))
                       (-dh-a a)
                       (-dh-c (clone-matrix -dh-a)))
                  (-dh-b (b 0))
                  (idx-dotm0 -dh-a -dh-b -dh-c)
                  -dh-c))
            (error "m*m: idx 2 must have 1 element"))
        (if (= 1 (idx-dim b 0))
            (if c
                (let* ((-dh-b (select b 0 0))
                       (-dh-a a)
                       (-dh-c c))
                  (idx-m1extm1 -dh-a -dh-b -dh-c)
                  -dh-c)
              (let* ((-dh-b (select b 0 0))
                     (-dh-a a)
                     (-dh-c (double-matrix (idx-dim -dh-a 0) (idx-dim -dh-b 0))))
                (idx-m1extm1 -dh-a -dh-b -dh-c)
                -dh-c))
          (error "m*m: idx 2 have bad dimensions")))
    (if (= 1 (idx-ndim b))
        (if c
            (let ((-dh-c c)) (idx-m2dotm1 a b -dh-c) -dh-c)
          (let* ((-dh-a a)
                 (-dh-b b)
                 (-dh-c (double-matrix (idx-dim -dh-a 0))))
            (idx-m2dotm1 a -dh-b -dh-c) -dh-c))
      (if c
          (let ((-dh-c c))
            (idx-eloop ((-dh-x b) (-dh-y -dh-c)) 
              (idx-m2dotm1 a -dh-x -dh-y))
            -dh-c)
        (let* ((-dh-a a)
               (-dh-b b)
               (-dh-c (double-matrix (idx-dim -dh-a 0) (idx-dim -dh-b 1))))
          (idx-eloop ((-dh-x -dh-b) (-dh-y -dh-c)) 
            (idx-m2dotm1 -dh-a -dh-x -dh-y))
          -dh-c)))))

(de m+m (a b &optional c)
  (if ~c (setq c (clone-matrix b)))
  (idx-add a b c)
  c)

(de mxm (a b &optional c)
  (if ~c (setq c (clone-matrix b)))
  (idx-mul a b c)
  c)

(de m/m (a b &optional c)
  (if ~c (setq c (clone-matrix b)))
  (idx-div a b c)
  c)

(de m-m (a b &optional c)
  (let ((b b))
    (if ~c (setq c (clone-matrix b)))
    (idx-sub a b c)
    c))

(de m*c (a b &optional c)
  (if ~c (setq c (clone-matrix a)))
  (let ((d (double-matrix)))
    (d b)
    (idx-dotm0 a d c)
    c))

(de m+c (a b &optional c)
  (if ~c (setq c (clone-matrix a)))
  (let ((d (double-matrix)))
    (d b)
    (idx-addm0 a d c)
    c))

(de transpose (m)
  (selectq (idx-ndim m)
    (1 (let ((m2 (idx-clone m)))
         (idx-unfold m2 0 (idx-dim m 0) 1)
         m2))
    (2 (let ((m2 (idx-clone m)))
         (idx-transpose m2 '(1 0))
         m2))
    (t (error 'transpose "Two dimensioned matrix expected" m))))

(dmd convolve(mat sx sy kernel &optional res)
  (error 'convolve "Compatibility function not implemented" ()) )

