
(define scheme-system 'mzscheme)

(if (eq? scheme-system 'mit-scheme)
    (load-option 'hash-table))

(if (eq? scheme-system 'mzscheme)
    (require-library "file.ss"))


(define SupGlobalSuperficieURL "http://superficie.sourceforge.net/")
(define SupGlobalProgramPath "superficie")
(define SupGlobalDefaultPointsNumber 20)

;; no se porqu no funciona case con smbolos

(define (sup-make-hash-table)
  (cond
    ((eq? scheme-system 'guile) (make-hash-table 1))
    ((eq? scheme-system 'mit-scheme) (make-string-hash-table 1))
    ((eq? scheme-system 'mzscheme) (make-hash-table))))

(define (sup-hash-table-put! ht key val)
  (cond
    ((eq? scheme-system 'guile) (hash-set! ht key val))
    ((eq? scheme-system 'mit-scheme) (hash-table/put! ht key val))
    ((eq? scheme-system 'mzscheme) (hash-table-put! ht key val))))


(define (sup-hash-table-get ht key)
  (cond
    ((eq? scheme-system 'guile) (hash-ref ht key))
    ((eq? scheme-system 'mit-scheme) (hash-table/get ht key 0))
    ((eq? scheme-system 'mzscheme) (hash-table-get ht key 0))))


(define (sup-make-temp-file)
  (cond
    ((eq? scheme-system 'guile) (tmpnam))
    ((eq? scheme-system 'mit-scheme) (tempname "/tmp" "sup"))
    ((eq? scheme-system 'mzscheme) (make-temporary-file))))



(define (sup-quads param iter1 iter2 points)
  (let*
      ((xmin (car  iter1))
       (xmax (cadr iter1))
       (ymin (car  iter2))
       (ymax (cadr iter2))
       (ptos (if (list? points) points (list points points)) )
       (datos (make-vector (* (car ptos) (cadr ptos)) 0) )
       (xinc (/ (- xmax xmin) (- (car  ptos) 1)) )
       (yinc (/ (- ymax ymin) (- (cadr ptos) 1)) )
       (i  0)
       (result (sup-make-hash-table)))
    (do ((iy 0 (+ iy 1))) ((>= iy (cadr ptos)))
      (do ((ix 0 (+ ix 1))) ((>= ix (car ptos)))
        (vector-set! datos i (param (+ ymin (* ix xinc))  (+ ymin (* iy yinc)) ) )
        (set! i  (+ i  1) )))
    
    (sup-hash-table-put! result 'data  datos)
    (sup-hash-table-put! result 'type  "QUADS")
    (sup-hash-table-put! result 'points  ptos)    
    result))


(define (sup-write-quads data file)
  (letrec
      ((indices
        (lambda (nx ny)
          (let
              ((k 0)
               (to (* nx (- ny 1)))
               (datos (make-vector (* (- nx 1) (- ny 1) 4) 0)))

            (do ((j 0 (+ j nx))) ((>= j to))
              (do ( (i j (+ i 1)) (xto (+ j (- nx 1))) ) ((>= i xto))
                     (vector-set! datos k i)
                     (vector-set! datos (+ k 1) (+ i 1))
                     (vector-set! datos (+ k 2) (+ i 1 nx))
                     (vector-set! datos (+ k 3) (+ i nx))
                     (set! k (+ k 4))))
            datos)))
       (ind 0) (numbers 0) (i 0) (f 0) (comillas 0))
    (define f (open-output-file file 'replace))
    (define (comillas) (display #\" f))
    
    (set! ind (apply indices (sup-hash-table-get data 'points)))
    (set! numbers (sup-hash-table-get data 'data))
  
    (display "<?xml version=" f)
    (comillas)
    (display "1.0" f)
    (comillas)
    (display "?>" f)
    (display #\newline f)
    (display "<sup:Scene xmlns:sup=" f)
    (comillas)
    (display SupGlobalSuperficieURL f)
    (comillas)
    (display ">" f)
    
    (display #\newline f)
    
    (display "<sup:Objects>" f ) (display #\newline f)
    (display "<sup:Object Type=" f) (comillas)
    (display "QUADS" f) (comillas)
    (display ">" f)
    
    (display #\newline f)
    (display "<sup:Common>" f ) (display #\newline f)
    (display "<sup:Vertex Length=" f ) (comillas)
    (display (* 3 (vector-length numbers)) f )
    (comillas)
    (display ">" f ) (display #\newline f)
    
    (do ((i 0 (+ i 1))) ((>= i (vector-length numbers)))
           (display (exact->inexact (car   (vector-ref numbers i))) f ) (display " " f )
           (display (exact->inexact (cadr  (vector-ref numbers i))) f ) (display " " f )
           (display (exact->inexact (caddr (vector-ref numbers i))) f ) (display " " f ))

    (display #\newline f)
    
    (display "</sup:Vertex>"  f ) (display #\newline f)
    (display "</sup:Common>"  f ) (display #\newline f)
    (display "<sup:Specific>" f ) (display #\newline f)
    
    (display "<sup:Index Length=" f )
    (comillas)
    (display (vector-length ind) f )
    (comillas)
    (display ">" f ) (display #\newline f)
    
    (do ((i 0 (+ i 1))) ((>= i (vector-length ind)))
      (display (vector-ref ind i) f ) (display " " f ))
    
    (display #\newline f)
    
    (display "</sup:Index>"    f ) (display #\newline f)
    (display "</sup:Specific>" f ) (display #\newline f)
    (display "</sup:Object>"   f ) (display #\newline f)
    (display "</sup:Objects>"  f ) (display #\newline f)
    (display "</sup:Scene>"    f ) (display #\newline f)
    
    (close-output-port f)))


(define (sup-write data file)
  (cond
    ((equal? (sup-hash-table-get data 'type) "QUADS") (sup-write-quads  data file))))


(define (sup-show data)
  (let
      ((tmpfile (sup-make-temp-file)))
    (sup-write data tmpfile)
    (system
     (string-append SupGlobalProgramPath " " tmpfile " >& /dev/null &"))))



(define (sup-parametric-plot-3d . args)
  (cond
    ( (equal? (length args) 4)
      (sup-show (sup-quads (car args) (cadr args) (caddr args) (cadddr args))) )
    ( (equal? (length args) 3)
      (sup-show (sup-quads (car args) (cadr args) (caddr args) SupGlobalDefaultPointsNumber)) )))


