128 lines
4.3 KiB
Scheme
128 lines
4.3 KiB
Scheme
(require scheme/class)
|
|
|
|
(define input%
|
|
(class object%
|
|
|
|
(field
|
|
(last-mouse (vector 0 0 0))
|
|
(last-button #f)
|
|
(last-keys '())
|
|
(new-keys '())
|
|
(keys-pressed '())
|
|
(selected 0)
|
|
(zoom -20))
|
|
|
|
(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 (bricks-in-list 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 cell (root wall (pos #:mutable) radius thresh))
|
|
|
|
(define selected 0)
|
|
|
|
(define (build-cell pos radius threshold)
|
|
(with-state
|
|
(push)
|
|
(hint-unlit)
|
|
(translate pos)
|
|
(scale radius)
|
|
(colour (vector 0.5 (+ 0.5 (* 0.5 (rndf))) 0.5))
|
|
(let ((root (build-sphere 7 7)))
|
|
(pop)
|
|
(parent root)
|
|
(scale threshold)
|
|
(opacity 0.3)
|
|
(colour (vector 0.5 (+ 0.5 (* 0.5 (rndf))) 0.5))
|
|
|
|
(let ((wall (build-sphere 7 7)))
|
|
(make-cell root wall pos radius threshold)))))
|
|
|
|
(define (cell-update cell input organism)
|
|
(with-primitive (cell-root cell)
|
|
(when (eq? (send input get-selected) (cell-wall cell))
|
|
(translate (send input get-mouse-change)))
|
|
|
|
(let ((dir (foldl
|
|
(lambda (other cur)
|
|
(if (not (eq? cell other))
|
|
(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.005)))
|
|
(else
|
|
cur)))
|
|
cur))
|
|
(vector 0 0 0)
|
|
organism)))
|
|
(translate (vector (vx dir) (vy dir) 0)))
|
|
|
|
(set-cell-pos! cell (vtransform (vector 0 0 0) (get-transform)))))
|
|
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define (build-organism count)
|
|
(build-list count (lambda (_) (build-cell (vmul (vector (crndf) (crndf) 0) 15) 1 2))))
|
|
|
|
(define (organism-update organism input)
|
|
(for-each
|
|
(lambda (cell)
|
|
(cell-update cell input organism))
|
|
organism))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
|
|
(clear)
|
|
(clear-colour (vector 0.2 0.3 0))
|
|
(define organism (build-organism 100))
|
|
|
|
(define input (make-object input%))
|
|
|
|
(define (update)
|
|
(send input pre-update)
|
|
(organism-update organism input)
|
|
(send input update))
|
|
|
|
(every-frame (update))
|