;; [ Copyright (C) 2008 Dave Griffiths : GPLv2 see LICENCE ]

;; StartSectionDoc-en
;; scheme-utils
;; High level fluxus commands written in Scheme.
;; Example:
;; EndSectionDoc 

;; StartSectionDoc-pt
;; blocos-de-construcao-fluxus
;; Um novo e pouco testado ajuste de estruturas de controle de ordem maior para 
;; manipular objetos e estados e estado no fluxus de uma maneira mais limpa e segura.
;; Exemplo:
;; EndSectionDoc 

#lang scheme/base
(require "fluxus-modules.ss")
(provide 
 with-state
 with-primitive
 with-pixels-renderer
 pdata-map!
 pdata-index-map!
 pdata-fold
 pdata-index-fold
 detach-parent
 vx vy vz vr vg vb va
 vx-set! vy-set! vz-set! vr-set! vg-set! vb-set! va-set!
 vadd vsub mmul madd msub mdiv
 )
 
;; StartFunctionDoc-en
;; detach-parent
;; Returns: void
;; Description:
;; Removes the parent for the current primitive, and fixes up the 
;; transform so the primitive doesn't move. Use (parent 1) to avoid this fix up.
;; Example:
;; ; builds and animates a random heirarchical structure,
;; ; click on the objects to detach them from their parents
;; (define (build-heir depth)
;;     (with-state
;;         (let ((p (with-state
;;                         (translate (vector 2 0 0))
;;                         (scale 0.9)
;;                         (build-cube))))
;;             (when (> depth 0)
;;                 (parent p)            
;;                 (for ((i (in-range 0 5)))
;;                     (when (zero? (random 3))
;;                         (rotate (vector 0 0 (* 45 (crndf))))
;;                         (build-heir (- depth 1))))))))
;; 
;; (define (animate-heir children depth)
;;     (for-each
;;         (lambda (child)
;;             (with-primitive child           
;;                 (rotate (vector 0 0 (sin (+ depth (time)))))
;;                 (animate-heir (get-children) (+ depth 1))))
;;         children))
;; 
;; (define (animate)
;;     (animate-heir (get-children) 0)
;;     (when (mouse-button 1)
;;         (let ((s (select (mouse-x) (mouse-y) 2)))
;;             (when (not (zero? s))
;;                 (with-primitive s
;;                     (detach-parent))))))
;; 
;; (clear)
;; (build-heir 5)
;; (every-frame (animate))
;; EndFunctionDoc  
 
 (define (detach-parent)
	(let ((m (get-global-transform)))
		(parent 1)
		(identity)
		(concat m)))

;; StartFunctionDoc-en
;; with-state expression ...
;; Returns: result of last expression
;; Description:
;; Encapsulates local state changes, and removes the need for push and pop.
;; Example:
;; ; state hierachy, by nesting with-state:
;; (with-state
;;    (hint-vertcols)
;;    (colour (vector 0 0 1))
;;    (with-state
;;        (translate (vector 1 0 0))
;;        (build-sphere 10 10))
;;     (build-torus 1 2 30 30))
;;
;; ; making primitives:
;; (define my-torus (with-state
;;    (hint-vertcols)
;;    (colour (vector 0 0 1))
;;    (build-torus 1 2 30 30)))
;; EndFunctionDoc  

;; StartFunctionDoc-pt
;; with-state expressão ...
;; Retorna: resultado da última expressão
;; Descrição:
;; Encapsula mudanças locais, e remove a necessidade por push e pop.
;; Exemplo:
;; ; state hierachy, by nesting with-state:
;; (with-state
;;    (hint-vertcols)
;;    (colour (vector 0 0 1))
;;    (with-state
;;        (translate (vector 1 0 0))
;;        (build-sphere 10 10))
;;     (build-torus 1 2 30 30))
;;
;; ; making primitives:
;; (define my-torus (with-state
;;    (hint-vertcols)
;;    (colour (vector 0 0 1))
;;    (build-torus 1 2 30 30)))
;; EndFunctionDoc

(define-syntax with-state
  (syntax-rules ()
    ((_ a ...)
     (begin
       (push)
       (let ((r (begin a ...)))
         (pop)
         r)))))

