(require scheme/class)
(require "sound.ss")
(define default-grow-speed 4)
(define grow-overshoot 10)

(define (fract n)
    (- n (floor n)))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(define twig-view%
    (class object%
        (init-field
            (id 0)
            (pos (vector 0 0 0))
            (type 'none)
            (dir (vector 0 1 0))
            (radius 1)
            (num-points 0)) 
        
        (field
            (index 0)
            (parent-twig-id -1)
            (child-twig-ids '())
            (ornaments '())
            (col (vector 1 1 1))
            (tex "")
            (markers '())
            (shrink-t 0)
            (grow-t -1)
            (marker-destroy-t 0)
            (grow-speed default-grow-speed)
            (delme #f))
        
        (define/public (get-id) id)        
        (define/public (delme?) delme)        
        (define/public (get-dir) dir)        
        (define/public (set-dir! s) (set! dir s))        
        (define/public (set-col! s) (set! col s))        
        (define/public (set-tex! s) (set! tex s))
        (define/public (get-pos) pos)
        (define/public (build) 0)        
        (define/public (get-num-points) index)
        (define/public (get-grow-t) grow-t)      
        (define/public (set-pos! s) (set! pos s))
        (define/public (get-child-twig-ids) child-twig-ids)
        (define/public (get-root) (error "need to overide this"))        
        (define/public (destroy-twig) (destroy (get-root)))
        (define/public (set-parent-twig-id s) (set! parent-twig-id s))
        (define/public (get-point point-index) (error "need to overide this"))        
        (define/public (get-width point-index) (error "need to overide this"))
        
        (define/public (add-child-twig-id twig-id)
            (set! child-twig-ids (cons twig-id child-twig-ids)))
        
        (define/public (growing?)
            (< grow-t (+ num-points grow-overshoot)))
        
        (define/public (start-growing)
            (set! grow-t 0)
            (set! markers (cons (build-locator) markers)))
        
        (define/public (start-shrinking)
            (set! shrink-t (if (growing?) grow-t (+ num-points grow-overshoot))))
        
        (define/pubment (add-point point width make-marker)
            (play-sound "snd/event01.wav" point (+ 0.1 (rndf)) 0.3) 
            (when make-marker
                (set! markers (append markers (list (with-state
                                (parent (get-root))
                                (translate point)
                                (scale 0.1)
                                (shader "shaders/toon.vert.glsl" "shaders/toon.frag.glsl")
                                (colour col)
                                (build-sphere 8 8))))))
            
            (inner (void) add-point point width make-marker))
        
        (define/public (add-ornament point-index property)          
            (when (< point-index grow-t)
                (play-sound "snd/nix.00203.wav" (get-point point-index) (+ 0.1 (rndf)) 0.3)
                (with-state
                    (parent (get-root))
                    (let ((ornament (property->ornament property
                                    (get-point point-index)
                                    (get-width point-index)
                                    (vnormalise (vsub (get-point point-index) (get-point (- point-index 1))))
                                    col)))
                        ; check above ground
                        (let ((pos (with-primitive (get-root) (vtransform (vector 0 0 0) (get-global-transform)))))
                            (if (not (and (send ornament above-ground-only?) 
                                        (< (vy (vadd pos (get-point point-index))) 1)))
                                ; todo - delete existing ornaments here
                                (set! ornaments (cons (list point-index ornament) ornaments))
                                (send ornament destroy-ornament)))))))
        
        (define/pubment (set-excitations! a b)
            (for-each
                (lambda (ornament)
                    (send (cadr ornament) set-excitations! a b))
                ornaments))
        
        (define/pubment (update t d)        
            (for-each
                (lambda (ornament)
                    (send (cadr ornament) update t d))
                ornaments)
            
            (when (> shrink-t 0) 
                (set! shrink-t (- shrink-t (* d grow-speed))))
            
            (when (< shrink-t 0)
                (set! delme #t))
            
            (inner (void) update t d)
            
            (when (and (not (eq? grow-t -1)) (< grow-t (+ num-points grow-overshoot)))
                (set! grow-t (+ grow-t (* d grow-speed)))
                (when (and (not (null? markers)) (> 0 (- marker-destroy-t grow-t)))
                    ; soundtodo: marker gobble
                    (set! marker-destroy-t (+ 1 marker-destroy-t))
                    (destroy (car markers))
                    (set! markers (cdr markers))))
            
            (when (> grow-t (+ num-points 10)) 
                (set! grow-t 999)))
        
        (super-new)))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(define ribbon-twig-view%
    (class twig-view%
        
        (inherit-field pos radius num-points index col tex grow-t)
        
        (field
            (root 0)
            (widths '())
            (points '())
            (global-growth 0)
            (global-growth-time 10))
        
        (define/override (build)
            (set! root (let ((p (with-state
                                (translate pos)
                                (colour col)
                                (hint-unlit)
                                (texture (load-texture "textures/ribbon-twig.png")) 
                                (build-ribbon num-points))))
                    (with-primitive p
                        (pdata-map! 
                            (lambda (w)
                                0)
                            "w")
                        (pdata-set! "w" 0 radius))
                    p)))
        
        
        (define/override (get-root)
            root)
        
        #;(define/override (get-point point-index)
            (with-primitive root
                (pdata-ref "p" point-index)))
        
        #;(define/override (get-width point-index)
            (with-primitive root
                (pdata-ref "w" point-index)))
        
        (define/override (get-point point-index)
            (list-ref points point-index))
        
        (define/override (get-width point-index)
            (list-ref widths point-index))
        
        (define/augment (add-point point width make-marker)
            #;(with-primitive root
                (pdata-index-map! ; set all the remaining points to the end
                    (lambda (i p)    ; in order to hide them
                        (if (< i index)
                            p
                            point))
                    "p"))
            (set! widths (append widths (list width)))
            (set! points (append points (list point)))
            (set! index (+ index 1)))
        
        (define/augment (update t d)
            (when (and (> grow-t 0) (< grow-t (+ (length points) 10)))
                (with-primitive root
                    (pdata-index-map!
                        (lambda (i w)    
                            (* (/ global-growth global-growth-time)
                                (cond ((< i (- grow-t 1))
                                        (list-ref widths i))
                                    ((< i grow-t)
                                        (* (list-ref widths i) (fract grow-t)))
                                    (else
                                        0))))
                        "w")
                    
                    (pdata-index-map!
                        (lambda (i p)    
                            (cond ((< i (- grow-t 1))
                                    (list-ref points i))
                                ((equal? i (inexact->exact (floor (+ grow-t 1))))
                                    (vmix 
                                        (list-ref points i)
                                        (list-ref points (- i 1)) (fract grow-t)))
                                (else
                                    (list-ref points i))))
                        "p")))
            
            (when (< global-growth global-growth-time)
                (set! global-growth (+ global-growth d))))
        
        (super-new)))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

; bunches of ribbon twigs 
(define twiglets%
    (class object%
        (init-field
            (par 0))
        
        (field
            (twigs '()))
        
        (define/public (build pos dir width length)
            (set! twigs (list (build-tree pos dir width length))))
        
        (define (build-tree pos dir width length)
            (let   ((t (make-object ribbon-twig-view% 0 pos 'ribbon 
                            dir 
                            (* width (+ 0.5 (rndf))) length)))
                (with-state
                    (parent par)
                    (send t build))
                (let ((m (mrotate (vmul (srndvec) 45)))
                        (ppos (vector 0 0 0)))
                    (for ((i (in-range 0 length)))
                        (let ((dir (vtransform (send t get-dir) m))
                                (width (if (eq? i (- length 1)) 0 (/ width (+ i 1)))))
                            (send t set-dir! dir)
                            (send t add-point ppos width #f)
                            (set! ppos (vadd ppos (vmul dir (* 5 width)))))))
                (send t start-growing)
                t))
        
        
        
        (define/public (update t d)
            (for-each 
                (lambda (twig)
                    (send twig update t d)
                    (when (and 
                            (< (length twigs) 50)
                            (> (send twig get-num-points) 2) 
                            (zero? (random 20)))
                        (let ((pi (inexact->exact (floor (send twig get-grow-t)))))
                            (when (< pi (send twig get-num-points))
                                (set! twigs (cons 
                                        (build-tree 
                                            (vadd (send twig get-pos) (send twig get-point pi)) 
                                            (send twig get-dir)
                                            (/ (send twig get-width pi) 1.4) 
                                            (/ (send twig get-num-points) 2))
                                        twigs))))))
                twigs))
        
        (super-new)))


(clear)
(clear-colour 0.5)
(define l (with-state 
        (build-locator)))


(define r '())

(let ((t (make-object twiglets% l)))
    (send t build (vector 0 0 0) (vector 0 1 0) 2 20)
    (set! r (cons t r)))

(every-frame 
    (begin
        (when (key-pressed " ")
            (let ((t (make-object twiglets% l)))
                (send t build (vector 0 0 0) (vector 0 1 0) 2 20)
                (set! r (cons t r))))
        (for-each
            (lambda (t)
                (send t update (time) 0.02))
            r))) 

;(start-framedump "ribbon-test-" "jpg")