Commit 7b32e8c0 authored by Dave Griffiths's avatar Dave Griffiths
Browse files

weaving code and compiler function arguments fix

parent b0540185
...@@ -212,6 +212,11 @@ ...@@ -212,6 +212,11 @@
(emit-expr (cadr x)) ;; address (emit-expr (cadr x)) ;; address
(emit (vector lds 0 0)))) (emit (vector lds 0 0))))
(define (emit-addr x)
(display "ello")(newline)
(display (variable-address (cadr x)))(newline)
(emit (vector ldl (variable-address (cadr x)) 0)))
(define (emit-cond-part x) (define (emit-cond-part x)
(let ((block (emit-expr-list (cdr x)))) (let ((block (emit-expr-list (cdr x))))
(append (append
...@@ -423,6 +428,7 @@ ...@@ -423,6 +428,7 @@
((eq? (car x) 'rndvec) (emit (vector rnd 0 0))) ((eq? (car x) 'rndvec) (emit (vector rnd 0 0)))
((eq? (car x) 'trace) (emit-trace x)) ((eq? (car x) 'trace) (emit-trace x))
((eq? (car x) 'read) (emit-read x)) ((eq? (car x) 'read) (emit-read x))
((eq? (car x) 'addr) (emit-addr x))
((eq? (car x) 'not) (emit-not x)) ((eq? (car x) 'not) (emit-not x))
((eq? (car x) 'mag) (unary-procedure len x)) ((eq? (car x) 'mag) (unary-procedure len x))
((eq? (car x) 'magsq) (unary-procedure lensq x)) ((eq? (car x) 'magsq) (unary-procedure lensq x))
......
...@@ -123,7 +123,15 @@ ...@@ -123,7 +123,15 @@
'(let ((vertex positions-start) '(let ((vertex positions-start)
(warp-end 0) (warp-end 0)
(warp-position (vector 0 0 0)) (warp-position (vector 0 0 0))
(shed 0)) (shed 0)
(weft-t 0)
(draft-pos 0)
(draft-size 4)
(draft (vector 1 0 1)) (draft-a1 0)
(draft-b0 (vector 0 1 0)) (draft-b1 1)
(draft-c0 (vector 1 0 1)) (draft-c1 0)
(draft-d0 (vector 0 1 0)) (draft-d1 1)
(draft-end 0))
(define build-quad (define build-quad
(lambda (tl size) (lambda (tl size)
...@@ -136,6 +144,9 @@ ...@@ -136,6 +144,9 @@
(define animate-shed (define animate-shed
(lambda (i v) (lambda (i v)
(set! v
(cond ((< v 0.5) 1)
((> v 0.5) -1)))
(set! warp-end 0) (set! warp-end 0)
(loop (< warp-end 10) (loop (< warp-end 10)
(write-add! (- i 6) 0 v 0 0 v v) (write-add! (- i 6) 0 v 0 0 v v)
...@@ -156,8 +167,18 @@ ...@@ -156,8 +167,18 @@
(set! warp-end (+ warp-end 1))) (set! warp-end (+ warp-end 1)))
(forever (forever
;; todo control externally
(set! weft-t (+ weft-t 0.05))
(cond ((> weft-t 1)
(set! draft-pos (+ draft-pos 1))
(cond ((> draft-pos draft-size)
(set! draft-pos 0)))
(set! weft-t 0)))
(trace (read (+ (addr draft) (* draft-pos 2))))
(set! vertex (+ positions-start 12)) (set! vertex (+ positions-start 12))
(animate-shed vertex (*v (vector 1 0 0) (* (sincos shed) 1))) (animate-shed vertex weft-t)
(set! shed (+ shed 5)) (set! shed (+ shed 5))
)))) ))))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment