FoAM/groworld
12
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

added hex ornament, and changed some other stuff?!

Browse source
This commit is contained in:
Dave Griffiths 2009-06-04 14:23:22 +01:00
parent a6076539d9
commit 0869b86c6b
9 changed files with 557 additions and 63 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
danceplant/gro.scm
View file

@ -303,7 +303,7 @@
(clear)
(clear-colour (vector 0 0.3 0.2))
(set-camera-transform (mmul (mtranslate (vector 0 -5 -10))
(mrotate (vector 90 90 180))))
(mrotate (vector 90 -90 180))))
(with-state
(hint-unlit)

2
danceplant/gro2.scm
View file

@ -305,7 +305,7 @@
(clear)
;(clear-colour (vector 0 0.5 0.4))
(set-camera-transform (mmul (mtranslate (vector 0 -5 -10))
(mrotate (vector 90 90 180))))
(mrotate (vector 90 -90 180))))
#;(with-state
(hint-unlit)

9
flatgarden/flatgarden.scm
View file

@ -107,14 +107,17 @@
(string->list string))
obj-list))
(define t 0)
(define (animate obj-list)
(set! t (+ t 0.05))
(let ((c 0))
(for-each
(lambda (objs)
(for-each
(lambda (obj)
(with-primitive obj
(rotate (vector 0 0 (* 0.1 (sin (+ c (time)))))))
(rotate (vector 0 0 (* 0.05 (sin (+ (* c 0.2) (* 4 t)))))))
(set! c (+ c 20)))
objs))
obj-list)))
@ -132,12 +135,12 @@
(colour 1)
(for ((i (in-range 0 5)))
(for ((i (in-range 0 10)))
(let ((t2 (with-state
(translate (vector 0 (* 20 (crndf)) (rndf)))
(build-locator))))
(set! trees (cons (ls-build t2 (ls-generate 3 "F" '(("F" "G-[-F+G+FB]+F[+F-G-FL]-F")))
(+ 10 (random 20)) 0.9) trees))))
(start-framedump "wind" "jpg")
(every-frame (animate trees))

14
hayfever/hayfever2.scm
View file

@ -17,7 +17,7 @@
(define pollen-particles 300)
(define max-pollen-radius 12)
(define suck-pollen-radius 8)
(define deterministic #f)
(define deterministic #t)
(define minimal-mode #f)
(define jid "plant0000003@fo.am")
(define pass "plant0000003")
@ -241,15 +241,21 @@
(when deterministic
(flxseed 3)
(random-seed 11) ; 2 5
(random-seed 1) ; 2 5
)
(let* ((pos (vector (* (crndf) 5) 0 0.1))
(let* ((pos (vector -4 #;(* (crndf) 5) 0 0.1))
(col (hsv->rgb (vector (rndf) 0.8 1)))
(desc (list (make-random-plant 0))))
(set! my-id jid)
(set-entity my-id (make-object plant% pos col desc))))
(set-entity my-id (make-object plant% pos col desc)))
(let* ((pos (vector 4 #;(* (crndf) 5) 0 0.1))
(col (hsv->rgb (vector (rndf) 0.8 1)))
(desc (list (make-random-plant 0))))
(set-entity "other" (make-object plant% pos col desc))))
(define/public (get-entity id)
(foldl

389
hex-ornament/hex-ornament.scm Normal file
View file

@ -0,0 +1,389 @@
(require scheme/class)
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; odds and sods
; return a version of list l with v inserted at the nth
; position and with c as a counter
(define (insert l n v c)
(cond
((null? l) l)
((eq? c n) (cons v (insert (cdr l) n v (+ c 1))))
(else (cons (car l) (insert (cdr l) n v (+ c 1))))))
(define (list-remove l i)
(if (zero? i)
(cdr l)
(cons (car l) (list-remove (cdr l) (- i 1)))))
(define (shuffle l)
(if (null? l)
'()
(let ((i (random (length l))))
(cons (list-ref l i)
(shuffle (list-remove l i))))))
; convert a list of bools into a number, treating the
; list as a binary sequence
(define (bool-list->num l n c)
(cond
((null? l) n)
((car l) (bitwise-ior (arithmetic-shift 1 c)
(bool-list->num (cdr l) n (+ c 1))))
(else (bool-list->num (cdr l) n (+ c 1)))))
; how to find your way around a hexagon
; .
; 5 (NW) / \ 0 (NE)
; / \
; 4 (W)| | 1 (E)
; | |
; \ /
; 3 (SW) \ / 2 (SE)
; `
(define NE 0)
(define E 1)
(define SE 2)
(define SW 3)
(define W 4)
(define NW 5)
(define directions (list NE E SE SW W NW))
(define (rdirection d)
(cond
((eq? d NE) SW)
((eq? d E) W)
((eq? d SE) NW)
((eq? d SW) NE)
((eq? d W) E)
((eq? d NW) SE)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; logic
(define comb-cell%
(class object%
(field
(neighbours '(#f #f #f #f #f #f))
(contents '())
(connections '(#f #f #f #f #f #f))
(visible #f)
(update-me #f))
(define/public (update-me?)
(let ((r update-me))
(set! update-me #f)
r))
(define/public (set-visible! s)
(set! update-me #t)
(set! visible s))
(define/public (visible?)
visible)
(define/public (get-neighbours)
neighbours)
(define/public (get-neighbour d)
(list-ref neighbours d))
(define/public (set-neighbour! d n)
(set! neighbours (insert neighbours d n 0)))
(define/public (get-contents)
contents)
(define/public (get-connections)
connections)
(define/public (no-connections?)
(equal? connections (list #f #f #f #f #f #f)))
(define/public (set-connection! d n)
(set! update-me #t)
(set! visible #t)
(set! connections (insert connections d n 0))
; tell all our neighbours to become visible
(for-each
(lambda (n)
(when n (send n set-visible! #t)))
neighbours))
(define/public (get-connection d)
(list-ref connections d))
(define/public (get-connection-num)
(bool-list->num connections 0 0))
; returns the first attachable neighbour found, and sets it's connection
(define (search/attach-to-neighbour l)
(cond
((null? l) #f)
((not (send (get-neighbour (car l)) no-connections?))
(send (get-neighbour (car l)) set-connection! (rdirection (car l)) #t)
(car l))
(else (search/attach-to-neighbour (cdr l)))))
(define/public (grow)
; only possible to grow when we are a clear cell
(when (equal? connections (list #f #f #f #f #f #f))
(let ((dir (search/attach-to-neighbour (shuffle directions))))
(when dir
; it's dir is false if we have nothing around us to
; connect to, probably shouldn't happen, haven't decided yet
(set-connection! dir #t)))))
(super-new)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define honey-comb%
(class object%
(field
(cells '())
(width 0)
(height 0))
(define/public (get-cell x y)
(list-ref cells (+ (* y height) x)))
(define/public (init w h)
(set! width w)
(set! height h)
; first build the cells
(set! cells (build-list (* w h) (lambda (_) (make-object comb-cell%))))
; then stitch them together like this:
; o o o o o o o o o o o
; o o o o o o o o o o o
; o o o o o o o o o o o
; o o o o o o o o o o o
(for ((x (in-range 0 width)))
(for ((y (in-range 0 height)))
(let ((cell (get-cell x y)))
(when (and (< x (- width 1)) (> y 0))
(send cell set-neighbour! NE (get-cell (if (odd? y) (+ x 1) x) (- y 1))))
(when (< x (- width 1))
(send cell set-neighbour! E (get-cell (+ x 1) y)))
(when (and (< x (- width 1)) (< y (- height 1)))
(send cell set-neighbour! SE (get-cell (if (odd? y) (+ x 1) x) (+ y 1))))
(when (and (> x 0) (> y 0))
(send cell set-neighbour! NW (get-cell (if (odd? y) x (- x 1)) (- y 1))))
(when (> x 0)
(send cell set-neighbour! W (get-cell (- x 1) y)))
(when (and (> x 0) (< y (- height 1)))
(send cell set-neighbour! SW (get-cell (if (odd? y) x (- x 1)) (+ y 1))))))))
(define/public (seed x y)
(send (get-cell x y) set-connection! SE #t)
(send (get-cell x (+ y 1)) set-connection! NW #t)
#;(let ((seed (get-cell x y)))
; set all directions to be connected
(for-each
(lambda (d)
(send seed set-connection! d #t))
directions)
(for-each
(lambda (n d)
(send n set-connection! (rdirection d) #t))
(send seed get-neighbours)
directions)))
(define/public (get-update-list)
(let ((i -1))
(foldl
(lambda (cell r)
(set! i (+ i 1))
(if (send cell update-me?)
(cons (list
(list (modulo i width) (quotient i height))
(send cell get-connection-num)) r)
r))
'()
cells)))
(super-new)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; graphics and interaction
(define (build-ngon n)
(let ((p (build-polygons n 'polygon)))
(with-primitive p
(pdata-index-map!
(lambda (i p)
(let ((a (* (/ i n) (* 2 3.141))))
(vector (cos a) (sin a) 0)))
"p")
(pdata-map!
(lambda (t p)
(let ((p (vtransform p (mmul
(mrotate (vector 0 0 -90))
(mscale (vector -1 1 1))))))
(vsub (vmul p 0.45) (vector 0.5 0.5 0))))
"t" "p")
(pdata-copy "t" "tref")
(pdata-map! (lambda (n) (vector 0 0 1)) "n"))
p))
(define cell-view%
(class object%
(field
(root 0)
(root2 0)
(t 0)
(pos '(0 0))
(owner 0))
(define/public (set-owner! s)
(set! owner s))
(define/public (get-root)
root)
(define/public (get-pos)
pos)
(define/public (set-pos! s)
(set! pos s))
(define (build-prim code)
(let ((p (with-state
;(hint-wire)
(parent owner)
(hint-depth-sort)
(opacity 0)
(colour (vector 0.9 1 0.5))
(hint-unlit)
(when (odd? (cadr pos))
(translate (vector 0.5 0 0)))
(translate (vector (car pos) (* 0.85 (cadr pos)) (* 0.001 (rndf))))
(scale 0.57)
(rotate (vector 0 0 90))
(build-ngon 6))))
(with-primitive p
(update-texture code))
p))
(define/public (build code)
(set! root (build-prim code))
(set! root2 (build-prim code)))
(define (update-texture code)
(texture (load-texture "textures/roots-ornate.png"))
(pdata-map!
(lambda (t tref)
(let ((size (/ 1 8)))
(vadd (vmul tref size) (vector (* 1 size (+ 1 (modulo code 8)))
(* size 1 (+ 1 (quotient code 8))) 0))))
"t" "tref"))
(define/public (new-code code)
(when (not (zero? root2))
(destroy root2)
(with-primitive root (opacity 1)))
(set! root2 (build-prim code))
(set! t 0))
(define/public (update)
(set! t (+ t 0.04))
(when (< t 1)
(with-primitive root
(opacity (- 1 t)))
(with-primitive root2
(opacity t)))
(when (> t 1)
(with-primitive root
(opacity 1))
(when (not (zero? root2))
(destroy root)
(set! root root2)
(set! root2 0))))
(super-new)))
(define honey-comb-view%
(class object%
(field
(root 0)
(cells '())) ; an associative array mapping position to cell-view obs
(define/public (init)
(set! root (build-locator)))
(define (get-pos-from-prim p l)
(cond
((null? l) #f)
((eq? (send (cadr (car l)) get-root) p) (caar l))
(else (get-pos-from-prim p (cdr l)))))
(define/public (deal-with-input)
(if (mouse-button 1)
(get-pos-from-prim (mouse-over) cells)
#f))
(define/public (update update-list)
(for-each
(lambda (cell)
(send (cadr cell) update))
cells)
(for-each
(lambda (item)
(let*
((pos (car item))
(code (cadr item))
(s (assoc pos cells)))
(cond
(s (send (cadr s) new-code code))
(else
(let ((cell (make-object cell-view%)))
(send cell set-pos! pos)
(send cell set-owner! root)
(send cell build code)
(set! cells (cons (list pos cell) cells)))))))
update-list))
(super-new)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(clear)
(clear-colour (vector 0.5 0.2 0.1))
(clear-texture-cache)
(show-axis 0)
(set-camera-transform (mtranslate (vector 0 0 -8)))
(define hc (make-object honey-comb%))
(define hcv (make-object honey-comb-view%))
(send hc init 100 100)
(with-state
(translate (vector -50 -42.5 0))
(send hcv init))
(send hc seed 50 50)
;(send (send hc get-cell 50 52) grow)
;(send (send hc get-cell 49 53) grow)
(define (animate)
(let ((clicked (send hcv deal-with-input)))
(when clicked
(send (send hc get-cell (car clicked) (cadr clicked)) grow)))
(send hcv update (send hc get-update-list)))
(every-frame (animate))

39
hex-ornament/hex.scm Normal file
View file

@ -0,0 +1,39 @@
(define (build-ngon n)
(let ((p (build-polygons n 'polygon)))
(with-primitive p
(pdata-index-map!
(lambda (i p)
(let ((a (* (/ i n) (* 2 3.141))))
(vector (cos a) (sin a) 0)))
"p")
(pdata-map!
(lambda (t p)
(vsub (vmul p 0.5) (vector 0.5 0.5 0)))
"t" "p"))
p))
(define (binarify n)
(pdata-index-map!
(lambda (i p)
(let ((c (arithmetic-shift 1 (inexact->exact i))))
(when (not (zero? (bitwise-and (inexact->exact n) c)))
(let ((pos (vtransform (vmul (vadd p (pdata-ref "p" (+ i 1))) 0.5) (get-transform))))
(with-state
(hint-none)
(hint-wire)
(translate pos)
(scale 0.1)
(build-ngon 10))))
p))
"p"))
(clear)
(for ((i (in-range 0 64)))
(with-primitive (with-state
(translate (vmul (vector (modulo i 8) (quotient i 8) 0) 2))
(hint-none)
(hint-wire)
(hint-unlit)
(build-ngon 6))
(binarify i)))

BIN
hex-ornament/textures/roots-ornate.png Normal file
View file

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 378 KiB

BIN
hex-ornament/textures/roots.png Normal file
View file

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 196 KiB

165
treetris/treetris.scm
View file

@ -265,57 +265,57 @@
; builds objects from a string
(define (ls-build string angle branch-scale branch-col leaf-col)
(with-state
(rotate (vector 0 180 0))
(hint-depth-sort)
(for-each
(lambda (char)
(cond
((char=? #\F char)
(with-state
(translate (vmul (crndvec) 0.01))
(scale (vector 1.2 1 1))
(rotate (vector 0 90 0))
(colour branch-col)
(with-primitive (build-ribbon 2)
; (texture (load-texture "../textures/fade4.png"))
; (hint-unlit)
(pdata-set! "w" 0 0.1)
(pdata-set! "w" 1 0.07)
(pdata-set! "p" 0 (vector 0 0 0.9))
(pdata-set! "p" 1 (vector 0 0 0))))
(translate (vector 1 0 0)))
((char=? #\L char)
(for ((i (in-range 1 2)))
(rotate (vector 0 180 0))
(hint-depth-sort)
(for-each
(lambda (char)
(cond
((char=? #\F char)
(with-state
(translate (vmul (srndvec) 0.3))
(scale (* (rndf) 0.5))
(colour leaf-col)
; (texture (load-texture "../textures/leaf.png"))
(build-sphere 3 3)))
#;(translate (vector 1 0 0)))
((char=? #\f char)
(translate (vector 1 0 0)))
((char=? #\/ char)
(rotate (vector angle 0 0)))
((char=? #\\ char)
(rotate (vector (- angle) 0 0)))
((char=? #\+ char)
(rotate (vector 0 angle 0)))
((char=? #\- char)
(rotate (vector 0 (- angle) 0)))
((char=? #\^ char)
(rotate (vector 0 0 (- angle))))
((char=? #\& char)
(rotate (vector 0 0 angle)))
((char=? #\| char)
(rotate (vector 0 0 180)))
((char=? #\[ char)
(push)
(scale (vector branch-scale branch-scale branch-scale)))
((char=? #\] char)
(pop))))
(string->list string))))
(translate (vmul (crndvec) 0.01))
(scale (vector 1.2 1 1))
(rotate (vector 0 90 0))
(colour branch-col)
(with-primitive (build-ribbon 2)
; (texture (load-texture "../textures/fade4.png"))
; (hint-unlit)
(pdata-set! "w" 0 0.1)
(pdata-set! "w" 1 0.07)
(pdata-set! "p" 0 (vector 0 0 0.9))
(pdata-set! "p" 1 (vector 0 0 0))))
(translate (vector 1 0 0)))
((char=? #\L char)
(for ((i (in-range 1 2)))
(with-state
(translate (vmul (srndvec) 0.3))
(scale (* (rndf) 0.5))
(colour leaf-col)
; (texture (load-texture "../textures/leaf.png"))
(build-sphere 3 3)))
#;(translate (vector 1 0 0)))
((char=? #\f char)
(translate (vector 1 0 0)))
((char=? #\/ char)
(rotate (vector angle 0 0)))
((char=? #\\ char)
(rotate (vector (- angle) 0 0)))
((char=? #\+ char)
(rotate (vector 0 angle 0)))
((char=? #\- char)
(rotate (vector 0 (- angle) 0)))
((char=? #\^ char)
(rotate (vector 0 0 (- angle))))
((char=? #\& char)
(rotate (vector 0 0 angle)))
((char=? #\| char)
(rotate (vector 0 0 180)))
((char=? #\[ char)
(push)
(scale (vector branch-scale branch-scale branch-scale)))
((char=? #\] char)
(pop))))
(string->list string))))
(define (make-plant p n)
(let ((root (build-locator)))
@ -406,15 +406,14 @@
; (hint-origin)
(build-locator)))
(lock-camera camera)
(set-camera-transform (mrotate (vector -90 0 0)))
;(camera-lag 0.5)
(camera-lag 0.5)
(light-diffuse 0 (vector 0 0 0))
(define l (make-light 'point 'free))
(light-diffuse l (vector 1 1 1))
(light-position l (vector 10 50 20))
(for ((i (in-range 1 100)))
(for ((i (in-range 1 30)))
(with-state
(rotate (vector 0 0 (random 360)))
(translate (vector (+ 20 (random 5)) 0 0))
@ -467,4 +466,62 @@
(set! tree (build-tree tree-size))
(particles-explode particles)))))
(every-frame (update))
(define running #f)
(define start-time (time))
(define intro-root (build-locator))
(define splash2
(with-state
(texture (load-texture "textures/gw.png"))
(hint-unlit)
; (colour 0)
(scale (vmul (vector 3 2.25 1) 12.5))
(translate (vector 0 0 0.9))
; (rotate (vector 90 0 0))
(build-plane)))
(define splash
(with-state
(texture (load-texture "textures/foam.png"))
(hint-unlit)
; (colour 0)
(scale (vmul (vector 3 2 1) 14))
(translate (vector 0 0 1))
; (rotate (vector 90 0 0))
(build-plane)))
(set-camera-transform (mtranslate (vector 0 0 -30)))
(define splash-time 8)
(define (animate)
(when (not running)
(when (< (time) (+ start-time (/ splash-time 2)))
(with-primitive splash
(scale 1.001)
(colour (- 1 (/ (- (+ start-time (/ splash-time 2)) (time)) (/ splash-time 2))))))
(when (> (time) (+ start-time (/ splash-time 2)))
(with-primitive splash
(scale 1.001)
(opacity (- 1 (/ (- (time) (+ start-time (/ splash-time 2))) 2)))))
(when (> (time) (+ start-time splash-time))
(with-primitive splash (hide 1)))
(when (or (not (zero? (length (keys-down)))) (not (zero? (length (keys-special-down)))))
(set-camera-transform (mrotate (vector -90 0 0)))
(set! running #t)
(set! next-time (flxtime))
(with-primitive intro-root (hide 1))
(with-primitive splash (hide 1))
(with-primitive splash2 (hide 1))))
(when running (update)))
(every-frame (animate))