groworld/plant-eyes/scripts/ornament-views.ss

;; p l a n t   e y e s  [ copyright (c) 2009 foam vzw : gpl v3 ]

#lang scheme/base
(require scheme/class 
  fluxus-016/fluxus 
  "sound.ss")
  
(provide (all-defined-out))

(define (clamp v l u)
  (if (< v l) l
    (if (> v u) u v)))

(define (property->ornament property pos width dir col)
  (make-object (cond 
	((eq? property 'horn) horn-ornament-view%)
	((eq? property 'inflatoe) inflatoe-ornament-view%)
	((eq? property 'leaf) leaf-ornament-view%)
	((eq? property 'flower) flower-ornament-view%)
	((eq? property 'fork) fork-ornament-view%)
	(else (error "can't find ornament for property " property)))
	pos width dir col))

(define ornament-view%
  (class object%
    (init-field
     (pos (vector 0 0 0))
     (sc 1)
     (dir (vector 0 0 1))
	 (col (vector 1 1 1))
     (time 0)
	 (ev-time 0)
	 (ev-dur 8)
	 (ev-col (vector 0 0 1))
	 (light 0))
    
    (field
     (const-scale 4)
     (rot (vector 0 0 0))
	 (excitation-changed #f)
     (root (build-root))
	  (particles (if (want-particles?)
	  	(let ((p (with-state
	  		(parent root)
			(translate (vector 0 0 1))
			(hint-depth-sort)
            (hint-unlit)
            (blend-mode 'src-alpha 'one)
            (texture (load-texture "textures/particle.png"))
			(build-particles 30))))
			(with-primitive p
				(pdata-add "vel" "v")
				(pdata-map!
					(lambda (vel)
						(vmul (srndvec) 0.01))
					"vel")
				(pdata-map!
					(lambda (s)
						(vmul (vector 1 1 1) (* 0.25 (rndf))))
					"s")
				(pdata-map!
					(lambda (c)
						(vadd ev-col (vmul (rndvec) (* 0.2 (rndf)))))
					"c"))
			p)
		0)))
    
	(define/public (destroy-ornament)
		(destroy root))
	
	(define/pubment (want-particles?) 
		(inner #f want-particles?))

	(define/pubment (above-ground-only?) 
		(inner #f above-ground-only?))

	(define/pubment (below-ground-only?) 
		(inner #f below-ground-only?))

	(define/pubment (centred?) 
		(inner #f centred?))

	(define/pubment (want-morph?) 
		(inner #f want-morph?))
	
	(define/pubment (build-root)
		(inner (build-root) build-root))
	
	(define/public (set-excitations! a b)
		(set! excitation-changed #t)
		(set! light a)
		(set! ev-dur (if (zero? a) 9999 (/ 1 a)))
		(set! ev-col (vmix (vector 0 0 1) (vector 1 0 0) b))
		(set! ev-time (* ev-dur 4 (rndf))))
	
    (define/pubment (update t d)
	  #;(inner (build-root) update)
	  
      (when (< time 1)
        (with-primitive root
                        (identity)
                        (translate pos)
                        (concat (maim dir (vector 0 1 0)))
                        (rotate rot)
						(scale (* const-scale sc 0.2 time))
						(when (not (centred?))
							(translate (vector 0 0 0.8))))
        (set! time (+ time (* 0.05 d))))
		
	  (when (and (want-morph?) excitation-changed)
	  	(printf "morphing~n")
	  	(with-primitive root 
			(pdata-map!
				(lambda (p p1 p2)
				   (vmix p1 p2 (clamp light 0 1)))
				"p" "p1" "p2")))
				
	  (when (want-particles?)
	  	(with-primitive particles 
			(pdata-op "+" "p" "vel")
			(pdata-op "*" "c" 0.995))
	  
	  	(when (< ev-time 0)
			(play-sound "snd/wateringcan.wav" pos (+ 0.1 (rndf)) 0.3)

			#;(with-primitive root
                    (identity)
                    (translate pos)
                    (concat (maim dir (vector 0 1 0)))
                    (rotate rot)
                    (scale (* const-scale sc 0.2 ev-time)))
					
		  ; todo inherit and call event happen or somesuch
		  (when (want-particles?)
		  	(with-primitive particles
		  	(pdata-index-map!		
				(lambda (i p)
					(cond ((zero? (random 2)) p)
						(else
						 (pdata-set! "c" i (vector (+ 0.5 (* 0.5 (rndf))) (+ 0.5 (* 0.5 (rndf))) 1))
						 (vector 0 0 0))))
				"p")))
		  (set! ev-time ev-dur))
	  	(set! ev-time (- ev-time d)))
		
		(set! excitation-changed #f))
    
    (super-new)))

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

(define leaf-ornament-view%
  (class ornament-view%
    (inherit-field col rot)
	(define/augment (centred?) #t)
	(define/augment (above-ground-only?) #t)
    (define/augment (build-root)
               (colour col)                             
               (texture (load-texture "textures/leaf.png"))
               (set! rot (vector 0 0 0))
               (load-primitive "meshes/leaf.obj"))    
    (super-new)))

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

(define horn-ornament-view%
  (class ornament-view%
    (inherit-field rot col)	
	(define/augment (want-particles?) #t)
    (define/augment (build-root)
			   (texture (load-texture "textures/wiggle.png"))
			   (shader "shaders/toon.vert.glsl" "shaders/toon.frag.glsl")
			   (colour col)
               (set! rot (vector (* (rndf) 360) 0 0))
               (load-primitive "meshes/horn.obj"))			 		
    (super-new)))

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

(define inflatoe-ornament-view%
  (class ornament-view%
    (inherit-field rot col)	
	(define/augment (want-morph?) #t)
    (define/augment (build-root)
			   (shader "shaders/toon.vert.glsl" "shaders/textoon.frag.glsl")
			   (texture (load-texture "textures/wiggle.png"))
			   (colour col)
               (set! rot (vector (* (rndf) 360) 0 0))
               (let ((p (load-primitive "meshes/inflatoe-full.obj")))
			     (let ((dp (load-primitive "meshes/inflatoe-empty.obj")))
				   (with-primitive p
				     (pdata-copy "p" "p1")
				     (pdata-add "p2" "v")
					 (pdata-index-map!
					   (lambda (i p2)
					     (with-primitive dp
						   (pdata-ref "p" i)))
					   "p2"))
					(destroy dp))
				  p))				  					
    (super-new)))

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

(define fork-ornament-view%
  (class ornament-view%
    (inherit-field rot col)
    (define/augment (build-root)
			   (texture (load-texture "textures/wiggle.png"))
			   (shader "shaders/toon.vert.glsl" "shaders/textoon.frag.glsl")
               (colour col)                             
               (set! rot (vector (* (rndf) 360) 0 0))
               (load-primitive "meshes/fork.obj"))    
    (super-new)))

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

(define flower-ornament-view%
  (class ornament-view%
    (inherit-field rot col)
	(define/augment (above-ground-only?) #t)
    (define/augment (build-root)
			   (texture (load-texture "textures/wiggle.png"))
			   (shader "shaders/toon.vert.glsl" "shaders/textoon.frag.glsl")
               (colour col)            
               (set! rot (vector (* (rndf) 360) 0 0))
               (load-primitive "meshes/flower.obj"))    
    (super-new)))

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