  [ Copyright ( C ) 2012   :  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

(require mzlib/string)

(require fluxus/fluxa)
(define drop-fudge 0)
(define lag-fudge 0.7)
(define drag-transparent 0.75)

(set-global-offset 0)

(define sound-check #f)
(define sound-fac #f)

(define (reset)
  ;;(clear-pings!)
  (searchpath "/home/dave/noiz/nm/")
  (reload)
  )

(volume 2)
(eq 1 1 1)

(reset)

(define palette '(() (play-now) (seq) (lambda) (reset) (reload) time clock sync-tempo
                  0 0.1 440 (play) (+) (*) (/) (-) (sine) (squ) (saw)
                  (white) (pink) (sample) (adsr 0 0.1 0 0) (mooglp)
                  (rndf) (note)
          (bootstrap (lambda () zop))
          (define (zop time clock zap)
            (if (modeq? clock 8) 
            (in time 0.5 zopp (+ clock 1) zap) 
            (in time 0.5 zop (+ clock 1) zap)))
                  (modulo clock 8)
          (note (* 2 (+ (modulo clock 3) (modulo clock 4))))
          (pick (list 0.1 0.2) clock)
          (crush (pick (list 0.02 0.1 3 2 10) clock) 10)
          (sine (* 200 (adsr 0 0.1 0.3 1)))
          (mooghp (pink 10) (sine 0.1) 1)
          (set-scale ethiopian) 
          (set-scale lydian) 
	  (play time (* (adsr 0 0.1 0.1 1)))
          (tb (saw 440) (* (adsr 0 0.1 0 0) (pick (list 0 0.3 0.5 1 0.8) clock)) 0.4)
	  (ks (random 1000) 0.9 0.1)
	  (pad 220 (* (modulo clock 5) 0.001) 0.5 0.6)
          (* (adsr 0 0.1 0.1 1) (sine 100) (sine 400))
          (sine (+ 100 (* 400 (sine 400))))
	  (+ 0.5 (* 0.5 (sine 1)))
	  (sine (+ 110 (* (adsr (pick (list 0.2 0 0 0) clock) (pick (list 0.3 0.01 0.2) clock) 0.1 1) (pick (list 400 440 80) clock) (sine (/ (note (modulo zap 7)) 4)))))
	  (sample (pick (list "MA.WAV" "SD2500.WAV" "LC25.WAV" "CL.WAV" "CH.WAV") clock) 300)
	  (sample (pick (list "ij.wav" "ih.wav" "ik.wav" "id.wav" "il.wav" "ic.wav") clock) (* 50 (+ (modulor zap 8) (modulo clock 5))))
	  (* 2 (sample (pick (list "b1.wav" "b2.wav" "b3.wav") zap) 440))
	  ))

(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))))

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


; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(define last-aspect 0)

