groworld/pluggable/pluggable.scm

159 lines
5.9 KiB
Scheme
Raw Normal View History

2009-03-12 11:51:02 +00:00
; converts a 2D vector into an angle, with some dodgy dave maths
(define (2dvec->angle x y)
(let ((q (/ 3.141 2)))
(when (zero? y) (set! y 0.0001))
(cond
((>= y 0)
(fmod (* (+ q q q (- q (atan (/ x y)))) 57.2957795) 360))
(else
(fmod (* (+ q (- q (atan (/ x y)))) 57.2957795) 360)))))
(define (i->pos i)
(vector (modulo i (pixels-width))
(quotient i (pixels-width)) 0))
(define (pos->i pos)
(+ (* (round (vy pos)) (pixels-width)) (round (vx pos))))
(define (pixels-ref name pos)
(pdata-ref name (pos->i pos)))
(define (pixels-set! name pos s)
(pdata-set! name (pos->i pos) s))
(define (search i)
(cond
((eq? i (pdata-size)) i)
((< (vr (pdata-ref "c" i)) 0.5) i)
(else (search (+ i 1)))))
(define (flood pos tc av)
(define (rec-flood pos)
(pixels-set! "c" pos (vector 1 0 1))
(set! tc (+ tc 1))
(set! av (vadd av pos))
(when (< (vr (pixels-ref "c" (vadd pos (vector -1 0 0)))) 0.5)
(rec-flood (vadd pos (vector -1 0 0))))
(when (< (vr (pixels-ref "c" (vadd pos (vector 1 0 0)))) 0.5)
(rec-flood (vadd pos (vector 1 0 0))))
(when (< (vr (pixels-ref "c" (vadd pos (vector 0 1 0)))) 0.5)
(rec-flood (vadd pos (vector 0 1 0))))
(when (< (vr (pixels-ref "c" (vadd pos (vector 0 -1 0)))) 0.5)
(rec-flood (vadd pos (vector 0 -1 0)))))
(rec-flood pos)
(vmul av (/ 1 tc)))
(define (find-centroids pos l)
(let ((i (search pos)))
(cond ((eq? i (pdata-size)) l)
(else
(find-centroids i
(cons (flood (i->pos i) 0 (vector 0 0 0)) l))))))
(define (convert-to-pos l)
(map
(lambda (cp)
(vector (- (- (/ (vx cp) (pixels-width)) 0.5))
(- 1 (/ (vy cp) (pixels-height))) 0))
l))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define connection-cache '())
(define (get-connection-list id)
(let ((ret (assoc id connection-cache)))
(cond
(ret (cdr ret))
(else
(let* ((tex (load-primitive (string-append "textures/comp-cp-" id ".png")))
(connections (with-primitive tex (convert-to-pos (find-centroids 0 '())))))
(set! connection-cache (cons (cons id connections) connection-cache))
(destroy tex)
connections)))))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define-struct component (root children))
(define (build-component id children)
(cond
((null? children)
(let ((root (with-state
(translate (vector 0 0.5 0))
(rotate (vector 0 0 180))
(hint-ignore-depth)
(texture (load-texture (string-append "textures/comp-" id ".png")))
(build-plane))))
(with-primitive root (apply-transform))
(make-component root '())))
(else
(let* ((connection-list (get-connection-list id))
(root (with-state
(translate (vector 0 0.5 0))
(rotate (vector 0 0 180))
(texture (load-texture (string-append "textures/comp-" id ".png")))
(build-plane)))
(comp (make-component root
(map
(lambda (child connection)
(with-state
(hint-ignore-depth)
(parent root)
(translate (vector 0 0 -0.01))
(printf "~a~n" connection)
(translate connection)
(scale 0.8)
(rotate (vector 0 0 (2dvec->angle
(vx connection) (- (vy connection) 0.5))))
(rotate (vector 0 0 0))
(build-component (car child) (cadr child))))
children
connection-list))))
(with-primitive root (apply-transform))
comp))))
(define (component-print component)
(printf "~a~n" (component-children component)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define (choose l)
(list-ref l (random (length l))))
(define (make-random-plant depth)
(let ((num-children (if (> depth 10) 0 (choose (list 0 1 2 3)))))
(cond
((eq? num-children 0) (list (choose (list "0" "0")) (list)))
((eq? num-children 1) (list "1-1" (list (make-random-plant (+ depth 1)))))
((eq? num-children 2) (list "2-1" (list (make-random-plant (+ depth 1))
(make-random-plant (+ depth 1)))))
((eq? num-children 3) (list (string-append "3-" (choose (list "1" "2")))
(list (make-random-plant (+ depth 1))
(make-random-plant (+ depth 1)) (make-random-plant (+ depth 1)))))
((eq? num-children 4) (list "4-1" (list (make-random-plant (+ depth 1))
(make-random-plant (+ depth 1)) (make-random-plant (+ depth 1))
(make-random-plant (+ depth 1)))))
((eq? num-children 5) (list "5-0" (list (make-random-plant (+ depth 1))
(make-random-plant (+ depth 1)) (make-random-plant (+ depth 1))
(make-random-plant (+ depth 1)) (make-random-plant (+ depth 1))))))))
(clear)
(clear-colour (vector 1 1 1))
(clear-geometry-cache)
(clear-texture-cache)
(hint-unlit)
;(opacity 0.5)
(define p (make-random-plant 0))
(display p) (newline)
(define c (build-component "1-1" (list p)))