;#lang scheme/base
(require scheme/class)
(require mzlib/string)
;(require fluxus-016/drflux)
(require fluxus-016/fluxa)

(define using-mouse #t)
; sync-tempo
(define slacker #f)
;(define load-script "sync.scm")
;(define load-script "core-bot.scm")
(define load-script "slub.scm")
;(define load-script "drummachine2.scm")
;(define load-script "foo.scm")
;(define load-script "cx.scm")
;(define load-script "cp.scm")
;(define load-script "chunk.scm")
;(define load-script "chime.scm")
;(define load-script "bs.scm")
;(define load-script "sw.scm")

(set-global-offset -0.04)
(set-bpm-mult 1)

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

(define (bricks-in-list a l)
    (cond 
        ((null? l) #f)
        ((eq? (car l) a) #t)
        (else (bricks-in-list a (cdr l)))))

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

(define bricks-input%
    (class object%
        
        (field
            (last-mouse (vector 0 0 0))
            (last-button #f)
            (last-keys '())
            (new-keys '())
            (keys-pressed '())
            (selected 0)
            (zoom -30)
            (typing-mode #f))
        
        (define/public (set-typing-mode s)
            (set! typing-mode s))
        
        (define/public (typing-mode?)
            typing-mode)
        
        (define/public (update)
            (set! last-button (mouse-button 1))
            (set! new-keys (append (keys-down) '() #;(get-special-keys-pressed)))
            (set! keys-pressed (filter
                    (lambda (key)
                        (not (bricks-in-list key last-keys)))
                    new-keys))
            (set! last-keys new-keys)
            (when (not typing-mode)
                (when (key-pressed "-") (set! zoom (* zoom 1.1)))
                (when (key-pressed "=") (set! zoom (* zoom 0.9)))
                (set-camera-transform (mtranslate (vector 0 0 zoom)))))
        
        (define/public (get-keys-pressed)
            keys-pressed)
        
        (define/public (pre-update)
            (when (or (and (not last-button) (mouse-button 1))
                    (mouse-button 2) (mouse-button 3))
                (set! selected (select (mouse-x) (mouse-y) 2))))
        
        (define/public (get-selected)
            selected)
        
        (define/public (mouse-b n)
            (mouse-button n))
        
        (define/public (get-pos-from-mouse)
            (let* ((ndcpos (vector (* (- (/ (mouse-x) (vx (get-screen-size))) 0.5) (* -2 zoom))
                            (* (- (- (/ (mouse-y) (vy (get-screen-size))) 0.5)) (* -1.5 zoom)) -10))
                    (scrpos (vtransform ndcpos (minverse (get-camera-transform)))))
                scrpos))        
        
        (define/public (get-mouse-change)
            (let ((r (if last-button (vsub (get-pos-from-mouse) last-mouse)
                            (vector 0 0 0))))
                (set! last-mouse (get-pos-from-mouse))
                r))
        
        (super-new)))

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

(define bricks-text%
    (class object%
        (field
            (str "")
            (root 0)
            (text-obj 0)
            (typing-mode #f))
        
        (define/public (get-text)
            str)
        
        (define/public (get-text-obj)
            text-obj)
        
        (define/public (build col r)
            (set! root (with-state
                    (parent r)
                    (translate (vector 0 0 0.01))
                    (build-locator)))
            (set-text ""))
        
        (define/public (unbuild)
            (destroy root)) ; will also destroy text obj child
        
        (define/public (set-text t)
            (set! str t)
            (when (not (zero? text-obj))
                (destroy text-obj))
            (with-state
                (parent root)
                (translate (vector -0.9 1.1 0.0001))
                (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)))
                (set! text-obj (build-text t))
                (with-primitive text-obj
                    (text-params t (/ 16 256) (/ 16 256) 16 0 -0.01 0 15 -20 0.005 0.2))))
        
        (define/public (update master-root input)
            
            (when (and typing-mode (send input mouse-b 3)
                    (not (eq? master-root (send input get-selected))))
                (send input set-typing-mode #f)
                (set! typing-mode #f))
            
            (when (and (send input mouse-b 3)
                    (or (eq? master-root (send input get-selected))
                        (eq? text-obj (send input get-selected)))
                    (not (send input typing-mode?)))
                (send input set-typing-mode #t)
                (set! typing-mode #t))
            
            (when typing-mode
                ; flash the parent!
                (with-primitive master-root
                    (colour (+ 0.5 (fmod (* 4 (flxtime)) 0.5))))
                (for-each
                    (lambda (key)
                        (when (char? key)             
                            (cond             
                                ((eq? (char->integer key) 8) ; delete
                                    (when (> (string-length str) 0)
                                        (set-text (substring str 0 (- (string-length str) 1)))))
                                ((eq? (char->integer key) 13) ; return
                                    (send input set-typing-mode #f)
                                    (set! typing-mode #f))
                                (else
                                    (set-text (string-append str (string key)))))))
                    (send input get-keys-pressed))))
        
        (super-new)))

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

(define bricks-obj%
    (class object%
        
        (field
            (root 0)
            (text '())
            (owner '())
            (sub-objs '())
            (dragging #f)            
            (being-dragged #f)
            (col (vector 1 1 1))
            (col2 (vector 0 0 0))
            (depth 0)
            (dockable #t)
            (remove-me #f))
        
        (define/public (locked?)
            (if (null? owner)
                #f
                (send owner locked?)))
        
        (define/public (remove-me?)
            remove-me)
        
        (define/public (remove)
            (set! remove-me #t))
        
        (define/public (get-root)
            root)
        
        (define/public (get-owner)
            owner)
        
        (define/public (set-owner! s)
            (set! owner s))
        
        (define/public (add-sub-obj s)
            (set! sub-objs (cons s sub-objs)))
        
        (define/public (set-being-dragged s)
            (set! being-dragged s))
        
        (define/public (being-dragged?)
            being-dragged)
        
        (define/public (get-depth)
            depth)
        
        (define/public (is-dockable?)
            dockable)
        
        (define/public (start-dragging! bricks)
            (send bricks set-current! this)
            (when (not (null? owner))
                (send owner undock this bricks))
            (set! dragging #t)
            (on-drag))
        
        (define/public (stop-dragging! bricks)
            (when dockable (send bricks drop this))
            (send bricks clear-current!)
            (set! dragging #f)
            (on-drop))
        
        (define/public (depth->colour)
            (let  ((t (fmod (/ depth 5) 1)))                 
                (with-primitive root
                    (colour (vmix col col2 t)))))
        
        (define/public (set-depth! s)
            (set! depth s)
            (depth->colour))
        
        (define/public (build pos)
            (set! root (with-state
                    (scale (vmul (rndvec) 4))
                    (colour col)
                    (build-plane)))
            (with-primitive root    
                (apply-transform)
                (translate pos)))
        
        (define/public (unbuild)
            (for-each
                (lambda (obj)
                    (send obj unbuild))
                sub-objs)
            (destroy root))
        
        (define/pubment (update bricks)
            (let ((input (send bricks get-input)))
                
                
                (cond 
                    ((not (send bricks have-current?)) ; nothing is currently selected
                        (when (send input mouse-b 1) ; are we being clicked on?
                            
                            ; delete?
                            #;(when (and (null? owner) (key-pressed "p"))
                                (remove))
                            
                            (when  (or 
                                    (eq? root (send input get-selected))
                                    (if (not (null? text))
                                        (eq? (send text get-text-obj) (send input get-selected))
                                        #f))
                                (start-dragging! bricks))))
                    (else
                        (when (eq? this (send bricks get-current)) ; we are selected
                            (when (not (send input mouse-b 1))
                                (stop-dragging! bricks)))))
                
                (when dragging
                    (with-primitive root         
                        (translate (send input get-mouse-change))))
                
                (with-primitive root
                    (when (locked?) (opacity 0.5))
                    (if (eq? (send bricks get-selection) this)
                        (colour (vmix (vector 1 0 0) (vector 1 1 0) (abs (sin (* (flxtime) 2)))))
                        (depth->colour)))
                
                (for-each
                    (lambda (sub-ob)
                        (send sub-ob update root input))
                    sub-objs)
                
                (when (and (send input mouse-b 2)
                        (eq? root (send input get-selected)))
                    (send bricks set-selection! this))
                (inner (void) update bricks)))
        
        (define/public (on-drag)
            0)
        
        (define/public (on-drop)
            0)
        
        (define/public (vsize)
            0)
        
        (define/public (over obj)
            0)
        
        (define/public (unover)
            0)
        
        (define/public (dock obj)
            0)
        
        (define/public (undock obj bricks)
            0)
        
        (define/public (get-code (insert #f))
            "")
        
        (super-new)))

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

(define bricks-list%
    (class bricks-obj%
        
        (field             
            (children '())
            (ghost '())
            (locked #f)
            (space 0))
        
        (inherit-field
            owner
            root
            text
            being-dragged
            col
            col2
            depth
            remove-me)
        
        (inherit
            add-sub-obj
            depth->colour)
        
        (define/override (remove)
            (set! remove-me #t)
            (for-each
                (lambda (child)
                    (send child remove))
                children))
        
        (define/override (get-code (insert #f))
            (let ((s (string-append "(" (send text get-text))))
                    
                    (for-each
                        (lambda (child)
                            (set! s (string-append s " " (send child get-code insert))))
                        children)
                    
                    ; eek
                    (when (and insert (eq? 2 (length children)) (string=? "play" (send text get-text)))
                        (set! s (string-append s " 0 (lambda () (with-primitive " (number->string root)
                                        " (colour (vector 1 1 1))))")))
                                    
                    (set! s (string-append s ")"))
                s))
        
        (define/public (set-name! s)
            (send text set-text s))
        
        (define/public (lock!)
            (set! locked #t))
        
        (define/override (locked?)
            (if locked
                #t
                (if (null? owner)
                    #f
                    (send owner locked?))))
        
        (define/override (build pos)
            (set! text (make-object bricks-text%))
            (set! col (vector 0.5 0.1 0))
            (set! col2 (vector 1 0.5 0))
            (set! root (with-state
                    (colour col)
                    ;(hint-box)
                    (build-polygons 8 'triangle-strip)))
            (with-primitive root    
                (hint-unlit)
                (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")
                (translate pos))
            (add-sub-obj text)
            (send text build col root))
        
        (define/override (vsize)
            (if (null? ghost)
                (+ 2 (children-vsize))
                (+ 2 (children-vsize) (send ghost vsize))))
        
        (define (children-vsize)
            (foldl
                (lambda (obj n)
                    (+ n space (send obj vsize)))
                0
                children))
        
        (define/override (on-drag)
            (set-being-dragged #t))
        
        (define/override (on-drop)
            (set-being-dragged #f))
        
        (define/override (set-being-dragged s)
            (set! being-dragged s)
            (for-each
                (lambda (child)
                    (send child set-being-dragged s))
                children))
        
        (define/override (over obj)
            (when (not being-dragged) 
                (set! ghost obj)
                (reshuffle)))
        
        (define/override (unover)
            (when (not being-dragged) 
                (set! ghost '())
                (reshuffle)))
        
        (define/override (dock obj)
            (when (and (not being-dragged) (not (locked?)))
                ; todo: shuffle to right position
                (set! children (append children (list obj)))
                (send obj set-owner! this)
                (send obj set-depth! (+ depth 1))
                (reshuffle)))
        
        (define/override (undock obj bricks)
            (when (not (locked?))
                (send obj set-owner! '())
                (with-primitive (send obj get-root)
                    (detach-parent))
                (set! children (filter
                        (lambda (o)
                            (not (eq? obj o)))
                        children))
                (reshuffle)))
        
        (define/public (reshuffle)
            (when (not (locked?))
                (let ((pos 1) (ghost-vsize 0) (ghost-pos 0))
                    (when (not (null? ghost))
                        (set! ghost-vsize (send ghost vsize)))                
                    ;            (set! pos (+ pos ghost-vsize))
                    (for-each
                        (lambda (obj)
                            (with-primitive (send obj get-root)
                                (identity)
                                (parent root)
                                (translate (vector 1 (- pos) 0)))
                            (set! pos (+ pos space (send obj vsize))))
                        children)
                    (expand (+ ghost-vsize (children-vsize))))))
        
        (define/public (expand n)
            (with-primitive root
                (for ((i (in-range 4 8)))
                    (pdata-set! "p" i (vadd (pdata-ref "pref" i) (vector 0 (- n) 0)))))
            (when (not (null? owner)) 
                (send owner reshuffle)))
        
        (define/public (add-child! obj)
            (set! children (cons obj children))
            (expand (send obj get-vsize)))
        
        (define/override (set-depth! s)
            (set! depth s)
            (depth->colour)
            (for-each
                (lambda (child)
                    (send child set-depth! (+ depth 1)))
                children))
        
        (super-new)))

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

(define bricks-palette%
    (class bricks-list%
        
        (field
            (timer 0))
        
        (inherit-field
            owner
            root
            col
            col2
            dockable
            space)
        
        (define/override (build pos)
            (set! space 0.5)
            (set! dockable #f)
            (set! col (vector 0 0 0.5))
            (set! col2 (vector 0 0 0.5))
            (set! root (with-state
                    (colour col)
                    (opacity 0.5)
                    (build-polygons 4 'triangle-strip)))
            (with-primitive root    
                (hint-unlit)
                (hint-depth-sort)
                ;(translate (vector 0 0 1))
                (pdata-set! "p" 0 (vector 8 1 0))
                (pdata-set! "p" 1 (vector -1 1 0))
                (pdata-set! "p" 2 (vector 8 -1 0))
                (pdata-set! "p" 3 (vector -1 -1 0))
                
                (pdata-map!
                    (lambda (n)
                        (vector 0 0 1))
                    "n")
                (apply-transform)
                (pdata-copy "p" "pref")
                (translate pos)))
        
        (define/override (expand n)
            (with-primitive root
                (for ((i (in-range 2 4)))
                    (pdata-set! "p" i (vadd (pdata-ref "pref" i) (vector 0 (- n) 0)))))
            (when (not (null? owner)) 
                (send owner reshuffle)))
        
        (define/override (undock obj bricks)
            (send bricks paste (list 
                    (eval-string (string-append "'" (send obj get-code))))))
        
        (define/augment (update bricks)
            (with-primitive root
                
                (when using-mouse
                  (when (or (< (mouse-wheel) 0) (key-special-pressed 103))
                    (set! timer 0)
                    (hide 0)
                    (translate (vector 0 3 0)))
                  (when (or (> (mouse-wheel) 0) (key-special-pressed 101))
                    (set! timer 0)
                    (hide 0)
                    (translate (vector 0 -3 0))))
                
                (set! timer (+ timer (delta)))
                (when (and using-mouse (> timer 3)) (hide 1))
                (let ((pos (vtransform (vector 0 0 0) (get-transform))))
                    (when (> (vy pos) 100) 
                        (translate (vector 0 -100 0)))
                    (when (< (vy pos) -10)
                        (translate (vector 0 100 0))))))
        
        
        (super-new)))

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

(define bricks-atom%
    (class bricks-obj%
        
        (inherit-field
            owner
            root
            text
            col
            col2)
        
        (inherit
            add-sub-obj)
        
        (define/override (get-code (insert #f))
            (send text get-text))
        
        (define/public (set-name! s)
            (send text set-text s))
        
        (define/override (build pos)
            (set! text (make-object bricks-text%))
            (set! col (vector 0 0.5 1))
            (set! col2 (vector 1 0 0))
            (set! root (with-state               
                    (colour col)
                    (build-polygons 4 'triangle-strip)))
            (with-primitive root    
                (hint-unlit)
                (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))
                
                (pdata-map!
                    (lambda (n)
                        (vector 0 0 1))
                    "n")
                (apply-transform)
                (pdata-copy "p" "pref")
                (translate pos)
                (add-sub-obj text)
                (send text build col root)))
        
        (define/override (vsize)
            1)
        
        (super-new)))

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

(define bricks%
    (class object%
        (field
            (obj-list '())
            (input (make-object bricks-input%))
            (have-current #f)
            (current 1)
            (selection '())
            (over '())
            (history-level 0)
            (history-latest 0)
            (paste-buf '()))
        
        (define/public (init)
            (let ((p (open-input-file "history/persist.scm")))
                (set! history-level (read p))
                (set! history-latest history-level)
                (display "history level is: ")(display history-level)(newline)
                (close-input-port p))
            (make-palette))
        
        (define/public (make-palette)
            (let ((palette (make-object bricks-palette%)))
                (send palette build (vector 20 20 0))
                (add! palette)
                (load-from-code '(()) palette)
                (load-from-code '((seq)) palette)
                (load-from-code '((lambda)) palette)
                (load-from-code '(time) palette)
                (load-from-code '(clock) palette)
                (load-from-code '(sync-tempo) palette)
                (load-from-code '(0) palette)
                (load-from-code '(0.1) palette)
                (load-from-code '(440) palette)
                (load-from-code '((play)) palette)
                (load-from-code '((mul)) palette)
                (load-from-code '((add)) palette)
                (load-from-code '((sine)) palette)
                (load-from-code '((squ)) palette)
                (load-from-code '((saw)) palette)
                (load-from-code '((white)) palette)
                (load-from-code '((pink)) palette)
                (load-from-code '((sample)) palette)
                (load-from-code '((adsr 0 0.1 0 0)) palette)
                (load-from-code '((mooglp)) palette)
                (load-from-code '((mooghp)) palette)
                (load-from-code '((moogbp)) palette)
                (load-from-code '((rndf)) palette)
                (load-from-code '((note)) palette)
                (load-from-code '((random 100)) palette)
                (load-from-code '((when (zmod clock 4))) palette) 
                (load-from-code '((clock-map (lambda (n) ) clock (list 440))) palette)
                (load-from-code '((+)) palette)
                (load-from-code '((*)) palette)
                (load-from-code '((modulo clock 8)) palette)
                (load-from-code '((when (and (< (modulo clock 34) 3) (zmod clock 2)))) palette)
                (load-from-code '((mul (adsr 0 0.1 0 0) (mooglp (add (saw 440) (saw 441)) 0.1 0.1))) palette)
                (send palette lock!)))
        
        (define/public (set-current! s) 
            (set! have-current #t)
            (set! current s))
        
        (define/public (clear-current!)
            (set! have-current #f))
        
        (define/public (have-current?)
            have-current)
        
        (define/public (get-current)
            current)
        
        (define/public (set-selection! s)
            (set! selection s))
        
        (define/public (get-selection)
            selection)
        
        (define/public (add! obj)
            (set! obj-list (cons obj obj-list)))
        
        (define/public (check-removals)
            (set! obj-list (filter
                    (lambda (other)
                        (cond ((send other remove-me?)
                                (set! have-current #f)
                                (set! current 1)
                                (set! selection '())
                                (set! over '())
                                (send other unbuild)
                                #f)
                            (else #t)))
                    obj-list)))
        
        (define/public (clear)
            (for-each
                (lambda (obj)
                    (send obj unbuild))
                obj-list)
            (set! obj-list '())
            (set! have-current #f)
            (set! current 1)
            (set! selection '())
            (set! over '())
            (make-palette))
        
        (define/public (paste code)
            (set! paste-buf code))
        
        (define/public (update)
            ;(check-removals)
            
            (send input pre-update) 
            (for-each 
                (lambda (obj)
                    (send obj update this))
                obj-list)
            
            (send input update)
            (check-intersection)
            (when (not (send input typing-mode?))
                #;(when (bricks-in-list #\a (send input get-keys-pressed))
                    (let ((atm (make-object bricks-atom%)))
                        (send atm build (vmul (vector (crndf) (crndf) 0) 5))
                        (add! atm)))
                #;(when (bricks-in-list #\s (send input get-keys-pressed))
                    (let ((lst (make-object bricks-list%)))
                        (send lst build (vmul (vector (crndf) (crndf) 0) 5))
                        (add! lst)))
                (when (bricks-in-list #\x (send input get-keys-pressed))
                    (run-code))
                (when (bricks-in-list #\, (send input get-keys-pressed))
                    (set! history-level (- history-level 1))          
                    (load-history))
                (when (bricks-in-list #\. (send input get-keys-pressed))
                    (set! history-level (+ history-level 1))
                    (load-history))
                (when (bricks-in-list #\/ (send input get-keys-pressed))
                    (set! history-level history-latest))
                (when (bricks-in-list #\C (send input get-keys-pressed))
                    (let ((f (open-output-file "scratch.scm" #:exists 'replace)))
                        (write-string (get-code) f)
                        (close-output-port f))
                    (let ((f (open-input-file "scratch.scm")))
                        (load-from-code (list (read f)) '())
                        (close-input-port f)))
                (when (not (null? paste-buf))                                        
                    (when have-current
                        (let ((new-obj (load-from-code paste-buf '())))
                            (with-primitive (send new-obj get-root)
                                (identity)
                                (concat (with-primitive (send current get-root) 
                                        (get-global-transform))))
                            (send current stop-dragging! this)
                            (send new-obj start-dragging! this)
                            (set! paste-buf '()))))))
        
        (define/public (run-code)
            (let ((code (get-code)))
                (display code)(newline)
                (when (not (string=? code ""))
                    (let* ((p (open-input-file "history/persist.scm"))
                            (v (+ (read p) 1)))
                        (close-input-port p)
                        (let ((po (open-output-file "history/persist.scm" #:exists 'replace)))
                            (write v po)
                            (close-output-port po))
                        (set! history-latest v)
                        (display "saving history: ")(display v)(newline)
                        (let ((f (open-output-file (string-append "history/brx-hist-" 
                                            (number->string v) ".scm") #:exists 'replace)))
                            (write-string code f)
                            (close-output-port f)))
                    (eval-string (get-code #t)))))
        
        (define/public (load-history)
            (when (< history-level 0) (set! history-level 0))
            (let* ((p (open-input-file "history/persist.scm"))
                    (v (read p)))
                (when (> history-level v) (set! history-level v))
                (close-input-port p))
            (display "loading history: ")(display history-level)(newline)
            (let* ((p (open-input-file (string-append "history/brx-hist-" (number->string history-level) ".scm"))))        
                (clear)
                (load-from-code (list (read p)) '())
                (close-input-port p)))
        
        (define/public (get-code (insert #f))
            (if (null? selection)
                ""
                (send selection get-code insert)))
        
        (define/public (load-from-code code p)
            (cond ((not (null? code))
                    (cond 
                        ((not (list? (car code)))
                            (let ((atm (make-object bricks-atom%)))
                                (send atm build (vector 0 0 0))
                                
                                (cond 
                                    ((string? (car code)) (send atm set-name! (string-append "\"" (car code) "\"")))
                                    ((number? (car code)) (send atm set-name! (number->string (car code))))
                                    ((symbol? (car code)) (send atm set-name! (symbol->string (car code)))))
                                
                                (when (not (null? p)) (send p dock atm))
                                (add! atm)
                                (load-from-code (cdr code) p)
                                atm))
                        (else
                            (let ((lst (make-object bricks-list%)))
                                (send lst build (vector 0 0 0))
                                (when (not (null? (car code)))
                                    (cond 
                                        ((string? (car (car code))) (send lst set-name! (string-append "\"" (car (car code)) "\"")))
                                        ((number? (car (car code))) (send lst set-name! (number->string (car (car code)))))
                                        ((symbol? (car (car code))) (send lst set-name! (symbol->string (car (car code)))))))
                                
                                (when (not (null? p)) (send p dock lst))
                                (add! lst)
                                (when (not (null? (car code)))
                                    (if (list? (car (car code)))
                                        (load-from-code (car code) lst)
                                        (load-from-code (cdr (car code)) lst)))
                                (load-from-code (cdr code) p)
                                lst))))))
        
        (define/public (get-input)
            input)
        
        (define/public (drop drop-obj)
            (when (not (null? over))
                (send over dock drop-obj)))
        
        (define (check-intersection)
            (when (not (null? over))
                (send over unover))                
            (when (and (have-current?) (send current is-dockable?))
                (for-each
                    (lambda (obj)
                        (with-primitive (send obj get-root) (recalc-bb)))
                    obj-list)
                (with-primitive (send current get-root)
                    (set! over '())
                    (for-each 
                        (lambda (obj)                            
                            (when (and (not (eq? obj current))
                                    (not (eq? (send obj vsize) 1))
                                    (not (send obj being-dragged?))
                                    (bb/bb-intersect? (send obj get-root) 0.1))
                                (when (not (null? over))
                                    (send over unover))
                                (set! over obj)
                                (with-primitive (send obj get-root)
                                    (send obj over current))))
                        obj-list))))        
        
        (super-new) (init)))

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

(clear)
(clear-colour (vector 0 0 0))
(reset-camera)

(define bricks (make-object bricks%))

(when slacker
    (let ((f (open-input-file load-script)))
        (send bricks load-from-code (list (read f)) '())
        (close-input-port f)))

(define (update)
    (send bricks update))

(every-frame (update))