(define (get-line-from-mouse)
  (let* ((aspect (/ (vy (get-screen-size)) (vx (get-screen-size))))
     (ndcpos (vector
          (* (- (/ (mouse-x) (vx (get-screen-size))) 0.5) 2)
          (* (- (- (/ (mouse-y) (vy (get-screen-size))) 0.5)) (* 2 aspect))
          -1))
        (scrpos2 (vtransform (vmul ndcpos 500) (minverse (get-camera-transform))))
    (scrpos (vtransform ndcpos (minverse (get-camera-transform)))))
    (when (not (eq? aspect last-aspect))
      (frustum -1 1 (- aspect) aspect))
    (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 "oolite-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))

(define (make-brick text children)
  (let* ((atom (not children))
         (prim (build-polygons (if atom 4 8) 'triangle-strip))
         (depth-shape-prim (build-polygons (if atom 16 32) 'quad-list))
         (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 "oolite-font.png"
                                             (list 'generate-mipmaps 0 'mip-level 0)))
                      (let ((text-prim (build-text text)))
                        (with-primitive
                         text-prim
                         (set-text text))
                        text-prim))))
    (with-primitive
     prim
     ;;(hint-none)(hint-wire)
     (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"))

    (let ((depth -3))

      
  (with-primitive
   depth-shape-prim
   (parent prim)
   (cond
    (atom
     (pdata-set! "p" 0 (vector -1 1 depth))
     (pdata-set! "p" 1 (vector -1 1 0))
     (pdata-set! "p" 2 (vector 5 1 0))
     (pdata-set! "p" 3 (vector 5 1 depth))

     (pdata-set! "n" 0 (vector 0 1 0))
     (pdata-set! "n" 1 (vector 0 1 0))
     (pdata-set! "n" 2 (vector 0 1 0))
     (pdata-set! "n" 3 (vector 0 1 0))

     (pdata-set! "p" 4 (vector 5 1 depth))
     (pdata-set! "p" 5 (vector 5 1 0))
     (pdata-set! "p" 6 (vector 5 0 0))
     (pdata-set! "p" 7 (vector 5 0 depth))

     (pdata-set! "n" 4 (vector 1 0 0))
     (pdata-set! "n" 5 (vector 1 0 0))
     (pdata-set! "n" 6 (vector 1 0 0))
     (pdata-set! "n" 7 (vector 1 0 0))

     (pdata-set! "p" 8 (vector 5 0 depth))
     (pdata-set! "p" 9 (vector 5 0 0))
     (pdata-set! "p" 10 (vector -1 0 0))
     (pdata-set! "p" 11 (vector -1 0 depth))

     (pdata-set! "n" 8 (vector 0 -1 0))
     (pdata-set! "n" 9 (vector 0 -1 0))
     (pdata-set! "n" 10 (vector 0 -1 0))
     (pdata-set! "n" 11 (vector 0 -1 0))

     (pdata-set! "p" 12 (vector -1 0 depth))
     (pdata-set! "p" 13 (vector -1 0 0))
     (pdata-set! "p" 14 (vector -1 1 0))
     (pdata-set! "p" 15 (vector -1 1 depth))

     (pdata-set! "n" 12 (vector -1 0 0))
     (pdata-set! "n" 13 (vector -1 0 0))
     (pdata-set! "n" 14 (vector -1 0 0))
     (pdata-set! "n" 15 (vector -1 0 0)))
    (else
     (pdata-set! "p" 0 (vector 0 0 0))
     (pdata-set! "p" 1 (vector 0 0 depth))
     (pdata-set! "p" 2 (vector 5 0 depth))
     (pdata-set! "p" 3 (vector 5 0 0))
     (pdata-set! "n" 0 (vector 0 -1 0))
     (pdata-set! "n" 1 (vector 0 -1 0))
     (pdata-set! "n" 2 (vector 0 -1 0))
     (pdata-set! "n" 3 (vector 0 -1 0))

     (pdata-set! "p" 4 (vector 5 0 0))
     (pdata-set! "p" 5 (vector 5 0 depth))
     (pdata-set! "p" 6 (vector 5 1 depth))
     (pdata-set! "p" 7 (vector 5 1 0))
     (pdata-set! "n" 4 (vector 1 0 0))
     (pdata-set! "n" 5 (vector 1 0 0))
     (pdata-set! "n" 6 (vector 1 0 0))
     (pdata-set! "n" 7 (vector 1 0 0))

     (pdata-set! "p" 8 (vector 5 1 0))
     (pdata-set! "p" 9 (vector 5 1 depth))
     (pdata-set! "p" 10 (vector -1 1 depth))
     (pdata-set! "p" 11 (vector -1 1 0))
     (pdata-set! "n" 8 (vector 0 1 0))
     (pdata-set! "n" 9 (vector 0 1 0))
     (pdata-set! "n" 10 (vector 0 1 0))
     (pdata-set! "n" 11 (vector 0 1 0))

     (pdata-set! "p" 12 (vector 0 0 depth))
     (pdata-set! "p" 13 (vector 0 0 0))
     (pdata-set! "p" 14 (vector 0 0 0)) ; --
     (pdata-set! "p" 15 (vector 0 0 depth)) ; --
     (pdata-set! "n" 12 (vector 1 0 0))
     (pdata-set! "n" 13 (vector 1 0 0))
     (pdata-set! "n" 14 (vector 1 0 0))
     (pdata-set! "n" 15 (vector 1 0 0))

     (pdata-set! "p" 16 (vector -1 1 0))
     (pdata-set! "p" 17 (vector -1 1 depth))
     (pdata-set! "p" 18 (vector -1 -1 depth)) ;--
     (pdata-set! "p" 19 (vector -1 -1 0)) ;--
     (pdata-set! "n" 16 (vector -1 0 0))
     (pdata-set! "n" 17 (vector -1 0 0))
     (pdata-set! "n" 18 (vector -1 0 0))
     (pdata-set! "n" 19 (vector -1 0 0))

     (pdata-set! "p" 20 (vector -1 -1 0)) ;--
     (pdata-set! "p" 21 (vector -1 -1 depth)) ;--
     (pdata-set! "p" 22 (vector 5 -1 depth)) ;--
     (pdata-set! "p" 23 (vector 5 -1 0)) ;--
     (pdata-set! "n" 20 (vector 0 -1 0))
     (pdata-set! "n" 21 (vector 0 -1 0))
     (pdata-set! "n" 22 (vector 0 -1 0))
     (pdata-set! "n" 23 (vector 0 -1 0))

     (pdata-set! "p" 24 (vector 5 -1 0)) ;--
     (pdata-set! "p" 25 (vector 5 -1 depth)) ;--
     (pdata-set! "p" 26 (vector 5 0 depth)) ;--
     (pdata-set! "p" 27 (vector 5 0 0)) ;--
     (pdata-set! "n" 24 (vector 1 0 0))
     (pdata-set! "n" 25 (vector 1 0 0))
     (pdata-set! "n" 26 (vector 1 0 0))
     (pdata-set! "n" 27 (vector 1 0 0))

     (pdata-set! "p" 28 (vector 5 0 0)) ;--
     (pdata-set! "p" 29 (vector 5 0 depth)) ;--
     (pdata-set! "p" 30 (vector 0 0 depth)) ; --
     (pdata-set! "p" 31 (vector 0 0 0)) ; --
     (pdata-set! "n" 28 (vector 0 1 0))
     (pdata-set! "n" 29 (vector 0 1 0))
     (pdata-set! "n" 30 (vector 0 1 0))
     (pdata-set! "n" 31 (vector 0 1 0))))

   (pdata-map!
    (lambda (p)
      (if (< (vz p) (/ depth 2))
      (vadd p (vector 0.5 0.5 0))
      p))
    "p")
   
   (pdata-copy "p" "pref")))

  (list text children empty-ghost prim text-prim depth-shape-prim #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 col-stop-a (vector 1 0 0.5))
(define col-stop-b (vector 1 1 0))
(define col-stop-c (vector 0.5 0 1))

(define (brick-col d)
  (vlerp
   col-stop-a 
   (vlerp col-stop-b col-stop-c (/ (modulo (quotient d 3) 7) 7))
   (/ (modulo d 4) 4)))

(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)
   (for ((i (in-range 4 8)))
        (pdata-set! "p" i (vadd (pdata-ref "pref" i) (vector 0 (- n) 0)))))
  (with-primitive
   (brick-depth b)
   (for-each (lambda (i)
               (pdata-set! "p" i (vadd (pdata-ref "pref" i) (vector 0 (- n) 0))))
             (list 14 15))
   (for ((i (in-range 18 32)))
        (pdata-set! "p" i (vadd (pdata-ref "pref" i) (vector 0 (- n) 0))))))

(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)
        (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)
  (if (brick-is-atom? b)
      (brick-text b)
      (string-append
       (remove-last
        (string-append "(" (brick-text b) " "
                       (apply string-append
                              (map
                               (lambda (child)
                                 (string-append
                                  (brick->text child do-insert) " "))
                               (brick-children b)))))
       (if do-insert (brick-code-inserts b) "") ")")))

(define (brick->sexpr b)
  (if (brick-is-atom? b)
      (string->symbol (brick-text b))
      (apply
       list
       (cons
        (string->symbol (brick-text b))
        (map brick->sexpr (brick-children b))))))

(define (brick-pos->slot b pos)
  (let ((relative-y
         (vy (vsub
              (with-primitive
               (brick-id b)
               (vtransform (vector 0 0 0) (get-global-transform)))
              pos))))
    (car (foldl
          (lambda (child r)
            (list
             ;; if we are lower than relative-y
             (if (< (+ (cadr r) drop-fudge) relative-y)
                 (+ (car r) 1) ; keep adding
                 (car r)) ; return this index
             (+ (cadr r) (brick-size child))))
          (list 0 1) ; index, y
          (brick-children b)))))

(define (brick-update-ghost b pos size)
  (brick-modify-ghost
   (lambda (g) (list (brick-pos->slot b pos) size))
   b))

(define (brick-dock b new)
  (cond ((or (brick-parent-locked b)
             (brick-locked b)) b)
        (else
         (with-primitive
          (brick-id new)
          (identity)
          (parent (brick-id b)))
         (brick-modify-children
          (lambda (children)
            (insert-to new (ghost-pos (brick-ghost b)) children))
          (brick-clear-ghost b)))))

(define (brick-undock b id)
  (cond ((or (brick-locked b)
             (brick-parent-locked b)) b)
        (else
         (with-primitive id (detach-parent))
         (brick-modify-children
          (lambda (children)
            (filter
             (lambda (b)
               (not (eqv? (brick-id b) id)))
             children))
          b))))

; update the primitive and children to match the state
(define (brick-update! b d)
  (with-primitive
   (brick-text-prim b)
   (set-text (brick-text b)))
  (with-primitive
   (brick-id b)
   (colour (brick-col d)))
  (with-primitive
   (brick-depth b)
   (colour (brick-col d)))
  (when (not (brick-is-atom? b))
        (let ((size
               (car
                (foldl
                 (lambda (child p)
                   (with-primitive
                    (brick-id child)
                    (identity)
                    (parent (brick-id b))
                    (when (brick-locked b) (translate (vector 0 (* (cadr p) -1.3) 0)))
                    (translate (vector 1 (- (car p)) 0)))
                   (brick-update! child (+ d 1))
                   (list
                    (if (and (ghost-pos (brick-ghost b))
                             (eq? (ghost-pos (brick-ghost b))
                                  (+ (cadr p)
                                     (ghost-size (brick-ghost b)))))
                        ;; insert ghost
                        (+ (car p) (brick-size child)
                           (ghost-size (brick-ghost b)))
                        (+ (car p) (brick-size child)))
                    (+ (cadr p) 1)))
                 (list
                  (if (and (ghost-pos (brick-ghost b))
                           (eq? (ghost-pos (brick-ghost b)) 0))
                      (+ 1 (ghost-size (brick-ghost b))) 1)
                  0) ; y, index
                 (brick-children b)))))
          (brick-expand! b (- size 1)))))

#;(define (brick-intersect b line)
  (with-primitive
   (brick-id b)
   (let ((p (geo/line-intersect (vtransform (car line) (minverse (get-global-transform)))
                                (vtransform (cadr line) (minverse (get-global-transform)))))
         (m (get-global-transform)))
     (if (not (null? p))
         b
         (if (not (brick-is-atom? b))
             (foldl
              (lambda (child r)
                (if (not r) (brick-intersect child line) r))
              #f
              (brick-children b))
             #f)))))

(define (brick-intersect b pos)
  (let ((hit (if (not (brick-is-atom? b))
                 (foldl
                  (lambda (child r)
                    (if (not r) (brick-intersect child pos) r))
                  #f
                  (brick-children b))
                 #f)))
    (if (not hit)
        (with-primitive
         (brick-id b)
         (recalc-bb)
         (if (bb/point-intersect? pos 0.1) b #f))
        hit)))

(define (brick-intersect-no-atoms b pos)
  (if (not (brick-is-atom? b))
      (let ((hit (foldl
                  (lambda (child r)
                    (if (not r) (brick-intersect-no-atoms child pos) r))
                  #f
                  (brick-children b))))
        (if (not hit)
            (with-primitive
             (brick-id b)
             (recalc-bb)
             (if (bb/point-intersect? pos 0.1) b #f))
            hit))
      #f))

;---------------------------------------------------------

(define (make-bricks)
  (list '() (vector 0 0 0) #f #f #f #f #f '() #f
        (let* ((p (open-input-file "history/persist.scm"))
               (r (read p)))
          (println "history level is: " r)
          (close-input-port p)
          r)))

(define (bricks-roots b) (list-ref b 0))
(define (bricks-modify-roots f b) (list-replace b 0 (f (bricks-roots b))))
(define (bricks-mouse b) (list-ref b 1))
(define (bricks-modify-mouse f b) (list-replace b 1 (f (bricks-mouse b))))
(define (bricks-button b) (list-ref b 2))
(define (bricks-modify-button f b) (list-replace b 2 (f (bricks-button b))))
(define (bricks-current b) (list-ref b 3))
(define (bricks-modify-current f b) (list-replace b 3 (f (bricks-current b))))
(define (bricks-drop-over b) (list-ref b 4))
(define (bricks-modify-drop-over f b) (list-replace b 4 (f (bricks-drop-over b))))
(define (bricks-typing b) (list-ref b 5))
(define (bricks-modify-typing f b) (list-replace b 5 (f (bricks-typing b))))
(define (bricks-typing-current b) (list-ref b 6))
(define (bricks-modify-typing-current f b) (list-replace b 6 (f (bricks-typing-current b))))
(define (bricks-keys b) (list-ref b 7))
(define (bricks-modify-keys f b) (list-replace b 7 (f (bricks-keys b))))
(define (bricks-code-current b) (list-ref b 8))
(define (bricks-modify-code-current f b) (list-replace b 8 (f (bricks-code-current b))))
(define (bricks-history b) (list-ref b 9))
(define (bricks-modify-history f b) (list-replace b 9 (f (bricks-history b))))

(define (bricks-save b fn)
  (let ((f (open-output-file fn #:exists 'replace)))
    (write
     (map
      (lambda (root)
        (list
         (with-primitive (brick-id root) (get-global-transform))
         (brick->text root #f)))
      (filter (lambda (root) (not (brick-locked root))) (bricks-roots b)))
     f)
    (close-output-port f)))

(define (bricks-load b fn)
  (let* ((f (open-input-file fn))
         (ret (foldl
               (lambda (e b)
                 (println "-" (cadr e) "-")
                 (if (not (string=? (cadr e) ""))
                     (let ((brick
                            (code->brick
                             (eval-string
                              (string-append "'" (cadr e))))))
                       (with-primitive
                        (brick-id brick)
                        (concat (car e)))
                       (bricks-add-root b brick))
                     b))
               b
               (read f))))
    (close-input-port f)
    ret))

(define (get-max-history)
  (let* ((f (open-input-file "history/persist.scm"))
         (max (read f)))
    (close-input-port f)
    max))

(define (increase-history!)
  (let* ((h (get-max-history))
         (f (open-output-file "history/persist.scm" #:exists 'replace)))
    (write (+ h 1) f)
    (close-output-port f)
    (+ h 1)))

(define (bricks-load-history b)
  (bricks-load
   (bricks-clear b)
   (string-append
    "history/"
    (number->string (bricks-history b))
    ".scm")))

(define (bricks-save-history! b)
  (bricks-save
   b
   (string-append
    "history/"
    (number->string (increase-history!))
    ".scm")))

(define (bricks-modify-brick fn b id)
  (bricks-modify-roots
   (lambda (roots)
     (map
      (lambda (root)
        (brick-modify-brick fn root id))
      roots))
   b))

(define (bricks-delete b brick)
  (let* ((id (brick-id brick))
         (parent (bricks-search-for-parent b id))
         (new-b (if parent
                    (bricks-modify-brick
                     (lambda (parent)
                       (brick-undock parent id))
                     b (brick-id parent))
                    (bricks-modify-roots
                     (lambda (roots)
                       (filter
                        (lambda (r)
                          (not (eq? (brick-id r) id)))
                        roots))
                     b))))
    (brick-destroy! brick) ;; destroy after potentially undocking
    new-b))

(define (bricks-palette b) (car (bricks-roots b)))

(define (bricks-add-root b root)
  (bricks-modify-roots
   (lambda (roots)
  add to end so palette is always first element
     (append roots (list root)))
   b))

(define (bricks-remove-root b id)
  (bricks-modify-roots
   (lambda (roots)
     (filter (lambda (root) (not (eq? id (brick-id root)))) roots))
   b))

(define (bricks-clear b)
  (for-each
   (lambda (root)
     (when (not (brick-locked root))
           (brick-destroy! root)))
   (bricks-roots b))
  (bricks-modify-roots
   (lambda (r) (list (car r)))
   (bricks-modify-code-current
    (lambda (c) #f)
    (bricks-modify-typing-current
     (lambda (t) #f)
     b))))

(define (bricks->text b)
  (apply
   string-append
   (map brick->text
        (filter (lambda (brx)
                  (not (brick-locked brx)))
                (bricks-roots b))
        #f)))

(define (bricks->sexpr b)
  (apply list (map brick->sexpr (bricks-roots b))))

(define (bricks-add-clone b brick)
  (bricks-add-root b (code->brick (brick->code brick))))

(define (bricks-add-spawn b brick)
  (let ((copy (code->brick (brick->code brick)))
        ;; copy the transform
        (tx (with-primitive (brick-id brick) (get-global-transform))))
    (brick-for-each
     (lambda (brick)
       (brick-transparent! brick drag-transparent)) ;; make transparent as we are dragging
     copy)
    (with-primitive (brick-id copy) (identity) (concat tx) (scale 2))
    (bricks-modify-current
     (lambda (c) copy)
     (bricks-add-root b copy))))

(define (bricks-add-code b code)
  (bricks-add-root b (code->brick code)))

(define (bricks-get-over b pos)
  (foldl
   (lambda (brick r)
     (if (and
          (not r) ;; not found anything yet
          (or
           (not (bricks-current b)) ;; not dragging anything
           ;; what we are dragging is not this
           (not (eq? (brick-id brick) (brick-id (bricks-current b))))))
         (brick-intersect brick pos)
         r))
   #f
   (bricks-roots b)))

(define (bricks-get-over-no-atoms b pos)
  (foldl
   (lambda (brick r)
     (if (and
          (not r) ;; not found anything yet
          (or
           (not (bricks-current b)) ;; not dragging anything
           ;; what we are dragging is not this
           (not (eq? (brick-id brick) (brick-id (bricks-current b))))))
         (brick-intersect-no-atoms brick pos)
         r))
   #f
   (bricks-roots b)))

;; look for the brick with id
(define (bricks-search b id)
  (foldl
   (lambda (b r)
     (if (not r) (brick-search b id) r))
   #f
   (bricks-roots b)))

  look for the brick which is the parent of the supplied one
(define (bricks-search-for-parent b id)
  (foldl
   (lambda (b r)
     (if (not r) (brick-search-for-parent b id) r))
   #f
   (bricks-roots b)))

;; find out which root a brick belongs to
(define (bricks-root-search b id)
  (foldl
   (lambda (root r)
     (if (and (not r) (brick-search root id))
         root r))
   #f
   (bricks-roots b)))

(define (bricks-mouse-down b)
  (and (mouse-button 1) (not (bricks-button b))))

(define (bricks-mouse-up b)
  (and (not (mouse-button 1)) (bricks-button b)))

(define (bricks-key-pressed? b key)
  (in-list? key (bricks-keys b)))

(define (keys-contains-enter? keys)
  (foldl
   (lambda (key r)
     (if (and (not r) (eq? (char->integer key) 13)) ; return
         #t r))
   #f
   keys))

(define (bricks-type-into b bx keys-pressed)
  ;; modify the brick text based on the keys pressed
  (foldl
   (lambda (key r)
     (if (char? key)
         (cond
  delete ( 128 on  )
           (if (> (string-length (brick-text r)) 0)
               (brick-modify-text
                (lambda (t)
                  (substring
                   t 0 (- (string-length t) 1)))
                r) r))
          (else
           (brick-modify-text
            (lambda (t)
              (string-append t (string key)))
            r)))
         r))
   bx
   keys-pressed))

(define (bricks-do-keys b pos)
  ;; get keys pressed since last update
  (let ((keys-pressed
         (filter
          (lambda (key)
            (not (in-list? key (bricks-keys b))))
          (keys-down))))
    (bricks-modify-keys
     (lambda (k) (keys-down))
     ;; dispatch
     (cond
      ;; do typing if we have a current brick
      ((bricks-typing-current b)
       (bricks-modify-brick
        (lambda (bx)
          ;; don't put returns into the code text...
          (if (not (keys-contains-enter? keys-pressed))
              (bricks-type-into b bx keys-pressed)
              bx))
        (if (keys-contains-enter? keys-pressed)
            (bricks-modify-typing-current
             (lambda (t) #f)
             b)
            b)
        (brick-id (bricks-typing-current b))))

      ;; do execute key if we have a code selection
      ((and (in-list? #\x keys-pressed)
            (bricks-code-current b))
       (let ((current (bricks-search b (bricks-code-current b))))
         (bricks-save-history! b)
         (broadcast 1 (brick->text current #t))
         (eval-string (brick->text current #t)
                      (lambda (error)
                        (broadcast 5 (exn-message error))))
         b))

      ;; do copy when code selection is active
      ((and (in-list? #\C keys-pressed)
            (bricks-code-current b))
       (bricks-add-root
        b
        (code->brick
         (brick->code (bricks-search b (bricks-code-current b))))))

      ;; keyboard alt for middle mouse (h)
      ((in-list? #\h keys-pressed)
       (bricks-modify-code-current
        (lambda (o)
          (let ((brick (bricks-get-over b pos)))
            (if brick (brick-id brick) #f)))
        b))

      ;; o saves
      ((in-list? #\o keys-pressed)
       (bricks-save b "test.scm")
       b)
      ((in-list? #\p keys-pressed)
       (bricks-load b "test.scm"))

      ;; undo - load last saved history and set current
      ((in-list? #\m keys-pressed)
       (bricks-load-history
        (bricks-modify-history
	 (lambda (h)
	   (let* ((p (open-input-file "history/persist.scm"))
		  (r (read p)))
	     (println "history level is: " r)
	     (close-input-port p)
	     r))
	 b)))
      
      ;; history navigation, backwards
      ((in-list? #\, keys-pressed)
       (bricks-load-history
        (bricks-modify-history
         (lambda (h) (max 1 (- h 1))) b)))

      ;; history navigation, forwards
      ((in-list? #\. keys-pressed)
       (let* ((f (open-input-file "history/persist.scm"))
              (max (read f)))
         (close-input-port f)
         (bricks-load-history
          (bricks-modify-history
           (lambda (h) (min max (+ h 1))) b))))

      ((in-list? #\P keys-pressed)
       (let ((brick (bricks-get-over b pos)))
         (if brick (bricks-delete b brick)
             b)))

      (else b)))))

(define (bricks-do-dragging b pos)
  ;; find what is underneath
  (let* ((temp (bricks-get-over-no-atoms b pos))
         (over (if (and temp (brick-is-atom? temp)) #f temp))
         (old-over (bricks-drop-over b)))
    (bricks-modify-drop-over
     (lambda (dropover) over)
     (if (and over (not (brick-parent-locked over)))
         ;; update the ghost position
         (bricks-modify-brick
          (lambda (over)
            (brick-update-ghost over pos (brick-size (bricks-current b))))
          (if old-over
              ;; update the ghost for the old over brick
              (bricks-modify-brick
               (lambda (over)
                 (brick-clear-ghost over))
               b
               (brick-id old-over))
              b)
          (brick-id over))
         b))))

(define (bricks-update-current b pos)
  (bricks-modify-current
   (lambda (current)
     (cond
      ((bricks-mouse-down b)
       (let ((c (bricks-get-over b pos)))
         (when (and c (not (brick-parent-locked c)))
               (brick-for-each
                (lambda (c)
                  (brick-transparent! c drag-transparent))
                c))
     (display c)(newline)
         c))
      ((bricks-mouse-up b)
       (when current
             (brick-for-each
              (lambda (c)
                (brick-opaque! c))
              current))
       #f)
      (else current)))
   ;; if we are dragging something
   (if (bricks-current b)
       (bricks-do-dragging b pos)
       b)))

(define (bricks-do-mouse-wheel b pos)
  (let ((over (bricks-get-over b pos)))
    (when over
          (let ((root (bricks-root-search b (brick-id over))))
            (if (brick-locked root) ;; it's the palette, translate
                (with-primitive
                 (brick-id root)
                 (when (or (< (mouse-wheel) 0) (key-special-pressed 103))
                       (translate (vector 0 6 0)))
                 (when (or (> (mouse-wheel) 0) (key-special-pressed 101))
                       (translate (vector 0 -6 0))))
                (with-primitive  ;; it's a normal brick, scale
                 (brick-id root)
                 (let* ((t (get-transform))
                        (d (vsub pos (vtransform (vector 0 0 0) (get-transform))))
                        (d2 (vmul d (/ 1 (vector-ref (get-transform) 0)))))
                   (when (or (< (mouse-wheel) 0) (key-special-pressed 103))
                         (translate d2)
                         (scale (vector 0.9 0.9 0.9))
                         (translate (vmul d2 -1)))
                   (when (or (> (mouse-wheel) 0) (key-special-pressed 101))
                         (translate d2)
                         (scale (vector 1.1 1.1 1.1))
                         (translate (vmul d2 -1))
                         ))))))
    b))

(define (bricks-do-input b pos)
  (bricks-do-mouse-wheel
   (bricks-do-keys
    (bricks-modify-mouse
     (lambda (m) pos)
     (bricks-modify-code-current
      (lambda (o)
        (if (mouse-button 2)
            (let ((brick (bricks-get-over b pos)))
              (if brick (brick-id brick) #f))
            o))
      (bricks-modify-typing
       (lambda (t) (mouse-button 3))
       (bricks-modify-button
        (lambda (button) (mouse-button 1))
        ;; keep track of the selection
        (bricks-update-current b pos))))) pos) pos))

(define (bricks-drag-start? b new-b)
  (and (not (list? (bricks-current b)))
       (list? (bricks-current new-b))))

(define (bricks-drag-end? b new-b)
  (and (list? (bricks-current b))
       (not (list? (bricks-current new-b)))))

(define (bricks-over-out? b new-b)
  (and (list? (bricks-drop-over b))
       (not (list? (bricks-drop-over new-b)))))

(define (bricks-do-docking b new-b)
  ;; check for brick to dock
  (if (and (bricks-drag-end? b new-b)
           (bricks-drop-over new-b)
           ;; don't want to dock with the palette (or do we?...)
           (not (brick-parent-locked (bricks-drop-over new-b))))
      ;; note - assume if drop over exists, then current must also exist
      (let* ((id (brick-id (bricks-current b)))
             (new-parent-id (brick-id (bricks-drop-over new-b))))
        (bricks-remove-root
         (bricks-modify-brick
          (lambda (new-parent)
            ;; docks to the ghost location
            (brick-dock new-parent (bricks-current b)))
          new-b
          new-parent-id)
         id))
      new-b))

(define (bricks-do-undocking b new-b)
  ;; check for brick to undock
  (if (bricks-drag-start? b new-b)
      (let* ((id (brick-id (bricks-current new-b)))
             (prnt (bricks-search-for-parent b id)))
        (if prnt ;; can't undock from root
            (if (or (brick-locked prnt)
                    (brick-parent-locked prnt))
                ;; for the pallette... make a copy
                (bricks-add-spawn new-b (bricks-current new-b))
                ;; add as new root
                (bricks-add-root
                 ;; undock from parent
                 (bricks-modify-brick
                  (lambda (parent)
                    (brick-undock parent id))
                  new-b
                  (brick-id prnt))
                 (bricks-current new-b)))
            new-b))
      new-b))

(define (bricks-remove-ghost b new-b)
  ;; check for brick to undock
  (if (bricks-over-out? b new-b)
      (let* ((id (brick-id (bricks-drop-over b))))
        (bricks-modify-brick
         (lambda (over)
           (brick-clear-ghost over))
         new-b
         id))
      new-b))

(define (bricks-do-typing b new-b pos)
  (if (and (not (bricks-typing b))
           (bricks-typing new-b))
      (bricks-modify-typing-current
       (lambda (t)
         (bricks-get-over new-b pos))
       new-b)
      new-b))

(define (bricks-do-glow! b)
  (let ((tc (bricks-typing-current b)))
    (when tc
          (brick-text-glow! (brick-id tc))
          (brick-text-glow! (brick-depth tc)))

  (let ((tc (bricks-code-current b)))
    (when tc
          (brick-code-glow! tc)
          #;(brick-code-glow! (brick-depth tc))))))

(define (bricks-update! b)
  (let* ((pos (vadd (vector 0 drop-fudge 0) (get-point-from-mouse))))
    #;(with-primitive pointer
                    (identity)
                    (translate pos))
    (when
    ; update bricks when mouse button is held down
  TODO - check for optimisation
     (or #t (bricks-button b))
      (for-each
       (lambda (b)
         (brick-update! b 0))
       (bricks-roots b)))

    (bricks-do-glow! b)

    ; move the current brick
    (when (list? (bricks-current b))
          (with-primitive
           (brick-id (bricks-current b))
           (when (and (mouse-button 1) (bricks-button b))
                 (translate (vdiv
                             (vsub pos (bricks-mouse b))
                             (* (brick-get-scale (bricks-current b))
                                lag-fudge))))))

    ; update the input stuff
    (bricks-do-typing
     b (bricks-remove-ghost
        b (bricks-do-docking
           b (bricks-do-undocking
              b (bricks-do-input b pos)))) pos)))

;---------------------------------------------------------

(clear)
;(hint-depth-sort)

(ortho)
(set-ortho-zoom 30)

  ancient fluxus bug
(define light-setup 0)

(define (setup-lights)
  (cond
   ((eq? light-setup 5)
    (light-diffuse 0 (vector 0 0 0))
    (light-specular 0 (vector 0 0 0))
    (light-ambient 0 (vector 1 1 1))
    (define mylight (make-light 'directional 'free))
    (display mylight)(newline)
    (light-position mylight (vector 0 0 0))
    (light-direction mylight (vector 0.3 0.7 1))
    (light-diffuse mylight (vector 1.5 1.5 1.5))
    (light-ambient mylight (vector 0 0 0))
    (set! light-setup 10))
   (else (set! light-setup (+ light-setup 1)))))

(set-camera-transform
 (mtranslate (vector 0 0 -30)))



(define b
  (bricks-add-code
   (make-bricks)
   palette))

;; activate palette
(set! b (bricks-modify-brick
         (lambda (palette)
           (brick-for-each
            (lambda (c)
              (with-primitive
               (brick-id c)
               (opacity 0.8))
              (with-primitive
               (brick-depth c)
               (opacity 0.8)))
            palette)
           ;; collapse the verts as we want to hide, but want to
           ;; keep the children visible
           (with-primitive (brick-id palette)
                           (translate (vector 25 10 0))
                           (scale 0.7)
                           (opacity 0)
                           (hint-nozwrite))
           (with-primitive (brick-depth palette)
                           (opacity 0)
                           (hint-nozwrite))
           (brick-modify-locked
            (lambda (l) #t)
            (brick-modify-all-children
             (lambda (c)
               (brick-modify-parent-locked
                (lambda (p) #t) c))
             palette)))
         b
         (brick-id (bricks-palette b))))

(define pointer (with-state (scale 0.1) (build-cube)))

(set-scale pentatonic-major)
(bootstrap (lambda () zop))
	   
( clear - colour ( vector 0.5 0.2 0.1 ) )
(define t (with-state
           (translate (vector -28 -20 0))
           (scale (vector 1 1 1))
           (colour (vector 0 0.5 1)) (build-cube)))

(set! b (bricks-load b "scenes/framework.scm"))
;;(set! b (bricks-load b "scenes/mellow.scm"))
;;(set! b (bricks-load b "scenes/.scm"))
;;(when sound-check (set! b (bricks-load b "sc2.scm")))
;;(when sound-fac (set! b (bricks-load b "fac.scm")))
;(set! b (bricks-load b "click.scm"))

(every-frame
 (begin
   (with-primitive pointer
                   (identity)
                   (translate (get-point-from-mouse))
                   (scale 0.1))
   (set! b (bricks-update! b))
   (setup-lights)
   (with-primitive t (rotate (vector 1 2 3)))))


 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
(clear-pings!)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 maths hacks, move to fluxa
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(hint-none)(hint-wire)
 --
 --
--
--
--
--
--
--
--
--
--
--
--
--
 --
 --
 for the palette
 set manually when creating the palette
 search children
 search children
 already found
 search children
(hint-nozwrite)
(hint-nozwrite)
 atom
 empty list
 list starting with atom
 anoymous list
 does the flashing when it plays the sound business
 if we are lower than relative-y
 keep adding
 return this index
 index, y
 update the primitive and children to match the state
 insert ghost
 y, index
(define (brick-intersect b line)
---------------------------------------------------------
 destroy after potentially undocking
 copy the transform
 make transparent as we are dragging
 not found anything yet
 not dragging anything
 what we are dragging is not this
 not found anything yet
 not dragging anything
 what we are dragging is not this
 look for the brick with id
 find out which root a brick belongs to
 return
 modify the brick text based on the keys pressed
 get keys pressed since last update
 dispatch
 do typing if we have a current brick
 don't put returns into the code text...
 do execute key if we have a code selection
 do copy when code selection is active
 keyboard alt for middle mouse (h)
 o saves
 undo - load last saved history and set current
 history navigation, backwards
 history navigation, forwards
 find what is underneath
 update the ghost position
 update the ghost for the old over brick
 if we are dragging something
 it's the palette, translate
 it's a normal brick, scale
 keep track of the selection
 check for brick to dock
 don't want to dock with the palette (or do we?...)
 note - assume if drop over exists, then current must also exist
 docks to the ghost location
 check for brick to undock
 can't undock from root
 for the pallette... make a copy
 add as new root
 undock from parent
 check for brick to undock
(brick-code-glow! (brick-depth tc))))))
(with-primitive pointer
 update bricks when mouse button is held down
 move the current brick
 update the input stuff
---------------------------------------------------------
(hint-depth-sort)
 activate palette
 collapse the verts as we want to hide, but want to
 keep the children visible
(set! b (bricks-load b "scenes/mellow.scm"))
(set! b (bricks-load b "scenes/.scm"))
(when sound-check (set! b (bricks-load b "sc2.scm")))
(when sound-fac (set! b (bricks-load b "fac.scm")))
(set! b (bricks-load b "click.scm"))
  [ Copyright ( C ) 2012   :  see LICENCE ]




(require mzlib/string)

(require fluxus/fluxa)
(define drop-fudge 0)
(define lag-fudge 0.7)
(define drag-transparent 0.75)

(set-global-offset 0)

(define sound-check #f)
(define sound-fac #f)

(define (reset)
  (searchpath "/home/dave/noiz/nm/")
  (reload)
  )

(volume 2)
(eq 1 1 1)

(reset)

(define palette '(() (play-now) (seq) (lambda) (reset) (reload) time clock sync-tempo
                  0 0.1 440 (play) (+) (*) (/) (-) (sine) (squ) (saw)
                  (white) (pink) (sample) (adsr 0 0.1 0 0) (mooglp)
                  (rndf) (note)
          (bootstrap (lambda () zop))
          (define (zop time clock zap)
            (if (modeq? clock 8) 
            (in time 0.5 zopp (+ clock 1) zap) 
            (in time 0.5 zop (+ clock 1) zap)))
                  (modulo clock 8)
          (note (* 2 (+ (modulo clock 3) (modulo clock 4))))
          (pick (list 0.1 0.2) clock)
          (crush (pick (list 0.02 0.1 3 2 10) clock) 10)
          (sine (* 200 (adsr 0 0.1 0.3 1)))
          (mooghp (pink 10) (sine 0.1) 1)
          (set-scale ethiopian) 
          (set-scale lydian) 
	  (play time (* (adsr 0 0.1 0.1 1)))
          (tb (saw 440) (* (adsr 0 0.1 0 0) (pick (list 0 0.3 0.5 1 0.8) clock)) 0.4)
	  (ks (random 1000) 0.9 0.1)
	  (pad 220 (* (modulo clock 5) 0.001) 0.5 0.6)
          (* (adsr 0 0.1 0.1 1) (sine 100) (sine 400))
          (sine (+ 100 (* 400 (sine 400))))
	  (+ 0.5 (* 0.5 (sine 1)))
	  (sine (+ 110 (* (adsr (pick (list 0.2 0 0 0) clock) (pick (list 0.3 0.01 0.2) clock) 0.1 1) (pick (list 400 440 80) clock) (sine (/ (note (modulo zap 7)) 4)))))
	  (sample (pick (list "MA.WAV" "SD2500.WAV" "LC25.WAV" "CL.WAV" "CH.WAV") clock) 300)
	  (sample (pick (list "ij.wav" "ih.wav" "ik.wav" "id.wav" "il.wav" "ic.wav") clock) (* 50 (+ (modulor zap 8) (modulo clock 5))))
	  (* 2 (sample (pick (list "b1.wav" "b2.wav" "b3.wav") zap) 440))
	  ))

(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 (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))))))



(define last-aspect 0)

(define (get-line-from-mouse)
  (let* ((aspect (/ (vy (get-screen-size)) (vx (get-screen-size))))
     (ndcpos (vector
          (* (- (/ (mouse-x) (vx (get-screen-size))) 0.5) 2)
          (* (- (- (/ (mouse-y) (vy (get-screen-size))) 0.5)) (* 2 aspect))
          -1))
        (scrpos2 (vtransform (vmul ndcpos 500) (minverse (get-camera-transform))))
    (scrpos (vtransform ndcpos (minverse (get-camera-transform)))))
    (when (not (eq? aspect last-aspect))
      (frustum -1 1 (- aspect) aspect))
    (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 "oolite-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))

(define (make-brick text children)
  (let* ((atom (not children))
         (prim (build-polygons (if atom 4 8) 'triangle-strip))
         (depth-shape-prim (build-polygons (if atom 16 32) 'quad-list))
         (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 "oolite-font.png"
                                             (list 'generate-mipmaps 0 'mip-level 0)))
                      (let ((text-prim (build-text text)))
                        (with-primitive
                         text-prim
                         (set-text text))
                        text-prim))))
    (with-primitive
     prim
     (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"))

    (let ((depth -3))

      
  (with-primitive
   depth-shape-prim
   (parent prim)
   (cond
    (atom
     (pdata-set! "p" 0 (vector -1 1 depth))
     (pdata-set! "p" 1 (vector -1 1 0))
     (pdata-set! "p" 2 (vector 5 1 0))
     (pdata-set! "p" 3 (vector 5 1 depth))

     (pdata-set! "n" 0 (vector 0 1 0))
     (pdata-set! "n" 1 (vector 0 1 0))
     (pdata-set! "n" 2 (vector 0 1 0))
     (pdata-set! "n" 3 (vector 0 1 0))

     (pdata-set! "p" 4 (vector 5 1 depth))
     (pdata-set! "p" 5 (vector 5 1 0))
     (pdata-set! "p" 6 (vector 5 0 0))
     (pdata-set! "p" 7 (vector 5 0 depth))

     (pdata-set! "n" 4 (vector 1 0 0))
     (pdata-set! "n" 5 (vector 1 0 0))
     (pdata-set! "n" 6 (vector 1 0 0))
     (pdata-set! "n" 7 (vector 1 0 0))

     (pdata-set! "p" 8 (vector 5 0 depth))
     (pdata-set! "p" 9 (vector 5 0 0))
     (pdata-set! "p" 10 (vector -1 0 0))
     (pdata-set! "p" 11 (vector -1 0 depth))

     (pdata-set! "n" 8 (vector 0 -1 0))
     (pdata-set! "n" 9 (vector 0 -1 0))
     (pdata-set! "n" 10 (vector 0 -1 0))
     (pdata-set! "n" 11 (vector 0 -1 0))

     (pdata-set! "p" 12 (vector -1 0 depth))
     (pdata-set! "p" 13 (vector -1 0 0))
     (pdata-set! "p" 14 (vector -1 1 0))
     (pdata-set! "p" 15 (vector -1 1 depth))

     (pdata-set! "n" 12 (vector -1 0 0))
     (pdata-set! "n" 13 (vector -1 0 0))
     (pdata-set! "n" 14 (vector -1 0 0))
     (pdata-set! "n" 15 (vector -1 0 0)))
    (else
     (pdata-set! "p" 0 (vector 0 0 0))
     (pdata-set! "p" 1 (vector 0 0 depth))
     (pdata-set! "p" 2 (vector 5 0 depth))
     (pdata-set! "p" 3 (vector 5 0 0))
     (pdata-set! "n" 0 (vector 0 -1 0))
     (pdata-set! "n" 1 (vector 0 -1 0))
     (pdata-set! "n" 2 (vector 0 -1 0))
     (pdata-set! "n" 3 (vector 0 -1 0))

     (pdata-set! "p" 4 (vector 5 0 0))
     (pdata-set! "p" 5 (vector 5 0 depth))
     (pdata-set! "p" 6 (vector 5 1 depth))
     (pdata-set! "p" 7 (vector 5 1 0))
     (pdata-set! "n" 4 (vector 1 0 0))
     (pdata-set! "n" 5 (vector 1 0 0))
     (pdata-set! "n" 6 (vector 1 0 0))
     (pdata-set! "n" 7 (vector 1 0 0))

     (pdata-set! "p" 8 (vector 5 1 0))
     (pdata-set! "p" 9 (vector 5 1 depth))
     (pdata-set! "p" 10 (vector -1 1 depth))
     (pdata-set! "p" 11 (vector -1 1 0))
     (pdata-set! "n" 8 (vector 0 1 0))
     (pdata-set! "n" 9 (vector 0 1 0))
     (pdata-set! "n" 10 (vector 0 1 0))
     (pdata-set! "n" 11 (vector 0 1 0))

     (pdata-set! "p" 12 (vector 0 0 depth))
     (pdata-set! "p" 13 (vector 0 0 0))
     (pdata-set! "n" 12 (vector 1 0 0))
     (pdata-set! "n" 13 (vector 1 0 0))
     (pdata-set! "n" 14 (vector 1 0 0))
     (pdata-set! "n" 15 (vector 1 0 0))

     (pdata-set! "p" 16 (vector -1 1 0))
     (pdata-set! "p" 17 (vector -1 1 depth))
     (pdata-set! "n" 16 (vector -1 0 0))
     (pdata-set! "n" 17 (vector -1 0 0))
     (pdata-set! "n" 18 (vector -1 0 0))
     (pdata-set! "n" 19 (vector -1 0 0))

     (pdata-set! "n" 20 (vector 0 -1 0))
     (pdata-set! "n" 21 (vector 0 -1 0))
     (pdata-set! "n" 22 (vector 0 -1 0))
     (pdata-set! "n" 23 (vector 0 -1 0))

     (pdata-set! "n" 24 (vector 1 0 0))
     (pdata-set! "n" 25 (vector 1 0 0))
     (pdata-set! "n" 26 (vector 1 0 0))
     (pdata-set! "n" 27 (vector 1 0 0))

     (pdata-set! "n" 28 (vector 0 1 0))
     (pdata-set! "n" 29 (vector 0 1 0))
     (pdata-set! "n" 30 (vector 0 1 0))
     (pdata-set! "n" 31 (vector 0 1 0))))

   (pdata-map!
    (lambda (p)
      (if (< (vz p) (/ depth 2))
      (vadd p (vector 0.5 0.5 0))
      p))
    "p")
   
   (pdata-copy "p" "pref")))

  (list text children empty-ghost prim text-prim depth-shape-prim #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-modify-locked f b) (list-replace b 6 (f (brick-locked b))))
(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)
      (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
      (if (brick-is-atom? b)
          #f
          (foldl
           (lambda (child r)
             (cond
              ((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
      (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)
   )
  (with-primitive
   (brick-depth b)
   (opacity a)
   ))

(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 col-stop-a (vector 1 0 0.5))
(define col-stop-b (vector 1 1 0))
(define col-stop-c (vector 0.5 0 1))

(define (brick-col d)
  (vlerp
   col-stop-a 
   (vlerp col-stop-b col-stop-c (/ (modulo (quotient d 3) 7) 7))
   (/ (modulo d 4) 4)))

(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)
   (for ((i (in-range 4 8)))
        (pdata-set! "p" i (vadd (pdata-ref "pref" i) (vector 0 (- n) 0)))))
  (with-primitive
   (brick-depth b)
   (for-each (lambda (i)
               (pdata-set! "p" i (vadd (pdata-ref "pref" i) (vector 0 (- n) 0))))
             (list 14 15))
   (for ((i (in-range 18 32)))
        (pdata-set! "p" i (vadd (pdata-ref "pref" i) (vector 0 (- n) 0))))))

(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
   ((not (list? code)) (make-brick-from-atom code))
   ((null? code) (make-brick "" '()))
   ((not (list? (car code)))
    (make-brick
     (text-from-code (car code))
     (map
      (lambda (item)
        (code->brick item))
      (cdr code))))
   (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))))

(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)
  (if (brick-is-atom? b)
      (brick-text b)
      (string-append
       (remove-last
        (string-append "(" (brick-text b) " "
                       (apply string-append
                              (map
                               (lambda (child)
                                 (string-append
                                  (brick->text child do-insert) " "))
                               (brick-children b)))))
       (if do-insert (brick-code-inserts b) "") ")")))

(define (brick->sexpr b)
  (if (brick-is-atom? b)
      (string->symbol (brick-text b))
      (apply
       list
       (cons
        (string->symbol (brick-text b))
        (map brick->sexpr (brick-children b))))))

(define (brick-pos->slot b pos)
  (let ((relative-y
         (vy (vsub
              (with-primitive
               (brick-id b)
               (vtransform (vector 0 0 0) (get-global-transform)))
              pos))))
    (car (foldl
          (lambda (child r)
            (list
             (if (< (+ (cadr r) drop-fudge) relative-y)
             (+ (cadr r) (brick-size child))))
          (brick-children b)))))

(define (brick-update-ghost b pos size)
  (brick-modify-ghost
   (lambda (g) (list (brick-pos->slot b pos) size))
   b))

(define (brick-dock b new)
  (cond ((or (brick-parent-locked b)
             (brick-locked b)) b)
        (else
         (with-primitive
          (brick-id new)
          (identity)
          (parent (brick-id b)))
         (brick-modify-children
          (lambda (children)
            (insert-to new (ghost-pos (brick-ghost b)) children))
          (brick-clear-ghost b)))))

(define (brick-undock b id)
  (cond ((or (brick-locked b)
             (brick-parent-locked b)) b)
        (else
         (with-primitive id (detach-parent))
         (brick-modify-children
          (lambda (children)
            (filter
             (lambda (b)
               (not (eqv? (brick-id b) id)))
             children))
          b))))

(define (brick-update! b d)
  (with-primitive
   (brick-text-prim b)
   (set-text (brick-text b)))
  (with-primitive
   (brick-id b)
   (colour (brick-col d)))
  (with-primitive
   (brick-depth b)
   (colour (brick-col d)))
  (when (not (brick-is-atom? b))
        (let ((size
               (car
                (foldl
                 (lambda (child p)
                   (with-primitive
                    (brick-id child)
                    (identity)
                    (parent (brick-id b))
                    (when (brick-locked b) (translate (vector 0 (* (cadr p) -1.3) 0)))
                    (translate (vector 1 (- (car p)) 0)))
                   (brick-update! child (+ d 1))
                   (list
                    (if (and (ghost-pos (brick-ghost b))
                             (eq? (ghost-pos (brick-ghost b))
                                  (+ (cadr p)
                                     (ghost-size (brick-ghost b)))))
                        (+ (car p) (brick-size child)
                           (ghost-size (brick-ghost b)))
                        (+ (car p) (brick-size child)))
                    (+ (cadr p) 1)))
                 (list
                  (if (and (ghost-pos (brick-ghost b))
                           (eq? (ghost-pos (brick-ghost b)) 0))
                      (+ 1 (ghost-size (brick-ghost b))) 1)
                 (brick-children b)))))
          (brick-expand! b (- size 1)))))

  (with-primitive
   (brick-id b)
   (let ((p (geo/line-intersect (vtransform (car line) (minverse (get-global-transform)))
                                (vtransform (cadr line) (minverse (get-global-transform)))))
         (m (get-global-transform)))
     (if (not (null? p))
         b
         (if (not (brick-is-atom? b))
             (foldl
              (lambda (child r)
                (if (not r) (brick-intersect child line) r))
              #f
              (brick-children b))
             #f)))))

(define (brick-intersect b pos)
  (let ((hit (if (not (brick-is-atom? b))
                 (foldl
                  (lambda (child r)
                    (if (not r) (brick-intersect child pos) r))
                  #f
                  (brick-children b))
                 #f)))
    (if (not hit)
        (with-primitive
         (brick-id b)
         (recalc-bb)
         (if (bb/point-intersect? pos 0.1) b #f))
        hit)))

(define (brick-intersect-no-atoms b pos)
  (if (not (brick-is-atom? b))
      (let ((hit (foldl
                  (lambda (child r)
                    (if (not r) (brick-intersect-no-atoms child pos) r))
                  #f
                  (brick-children b))))
        (if (not hit)
            (with-primitive
             (brick-id b)
             (recalc-bb)
             (if (bb/point-intersect? pos 0.1) b #f))
            hit))
      #f))


(define (make-bricks)
  (list '() (vector 0 0 0) #f #f #f #f #f '() #f
        (let* ((p (open-input-file "history/persist.scm"))
               (r (read p)))
          (println "history level is: " r)
          (close-input-port p)
          r)))

(define (bricks-roots b) (list-ref b 0))
(define (bricks-modify-roots f b) (list-replace b 0 (f (bricks-roots b))))
(define (bricks-mouse b) (list-ref b 1))
(define (bricks-modify-mouse f b) (list-replace b 1 (f (bricks-mouse b))))
(define (bricks-button b) (list-ref b 2))
(define (bricks-modify-button f b) (list-replace b 2 (f (bricks-button b))))
(define (bricks-current b) (list-ref b 3))
(define (bricks-modify-current f b) (list-replace b 3 (f (bricks-current b))))
(define (bricks-drop-over b) (list-ref b 4))
(define (bricks-modify-drop-over f b) (list-replace b 4 (f (bricks-drop-over b))))
(define (bricks-typing b) (list-ref b 5))
(define (bricks-modify-typing f b) (list-replace b 5 (f (bricks-typing b))))
(define (bricks-typing-current b) (list-ref b 6))
(define (bricks-modify-typing-current f b) (list-replace b 6 (f (bricks-typing-current b))))
(define (bricks-keys b) (list-ref b 7))
(define (bricks-modify-keys f b) (list-replace b 7 (f (bricks-keys b))))
(define (bricks-code-current b) (list-ref b 8))
(define (bricks-modify-code-current f b) (list-replace b 8 (f (bricks-code-current b))))
(define (bricks-history b) (list-ref b 9))
(define (bricks-modify-history f b) (list-replace b 9 (f (bricks-history b))))

(define (bricks-save b fn)
  (let ((f (open-output-file fn #:exists 'replace)))
    (write
     (map
      (lambda (root)
        (list
         (with-primitive (brick-id root) (get-global-transform))
         (brick->text root #f)))
      (filter (lambda (root) (not (brick-locked root))) (bricks-roots b)))
     f)
    (close-output-port f)))

(define (bricks-load b fn)
  (let* ((f (open-input-file fn))
         (ret (foldl
               (lambda (e b)
                 (println "-" (cadr e) "-")
                 (if (not (string=? (cadr e) ""))
                     (let ((brick
                            (code->brick
                             (eval-string
                              (string-append "'" (cadr e))))))
                       (with-primitive
                        (brick-id brick)
                        (concat (car e)))
                       (bricks-add-root b brick))
                     b))
               b
               (read f))))
    (close-input-port f)
    ret))

(define (get-max-history)
  (let* ((f (open-input-file "history/persist.scm"))
         (max (read f)))
    (close-input-port f)
    max))

(define (increase-history!)
  (let* ((h (get-max-history))
         (f (open-output-file "history/persist.scm" #:exists 'replace)))
    (write (+ h 1) f)
    (close-output-port f)
    (+ h 1)))

(define (bricks-load-history b)
  (bricks-load
   (bricks-clear b)
   (string-append
    "history/"
    (number->string (bricks-history b))
    ".scm")))

(define (bricks-save-history! b)
  (bricks-save
   b
   (string-append
    "history/"
    (number->string (increase-history!))
    ".scm")))

(define (bricks-modify-brick fn b id)
  (bricks-modify-roots
   (lambda (roots)
     (map
      (lambda (root)
        (brick-modify-brick fn root id))
      roots))
   b))

(define (bricks-delete b brick)
  (let* ((id (brick-id brick))
         (parent (bricks-search-for-parent b id))
         (new-b (if parent
                    (bricks-modify-brick
                     (lambda (parent)
                       (brick-undock parent id))
                     b (brick-id parent))
                    (bricks-modify-roots
                     (lambda (roots)
                       (filter
                        (lambda (r)
                          (not (eq? (brick-id r) id)))
                        roots))
                     b))))
    new-b))

(define (bricks-palette b) (car (bricks-roots b)))

(define (bricks-add-root b root)
  (bricks-modify-roots
   (lambda (roots)
  add to end so palette is always first element
     (append roots (list root)))
   b))

(define (bricks-remove-root b id)
  (bricks-modify-roots
   (lambda (roots)
     (filter (lambda (root) (not (eq? id (brick-id root)))) roots))
   b))

(define (bricks-clear b)
  (for-each
   (lambda (root)
     (when (not (brick-locked root))
           (brick-destroy! root)))
   (bricks-roots b))
  (bricks-modify-roots
   (lambda (r) (list (car r)))
   (bricks-modify-code-current
    (lambda (c) #f)
    (bricks-modify-typing-current
     (lambda (t) #f)
     b))))

(define (bricks->text b)
  (apply
   string-append
   (map brick->text
        (filter (lambda (brx)
                  (not (brick-locked brx)))
                (bricks-roots b))
        #f)))

(define (bricks->sexpr b)
  (apply list (map brick->sexpr (bricks-roots b))))

(define (bricks-add-clone b brick)
  (bricks-add-root b (code->brick (brick->code brick))))

(define (bricks-add-spawn b brick)
  (let ((copy (code->brick (brick->code brick)))
        (tx (with-primitive (brick-id brick) (get-global-transform))))
    (brick-for-each
     (lambda (brick)
     copy)
    (with-primitive (brick-id copy) (identity) (concat tx) (scale 2))
    (bricks-modify-current
     (lambda (c) copy)
     (bricks-add-root b copy))))

(define (bricks-add-code b code)
  (bricks-add-root b (code->brick code)))

(define (bricks-get-over b pos)
  (foldl
   (lambda (brick r)
     (if (and
          (or
           (not (eq? (brick-id brick) (brick-id (bricks-current b))))))
         (brick-intersect brick pos)
         r))
   #f
   (bricks-roots b)))

(define (bricks-get-over-no-atoms b pos)
  (foldl
   (lambda (brick r)
     (if (and
          (or
           (not (eq? (brick-id brick) (brick-id (bricks-current b))))))
         (brick-intersect-no-atoms brick pos)
         r))
   #f
   (bricks-roots b)))

(define (bricks-search b id)
  (foldl
   (lambda (b r)
     (if (not r) (brick-search b id) r))
   #f
   (bricks-roots b)))

  look for the brick which is the parent of the supplied one
(define (bricks-search-for-parent b id)
  (foldl
   (lambda (b r)
     (if (not r) (brick-search-for-parent b id) r))
   #f
   (bricks-roots b)))

(define (bricks-root-search b id)
  (foldl
   (lambda (root r)
     (if (and (not r) (brick-search root id))
         root r))
   #f
   (bricks-roots b)))

(define (bricks-mouse-down b)
  (and (mouse-button 1) (not (bricks-button b))))

(define (bricks-mouse-up b)
  (and (not (mouse-button 1)) (bricks-button b)))

(define (bricks-key-pressed? b key)
  (in-list? key (bricks-keys b)))

(define (keys-contains-enter? keys)
  (foldl
   (lambda (key r)
         #t r))
   #f
   keys))

(define (bricks-type-into b bx keys-pressed)
  (foldl
   (lambda (key r)
     (if (char? key)
         (cond
  delete ( 128 on  )
           (if (> (string-length (brick-text r)) 0)
               (brick-modify-text
                (lambda (t)
                  (substring
                   t 0 (- (string-length t) 1)))
                r) r))
          (else
           (brick-modify-text
            (lambda (t)
              (string-append t (string key)))
            r)))
         r))
   bx
   keys-pressed))

(define (bricks-do-keys b pos)
  (let ((keys-pressed
         (filter
          (lambda (key)
            (not (in-list? key (bricks-keys b))))
          (keys-down))))
    (bricks-modify-keys
     (lambda (k) (keys-down))
     (cond
      ((bricks-typing-current b)
       (bricks-modify-brick
        (lambda (bx)
          (if (not (keys-contains-enter? keys-pressed))
              (bricks-type-into b bx keys-pressed)
              bx))
        (if (keys-contains-enter? keys-pressed)
            (bricks-modify-typing-current
             (lambda (t) #f)
             b)
            b)
        (brick-id (bricks-typing-current b))))

      ((and (in-list? #\x keys-pressed)
            (bricks-code-current b))
       (let ((current (bricks-search b (bricks-code-current b))))
         (bricks-save-history! b)
         (broadcast 1 (brick->text current #t))
         (eval-string (brick->text current #t)
                      (lambda (error)
                        (broadcast 5 (exn-message error))))
         b))

      ((and (in-list? #\C keys-pressed)
            (bricks-code-current b))
       (bricks-add-root
        b
        (code->brick
         (brick->code (bricks-search b (bricks-code-current b))))))

      ((in-list? #\h keys-pressed)
       (bricks-modify-code-current
        (lambda (o)
          (let ((brick (bricks-get-over b pos)))
            (if brick (brick-id brick) #f)))
        b))

      ((in-list? #\o keys-pressed)
       (bricks-save b "test.scm")
       b)
      ((in-list? #\p keys-pressed)
       (bricks-load b "test.scm"))

      ((in-list? #\m keys-pressed)
       (bricks-load-history
        (bricks-modify-history
	 (lambda (h)
	   (let* ((p (open-input-file "history/persist.scm"))
		  (r (read p)))
	     (println "history level is: " r)
	     (close-input-port p)
	     r))
	 b)))
      
      ((in-list? #\, keys-pressed)
       (bricks-load-history
        (bricks-modify-history
         (lambda (h) (max 1 (- h 1))) b)))

      ((in-list? #\. keys-pressed)
       (let* ((f (open-input-file "history/persist.scm"))
              (max (read f)))
         (close-input-port f)
         (bricks-load-history
          (bricks-modify-history
           (lambda (h) (min max (+ h 1))) b))))

      ((in-list? #\P keys-pressed)
       (let ((brick (bricks-get-over b pos)))
         (if brick (bricks-delete b brick)
             b)))

      (else b)))))

(define (bricks-do-dragging b pos)
  (let* ((temp (bricks-get-over-no-atoms b pos))
         (over (if (and temp (brick-is-atom? temp)) #f temp))
         (old-over (bricks-drop-over b)))
    (bricks-modify-drop-over
     (lambda (dropover) over)
     (if (and over (not (brick-parent-locked over)))
         (bricks-modify-brick
          (lambda (over)
            (brick-update-ghost over pos (brick-size (bricks-current b))))
          (if old-over
              (bricks-modify-brick
               (lambda (over)
                 (brick-clear-ghost over))
               b
               (brick-id old-over))
              b)
          (brick-id over))
         b))))

(define (bricks-update-current b pos)
  (bricks-modify-current
   (lambda (current)
     (cond
      ((bricks-mouse-down b)
       (let ((c (bricks-get-over b pos)))
         (when (and c (not (brick-parent-locked c)))
               (brick-for-each
                (lambda (c)
                  (brick-transparent! c drag-transparent))
                c))
     (display c)(newline)
         c))
      ((bricks-mouse-up b)
       (when current
             (brick-for-each
              (lambda (c)
                (brick-opaque! c))
              current))
       #f)
      (else current)))
   (if (bricks-current b)
       (bricks-do-dragging b pos)
       b)))

(define (bricks-do-mouse-wheel b pos)
  (let ((over (bricks-get-over b pos)))
    (when over
          (let ((root (bricks-root-search b (brick-id over))))
                (with-primitive
                 (brick-id root)
                 (when (or (< (mouse-wheel) 0) (key-special-pressed 103))
                       (translate (vector 0 6 0)))
                 (when (or (> (mouse-wheel) 0) (key-special-pressed 101))
                       (translate (vector 0 -6 0))))
                 (brick-id root)
                 (let* ((t (get-transform))
                        (d (vsub pos (vtransform (vector 0 0 0) (get-transform))))
                        (d2 (vmul d (/ 1 (vector-ref (get-transform) 0)))))
                   (when (or (< (mouse-wheel) 0) (key-special-pressed 103))
                         (translate d2)
                         (scale (vector 0.9 0.9 0.9))
                         (translate (vmul d2 -1)))
                   (when (or (> (mouse-wheel) 0) (key-special-pressed 101))
                         (translate d2)
                         (scale (vector 1.1 1.1 1.1))
                         (translate (vmul d2 -1))
                         ))))))
    b))

(define (bricks-do-input b pos)
  (bricks-do-mouse-wheel
   (bricks-do-keys
    (bricks-modify-mouse
     (lambda (m) pos)
     (bricks-modify-code-current
      (lambda (o)
        (if (mouse-button 2)
            (let ((brick (bricks-get-over b pos)))
              (if brick (brick-id brick) #f))
            o))
      (bricks-modify-typing
       (lambda (t) (mouse-button 3))
       (bricks-modify-button
        (lambda (button) (mouse-button 1))
        (bricks-update-current b pos))))) pos) pos))

(define (bricks-drag-start? b new-b)
  (and (not (list? (bricks-current b)))
       (list? (bricks-current new-b))))

(define (bricks-drag-end? b new-b)
  (and (list? (bricks-current b))
       (not (list? (bricks-current new-b)))))

(define (bricks-over-out? b new-b)
  (and (list? (bricks-drop-over b))
       (not (list? (bricks-drop-over new-b)))))

(define (bricks-do-docking b new-b)
  (if (and (bricks-drag-end? b new-b)
           (bricks-drop-over new-b)
           (not (brick-parent-locked (bricks-drop-over new-b))))
      (let* ((id (brick-id (bricks-current b)))
             (new-parent-id (brick-id (bricks-drop-over new-b))))
        (bricks-remove-root
         (bricks-modify-brick
          (lambda (new-parent)
            (brick-dock new-parent (bricks-current b)))
          new-b
          new-parent-id)
         id))
      new-b))

(define (bricks-do-undocking b new-b)
  (if (bricks-drag-start? b new-b)
      (let* ((id (brick-id (bricks-current new-b)))
             (prnt (bricks-search-for-parent b id)))
            (if (or (brick-locked prnt)
                    (brick-parent-locked prnt))
                (bricks-add-spawn new-b (bricks-current new-b))
                (bricks-add-root
                 (bricks-modify-brick
                  (lambda (parent)
                    (brick-undock parent id))
                  new-b
                  (brick-id prnt))
                 (bricks-current new-b)))
            new-b))
      new-b))

(define (bricks-remove-ghost b new-b)
  (if (bricks-over-out? b new-b)
      (let* ((id (brick-id (bricks-drop-over b))))
        (bricks-modify-brick
         (lambda (over)
           (brick-clear-ghost over))
         new-b
         id))
      new-b))

(define (bricks-do-typing b new-b pos)
  (if (and (not (bricks-typing b))
           (bricks-typing new-b))
      (bricks-modify-typing-current
       (lambda (t)
         (bricks-get-over new-b pos))
       new-b)
      new-b))

(define (bricks-do-glow! b)
  (let ((tc (bricks-typing-current b)))
    (when tc
          (brick-text-glow! (brick-id tc))
          (brick-text-glow! (brick-depth tc)))

  (let ((tc (bricks-code-current b)))
    (when tc
          (brick-code-glow! tc)

(define (bricks-update! b)
  (let* ((pos (vadd (vector 0 drop-fudge 0) (get-point-from-mouse))))
                    (identity)
                    (translate pos))
    (when
  TODO - check for optimisation
     (or #t (bricks-button b))
      (for-each
       (lambda (b)
         (brick-update! b 0))
       (bricks-roots b)))

    (bricks-do-glow! b)

    (when (list? (bricks-current b))
          (with-primitive
           (brick-id (bricks-current b))
           (when (and (mouse-button 1) (bricks-button b))
                 (translate (vdiv
                             (vsub pos (bricks-mouse b))
                             (* (brick-get-scale (bricks-current b))
                                lag-fudge))))))

    (bricks-do-typing
     b (bricks-remove-ghost
        b (bricks-do-docking
           b (bricks-do-undocking
              b (bricks-do-input b pos)))) pos)))


(clear)

(ortho)
(set-ortho-zoom 30)

  ancient fluxus bug
(define light-setup 0)

(define (setup-lights)
  (cond
   ((eq? light-setup 5)
    (light-diffuse 0 (vector 0 0 0))
    (light-specular 0 (vector 0 0 0))
    (light-ambient 0 (vector 1 1 1))
    (define mylight (make-light 'directional 'free))
    (display mylight)(newline)
    (light-position mylight (vector 0 0 0))
    (light-direction mylight (vector 0.3 0.7 1))
    (light-diffuse mylight (vector 1.5 1.5 1.5))
    (light-ambient mylight (vector 0 0 0))
    (set! light-setup 10))
   (else (set! light-setup (+ light-setup 1)))))

(set-camera-transform
 (mtranslate (vector 0 0 -30)))



(define b
  (bricks-add-code
   (make-bricks)
   palette))

(set! b (bricks-modify-brick
         (lambda (palette)
           (brick-for-each
            (lambda (c)
              (with-primitive
               (brick-id c)
               (opacity 0.8))
              (with-primitive
               (brick-depth c)
               (opacity 0.8)))
            palette)
           (with-primitive (brick-id palette)
                           (translate (vector 25 10 0))
                           (scale 0.7)
                           (opacity 0)
                           (hint-nozwrite))
           (with-primitive (brick-depth palette)
                           (opacity 0)
                           (hint-nozwrite))
           (brick-modify-locked
            (lambda (l) #t)
            (brick-modify-all-children
             (lambda (c)
               (brick-modify-parent-locked
                (lambda (p) #t) c))
             palette)))
         b
         (brick-id (bricks-palette b))))

(define pointer (with-state (scale 0.1) (build-cube)))

(set-scale pentatonic-major)
(bootstrap (lambda () zop))
	   
( clear - colour ( vector 0.5 0.2 0.1 ) )
(define t (with-state
           (translate (vector -28 -20 0))
           (scale (vector 1 1 1))
           (colour (vector 0 0.5 1)) (build-cube)))

(set! b (bricks-load b "scenes/framework.scm"))

(every-frame
 (begin
   (with-primitive pointer
                   (identity)
                   (translate (get-point-from-mouse))
                   (scale 0.1))
   (set! b (bricks-update! b))
   (setup-lights)
   (with-primitive t (rotate (vector 1 2 3)))))

