275 lines
9.6 KiB
Scheme
275 lines
9.6 KiB
Scheme
(require scheme/class)
|
|
|
|
(define photon-thresh 0.1)
|
|
|
|
(define (contains? a l)
|
|
(cond
|
|
((null? l) #f)
|
|
((eq? (car l) a) #t)
|
|
(else (contains? a (cdr l)))))
|
|
|
|
(define (remove a l)
|
|
(cond
|
|
((null? l) l)
|
|
((eq? (car l) a) (remove a (cdr l)))
|
|
(else (cons (car l) (remove a (cdr l))))))
|
|
|
|
(define input%
|
|
(class object%
|
|
|
|
(field
|
|
(last-mouse (vector 0 0 0))
|
|
(last-button #f)
|
|
(last-keys '())
|
|
(new-keys '())
|
|
(keys-pressed '())
|
|
(selected 0)
|
|
(zoom -50))
|
|
|
|
(define/public (pre-update)
|
|
(when (and (not last-button) (mouse-button 1))
|
|
(set! selected (select (mouse-x) (mouse-y) 2))))
|
|
|
|
(define/public (update)
|
|
(set! last-button (mouse-button 1))
|
|
(set! new-keys (append (keys-down) '() #;(get-special-keys-pressed)))
|
|
(set! keys-pressed (filter
|
|
(lambda (key)
|
|
(not (contains? key last-keys)))
|
|
new-keys))
|
|
(set! last-keys new-keys)
|
|
(when (key-pressed "-") (set! zoom (* zoom 1.1)))
|
|
(when (key-pressed "=") (set! zoom (* zoom 0.9)))
|
|
(set-camera-transform (mtranslate (vector 0 0 zoom))))
|
|
|
|
(define/public (get-keys-pressed)
|
|
keys-pressed)
|
|
|
|
(define/public (get-selected)
|
|
selected)
|
|
|
|
(define/public (mouse-b n)
|
|
(mouse-button n))
|
|
|
|
(define/public (get-pos-from-mouse)
|
|
(let* ((ndcpos (vector (* (- (/ (mouse-x) (vx (get-screen-size))) 0.5) (* -2 zoom))
|
|
(* (- (- (/ (mouse-y) (vy (get-screen-size))) 0.5)) (* -1.5 zoom)) -10))
|
|
(scrpos (vtransform ndcpos (minverse (get-camera-transform)))))
|
|
scrpos))
|
|
|
|
(define/public (get-mouse-change)
|
|
(let ((r (if last-button (vsub (get-pos-from-mouse) last-mouse)
|
|
(vector 0 0 0))))
|
|
(set! last-mouse (get-pos-from-mouse))
|
|
r))
|
|
|
|
(super-new)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define-struct photons (root))
|
|
|
|
(define (build-photons photon-count)
|
|
(with-state
|
|
(hint-depth-sort)
|
|
(texture (load-texture "textures/star.png"))
|
|
(let ((p (build-particles photon-count)))
|
|
(with-primitive p
|
|
(pdata-map!
|
|
(lambda (s)
|
|
(vector 2 2 0))
|
|
"s")
|
|
(pdata-map!
|
|
(lambda (c)
|
|
(vector 1 1 1))
|
|
"c")
|
|
(pdata-map!
|
|
(lambda (p)
|
|
(vector 1 1000 1))
|
|
"p"))
|
|
(make-photons p))))
|
|
|
|
(define (photons-update light)
|
|
(with-primitive (photons-root light)
|
|
(for ((i (in-range 0 30)))
|
|
(let ((p (vector (* (crndf) 30) (* (rndf) 30) 0)))
|
|
(if (> (snoise (* 0.03 (vx p)) (* 0.03 (vy p)) (* 0.1 (time))) photon-thresh)
|
|
(pdata-set! "p" (random (pdata-size)) p)
|
|
(pdata-set! "p" (random (pdata-size)) (vector 0 1000 0)))))))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define-struct resources ((water #:mutable)))
|
|
|
|
(define (build-resources)
|
|
(make-resources (build-list 5 (lambda (_)
|
|
(with-state
|
|
(translate (vmul (vector (crndf) (- (rndf)) 0) 30))
|
|
(translate (vector 0 -10 10))
|
|
(opacity 0.5)
|
|
(scale (vector 10 10 1))
|
|
(colour (vector 0.5 0.5 1))
|
|
(build-sphere 10 10))))))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define-struct cell (root
|
|
wall
|
|
(pos #:mutable)
|
|
radius
|
|
thresh
|
|
(dragging #:mutable)
|
|
(connected #:mutable)
|
|
(energy #:mutable)
|
|
type))
|
|
|
|
(define (build-cell pos radius threshold type)
|
|
(with-state
|
|
(push)
|
|
(hint-unlit)
|
|
(translate pos)
|
|
(scale radius)
|
|
(let ((root (build-sphere 7 7)))
|
|
(pop)
|
|
(parent root)
|
|
(scale threshold)
|
|
(opacity 0.3)
|
|
(if (eq? type 'photo)
|
|
(colour (vector 0 1 0))
|
|
(colour (vector 1 0.5 0)))
|
|
(let ((wall (build-sphere 7 7)))
|
|
(make-cell root wall pos radius threshold #f '() 0 type)))))
|
|
|
|
(define (cell-connect! cell other)
|
|
(set-cell-connected! cell (cons other (cell-connected cell)))
|
|
(set-cell-connected! other (cons cell (cell-connected other))))
|
|
|
|
(define (cell-disconnect cell other)
|
|
(set-cell-connected! cell (remove other (cell-connected cell)))
|
|
(set-cell-connected! other (remove cell (cell-connected other))))
|
|
|
|
(define (choose l)
|
|
(list-ref l (random (length l))))
|
|
|
|
(define (cell-divide cell organism)
|
|
(let ((new-cell (build-cell
|
|
(vadd (cell-pos cell) (vmul (srndvec) 3))
|
|
(cell-radius cell) (cell-thresh cell)
|
|
(choose '(photo struct struct struct absorb)))))
|
|
(cell-connect! cell new-cell)
|
|
(set-organism-cells! organism (cons new-cell
|
|
(organism-cells organism)))))
|
|
|
|
(define (cell-update cell input organism photons)
|
|
|
|
(with-primitive (cell-wall cell)
|
|
(if (null? (cell-connected cell))
|
|
(hide 1)
|
|
(hide 0)))
|
|
|
|
(with-primitive (cell-root cell)
|
|
(cond ((eq? (cell-type cell) 'photo)
|
|
(colour (vmul (vector 0.5 1 0.5) (+ 0.5 (cell-energy cell)))))
|
|
((eq? (cell-type cell) 'struct)
|
|
(colour (vmul (vector 1 0.7 0.3) (+ 0.5 (cell-energy cell)))))
|
|
((eq? (cell-type cell) 'absorb)
|
|
(when (> (cell-energy cell) 1)
|
|
(set-cell-energy! cell 0)
|
|
(cell-divide cell organism))
|
|
(colour (vmul (vector 0.5 0.5 1) (+ 0.5 (cell-energy cell))))))
|
|
|
|
|
|
(when (or (eq? (send input get-selected) (cell-wall cell))
|
|
(eq? (send input get-selected) (cell-root cell)))
|
|
(translate (send input get-mouse-change))
|
|
(for-each
|
|
(lambda (other)
|
|
(when (and (not (eq? cell other))
|
|
(not (contains? other (cell-connected cell))))
|
|
|
|
(let ((dist (vdist (cell-pos cell) (cell-pos other))))
|
|
(when (< dist (+ (cell-thresh cell) (cell-thresh other)))
|
|
(cell-connect! other cell)))))
|
|
(organism-cells organism)))
|
|
|
|
|
|
(let ((dir (foldl
|
|
(lambda (other cur)
|
|
(let ((dist (vdist (cell-pos cell) (cell-pos other))))
|
|
(cond
|
|
; inside nucleus
|
|
((< dist (+ (cell-radius cell) (cell-radius other)))
|
|
(vadd cur (vmul (vsub (cell-pos cell) (cell-pos other)) (* 0.1 (/ 1 dist)))))
|
|
((< dist (+ (cell-thresh cell) (cell-thresh other)))
|
|
(vadd cur (vmul (vsub (cell-pos cell) (cell-pos other)) -0.01)))
|
|
(else
|
|
(cell-disconnect cell other)
|
|
cur))))
|
|
(vector 0 0 0)
|
|
(cell-connected cell))))
|
|
(when (eq? (cell-type cell) 'photo)
|
|
(translate (vector (vx dir) (vy dir) 0))))
|
|
|
|
(when (and (eq? (cell-type cell) 'photo)
|
|
(not (null? (cell-connected cell))))
|
|
(with-primitive (photons-root photons)
|
|
(set-cell-energy! cell
|
|
(+ (pdata-fold
|
|
(lambda (p v)
|
|
(if (< (vdist (cell-pos cell) p) (cell-radius cell))
|
|
(+ 0.2 v)
|
|
v))
|
|
0 "p") (cell-energy cell)))))
|
|
|
|
(when (zero? (random 10))
|
|
(for-each
|
|
(lambda (other)
|
|
(when (> (cell-energy other) 0.1)
|
|
(set-cell-energy! cell (+ (cell-energy cell) (* (cell-energy other) 0.49)))
|
|
(set-cell-energy! other (* (cell-energy other) 0.49))))
|
|
(cell-connected cell)))
|
|
|
|
(set-cell-pos! cell (vtransform (vector 0 0 0) (get-transform)))))
|
|
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define-struct organism ((cells #:mutable)))
|
|
|
|
(define (build-organism count)
|
|
(make-organism
|
|
(build-list count
|
|
(lambda (_)
|
|
(build-cell (vmul (vector (crndf) (crndf) 0) 5) 1 2
|
|
(choose '(struct struct struct photo absorb)))))))
|
|
|
|
(define (organism-update organism input photons)
|
|
(for-each
|
|
(lambda (cell)
|
|
(cell-update cell input organism photons))
|
|
(organism-cells organism)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
|
|
(clear)
|
|
(clear-colour (vector 0.2 0.1 0.1))
|
|
(define organism (build-organism 10))
|
|
(define photons (build-photons 40))
|
|
(define input (make-object input%))
|
|
(define resources (build-resources))
|
|
|
|
(define sky (with-state
|
|
(colour (vector 0.3 0.5 0.2))
|
|
(translate (vector 0 30 -10))
|
|
(scale (vector 150 60 0))
|
|
(build-plane)))
|
|
|
|
(define (update)
|
|
(send input pre-update)
|
|
(organism-update organism input photons)
|
|
(photons-update photons)
|
|
(send input update))
|
|
|
|
(every-frame (update))
|