#lang scheme/base (require scheme/class fluxus-016/fluxus "message.ss" "list-utils.ss") (provide (all-defined-out)) ; the fluxus code to make things look the way they do (define debug-messages #t) ; prints out all the messages sent to the renderer (define audio-on #f) (define (ornament-colour) (vector 0.5 1 0.4)) (define (pickup-colour) (vector 1 1 1)) (define (earth-colour) (vector 0.2 0.1 0)) (define (stones-colour) (vmul (earth-colour) (+ 0.5 (* (rndf) 0.5)))) (define wire-mode #f) (define fog-col (earth-colour)) (define fog-strength 0.001) (define max-ornaments 30) ; per twig (define default-grow-speed 0.5) (when audio-on (oa-start)) ;; start openAL audio ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (define ornament-view% (class object% (init-field (pos (vector 0 0 0)) (sc 1) (dir (vector 0 0 1)) (property 'none) (time 0)) (field (const-scale 2) (rot (vector 0 0 0)) (root (with-state (translate pos) (concat (maim dir (vector 0 1 0))) (scale (* const-scale sc)) ;(shader "shaders/textoon.vert.glsl" "shaders/textoon.frag.glsl") (cond ((eq? property 'wiggle) ; (opacity 1) (hint-depth-sort) (colour (vector 0.5 0.0 0.0)) (load-primitive "meshes/wiggle.obj")) ((eq? property 'leaf) (colour (vector 0.8 1 0.6)) (texture (load-texture "textures/leaf.png")) (set! rot (vector 0 0 0)) (hint-origin) (load-primitive "meshes/leaf.obj")) (else (error "")))))) (define/public (update t d) (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))) (set! time (+ time (* 0.1 d))))) (super-new))) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (define pickup-view% (class object% (init-field (id -1) (type 'none) (pos (vector 0 0 0))) (field (rot (vmul (rndvec) 360)) (root (with-state (translate pos) (rotate rot) (colour (pickup-colour)) (scale 0.3) ;(shader "shaders/textoon.vert.glsl" "shaders/textoon.frag.glsl") (texture (cond ((eq? type 'wiggle) (load-texture "textures/wiggle.png")) ((eq? type 'leaf) (load-texture "textures/leaf.png")) ((eq? type 'curly) (load-texture "textures/curl.png")))) (cond ((eq? type 'wiggle) (load-primitive "meshes/pickup.obj")) ((eq? type 'leaf) (load-primitive "meshes/leaf.obj")) ((eq? type 'curly) (load-primitive "meshes/pickup.obj"))))) (from pos) (destination (vector 0 0 0)) (speed 0.05) (t -1)) (define/public (pick-up) (destroy root)) (define/public (move-to s) (set! t 0) (set! from pos) (set! destination s)) (define/public (update t d) (with-primitive root (rotate (vector (* d 10) 0 0))) #;(when (and (>= t 0) (< t 1)) (set! pos (vadd pos (vmul (vsub destination from) speed))) (with-primitive root (identity) (translate pos) (rotate rot)) (set! t (+ t speed)))) (super-new))) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (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 '()) (grow-t 999) (marker-destroy-t 0) (grow-speed default-grow-speed)) (define/public (get-id) id) (define/public (get-dir) dir) (define/public (set-col! s) (set! col s)) (define/public (set-tex! s) (set! tex s)) (define/public (build) 0) (define/public (get-num-points) index) (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 (start-growing) (set! grow-t 0) (set! markers (cons (build-locator) markers))) (define/pubment (add-point point width) (when audio-on (let ((growing-noise (oa-load-sample (fullpath "snd/event01.wav")))) (oa-play growing-noise (vector 0 0 0) (rndf) 0.3))) (set! markers (append markers (list (with-state (parent (get-root)) (translate point) (scale 0.2) (shader "shaders/toon.vert.glsl" "shaders/toon.frag.glsl") (colour col) (build-sphere 10 10))))) (inner (void) add-point point width)) (define/public (add-ornament point-index property) (when (< (length ornaments) max-ornaments) (with-state (parent (get-root)) ; todo - different ornament-view objects per property needed? ; todo - delete existing ornaments here (set! ornaments (cons (list point-index (make-object ornament-view% (get-point point-index) (get-width point-index) (vnormalise (vsub (get-point point-index) (get-point (- point-index 1)))) property)) ornaments))))) (define/pubment (update t d) (for-each (lambda (ornament) (send (cadr ornament) update t d)) ornaments) (inner (void) update t d) (when (< grow-t num-points) (set! grow-t (+ grow-t (* d grow-speed))) (when (> 0 (- marker-destroy-t grow-t)) ; soundtodo: marker gobble (set! marker-destroy-t (+ 1 marker-destroy-t)) (destroy (car markers)) (set! markers (cdr markers))))) (super-new))) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (define ribbon-twig-view% (class twig-view% (inherit-field pos radius num-points index col tex) (field (root 0)) (define/override (build) (set! root (let ((p (with-state (translate pos) (colour col) (texture (load-texture tex)) (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/augment (add-point point width) (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") (pdata-index-map! ; do a similar thing with the width (lambda (i w) (if (< i (+ index 1)) w width)) "w")) (set! index (+ index 1))) (define/augment (update t d) 0) (super-new))) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (define extruded-twig-view% (class twig-view% (inherit-field index radius num-points pos dir col tex grow-t) (field (profile '()) (path '()) (root 0) (widths '())) (define/override (build) (set! profile (build-circle-profile 12 1)) (set! path (build-list num-points (lambda (_) (vector 0 0 0)))) (set! widths (build-list num-points (lambda (_) 1))) (set! root (let ((p (with-state (backfacecull 0) (when wire-mode (hint-none) (hint-wire)) (shader "shaders/toon.vert.glsl" "shaders/toon.frag.glsl") (texture (load-texture tex)) (opacity 0.6) (colour col) #;(colour (vector 1 1 1)) #;(texture (load-texture "textures/root.png")) (build-partial-extrusion profile path 3)))) p))) (define/override (get-root) root) (define/override (get-point point-index) (list-ref path point-index)) (define/override (get-width point-index) (list-ref widths point-index)) (define (list-set l c s) (cond ((null? l) '()) ((zero? c) (cons s (list-set (cdr l) (- c 1) s))) (else (cons (car l) (list-set (cdr l) (- c 1) s))))) (define/augment (add-point point width) (set! path (list-set path index point)) (set! widths (list-set widths index width)) (set! index (+ index 1))) (define/augment (update t d) (when (< grow-t (length path)) (with-primitive root (partial-extrude grow-t profile path widths (vector 1 0 0) 0.05)))) (define/public (get-end-pos) (list-ref path (if (zero? index) 0 (- index 1))) #;(with-primitive root (pdata-ref "p" (- (* index (length profile)) 1)))) (super-new))) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (define plant-view% (class object% (init-field (id "none") (pos (vector 0 0 0)) (size 0) (col (vector 1 1 1)) (tex "ooo")) (field (twigs '()) ; a assoc list map between ids and twigs stored flat here, ; for fast access, but prims heirachically in the scenegraph (root (with-state (translate pos) (build-locator))) (seed (with-state (parent root) (shader "shaders/toon.vert.glsl" "shaders/toon.frag.glsl") (texture (load-texture tex)) (backfacecull 0) (opacity 0.6) (colour col) (hint-depth-sort) (scale (* 0.12 size)) (when wire-mode (hint-none) (hint-wire)) ;(hint-unlit) (load-primitive "meshes/seed.obj"))) (nutrients (let ((p (with-state (hint-depth-sort) (hint-unlit) (parent root) (blend-mode 'src-alpha 'one) (texture (load-texture "textures/star.png")) (build-particles 100)))) (with-primitive p (pdata-add "twig" "f") (pdata-add "point" "f") (pdata-add "offset" "v") (pdata-add "speed" "f") (pdata-map! (lambda (point) 0) "point") (pdata-map! (lambda (point) (* 3 (+ 0.1 (rndf)))) "speed") (pdata-map! (lambda (offset) (vector 0 0 0)) "offset") (pdata-map! (lambda (c) (vector 0 (rndf) (rndf))) "c") (pdata-map! (lambda (p) (vmul (vadd (crndvec) (vector 0 -1 0)) 900)) "p") (pdata-map! (lambda (s) (vmul (vector 1 1 1) (+ 0.1 (rndf)))) "s")) p))) (define/public (get-id) id) (define/public (get-col) col) (define/public (get-twig twig-id) (let ((l (assq twig-id twigs))) (if l (cadr (assq twig-id twigs)) #f))) (define/public (destroy-branch-twig twig-id) (for-each (lambda (twig-id) (destroy-branch-twig twig-id)) (send (get-twig twig-id) get-child-twig-ids)) (send (get-twig twig-id) destroy-twig) (set! twigs (assoc-remove twig-id twigs))) (define/public (destroy-plant) (destroy root) (for-each (lambda (twig) (destroy-branch-twig (car twig))) twigs)) (define/public (add-twig parent-twig-id point-index twig) (let ((ptwig (get-twig parent-twig-id))) (when ptwig (send twig set-pos! (send ptwig get-point point-index)) ; attach to parent twig ; tell the twigs about this relationship (might turn out to be overkill) (send ptwig add-child-twig-id (send twig get-id)) (send twig set-parent-twig-id parent-twig-id)) (send twig set-col! col) (send twig set-tex! tex) (send twig build) (with-primitive (send twig get-root) (parent root)) (set! twigs (cons (list (send twig get-id) twig) twigs)))) (define/public (add-twig-point twig-id point width) (send (get-twig twig-id) add-point point width)) (define/public (start-twig-growing twig-id) (send (get-twig twig-id) start-growing)) (define/public (grow-seed amount) (with-primitive seed (scale amount))) (define/public (add-ornament twig-id point-index property) (send (get-twig twig-id) add-ornament point-index property)) (define/public (update-nutrients t d) (when (not (null? twigs)) (with-primitive nutrients (pdata-index-map! (lambda (i p twig-id point offset speed) (let* ((twig-id (inexact->exact twig-id)) (twig (get-twig twig-id)) (point (inexact->exact point))) (cond ((or (< point 1) (not twig)) (let* ((new-twig (choose twigs)) (num-points (send (cadr new-twig) get-num-points)) (new-point (if (zero? num-points) 0 (random num-points)))) (pdata-set! "twig" i (car new-twig)) (pdata-set! "point" i new-point) (pdata-set! "offset" i (vmix offset (vmul (srndvec) (send (cadr new-twig) get-width new-point)) 0.2)) (send (cadr new-twig) get-point new-point))) ((< (vdist (vadd (send twig get-point point) offset) p) 0.1) (pdata-set! "point" i (- point 1)) (vadd p (vmul (vnormalise (vsub (vadd (send twig get-point (- point 1)) offset) p)) (* speed d)))) (else (vadd p (vmul (vnormalise (vsub (vadd (send twig get-point point) offset) p)) (* speed d))))))) "p" "twig" "point" "offset" "speed")))) (define/public (update t d) (update-nutrients t d) (with-primitive seed (scale (+ 1 (* 0.001 (sin (* 2 t)))))) (for-each (lambda (twig) (send (cadr twig) update t d)) twigs)) (super-new))) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (define (build-env-box top bottom left right front back lower) (let ((p (build-locator))) (with-state (parent p) (hint-unlit) (list (let ((t (with-state (texture (load-texture top)) (translate (vector 0 0.5 0)) (rotate (vector 90 0 0)) (build-plane)))) (when lower (with-primitive t (pdata-map! (lambda (t) (vmul t 10)) "t")) ) t) (with-state (texture (load-texture left)) (translate (vector 0 0 -0.5)) (rotate (vector 0 0 0)) (build-plane)) (with-state (texture (load-texture back)) (translate (vector 0.5 0 0)) (rotate (vector 0 90 0)) (build-plane)) (with-state (texture (load-texture right)) (translate (vector 0 0 0.5)) (rotate (vector 0 0 0)) (build-plane)) (with-state (texture (load-texture front)) (translate (vector -0.5 0 0)) (rotate (vector 0 90 0)) (build-plane)) (if lower (with-state (texture (load-texture bottom)) (translate (vector 0 -0.5 0)) (rotate (vector 90 0 0)) (build-plane)) 0))))) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (define game-view% (class object% (field (plants '()) ; map of ids -> plants (pickups '()) ; map of ids -> pickups (camera-dist 1) (env-root (with-state (scale 1000) (build-locator))) (root-camera-t 0) #;(upper-env (with-state (parent env-root) (hint-depth-sort) (colour 2) (translate (vector 0 0.28 0)) (build-env-box "textures/top.png" "textures/bottom-trans.png" "textures/left.png" "textures/right.png" "textures/front.png" "textures/back.png"))) #;(lower-env (with-state (parent env-root) (hint-depth-sort) (translate (vector 0 -0.22001 0)) (build-env-box "textures/bottom-trans.png" "textures/bottom.png" "textures/sleft.png" "textures/sright.png" "textures/sfront.png" "textures/sback.png"))) (upper-env (with-state (parent env-root) ;(hint-depth-sort) (hint-unlit) (translate (vector 0 0.28 0)) (build-env-box "textures/sky-top.png" "textures/floor.png" "textures/sky-side.png" "textures/sky-side.png" "textures/sky-side.png" "textures/sky-side.png" #f))) (lower-env (with-state (parent env-root) ;(hint-depth-sort) (hint-unlit) (colour (earth-colour)) (translate (vector 0 -0.22001 0)) (build-env-box "textures/floor.png" "textures/earth-bottom.png" "textures/earth-side.png" "textures/earth-side.png" "textures/earth-side.png" "textures/earth-side.png" #t))) (stones '())) (define/public (setup world-list) (let ((l (make-light 'point 'free))) (light-diffuse 0 (vector 0.5 0.5 0.5)) (light-diffuse l (vector 1 1 1)) (light-position l (vector 10 50 -4))) (clear-colour fog-col) (clip 0.5 10000) (fog fog-col fog-strength 1 100) (set! stones (map (lambda (stone) (let ((p (with-state (hint-frustum-cull) (shader "shaders/toon.vert.glsl" "shaders/toon.frag.glsl") (colour (stones-colour)) (translate (list-ref stone 1)) (scale (list-ref stone 2)) (rotate (list-ref stone 3)) (texture (load-texture "textures/quartz.png")) (load-primitive (list-ref stone 0))))) (with-primitive p (apply-transform) (recalc-bb)) ; apply the transform to speed up the ray tracing, don't have to tranform the ray into object space p)) (list-ref world-list 2)))) (define/public (get-stones) stones) (define/public (add-plant plant) (printf "ADD-PLANT~n") ;(destroy-plant (send plant get-id)) ; just in case (set! plants (cons (list (send plant get-id) plant) plants))) (define/public (get-plant plant-id) (let ((p (assoc plant-id plants))) (if (not p) #f (cadr p)))) (define/public (destroy-plant plant-id) (let ((p (get-plant plant-id))) (when p (send p destroy-plant) (set! plants (assoc-remove plant-id plants))))) (define/public (destroy-branch-twig plant-id twig-id) (send (get-plant plant-id) destroy-branch-twig twig-id)) (define/public (add-twig plant-id parent-twig-id point-index twig) (send (get-plant plant-id) add-twig parent-twig-id point-index twig)) (define/public (grow-seed plant-id amount) (send (get-plant plant-id) grow-seed amount)) (define/public (get-pickup pickup-id) (cadr (assq pickup-id pickups))) (define/public (add-pickup pickup-id type pos) (set! pickups (cons (list pickup-id (make-object pickup-view% pickup-id type pos)) pickups))) (define/public (pick-up-pickup pickup-id) (send (get-pickup pickup-id) pick-up) (set! pickups (assoc-remove pickup-id pickups))) (define/public (add-ornament plant-id twig-id point-index property) (send (get-plant plant-id) add-ornament twig-id point-index property)) (define/public (update t d messages) (for-each (lambda (plant) (send (cadr plant) update t d)) plants) (for-each (lambda (pickup) (send (cadr pickup) update t d)) pickups) (when debug-messages (for-each (lambda (msg) (send msg print)) messages)) (for-each (lambda (msg) (cond ((eq? (send msg get-name) 'player-plant) ; not really any difference now (add-plant (make-object plant-view% (send msg get-data 'plant-id) (send msg get-data 'pos) (send msg get-data 'size) (send msg get-data 'col) (send msg get-data 'tex)))) ((eq? (send msg get-name) 'new-plant) (printf "adding new plant to view ~a~n" (send msg get-data 'plant-id)) (add-plant (make-object plant-view% (send msg get-data 'plant-id) (send msg get-data 'pos) (send msg get-data 'size) (send msg get-data 'col) (send msg get-data 'tex)))) ((eq? (send msg get-name) 'grow-seed) (grow-seed (send msg get-data 'plant-id) (send msg get-data 'amount))) ((eq? (send msg get-name) 'destroy-branch-twig) (destroy-branch-twig (send msg get-data 'plant-id) (send msg get-data 'twig-id))) ((eq? (send msg get-name) 'new-twig) (add-twig (send msg get-data 'plant-id) (send msg get-data 'parent-twig-id) (send msg get-data 'point-index) (cond ((eq? (send msg get-data 'render-type) 'ribbon) (make-object ribbon-twig-view% (send msg get-data 'twig-id) (vector 0 0 0) ; will be filled in by add-twig (send msg get-data 'type) (send msg get-data 'dir) (send msg get-data 'width) (send msg get-data 'num-points))) ((eq? (send msg get-data 'render-type) 'extruded) (make-object extruded-twig-view% (send msg get-data 'twig-id) (vector 0 0 0) ; will be filled in by add-twig (send msg get-data 'type) (send msg get-data 'dir) (send msg get-data 'width) (send msg get-data 'num-points)))))) ((eq? (send msg get-name) 'add-twig-point) (send (get-plant (send msg get-data 'plant-id)) add-twig-point (send msg get-data 'twig-id) (send msg get-data 'point) (send msg get-data 'width))) ((eq? (send msg get-name) 'start-growing) (send (get-plant (send msg get-data 'plant-id)) start-twig-growing (send msg get-data 'twig-id))) ((eq? (send msg get-name) 'new-pickup) (add-pickup (send msg get-data 'pickup-id) (send msg get-data 'type) (send msg get-data 'pos))) ((eq? (send msg get-name) 'pick-up-pickup) (pick-up-pickup (send msg get-data 'pickup-id))) ((eq? (send msg get-name) 'pick-up-pickup) (pick-up-pickup (send msg get-data 'pickup-id))) ((eq? (send msg get-name) 'light-level) (for-each (lambda (p) (with-primitive p (colour (send msg get-data 'amount)))) upper-env)) )) messages)) (super-new)))