loads of fixes from scheme bricks test

README.md

@@ -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.

assets/boot.scm

@@ -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
 

experiments/math-hack.scm

+;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+; 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))))))

experiments/sb.scm

+;; [ 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)