;; StartFunctionDoc-en
;; with-primitive primitive expression ...
;; Returns: result of last expression
;; Description:
;; Encapsulates primitive state changes, and removes the need for grab and ungrab.
;; Example:  
;; (define my-torus (with-state
;;    (colour (vector 0 0 1))
;;    (build-torus 1 2 30 30)))
;;
;; ; change the torus colour: 
;; (with-primitive my-torus
;;    (colour (vector 0 1 0)))
;; EndFunctionDoc  

;; StartFunctionDoc-pt
;; with-primitive primitiva expressão ...
;; Retorna: resultado da última expressão
;; Descrição:
;; Encapsula mudanças de estado das primitivas
;; Exemplo:
;; 
;; EndFunctionDoc

(define-syntax with-primitive
  (syntax-rules ()
    ((_ a b ...)
     (begin
       (grab a)
       (let ((r (begin b ...)))
         (ungrab)
         r)))))

;; StartFunctionDoc-en
;; with-pixels-renderer pixels-primitive expression ...
;; Returns: result of last expression
;; Description:
;; Allows you to render into a pixel primitive.
;; Example:  
;; EndFunctionDoc  

(define-syntax with-pixels-renderer
  (syntax-rules ()
    ((_ a b ...)
     (begin
       (renderer-grab a)
       (let/ec out
           ;; handle errors
           (let ([renderer-error
                   (lambda (e)
                     (printf "Error in with-pixels-renderer '~a - render target restored.~% Error: ~a ~%"
                            a e)
                     (renderer-ungrab)
                     (out #t))])
                 (call-with-exception-handler renderer-error
                                              (lambda ()
                                                (let ([r (begin b ...)])
                                                  (renderer-ungrab)
                                                  r)))
           ))
     ))))

;; StartFunctionDoc-en
;; pdata-map! procedure read/write-pdata-name read-pdata-name ...
;; Returns: void
;; Description:
;; A high level control structure for simplifying passing over pdata arrays for 
;; primitive deformation. Should be easier and less error prone than looping manually.
;; Writes to the first pdata array.
;; Example:
;; (clear)
;; (define my-torus (build-torus 1 2 30 30))
;; 
;; (with-primitive my-torus
;;   (pdata-map!
;;      (lambda (position)
;;          (vadd position (vector (flxrnd) 0 0))) ; jitter the vertex in x
;;      "p")) ; read/write the position pdata array
;; 
;; (with-primitive my-torus
;;   (pdata-map!
;;      (lambda (position normal)
;;          (vadd position normal)) ; add the normal to the position (expand the object)
;;      "p" "n")) ; read/write the position pdata array, read the normals array
;; EndFunctionDoc  	   

;; StartFunctionDoc-pt
;; pdata-map! procedimento nome-pdata-leitura/escrita nome-pdata-leitura ...
;; Retorna: void
;; Descrição:
;; Uma estrutura de controle de alto nível para simplificar a passagem sobre uma array de 
;; pdata para deformação de primitivas. Deve ser mais fácil e menos sujeito a erros do que fazer 
;; o loop manualmente. Escreve na primeira array pdata.
;; Exemplo:
;; (clear)
;; (define my-torus (build-torus 1 2 30 30))
;; 
;; (with-primitive my-torus
;;   (pdata-map!
;;      (lambda (position)
;;          (vadd position (vector (flxrnd) 0 0))) ; jitter the vertex in x
;;      "p")) ; read/write the position pdata array
;; 
;; (with-primitive my-torus
;;   (pdata-map!
;;      (lambda (position normal)
;;          (vadd position normal)) ; add the normal to the position (expand the object)
;;      "p" "n")) ; read/write the position pdata array, read the normals array
;; EndFunctionDoc

(define-syntax pdata-map!
  (syntax-rules ()
    ((_ proc pdata-write-name pdata-read-name ...)
     (letrec 
         ((loop (lambda (n total)
                  (cond ((not (> n total))
                         (pdata-set! pdata-write-name n 
                                     (proc (pdata-ref pdata-write-name n) 
                                           (pdata-ref pdata-read-name n) ...))
                         (loop (+ n 1) total))))))
       (loop 0 (- (pdata-size) 1))))))

;; StartFunctionDoc-en
;; pdata-index-map! procedure read/write-pdata-name read-pdata-name ...
;; Returns: void
;; Description:
;; A high level control structure for simplifying passing over pdata arrays for 
;; primitive deformation. Same as pdata-map! except pdata-index-map! supplies 
;; the index of the current pdata element as the first argument to 'procedure'. 
;; Example:
;; (clear)
;; (define my-torus (build-torus 1 2 30 30))
;; 
;; (with-primitive my-torus
;;   (pdata-index-map!
;;      (lambda (index position)
;;          (vadd position (vector (gh index) 0 0))) ; jitter the vertex in x
;;      "p")) ; read/write the position pdata array
;; EndFunctionDoc  	   

;; StartFunctionDoc-pt
;; pdata-index-map! procedimento nome-pdata-leitura/escrita nome-pdata-leitura ...
;; Retorna: void
;; Descrição:
;; Uma estrutura de controle de alto nível para simplificar a passagem sobre uma array de 
;; pdata para deformação de primitivas. Mesmo que pdata-map! exceto que pdata-index-map! fornece
;; o índice do elemento pdata atual como o primeiro argumento ao "procedimento".
;; Exemplo:
;; (clear)
;; (define my-torus (build-torus 1 2 30 30))
;; 
;; (with-primitive my-torus
;;   (pdata-index-map!
;;      (lambda (index position)
;;          (vadd position (vector (gh index) 0 0))) ; jitter the vertex in x
;;      "p")) ; read/write the position pdata array
;; EndFunctionDoc

(define-syntax pdata-index-map!
  (syntax-rules ()
    ((_ proc pdata-write-name pdata-read-name ...)
     (letrec 
         ((loop (lambda (n total)
                  (cond ((not (> n total))
                         (pdata-set! pdata-write-name n 
                                     (proc n (pdata-ref pdata-write-name n) 
                                           (pdata-ref pdata-read-name n) ...))
                         (loop (+ n 1) total))))))
       (loop 0 (- (pdata-size) 1))))))

;; StartFunctionDoc-en
;; pdata-fold procedure start-value read-pdata-name ...
;; Returns: result of folding procedure over pdata array
;; Description:
;; A high level control structure for doing calculations on pdata arrays. 
;; Runs the procedure over each pdata element accumulating the result.
;; Should be easier and less error prone than looping manually.
;; Example:  
;; (define my-torus (build-torus 1 2 30 30))
;; 
;; ; find the centre of the primitive by averaging 
;; ; the points position's together
;; (let ((centre 
;;        (with-primitive my-torus
;;                        (vdiv (pdata-fold
;;                               vadd
;;                               (vector 0 0 0)
;;                               "p") (pdata-size)))))
;;   
;;   (display centre)(newline))
;; EndFunctionDoc  	   

;; StartFunctionDoc-pt
;; pdata-fold procedimento valor-inicial nome-pdata-leitura ...
;; Retorna: resultado do procedimento de dobragem sobre a array pdata
;; Descrição:
;; Uma estrutura de controle de alto nível para fazer cálculos em arrays pdata.
;; Roda o procedimento sobre cada elemento pdata acumulando o resultado.
;; Deve ser mais fácil e menos sujeito a erros que percorrer manualmente.
;; Exemplo:
;; (define my-torus (build-torus 1 2 30 30))
;; 
;; ; find the centre of the primitive by averaging 
;; ; the points position's together
;; (let ((centre 
;;        (with-primitive my-torus
;;                        (vdiv (pdata-fold
;;                               vadd
;;                               (vector 0 0 0)
;;                               "p") (pdata-size)))))
;;   
;;   (display centre)(newline))  
;; EndFunctionDoc

(define-syntax pdata-fold
  (syntax-rules ()
    ((_ proc start pdata-read-name ...)
     (letrec
         ((loop (lambda (n total current)
                  (cond ((> n total) current)
                        (else
                         (proc (pdata-ref pdata-read-name n) ...
                               (loop (+ n 1) total current)))))))
       (loop 0 (- (pdata-size) 1) start)))))

;; StartFunctionDoc-en
;; pdata-index-fold procedure start-value read-pdata-name ...
;; Returns: result of folding procedure over pdata array
;; Description:
;; Same as pdata-fold except it passes the index of the current pdata 
;; element as the first parameter of 'procedure'.
;; Example:  
;; (define my-torus (build-torus 1 2 30 30))
;; 
;; ; can't think of a good example for this yet...
;; (let ((something 
;;        (with-primitive my-torus
;;                        (vdiv (pdata-index-fold
;;                               (lambda (index position ret)
;;                                   (vadd ret (vmul position index)))
;;                               (vector 0 0 0)
;;                               "p") (pdata-size)))))
;;   
;;   (display something)(newline))
;; EndFunctionDoc  	   

;; StartFunctionDoc-pt
;; pdata-index-fold procedimento valor-inicial nome-pdata-leitura ...
;; Retorna: resultado do procedimento de dobragem sobre a array pdata
;; Descrição:
;; Igual a pdata-fold exceto que passa o índice do elemento pdata atual 
;; como o primeiro parâmetro de "procedimento".
;; Exemplo:
;; (define my-torus (build-torus 1 2 30 30))
;; 
;; ; can't think of a good example for this yet...
;; (let ((something 
;;        (with-primitive my-torus
;;                        (vdiv (pdata-index-fold
;;                               (lambda (index position ret)
;;                                   (vadd ret (vmul position index)))
;;                               (vector 0 0 0)
;;                               "p") (pdata-size)))))
;;   
;;   (display something)(newline))  
;; EndFunctionDoc

(define-syntax pdata-index-fold
  (syntax-rules ()
    ((_ proc start pdata-read-name ...)
     (letrec
         ((loop (lambda (n total current)
                  (cond ((> n total) current)
                        (else
                         (proc n (pdata-ref pdata-read-name n) ...
                               (loop (+ n 1) total current)))))))
       (loop 0 (- (pdata-size) 1) start)))))

;; shorthand helpers
(define (vx v) (vector-ref v 0))
(define (vy v) (vector-ref v 1))
(define (vz v) (vector-ref v 2))
(define (vw v) (vector-ref v 3))

(define (vr v) (vector-ref v 0))
(define (vg v) (vector-ref v 1))
(define (vb v) (vector-ref v 2))
(define (va v) (vector-ref v 3))

(define (vx-set! v s) (vector-set! v 0 s))
(define (vy-set! v s) (vector-set! v 1 s))
(define (vz-set! v s) (vector-set! v 2 s))
(define (vw-set! v s) (vector-set! v 3 s))

(define (vr-set! v s) (vector-set! v 0 s))
(define (vg-set! v s) (vector-set! v 1 s))
(define (vb-set! v s) (vector-set! v 2 s))
(define (va-set! v s) (vector-set! v 3 s))

; macros for vadd, vsub, mmul, madd, mdiv, msub allowing 
; them to take arbitrary counts of arguments 
				
(define-syntax vadd
	(syntax-rules ()
		((_ a ...)
			(vadd-list (list a ...)))))

(define (vadd-list l)
	(cond
		((eq? (length l) 1) (car l))
		((eq? (length l) 2) (vadd2 (car l) (cadr l)))
		(else (vadd2 (car l) (vadd-list (cdr l))))))

(define-syntax vsub
	(syntax-rules ()
		((_ a ...)
			(vsub-list (list a ...)))))

(define (vsub-list l)
	(cond
		((eq? (length l) 1) (car l))
		((eq? (length l) 2) (vsub2 (car l) (cadr l)))
		(else (vsub2 (car l) (vadd-list (cdr l))))))

(define-syntax mmul
	(syntax-rules ()
		((_ a ...)
			(mmul-list (list a ...)))))

(define (mmul-list l)
	(cond
		((eq? (length l) 1) (car l))
		((eq? (length l) 2) (mmul2 (car l) (cadr l)))
		(else (mmul2 (car l) (mmul-list (cdr l))))))

(define-syntax madd
	(syntax-rules ()
		((_ a ...)
			(madd-list (list a ...)))))

(define (madd-list l)
	(cond
		((eq? (length l) 1) (car l))
		((eq? (length l) 2) (madd2 (car l) (cadr l)))
		(else (madd2 (car l) (madd-list (cdr l))))))
		
(define-syntax msub
	(syntax-rules ()
		((_ a ...)
			(msub-list (list a ...)))))

(define (msub-list l)
	(cond
		((eq? (length l) 1) (car l))
		((eq? (length l) 2) (msub2 (car l) (cadr l)))
		(else (msub2 (car l) (msub-list (cdr l))))))
		
(define-syntax mdiv
	(syntax-rules ()
		((_ a ...)
			(mdiv-list (list a ...)))))

(define (mdiv-list l)
	(cond
		((eq? (length l) 1) (car l))
		((eq? (length l) 2) (mdiv2 (car l) (cadr l)))
		(else (mdiv2 (car l) (mdiv-list (cdr l))))))
		

