2009-06-30 16:55:49 +00:00
|
|
|
#lang scheme
|
|
|
|
(require fluxus-016/drflux)
|
|
|
|
|
|
|
|
; extrusion code
|
2009-06-25 10:18:37 +00:00
|
|
|
|
|
|
|
(define (draw-profile index profile offset)
|
|
|
|
(cond ((not (null? profile))
|
|
|
|
(pdata-set! "p" index (vadd (car profile) offset))
|
|
|
|
(draw-profile (+ index 1) (cdr profile) offset))))
|
|
|
|
|
|
|
|
|
|
|
|
(define (transform-profile profile m)
|
|
|
|
(cond
|
|
|
|
((null? profile) '())
|
|
|
|
(else
|
|
|
|
(cons (vtransform (car profile) m)
|
|
|
|
(transform-profile (cdr profile) m)))))
|
|
|
|
|
|
|
|
; figures out the vector for rotation of the profile
|
|
|
|
(define (path-vector first-segment path lv)
|
|
|
|
(let* ((v (if (null? (cdr path)) ; last segment?
|
|
|
|
lv ; use the last vector used
|
|
|
|
(vsub (cadr path) (car path)))) ; use the next point
|
|
|
|
(vd (if first-segment v ; first segment?
|
|
|
|
(vadd (vmul lv 0.5) ; blend with the last vector
|
|
|
|
(vmul v 0.5)))))
|
|
|
|
vd))
|
|
|
|
|
2009-06-30 16:55:49 +00:00
|
|
|
(define (extrude-segment index profile path width lv up)
|
2009-06-25 10:18:37 +00:00
|
|
|
(cond ((not (null? path))
|
|
|
|
(let ((v (path-vector (zero? index) path lv)))
|
|
|
|
(draw-profile index (transform-profile profile
|
|
|
|
(mmul
|
2009-06-30 16:55:49 +00:00
|
|
|
(maim v up)
|
|
|
|
(mrotate (vector 0 90 0))
|
|
|
|
(mscale (vector (car width) (car width) (car width)))))
|
2009-06-25 10:18:37 +00:00
|
|
|
(car path))
|
|
|
|
v))))
|
|
|
|
|
2009-06-30 16:55:49 +00:00
|
|
|
(define (extrude-segment-grow index profile path width lv up t)
|
2009-06-25 10:18:37 +00:00
|
|
|
(cond ((not (null? path))
|
2009-06-30 16:55:49 +00:00
|
|
|
(let ((v (path-vector (zero? index) path lv)))
|
|
|
|
(draw-profile index (transform-profile profile
|
|
|
|
(mmul
|
|
|
|
(maim v up)
|
|
|
|
(mrotate (vector 0 90 0))
|
|
|
|
(mscale (vmul (vector (car width) (car width) (car width)) t))))
|
|
|
|
(car path))
|
2009-06-25 10:18:37 +00:00
|
|
|
v))))
|
|
|
|
|
2009-06-30 16:55:49 +00:00
|
|
|
(define (extrude index profile path width lv up)
|
2009-06-25 10:18:37 +00:00
|
|
|
(cond ((not (null? path))
|
2009-06-30 16:55:49 +00:00
|
|
|
(let ((v (extrude-segment index profile path width lv up)))
|
|
|
|
(extrude (+ index (length profile)) profile (cdr path) (cdr width) v up)))))
|
2009-06-25 10:18:37 +00:00
|
|
|
|
|
|
|
(define (stitch-face index count profile-size in)
|
|
|
|
(cond
|
|
|
|
((eq? 1 count)
|
|
|
|
(append in (list (+ (- index profile-size) 1) index (+ index profile-size)
|
|
|
|
(+ (- index profile-size) 1 profile-size))))
|
|
|
|
(else
|
|
|
|
(append
|
|
|
|
(list (+ index 1) index
|
|
|
|
(+ index profile-size) (+ index profile-size 1))
|
|
|
|
(stitch-face (+ index 1) (- count 1) profile-size in)))))
|
|
|
|
|
|
|
|
(define (stitch-indices index profile-size path-size in)
|
|
|
|
(cond
|
|
|
|
((eq? 1 path-size) in)
|
|
|
|
(else
|
|
|
|
(append
|
|
|
|
(stitch-face index profile-size profile-size '())
|
|
|
|
(stitch-indices (+ index profile-size)
|
|
|
|
profile-size
|
|
|
|
(- path-size 1)
|
|
|
|
in)))))
|
|
|
|
|
2009-06-30 16:55:49 +00:00
|
|
|
(define (build-tex-coords profile-size path-size vscale)
|
|
|
|
(pdata-index-map!
|
|
|
|
(lambda (i t)
|
|
|
|
(vector (* vscale (/ (quotient i profile-size) path-size))
|
|
|
|
(/ (modulo i profile-size) profile-size) 0))
|
|
|
|
"t"))
|
|
|
|
|
|
|
|
(define (build-extrusion profile path width tex-vscale up)
|
2009-06-25 10:18:37 +00:00
|
|
|
(let ((p (build-polygons (* (length profile) (length path)) 'quad-list)))
|
|
|
|
(with-primitive p
|
|
|
|
(poly-set-index (stitch-indices 0 (length profile) (length path) '()))
|
2009-06-30 16:55:49 +00:00
|
|
|
(build-tex-coords (length profile) (length path) tex-vscale)
|
|
|
|
(extrude 0 profile path width (vector 0 0 0) up)
|
2009-06-25 10:18:37 +00:00
|
|
|
(recalc-normals 0))
|
|
|
|
p))
|
|
|
|
|
|
|
|
; partial extrusions are for animating
|
|
|
|
|
2009-06-30 16:55:49 +00:00
|
|
|
(define (build-partial-extrusion profile path tex-vscale)
|
2009-06-25 10:18:37 +00:00
|
|
|
(let ((p (build-polygons (* (length profile) (length path)) 'quad-list)))
|
|
|
|
(with-primitive p
|
2009-06-30 16:55:49 +00:00
|
|
|
(poly-set-index (stitch-indices 0 (length profile) (length path) '()))
|
|
|
|
(build-tex-coords (length profile) (length path) tex-vscale))
|
2009-06-25 10:18:37 +00:00
|
|
|
p))
|
|
|
|
|
|
|
|
(define (chop-front l n)
|
|
|
|
(cond ((null? l) l)
|
|
|
|
(else
|
|
|
|
(if (zero? n) (cons (car l) (chop-front (cdr l) n))
|
|
|
|
(chop-front (cdr l) (- n 1))))))
|
|
|
|
|
2009-06-30 16:55:49 +00:00
|
|
|
(define (partial-extrude p t v profile path width up)
|
2009-06-25 10:18:37 +00:00
|
|
|
(with-primitive p 0
|
|
|
|
|
2009-06-30 16:55:49 +00:00
|
|
|
(let* ((T (floor t))
|
|
|
|
(t (- t T))
|
|
|
|
(seg-len (length profile))
|
|
|
|
(start (* T seg-len))
|
|
|
|
(end (* (length path) seg-len))
|
|
|
|
(v (extrude-segment start profile
|
|
|
|
(chop-front path T)
|
|
|
|
(chop-front width T) v up)))
|
|
|
|
|
|
|
|
(when (< T (- (length path) 1))
|
|
|
|
; extrude the next segment
|
|
|
|
(extrude-segment (+ start seg-len) profile
|
|
|
|
(chop-front path (+ T 1))
|
|
|
|
(chop-front width (+ T 1)) v up)
|
|
|
|
|
|
|
|
; and now blend it back by using both segments to t
|
|
|
|
(for ((i (in-range (+ start seg-len)
|
|
|
|
(+ start (* 2 seg-len)))))
|
|
|
|
|
|
|
|
(pdata-set! "p" i (vmix (pdata-ref "p" i)
|
|
|
|
(pdata-ref "p" (- i seg-len))
|
|
|
|
|
|
|
|
t)))
|
|
|
|
|
|
|
|
|
|
|
|
|
2009-06-25 10:18:37 +00:00
|
|
|
; collapse the yet un-extruded part into the last vert
|
2009-06-30 16:55:49 +00:00
|
|
|
(for ((i (in-range (+ start (* seg-len 2)) end)))
|
|
|
|
(pdata-set! "p" i (pdata-ref "p" (+ seg-len start)))))
|
2009-06-25 10:18:37 +00:00
|
|
|
|
|
|
|
(recalc-normals 0)
|
|
|
|
v)))
|
|
|
|
|
2009-06-30 16:55:49 +00:00
|
|
|
(define (partial-extrude-grow p t v profile path width up)
|
2009-06-25 10:18:37 +00:00
|
|
|
(with-primitive p 0
|
2009-06-30 16:55:49 +00:00
|
|
|
|
|
|
|
(let* ((T (floor t))
|
|
|
|
(t (- t T))
|
|
|
|
(seg-len (length profile))
|
|
|
|
(start (* T seg-len))
|
|
|
|
(end (* (length path) seg-len))
|
|
|
|
(v (extrude-segment-grow start profile
|
|
|
|
(chop-front path T)
|
|
|
|
(chop-front width T) v up t)))
|
|
|
|
|
|
|
|
(when (< T (- (length path) 1))
|
|
|
|
; extrude the next segment
|
|
|
|
(extrude-segment-grow (+ start seg-len) profile
|
|
|
|
(chop-front path (+ T 1))
|
|
|
|
(chop-front width (+ T 1)) v up 0)
|
|
|
|
|
|
|
|
; and now blend it back by using both segments to t
|
|
|
|
(for ((i (in-range (+ start seg-len)
|
|
|
|
(+ start (* 2 seg-len)))))
|
|
|
|
|
|
|
|
(pdata-set! "p" i (vmix (pdata-ref "p" i)
|
|
|
|
(pdata-ref "p" (- i seg-len))
|
|
|
|
|
|
|
|
t)))
|
|
|
|
|
|
|
|
|
|
|
|
|
2009-06-25 10:18:37 +00:00
|
|
|
; collapse the yet un-extruded part into the last vert
|
2009-06-30 16:55:49 +00:00
|
|
|
(for ((i (in-range (+ start (* seg-len 2)) end)))
|
|
|
|
(pdata-set! "p" i (pdata-ref "p" (+ seg-len start)))))
|
2009-06-25 10:18:37 +00:00
|
|
|
|
|
|
|
(recalc-normals 0)
|
|
|
|
v)))
|
|
|
|
|
|
|
|
(define (build-circle-profile n r)
|
|
|
|
(define (_ n c l)
|
|
|
|
(cond ((zero? c) l)
|
|
|
|
(else
|
|
|
|
(let ((a (* (/ c n) (* 2 3.141))))
|
|
|
|
(_ n (- c 1)
|
|
|
|
(cons (vmul (vector (sin a) (cos a) 0) r) l))))))
|
|
|
|
(_ n n '()))
|
|
|
|
|
|
|
|
(clear)
|
2009-06-30 16:55:49 +00:00
|
|
|
(clear-colour 0.5)
|
2009-06-25 10:18:37 +00:00
|
|
|
|
|
|
|
(define l (make-light 'point 'free))
|
|
|
|
(light-diffuse 0 (vector 0 0 0))
|
|
|
|
(light-diffuse l (vector 1 1 1))
|
|
|
|
(light-position l (vector 50 50 0))
|
|
|
|
(light-specular l (vector 1 1 1))
|
|
|
|
|
|
|
|
(define profile (build-circle-profile 12 0.5))
|
|
|
|
|
2009-06-30 16:55:49 +00:00
|
|
|
(define width (build-list 100
|
|
|
|
(lambda (n) (* 0.5 (+ 1 (sin (* 0.3 n)))))))
|
2009-06-25 10:18:37 +00:00
|
|
|
|
2009-06-30 16:55:49 +00:00
|
|
|
(define path (build-list 100
|
|
|
|
(lambda (n) (vmul (vector (sin (* 0.05 n)) 0 (cos (* 0.05 n))) (+ 0.5 (* 0.2 n))))))
|
2009-06-25 10:18:37 +00:00
|
|
|
|
|
|
|
(define p (with-state
|
|
|
|
; (hint-wire)
|
|
|
|
(colour (vector 0 0.5 0.5))
|
|
|
|
(specular (vector 1 1 1))
|
|
|
|
(shinyness 20)
|
2009-06-30 16:55:49 +00:00
|
|
|
(build-partial-extrusion profile path 1)))
|
2009-06-25 10:18:37 +00:00
|
|
|
|
|
|
|
(with-state
|
|
|
|
(wire-opacity 0.4)
|
|
|
|
(translate (vector 0 0 0))
|
|
|
|
(wire-colour (vector 0 0 1))
|
|
|
|
(hint-none)
|
|
|
|
(hint-wire)
|
|
|
|
; (hint-normal)
|
|
|
|
(backfacecull 1)
|
|
|
|
(point-width 5)
|
2009-06-30 16:55:49 +00:00
|
|
|
(build-extrusion profile path width 1 (vector 0 1 0)))
|
|
|
|
|
|
|
|
(define v (vector 0 0 0))
|
|
|
|
|
|
|
|
(define (animate)
|
|
|
|
(set! v (partial-extrude-grow p (fmod (* 2 (flxtime)) (length path)) v profile path width (vector 0 1 0))))
|
|
|
|
|
|
|
|
|
|
|
|
(every-frame (animate))
|
|
|
|
|
|
|
|
|