Commit df08c096 authored by Dave Griffiths's avatar Dave Griffiths
Browse files

loads of fixes from scheme bricks test

parent 878fbc03
......@@ -243,3 +243,38 @@ sqr len dup drp cmp shf bld ret dbg
nrm mst mad msb swp rnd mull
jmr ldlv lensq noise lds sts mulv
synth-crt synth-con synth-ply flr
### TinyScheme Licence follows ###
LICENSE TERMS
Copyright (c) 2000, Dimitrios Souflis
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
Neither the name of Dimitrios Souflis nor the names of the
contributors may be used to endorse or promote products derived from
this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
......@@ -30,11 +30,31 @@
(define (hint-anti-alias) (hint 5))
(define (hint-bound) (hint 6))
(define (hint-unlit) (hint 7))
(define (hint-vertcols) (hint 8))
(define (hint-origin) (hint 9))
(define (hint-cast-shadow) (hint 10))
(define (hint-ignore-depth) (hint 11))
(define (hint-depth-sort) (hint 12))
(define (hint-lazy-parent) (hint 13))
(define (hint-cull-ccw) (hint 14))
(define (hint-wire-stippled) (hint 15))
(define (hint-spere-map) (hint 16))
(define (hint-frustum-cull) (hint 17))
(define (hint-normalise) (hint 18))
(define (hint-noblend) (hint 19))
(define (hint-nozwrite) (hint 20))
;------------------------------------------------------------
(define _mouse-x 0)
(define _mouse-y 0)
(define keys '())
(define keys-this-frame '())
(define special-keys '())
(define special-keys-this-frame '())
(define mouse (vector 0 0))
(define mouse-buttons (vector #f #f #f #f))
(define mouse-wheel-v 0)
(define key-mods '())
;; this stuff for touchscreens
(define _mouse-b -1)
(define _mouse-s 1) ; state - 0 down, 1 up
......@@ -46,25 +66,21 @@
(when (zero? _mouse-s) ; eh?
(set! _touching #t)
(set! _touches (list (list 0 x y))))
(set! _mouse-x x)
(set! _mouse-y y))
(vector-set! mouse 0 x)
(vector-set! mouse 1 y))
(define (mouse-x) (vector-ref mouse 0))
(define (mouse-y) (vector-ref mouse 1))
;;(define (mouse-button n)
;; (if _touching
;; #t
;; (if (zero? _mouse-s)
;; (eqv? _mouse-b n) #f)))
(define (mouse-x) _mouse-x)
(define (mouse-y) _mouse-y)
(define (mouse-button n)
(if _touching
#t
(if (zero? _mouse-s)
(eqv? _mouse-b n) #f)))
(vector-ref mouse-buttons (- n 1)))
(define keys '())
(define keys-this-frame '())
(define special-keys '())
(define special-keys-this-frame '())
(define mouse (vector 0 0))
(define mouse-buttons (vector #f #f #f))
(define mouse-wheel-v 0)
(define key-mods '())
; utils funcs for using lists as sets
(define (set-remove a l)
......@@ -104,19 +120,19 @@
; (for/list ([bitmask (list 1 2 4)]
; [bitsym '(shift ctrl alt)]
; #:when (> (bitwise-and mod bitmask) 0))
; bitsym))
; bitsym))
(cond ; mouse
((and (eq? key 0) (eq? special -1))
((and (eqv? key 0) (eqv? special -1))
(when (eq? button 3) (set! mouse-wheel-v 1))
(when (eq? button 4) (set! mouse-wheel-v -1))
(when (and (eq? state 0)
(when (and (eqv? state 0)
(< button (vector-length mouse-buttons)))
(vector-set! mouse-buttons button #t))
(when (and (eq? state 1)
(when (and (eqv? state 1)
(< button (vector-length mouse-buttons)))
(vector-set! mouse-buttons button #f))
(vector-set! mouse 0 x)
(vector-set! mouse 1 y))))
(vector-set! mouse-buttons button #f))))
(vector-set! mouse 0 x)
(vector-set! mouse 1 y))
(define (register-up key button special state x y mod)
(when (not (eq? key -1))
......@@ -289,6 +305,27 @@
(loop (+ n 1) total))))))
(loop 0 (- (pdata-size) 1)))))
(define (pdata-range-map! start end . args)
(let ((proc (car args))
(pdata-write-name (cadr args))
(pdata-read-names (cddr args)))
(letrec
((loop (lambda (n total)
(cond ((not (> n total))
(pdata-set!
pdata-write-name n
(apply
proc
(cons
(pdata-ref pdata-write-name n)
(map
(lambda (read)
(pdata-ref read n))
pdata-read-names))))
(loop (+ n 1) total))))))
(loop start (min (pdata-size) end)))))
(define (pdata-index-map! . args)
(let ((proc (car args))
(pdata-write-name (cadr args))
......@@ -482,6 +519,13 @@
; (display code)(newline)
(eval code)))
;; detach and retain original transform
(define (detach-parent)
(let ((m (get-global-transform)))
(parent 1) ;; reparent to root
(identity)
(concat m)))
;;---------------------------------------------------------
;; jellyfish helpers
......
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; maths hacks, move to fluxa
(define (all-numbers? l)
(cond
((null? l) #t)
((not (number? (car l))) #f)
(else (all-numbers? (cdr l)))))
(define (+ . args)
(if (all-numbers? args)
(apply + args)
(proc-list add args)))
(define (- . args)
(if (all-numbers? args)
(apply - args)
(proc-list sub args)))
(define (/ . args)
(if (all-numbers? args)
(apply / args)
(proc-list div args)))
(define (* . args)
(if (all-numbers? args)
(apply * args)
(proc-list mul args)))
(define (proc-list p l)
(cond
((eq? (length l) 1) (car l))
((eq? (length l) 2) (p (car l) (cadr l)))
(else (p (car l) (proc-list p (cdr l))))))
;; [ Copyright (C) 2012 Dave Griffiths : GPLv3 see LICENCE ]
;; todo:
;; * show/hide palette
;; * rotate/hide block
;; * click undock bug
;; * auto record edits
;; * load/save code
;; * copy/paste
;; * drag resized distance
;; * resize block
;; * execute flash block
;; * play flash insertion
;; * middle click code select
;; * palette move with mouse wheel
;; * lock pallete items from drag/drop (lock all recusively?)
;; * drop messed up from bottom
;; * right click text edit
(define drop-fudge 0)
(define lag-fudge 0.7)
(define drag-transparent 0.75)
(define sound-check #f)
(define sound-fac #f)
(define palette '(
(test (2) (1 2 3 4))
))
(define (_println l)
(map
(lambda (a)
(display a)(display " "))
l)
(newline))
(define (println . args) (_println args))
(define (dbg . args) (_println args) (car args))
(define (insert-to i p l)
(cond
((null? l) (list i))
((zero? p) (cons i l))
(else
(cons (car l) (insert-to i (- p 1) (cdr l))))))
;; (list-replace '(1 2 3 4) 2 100) => '(1 2 100 4)
(define (list-replace l i v)
(cond
((null? l) l)
((zero? i) (cons v (list-replace (cdr l) (- i 1) v)))
(else (cons (car l) (list-replace (cdr l) (- i 1) v)))))
(define (in-list? a l)
(cond
((null? l) #f)
((eq? (car l) a) #t)
(else (in-list? a (cdr l)))))
(define (text-from-code code)
(cond
((string? code)
(string-append "\"" code "\""))
((number? code)
(number->string code))
((symbol? code)
(symbol->string code))))
; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define (get-line-from-mouse)
(let* ((ndcpos (vector (* (- (/ (mouse-x) (vx (get-screen-size))) 0.5) 6)
(* (- (- (/ (mouse-y) (vy (get-screen-size))) 0.5)) 4) -1))
(scrpos2 (vtransform (vmul ndcpos 500) (minverse (get-camera-transform))))
(scrpos (vtransform ndcpos (minverse (get-camera-transform)))))
(list scrpos scrpos2)))
(define (get-point-from-mouse)
(let ((line (get-line-from-mouse)))
(vlerp (car line) (cadr line) (/ (vz (car line))
(- (vz (car line)) (vz (cadr line)))))))
(define (linebreak txt)
(let ((t (foldl
(lambda (ch r)
(if (and (char=? ch #\ ) (> (string-length (car r)) 40))
(list "" (append (cadr r) (list (car r))))
(list (string-append (car r) (string ch))
(cadr r))))
(list "" '())
(string->list txt))))
(append (cadr t) (list (car t)))))
(define (broadcast t error)
(display error)(newline)
(let ((error (linebreak error)))
(let ((p (build-locator)))
(with-state
(parent p)
(translate (vector -24 18 5))
(scale 1)
(hint-unlit)
;;(hint-depth-sort)
;;(texture-params 0 (list 'min 'linear 'mag 'linear))
(texture (load-texture "font.png"
;;(list 'generate-mipmaps 0 'mip-level 0)
))
(for-each
(lambda (line)
(let ((pp (build-text line)))
(translate (vector 0 -1 0))
(with-primitive pp
(text-params line (/ 16 256) (/ 16 256) 16 0 -0.01 0 15 -20 0.005 0.2))))
error))
(spawn-timed-task (+ (time-now) t)
(lambda () (destroy p))))))
; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define (set-text text)
;;(text-params text (/ 16 256) (/ 16 256) 16 0 -0.01 0 15 -20 0.005 0.2)
0
)
(define (make-brick text children)
(let* ((atom (not children))
(prim (build-polygons (if atom 4 8) triangle-strip))
(text-prim (with-state
(parent prim)
(translate (vector -0.9 1.1 0.001))
(hint-unlit)
;;(hint-depth-sort)
(colour 0)
;;(texture-params 0 (list 'min 'linear 'mag 'linear))
(texture (load-texture "font.png"
;;(list 'generate-mipmaps 0 'mip-level 0)
))
(msg text)
(let ((text-prim (build-text text)))
;(with-primitive
; text-prim
; (set-text text))
text-prim))))
(msg "making brick")
(with-primitive
prim
;;(hint-none)(hint-wire)
(hint-unlit)
(cond
(atom
(pdata-set! "p" 0 (vector 5 0 0))
(pdata-set! "p" 1 (vector 5 1 0))
(pdata-set! "p" 2 (vector -1 0 0))
(pdata-set! "p" 3 (vector -1 1 0)))
(else
(pdata-set! "p" 0 (vector 5 0 0))
(pdata-set! "p" 1 (vector 5 1 0))
(pdata-set! "p" 2 (vector 0 0 0))
(pdata-set! "p" 3 (vector -1 1 0))
(pdata-set! "p" 4 (vector 0 0 0))
(pdata-set! "p" 5 (vector -1 -1 0))
(pdata-set! "p" 6 (vector 5 0 0))
(pdata-set! "p" 7 (vector 5 -1 0))))
(pdata-map! (lambda (n) (vector 0 0 1)) "n")
;(apply-transform)
(pdata-copy "p" "pref"))
(list text children empty-ghost prim text-prim 0 #f #f)))
(define (brick-text b) (list-ref b 0))
(define (brick-modify-text f b) (list-replace b 0 (f (brick-text b))))
(define (brick-children b) (list-ref b 1))
(define (brick-is-atom? b) (not (brick-children b)))
(define (brick-modify-children f b) (list-replace b 1 (f (brick-children b))))
(define (brick-ghost b) (list-ref b 2))
(define (brick-modify-ghost f b) (list-replace b 2 (f (brick-ghost b))))
(define ghost-pos car)
;(define ghost-size cadr)
(define (ghost-size i) 1)
(define empty-ghost (list #f 1))
(define (brick-clear-ghost b) (brick-modify-ghost (lambda (g) empty-ghost) b))
(define (brick-id b) (list-ref b 3))
(define (brick-text-prim b) (list-ref b 4))
(define (brick-depth b) (list-ref b 5))
(define (brick-locked b) (list-ref b 6)) ; for the palette
(define (brick-modify-locked f b) (list-replace b 6 (f (brick-locked b))))
;; set manually when creating the palette
(define (brick-parent-locked b) (list-ref b 7))
(define (brick-modify-parent-locked f b) (list-replace b 7 (f (brick-parent-locked b))))
(define (brick-for-each fn b)
(fn b)
(when (brick-children b)
(for-each
(lambda (c)
(brick-for-each fn c))
(brick-children b))))
(define (brick-destroy! b)
(brick-for-each
(lambda (b)
(destroy (brick-id b)))
b))
(define (brick-modify-all-children fn b)
(if (brick-is-atom? b)
(fn b)
(brick-modify-children
(lambda (children)
(map
(lambda (child)
(brick-modify-all-children fn child))
children))
(fn b))))
(define (brick-modify-brick fn b id)
;; check ourself first
(if (eq? (brick-id b) id)
(fn b)
;; search children
(if (brick-is-atom? b)
b
(brick-modify-children
(lambda (children)
(map
(lambda (child)
(brick-modify-brick fn child id))
children))
b))))
(define (brick-search b id)
;; check ourself first
(if (eq? (brick-id b) id)
b
;; search children
(if (brick-is-atom? b)
#f
(foldl
(lambda (child r)
(cond
(r r) ;; already found
((eq? (brick-id child) id) child)
(else (brick-search child id))))
#f
(brick-children b)))))
(define (brick-search-for-parent b id)
(if (brick-is-atom? b)
#f
;; search children
(foldl
(lambda (child r)
(if (not r)
(cond
((eq? (brick-id child) id) b)
(else (brick-search-for-parent child id)))
r))
#f
(brick-children b))))
(define (brick-transparent! b a)
(with-primitive
(brick-id b)
; (opacity a)
;(hint-nozwrite)
)
(with-primitive
(brick-depth b)
; (opacity a)
;(hint-nozwrite)
))
(define (brick-opaque! b)
(with-primitive
(brick-id b)
; (opacity 1)
(hint-none)(hint-solid))
(with-primitive
(brick-depth b)
; (opacity 1)
(hint-none)(hint-solid)))
(define (brick-text-glow! p)
(with-primitive
p
(colour (+ 0.5 (fmod (* 4 (flxtime)) 0.5)))))
(define (brick-code-glow! p)
(with-primitive
p
(colour (vmix
(vector 1 0 0)
(vector 1 1 0)
(abs (sin (* (flxtime) 2)))))))
(define (brick-get-scale b)
(with-primitive
(brick-id b)
(let ((tx (get-transform)))
(vmag (vector
(vector-ref tx 0)
(vector-ref tx 5)
(vector-ref tx 11))))))
(define (brick-expand! b n)
(with-primitive
(brick-id b)
(pdata-range-map!
4 8
(lambda (p pref)
(vadd pref (vector 0 (- n) 0)))
"p" "pref")))
(define (brick-children-size b)
(if (not (brick-is-atom? b))
(foldl
(lambda (child n)
(+ n (brick-size child)))
(if (ghost-pos (brick-ghost b))
(ghost-size (brick-ghost b)) 0)
(brick-children b))
0))
(define (make-brick-from-atom code)
(make-brick (text-from-code code) #f))
(define (code->brick code)
(cond
;; atom
((not (list? code)) (make-brick-from-atom code))
;; empty list
((null? code) (make-brick "" '()))
;; list starting with atom
((not (list? (car code)))
(make-brick
(text-from-code (car code))
(map
(lambda (item)
(msg item)
(code->brick item))
(cdr code))))
;; anoymous list
(else
(make-brick
""
(map
(lambda (item)
(code->brick item))
code)))))
(define (brick-size b)
(if (brick-is-atom? b) 1
(+ 2 (brick-children-size b))))
(define (remove-last str)
(substring str 0 (- (string-length str) 1)))
(define (brick->code b)
(eval-string (string-append "'" (brick->text b #f))))
;; does the flashing when it plays the sound business
(define (brick-code-inserts b)
(cond
((and (eq? 2 (length (brick-children b)))
(string=? "play" (brick-text b)))
(string-append " 0 (lambda () (with-primitive " (number->string (brick-id b))
" (colour (vector 1 1 1)))"
"(with-primitive " (number->string (brick-depth b))
" (colour (vector 1 1 1))))"))
((and (eq? 3 (length (brick-children b)))
(string=? "play" (brick-text b)))
(string-append " (lambda () (with-primitive " (number->string (brick-id b))
" (colour (vector 1 1 1)))"
"(with-primitive " (number->string (brick-depth b))
" (colour (vector 1 1 1))))"))
(else "")))
(define (brick->text b do-insert)