; b e t a b l o c k e r
; (c) 2006 dave griffiths 
; GPL licence

; (true story: my heart made breakbeats, 
; so my doctor suggested betablockers)

; deal with the mutable lists :(
; this code is now completely hacked, but works...
(require scheme/mpair)
(require r5rs)
(define (list-set! lst index new)
    (define (nthcdr l n)
        (if (zero? n) l (nthcdr (cdr l) (- n 1))))
    (set-car! (nthcdr lst index) new))
(define (osc-sendm name format l)
  (osc-send name format (mlist->list l)))
    
(require (lib "1.ss" "srfi"))
(desiredfps 50)
(define global-speed 33) ; clks per sec
(persp)

;(define (delta) 
;    (/ 1764 44100))

; fix for fluxus 0.13
(define current-time (/ (current-inexact-milliseconds) 1000))
(define current-time current-time)

; where stuff is 
(define block-code-location "blockcode/")                   ; where to find the asm code 
(define block-patch-location "blockpatches/")               ; where to find scm voice code
(define block-tuning "equaltemp.scm")                        ; the tuning file
(define scratchy-sample-location "/home/dave/noiz/pattern-cascade/") ; where samples are
(define osc-itchy "4001")
(define osc-scratchy "4002")
(define osc-prefix "osc.udp://localhost:")
(define bpm-multiplier 4)
(define sync-offset 0)
(define sync-quantize 2)
(define key-repeat 100)

(define global-timewarp 0.1) ; seconds in the future to offset output events by
(osc-source "4444")
(define deadzone 0.1)

;        ____              ____
;       [_L2_]            [_R2_]
;        ____              ____
;       [_L1_]            [_R1_]
;
;      .-----.            .-----.
;     /  .-.  '----------'     F \
;    | .-' '-.               D   E|
;    | '-. .-'       sel   B   C  |
;     \  '-' .---.    .---.  A   /
;    / '--- //LS \\  //RS \\ ---' \
;   /      _\\___//__\\___//_      \
;  /      /  '---'    '---'  \      \   
; |      |                    |      |
;  \     /                    \     /
;   '---'                      '---'

; mapping for saitek p2600 joypad
(define joymap-a 1)
(define joymap-b 0)
(define joymap-c 2)
(define joymap-d 3)
(define joymap-e 8)
(define joymap-f 9)
(define joymap-l1 4)
(define joymap-l2 6)
(define joymap-r1 5)
(define joymap-r2 7)
(define joymap-select 11)
(define joymap-dpad 2)
(define joymap-lstick 0)
(define joymap-rstick 1)

; default theme
(define back-colour (vector 0 0 0.5))
(define text-colour (vector 1 1 1))
(define bg-colour (vector 0 0 0))
(define poke-colour (vector 1 0 0))
(define peek-colour (vector 1 1 1))
(define menu-colour (vector 1 0 0))
(define menu-hi-colour (vector 1 1 1))
(define data-colour (vector 0.5 0 1))
(define op-colour (vector 1 0 0.5))

   
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; timing and music code
;
; itchy and scratchy stuff goes here only

; helper to minimise switching between osc destinations

(define osc-current "")

(define betablocker-osc-destination
    (lambda (address)
        (when (not (string=? osc-current address)) ; minimise switches
            (osc-destination (string-append osc-prefix address)))))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; itchy part

; define a synth voice
(define itchy-voice 
    (lambda (id type keyvalue)
        (define build-argsstr
            (lambda (keyvalue str)
                (set! str (string-append str "sf"))
                (if (eq? (cdr (cdr keyvalue)) '())
                    str
                    (build-argsstr (cdr (cdr keyvalue)) str))))
                    
        (betablocker-osc-destination osc-itchy)
        (osc-sendm "/addinstrument" "is" (list id type))
        (set! keyvalue (cons id keyvalue))
        (set! keyvalue (cons "map" keyvalue))
        (osc-sendm "/modify" 
            (build-argsstr keyvalue "i") 
            (append (list id) keyvalue))))

; set voice volume individually
(define itchy-voice-volume
    (lambda (vol)
        (betablocker-osc-destination osc-itchy)
        (osc-sendm "/globalvolume" "f" (list vol))))
    
    
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; scratchy part

(define scratchy-sample-id 0)

; load a sample into a voice
(define scratchy-sample
    (lambda (id file)
        (betablocker-osc-destination osc-scratchy)
        (set! scratchy-sample-id (+ scratchy-sample-id 1))
        (osc-sendm "/addtoqueue" "is" (list scratchy-sample-id file))
        (osc-sendm "/loadqueue" "" '())
        (osc-sendm "/map" "ii" (list scratchy-sample-id id))))

; set global properties for a sample
(define scratchy-sample-globals 
    (lambda (id vol freq pan)
        (betablocker-osc-destination osc-scratchy)
        (set! scratchy-sample-id (+ scratchy-sample-id 1))
        (osc-sendm "/setglobals" "ifff" (list vol freq pan))))

; sets the global sampler volume
(define scratchy-sample-volume
    (lambda (vol)
        (betablocker-osc-destination osc-scratchy)
        (osc-sendm "/globalvolume" "f" (list vol))))

; sets the global pitch of the sampler
(define scratchy-sample-pitch
    (lambda (pitch)
        (betablocker-osc-destination osc-scratchy)
        (osc-sendm "/globalpitch" "f" (list pitch))))


; load a load of samples in one go from a directory specified and
; assign them to one voice for pitch based percussion style use
(define scratchy-samples
    (lambda (id dir)    
        (define get-samples
            (lambda (d l)
                (cond ((null? d)
                    l)
                   (else
                    (let ((ret (path->string (car d))))
                    (when (and (> (string-length ret) 4)
                                (or (string=? (substring ret (- (string-length ret) 4)) ".wav")
                                    (string=? (substring ret (- (string-length ret) 4)) ".WAV")))
                                (set! l (append l (list ret))))
                    (get-samples (cdr d) l))))))
                        
        (define load-list
            (lambda (id dir l)
                (set! scratchy-sample-id (+ scratchy-sample-id 1))
                (osc-sendm "/addtoqueue" "is" (list scratchy-sample-id (string-append dir "/" (car l))))
                (osc-sendm "/map" "ii" (list scratchy-sample-id id))
                (if (eq? (cdr l) '())
                    0
                    (load-list id dir (cdr l)))))
                    
        (betablocker-osc-destination osc-scratchy)
        (load-list id dir (get-samples (list->mlist (directory-list (string-append scratchy-sample-location dir))) '()))
        (osc-sendm "/loadqueue" "" '())))

(define scratchy-sample-unmap
    (lambda ()
        (betablocker-osc-destination osc-scratchy)
        (osc-sendm "/unmapall" "" '())))
        
(define scratchy-sample-stop
    (lambda ()
        (betablocker-osc-destination osc-scratchy)
        (osc-sendm "/stop" "" '())))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#

; converts from UTC time to get a 64bit NTP timestamp
(define (time->timestamp time)
    ; january 1972 UTC -> january 1900 NTP era (overflow in 2036...)
    (let ((adjusted (+ time 2208988800L0))) 
    ; floor the time for the seconds
    (let ((seconds (inexact->exact (floor adjusted)))) 
    ; get the remainder and scale to max unsigned int for the fraction of the second
    (let ((frac (inexact->exact (floor (* (- adjusted seconds) 4294967295))))) 
    (vector seconds frac)))))
 
 ; ... and back the other way
(define (timestamp->time timestamp)
    (+ (- (vector-ref timestamp 0) 2208988800L0) (/ (vector-ref timestamp 1) 4294967295.0)))
    
(define scale-lut '())

(define (load-scale-lut filename)
    (let ((f (open-input-file (fullpath filename))))
    (set! scale-lut (read f))
    (close-input-port f)))
    
(define voice-count 1)

(define (play-note notetime note voice)
    (when (not (zero? note))
        (let ((timestamp (time->timestamp notetime)))
        (let ((freq (list-ref scale-lut (modulo note 32))))
        ;(display "playing ")(display (* 0.25 (list-ref scale-lut note)))(newline)
        (betablocker-osc-destination osc-itchy)
        (osc-sendm "/play" "iiiffffi" 
            (list (vector-ref timestamp 0) 
                  (vector-ref timestamp 1) 
                  (+ 1 (modulo voice voice-count)) freq 0 1 0.5 79))
 
        (betablocker-osc-destination osc-scratchy)
        (osc-sendm "/play" "iiiffffi" 
            (list (vector-ref timestamp 0) 
                  (vector-ref timestamp 1) 
                    (+ 1 (modulo voice voice-count)) freq 0 1 0.5 79))))))
              

(define (itchyscratchy-init)

    ;(display "itchy & scratchy init...")(newline)
    (betablocker-osc-destination osc-itchy)
    (osc-sendm "/clear" "" '())
    (osc-sendm "/setclock" "" '())
    
    (betablocker-osc-destination osc-scratchy)
    (osc-sendm "/clear" "" '())
    (osc-sendm "/setclock" "" '())
    (osc-sendm "/addsearchpath" "s" (list scratchy-sample-location))
    (osc-sendm "/globalvolume" "f" (list 3))
    
    ; preload all the samples we'll be using to get scratchy to cache them
    (scratchy-samples 1 "electro_d")
    (scratchy-samples 2 "kip")
    (scratchy-samples 3 "tabla")
    (scratchy-samples 4 "808")
    (scratchy-samples 5 "rip")
    )

(define (block-patch-init)
    (betablocker-osc-destination osc-itchy)
    ;(osc-sendm "/setclock" "" '())
    ;(osc-sendm "/clear" "" '())
    (betablocker-osc-destination osc-scratchy)
    ;(osc-sendm "/clear" "" '())
    ;(osc-sendm "/setclock" "" '())
    (scratchy-sample-unmap))

;~~~~~~~~~~~~~~~~~~~
; the betablocker virtual machine 
;
; heap is u8, operators for bitshifting, bitwise logic 
; etc as well as common arithmetic for ease of use
; largely stack based - every thread has it's own stack
; usage is very forth influenced
;
; crashing/stopping is designed away, but this always 
; makes bugs harder to track down:
;
;     div 0 = 0
;     mod # 0 = 0
;     popping empty stack = 0

;~~~~~~~~~~~~~~~~~~
; core vm stack

(define (make-stack)
    (list (list)))

(define (stack-get-stack stack)
    (list-ref stack 0))

(define (stack-set-stack! stack newstack)
    (list-set! stack 0 newstack))

(define (stack-push! stack value)
    ; max stack size, to prevent using up all memory :)
    (when (< (length stack) 32)
        ; convert to 0->255 to be compatible with the u8 heap
        (stack-set-stack! stack (cons (modulo value 256) (stack-get-stack stack)))))

(define (stack-pop! stack)
    (cond
        ((eq? (stack-get-stack stack) '())
            ;(display "stack empty!")(newline)
            0) ; return zero on stack empty
        (else
            (let ((ret (car (stack-get-stack stack))))
            (stack-set-stack! stack (cdr (stack-get-stack stack)))
            ret))))

; retrieve the top of the stack without popping
(define (stack-top stack)
    (cond
        ((eq? (stack-get-stack stack) '())
            ;(display "stack empty!")(newline)
            0) ; return zero on stack empty
        (else
            (car (stack-get-stack stack)))))

;~~~~~~~~~~~~~~~~~~
; core vm heap
;
; main memory

(define (make-heap size)
    (make-vector size 0))

; peek hooks allow us to display threads and other accesses 
; from the gui. also allows complete gui/core seperation for 
; the timing offset and general cleanliness

(define peek-hook 0) ; global for the moment, as we can't stuff it in the heap vector
(define peek-hook-data 0)
(define poke-hook 0) ; global for the moment, as we can't stuff it in the heap vector
(define poke-hook-data 0)
(define note-hook 0) ; global for the moment, as we can't stuff it in the heap vector
(define note-hook-data 0)

(define (set-note-hook! hook data)
    (set! note-hook hook)
    (set! note-hook-data data))

(define (set-peek-hook! hook data)
    (set! peek-hook hook)
    (set! peek-hook-data data))
    
; read from memory
(define (peek heap addr)
    (let ((wrapped (modulo addr (vector-length heap))))
    (when (not (number? peek-hook))
        (peek-hook peek-hook-data wrapped))
    (vector-ref heap wrapped)))

(define (set-poke-hook! hook data)
    (set! poke-hook hook)
    (set! poke-hook-data data))

; write to memory
(define (poke! heap addr value)
    (let ((wrapped (modulo addr (vector-length heap))) ; wrap the address within range
         (wval (modulo value 256))) ; and wrap the value to 8 bit range
    (when (not (number? poke-hook))
        (poke-hook poke-hook-data wrapped wval))
    (vector-set! heap wrapped wval)))

; not bounds checked... and no feedback
; remove!
(define (heap-write! heap addr values)
    (poke! heap addr (car values))
    (if (null? (cdr values))
        0
        (heap-write! heap (+ addr 1) (cdr values))))

;~~~~~~~~~~~~~~~~~~
; core vm threads

; time is the base time for this thread - ie it will only be incremented by the 
; amount of time between beats, so thread can be syncronised with one start time
; dunno how network sync is going to work yet - I guess the time can be set to 
; the incoming sync time/timestamp

; a thread has it's own stack, and an origin 
; (org) value which all memory accesses are 
; relative to. this allows easier code, as 
; the same code can be run anywhere in memory 

(define (make-thr addr vox)
    (list 0 (make-stack) addr vox))

(define (thr-get-pc thr)
    (list-ref thr 0))

(define (thr-get-pc-global thr)
    (+ (thr-get-pc thr) (thr-get-org thr)))

(define (thr-set-pc! thr pc)
    (list-set! thr 0 (modulo pc 256)))

(define (thr-inc-pc! thr)
    (list-set! thr 0 (modulo (+ (list-ref thr 0) 1) 256)))

(define (thr-push! thr value)
    (stack-push! (list-ref thr 1) value))

(define (thr-pop! thr)
    (stack-pop! (list-ref thr 1)))

(define (thr-top thr)
    (stack-top (list-ref thr 1)))

(define (thr-get-stack thr)
    (list-ref thr 1))

(define (thr-get-org thr)
    (list-ref thr 2))

(define (thr-set-org! thr addr)
    (thr-set-pc! thr 0)
    (list-set! thr 2 addr))

(define (thr-peek thr heap addr)
    (peek heap (+ (thr-get-org thr) addr)))

(define (thr-poke! thr heap addr value)
    (poke! heap (+ (thr-get-org thr) addr) value))

(define (thr-get-vox thr)
    (list-ref thr 3))

(define (thr-set-vox! thr vox)
    (list-set! thr 3 vox))

(define (make-opinfo pc opcode)
    (list opcode pc))
    
(define (opinfo-get-opcode opinfo)
    (list-ref opinfo 0))

(define (opinfo-get-pc opinfo)
    (list-ref opinfo 1))

; returns an opinfo containing the executed opcode, zero otherwise, and the pc
; for updating the gui with "assembled" code (really just the appropriate opcode)
(define (thr-update thr heap time)
    ; return the opinfo
    (make-opinfo (modulo (thr-get-pc-global thr) (vector-length heap))
        (thr-execute thr heap time)))

; constant opcodes - could get rid of these, but make life easier debugging and testing

(define NOP   0)
(define PSHL  1)
(define PSH   2)
(define PSHI  3)
(define POP   4)
(define POPI  5)
(define INC   6)
(define ADD   7)
(define SUB   8)
(define MUL   9)
(define DIV   10)
(define EQ?   11)
(define JMPZ  12)
(define JMP   13)
(define NOTE  14)
(define ORG   15)
(define MOD   16)
(define AND   17)
(define OR    18)
(define XOR   19)
(define NOT   20)
(define ROR   21)
(define ROL   22)
(define VOX   23)
(define DEC   24)
(define MOV   25)
(define MOVI  26)
(define PIP   27)
(define PDP   28)

(define (thr-execute thr heap time)
    ; all the operations
    (define ops
        (list
            (cons NOP
                0)
                
            (cons PSHL  ; push from code literal
                (lambda ()
                    (thr-inc-pc! thr)
                    (thr-push! thr (thr-peek thr heap (thr-get-pc thr)))))

            (cons PSH ; push from heap address
                (lambda ()
                    (thr-inc-pc! thr)
                    (thr-push! thr (thr-peek thr heap 
                        (thr-peek thr heap (thr-get-pc thr))))))

            (cons PSHI ; push from heap address stored on heap
                (lambda ()
                    (thr-inc-pc! thr)
                    (thr-push! thr (thr-peek thr heap 
                        (thr-peek thr heap 
                            (thr-peek thr heap (thr-get-pc thr)))))))

            (cons POP ; pop to heap address
                (lambda ()
                    (thr-inc-pc! thr)
                    (thr-poke! thr heap (thr-peek thr heap (thr-get-pc thr))
                        (thr-pop! thr))))

            (cons POPI ; pop to heap address stored on heap
                (lambda ()
                    (thr-inc-pc! thr)
                    (thr-poke! thr heap (thr-peek thr heap 
                        (thr-peek thr heap (thr-get-pc thr)))
                            (thr-pop! thr))))
          

            (cons MOV ; copy to heap address
                (lambda ()
                    (thr-inc-pc! thr)
                    (thr-poke! thr heap (thr-peek thr heap (thr-get-pc thr))
                        (thr-top thr))))

            (cons MOVI ; copy to heap address stored on heap
                (lambda ()
                    (thr-inc-pc! thr)
                    (thr-poke! thr heap (thr-peek thr heap 
                        (thr-peek thr heap (thr-get-pc thr)))
                            (thr-top thr))))
          
            (cons INC 
                (lambda ()
                    (thr-push! thr (+ (thr-pop! thr) 1))))
                    
            (cons ADD ; pop and add top two items on the stack and push the result
                (lambda ()
                    (thr-push! thr (+ (thr-pop! thr) (thr-pop! thr)))))

            (cons SUB 
                (lambda ()
                    (thr-push! thr (- (thr-pop! thr) (thr-pop! thr)))))

            (cons MUL
                (lambda ()
                    (thr-push! thr (* (thr-pop! thr) (thr-pop! thr)))))

            (cons DIV
                (lambda ()
                    (let ((a (thr-pop! thr)) (b (thr-pop! thr)))
                    (if (zero? b)
                        (thr-push! thr 0) ; return 0 for divide by zero
                        (thr-push! thr (inexact->exact (round (/ a b))))))))

            (cons EQ?
                (lambda ()
                    (cond
                        ((eq? (thr-pop! thr) (thr-pop! thr))
                            (thr-push! thr 1))
                        (else
                            (thr-push! thr 0)))))

            (cons JMPZ
                (lambda ()
                    (thr-inc-pc! thr)
                    (cond
                        ((eq? (thr-top thr) 0)
                            ; -1 accounts for the pc inc below
                            (thr-set-pc! thr (- (thr-peek thr heap (thr-get-pc thr)) 1))))))

            (cons JMP
                (lambda ()
                    (thr-inc-pc! thr)                            
                    ; -1 accounts for the pc inc below
                    (thr-set-pc! thr (- (thr-peek thr heap (thr-get-pc thr)) 1))))

            (cons NOTE
                (lambda ()
                    (let ((note (thr-pop! thr)))
                    (when (not (zero? note))
                        (note-hook note-hook-data time (thr-get-pc-global thr)))               
                    (play-note time note (thr-get-vox thr)))))

            (cons VOX
                (lambda ()
                    (thr-set-vox! thr (thr-top thr))))

            (cons ORG
                (lambda ()
                    (thr-set-org! thr (thr-get-pc-global thr))))
                    
            (cons MOD
                (lambda ()
                    (let ((a (thr-pop! thr)) (b (thr-pop! thr)))
                    (if (zero? b)
                        (thr-push! thr 0) ; return 0 for modulo zero
                        (thr-push! thr (modulo a b))))))
                   
            (cons AND
                (lambda ()
                    (thr-push! thr (bitwise-and (thr-pop! thr) (thr-pop! thr)))))

            (cons OR
                (lambda ()
                    (thr-push! thr (bitwise-ior (thr-pop! thr) (thr-pop! thr)))))
                    
            (cons XOR
                (lambda ()
                    (thr-push! thr (bitwise-xor (thr-pop! thr) (thr-pop! thr)))))
                    
            (cons NOT
                (lambda ()
                    (thr-push! thr (bitwise-not (thr-pop! thr)))))

            ; rotate bits right
            (cons ROR
                (lambda ()
                    (thr-push! thr (arithmetic-shift (thr-pop! thr) (- (thr-pop! thr))))))

            ; rotate bits left
            (cons ROL
                (lambda ()
                    (thr-push! thr (arithmetic-shift (thr-pop! thr) (thr-pop! thr)))))

 
            (cons DEC 
                (lambda ()
                    (thr-push! thr (- (thr-pop! thr) 1))))

            (cons PIP 
                (lambda ()
                    (thr-inc-pc! thr)
                    (thr-poke! thr heap (thr-peek thr heap (thr-get-pc thr))
                         (+ (thr-peek thr heap (thr-peek thr heap (thr-get-pc thr))) 1))))

            (cons PDP 
                (lambda ()
                    (thr-inc-pc! thr)
                    (thr-poke! thr heap (thr-peek thr heap (thr-get-pc thr))
                         (- (thr-peek thr heap (thr-peek thr heap (thr-get-pc thr))) 1))))
                            
        ;    (cons CALL
        ;        (lambda ()
        ;            (thr-inc-pc! thr)
        ;            (thr-push! thr (thr-get-pc thr))
        ;            (thr-set-pc! thr (thr-peek thr heap (thr-get-pc thr)))))

        ;    (cons RET
        ;        (lambda ()
        ;            (thr-inc-pc! thr)
        ;            (thr-set-pc! thr (thr-pop! thr))))
        ))

    (let ((opcode (thr-peek thr heap (thr-get-pc thr))))
    (let ((op (assq opcode ops)))

    (cond
        ((eq? #f op)
            0);(display "op [")(display opcode)(display "] not understood")(newline))
        (else
            (cond 
                ((not (zero? opcode))
                    ((cdr op))))))

    (thr-inc-pc! thr)
    opcode)))
    

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; joystick input


(define (make-joylisten)
    (define (make-axes n l)
        (if (zero? n)
            l
            (make-axes (- n 1) (cons (make-vector 2 0) l))))
            
    (list (list->mlist (make-list 16 0)) (make-axes 16 '()) (list->mlist (make-list 16 0))))
    
(define (joylisten-get-buttons joylisten)
    (list-ref joylisten 0))

(define (joylisten-get-axes joylisten)
    (list-ref joylisten 1))

(define (joylisten-get-button-state joylisten)
    (list-ref joylisten 2))
   
(define (joylisten-get-button joylisten n)
    (list-ref (joylisten-get-buttons joylisten) n))

(define (joylisten-button-changed joylisten n)
    (list-ref (joylisten-get-button-state joylisten) n))

(define (joylisten-get-axis joylisten n)
    (list-ref (joylisten-get-axes joylisten) n))

(define (joylisten-set-button! joylisten n s)
    (list-set! (joylisten-get-buttons joylisten) n s))

(define (joylisten-update joylisten)
    (define (drain path value)         ; drains all osc events for a message and 
        (if (osc-msg path)             ; only reports the last one which is ok for
            (drain path (osc 0))       ; this sort of control
            value))
            
    (define (do-axes n)
        (let ((value (drain (string-append "/oscjoy.0.axis." (number->string n)) #f)))
        (cond
            ((number? value)
                ; do some mangling of values here,
                ; firstly, make 0=x 1=y and secondly,
                ; change the range from 0 to 1 to -1 to 1
                (vector-set! (joylisten-get-axis joylisten (inexact->exact (truncate (/ n 2))))
                    (- 1 (modulo n 2)) (* 2 (- value 0.5))))))
          (if (zero? n)
            0
            (do-axes (- n 1))))
 
    (define (do-buttons n)
        (let ((value (drain (string-append "/oscjoy.0.button." (number->string n)) #f)))
        (cond 
            ((number? value)
                ; have we changed?
                (if (not (eq? (joylisten-get-button joylisten n) value))
                    (list-set! (joylisten-get-button-state joylisten) n #t)
                    (list-set! (joylisten-get-button-state joylisten) n #f))
                (joylisten-set-button! joylisten n value))))
        (if (zero? n)
            0
            (do-buttons (- n 1))))

    ;(display (osc-peek)) (newline)
    
    (do-axes 16)
    (do-buttons 16)
    )
                


;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; heap editor IDE user interface thing
;
; the rest of this code is all about the user interface

(define gui-opcodes 
    (list "nop" "pshl" "psh" "pshi" "pop" "popi" "inc" "add" "sub" "mul" "div" "eq?" "jmpz" "jmp" "note" "org"
          "mod" "and" "or" "xor" "not" "ror" "rol" "vox" "dec" "mov" "movi" "pip" "pdp"))
 
(define (gui-byte-make-text text)
    (push)
    (hint-ignore-depth)
    (colour text-colour)
    (translate (vector -0.4 0.45 0.001))
    (scale (vector 0.6 0.6 0.6))
    (texture (load-texture "font.png"))
    (let ((ret (build-text text)))
    (pop)
    (grab ret)
    (selectable 0) ; turn off selection so we only pick up the background tile
    (ungrab)
    ret))

; makes a tile element representing a byte
(define (make-gui-byte heap addr)
    (colour bg-colour)
    (make-gui-tile (number->string (peek heap addr))))
    
; makes a tile element with a string
(define (make-gui-tile text)

    (define (make-bg)
        (push)
        (hint-ignore-depth)
        (texture (load-texture "element.png"))
        (let ((ret (build-plane)))
        (pop)
        ret))
        
    (let ((bg (make-bg)))
    (push)
    (identity)
    (parent bg)
    (let ((txt (gui-byte-make-text text)))
    (opacity 0.3)
    (colour (vector 1 1 1))
    (hint-depth-sort)
    (texture (load-texture "element.png"))
    (translate (vector 0 0 0.1))
    (let ((trigger (build-plane)))
    (pop)
    (grab trigger)
    (hide 1)
    (ungrab)
    (apply-transform trigger)
    (list bg txt 0 trigger -1)))))

(define (gui-byte-get-obj byte)
    (list-ref byte 0))

(define (gui-byte-get-type byte)
    (list-ref byte 2))

(define (gui-byte-get-trigger byte)
    (list-ref byte 3))

(define (gui-byte-get-trigger-time byte)
    (list-ref byte 4))

(define (gui-byte-set-trigger-time byte s)
    (list-set! byte 4 s))

(define (gui-byte-set-trigger byte t)
    (list-set! byte 4 (- t current-time)))

(define (gui-byte-set-type! byte type)
    (list-set! byte 2 type)
    (grab (gui-byte-get-obj byte))
;    (colour (gui-byte-get-col byte))
    (ungrab))

(define (gui-byte-get-col byte)
    (if (eq? (gui-byte-get-type byte) 0)
        data-colour
        op-colour))

(define (gui-byte-set-text! byte text)
    (destroy (list-ref byte 1)) ; destroy the old one
    (push)
    (parent (gui-byte-get-obj byte))
    (list-set! byte 1 (gui-byte-make-text text))
    (pop))

(define (gui-byte-set-data! byte data)
    (gui-byte-set-type! byte 0)
    (gui-byte-set-text! byte (number->string data)))

(define (gui-byte-set-op! byte op)
    (gui-byte-set-type! byte 1)
    (gui-byte-set-text! byte op))

(define (gui-byte-update byte)
    (cond
        ((>= (gui-byte-get-trigger-time byte) -99)

         (grab (gui-byte-get-trigger byte))     
         (cond 
            ((> (gui-byte-get-trigger-time byte) 1)
                (hide 1)
                (gui-byte-set-trigger-time byte -100))
            (else
                (hide 0)
                (colour menu-hi-colour)
                (identity)
                (scale (vmul (vector 1.0 1.0 1.0) 
                    (* (gui-byte-get-trigger-time byte) 10)))
                (gui-byte-set-trigger-time byte 
                    (+ (gui-byte-get-trigger-time byte) (delta)))))
         (ungrab))))
        
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

; makes all the byte elements for the heap
(define (make-gui-heap heap width)

    (let ((ret '()) (addr 0))

    ; returns the next address
    (define (heap-line n)
        (translate (vector 1 0 0))
        (set! ret (append ret (list (make-gui-byte heap addr))))
        (set! addr (+ addr 1))
        (if (or (zero? n) (> addr (- (vector-length heap) 1)))
            0
            (heap-line (- n 1))))
    
    (define (heap-grid)
        (push)
        (heap-line width)
        (pop)
        (translate (vector 0 -1 0))
        (if (> addr (- (vector-length heap) 1))
            0
            (heap-grid)))
            
    (set! width (- width 1))

    (push)
    (heap-grid)
    (pop)
    ret))

(define (gui-heap-get-byte gui-heap addr)
    (list-ref gui-heap addr))

; finds the byte given a fluxus object
(define (gui-heap-find-byte gui-heap obj)
    (cond 
        ((eq? (gui-byte-get-obj (car gui-heap)) obj)
            (car gui-heap))
        (else
            (if (null? (cdr gui-heap))
                0
                (gui-heap-find-byte (cdr gui-heap) obj))))) 

(define highlight '())

; to be called by poke
(define (gui-heap-update gui-heap addr value)
    (set! highlight (cons (gui-heap-get-byte gui-heap addr) highlight))
    (gui-byte-set-data! (car highlight) value)
    (grab (gui-byte-get-obj (car highlight)))
    (colour poke-colour)
    (ungrab))

; to be called by peek
(define (gui-heap-display-peek gui-heap addr)
    (set! highlight (cons (gui-heap-get-byte gui-heap addr) highlight))
    (grab (gui-byte-get-obj (car highlight)))
    (colour peek-colour)
    (ungrab))

; to be called by note
(define (gui-heap-trigger gui-heap time addr)
    (gui-byte-set-trigger (gui-heap-get-byte gui-heap (modulo addr 256)) time))


; reset all the highlighted bytes peeked
(define (unhighlight highlight)
    (cond ((not (null? highlight))
        (grab (gui-byte-get-obj (car highlight)))
        (colour (gui-byte-get-col (car highlight)))
        (ungrab)
        (if (null? (cdr highlight))
            0
            (unhighlight (cdr highlight))))))


(define (gui-heap-frame-update gui-heap)
    (for-each
        (lambda (gui-byte)
            (gui-byte-update gui-byte))
        (mlist->list gui-heap)))


    
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; cursor
;
; defines where we are, and where
; to put the menus

(define (make-gui-cursor)
    (define (make-cursor)
        (push)
        (translate (vector 0 0 0.001))
        (scale (vector 1.2 1.2 1.2))
        (texture (load-texture "cursor.png"))
        (let ((ret (build-plane)))
        (pop)
        ret))
    (push)
    (scale (vector 1.2 1.2 1.2))
    (let ((obj (make-cursor)))
    (pop)
    (apply-transform obj)
    (lock-camera obj)
    (camera-lag 0.01)
    (list obj 0 0)))
    
(define (gui-cursor-get-obj cursor)
    (list-ref cursor 0))

(define (gui-cursor-get-addr cursor)
    (list-ref cursor 1))

(define (gui-cursor-set-addr! cursor addr)
    (list-set! cursor 1 addr))

(define (gui-cursor-get-next-time cursor)
    (list-ref cursor 2))

(define (gui-cursor-set-next-time! cursor time)
    (list-set! cursor 2 time))
    
(define (gui-cursor-animate cursor)
    (grab (gui-cursor-get-obj cursor))
    (colour (vector (cos (* current-time 20)) (cos (* current-time 20)) 1))
    (ungrab))
    
(define (gui-cursor-move cursor addr gui-heap)
    (let ((addr (modulo addr 256)))
    (push)
    (grab (gui-byte-get-obj (gui-heap-get-byte gui-heap addr)))
    (let ((tx (get-transform)))
    (ungrab)
    (grab (gui-cursor-get-obj cursor))
    (identity)
    (concat tx))
    (translate (vector 0 0 0.001))
    (ungrab)
    (gui-cursor-set-addr! cursor addr)))


;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; ring menu

; ring menus are great with analogue controllers as they allow fast selection
; from quite a large range - and the positions can be memorised quickly

; items is a list of strings for the menu selector
(define (make-menu position items)
    (list position items '() 0 0 0))

(define (menu-get-position menu)
    (list-ref menu 0))

(define (menu-set-position! menu pos)
    (list-set! menu 0 pos)
    (cond 
        ((not (null? (menu-get-objs menu)))
            (grab (menu-get-root menu))
            (identity)
            (translate pos)
            (ungrab))))

(define (menu-get-items menu)
    (list-ref menu 1))

(define (menu-get-objs menu)
    (list-ref menu 2))

(define (menu-set-objs! menu objs)
    (list-set! menu 2 objs))

(define (menu-get-root menu)
    (list-ref menu 3))

(define (menu-set-root! menu root)
    (list-set! menu 3 root))

(define (menu-get-selected menu)
    (list-ref menu 4))

(define (menu-set-selected! menu selected)
    (list-set! menu 4 selected))

(define (menu-get-shown menu)
    (list-ref menu 5))

(define (menu-set-shown! menu shown)
    (list-set! menu 5 shown))

(define (menu-build menu)
    (define (loop n size)
        (push)
        (rotate (vector 0 0 (* 360 (/ n size))))
        (translate (vector 2 0 0))
        (rotate (vector 0 0 (- (* 360 (/ n size)))))
        (if (zero? n) 
            (translate (vector 0 0 0.1)) ; compensate for the selection
            (scale (vector 0.5 0.5 1))) ; don't scale the selected one
        (menu-set-objs! menu (cons (car (make-gui-tile (list-ref (menu-get-items menu) n)))
            (menu-get-objs menu)))
        (pop)
        (if (zero? n)
            0
            (loop (- n 1) size)))
    
    (let ((size (length (menu-get-items menu))))
    (push)
    (colour menu-colour)
    (translate (vector 0 0 1))
    (menu-set-root! menu (build-locator))
    (parent (menu-get-root menu))
    (loop (- size 1) size))
    (pop))

(define (menu-update menu joylisten axis select-fn)
    (define (ang x y)
        (let ((q (/ 3.141 2)))
        (when (zero? y) (set! y 0.0001))
        (cond 
            ((>= y 0)
                (+ q q q (- q (atan (/ x y)))))
            (else
                (+ q (- q (atan (/ x y))))))))
    
    (grab (menu-get-root menu))
    (let ((s (sqrt (+ (* (vector-ref (joylisten-get-axis joylisten axis) 0) (vector-ref (joylisten-get-axis joylisten axis) 0))
                      (* (vector-ref (joylisten-get-axis joylisten axis) 1) (vector-ref (joylisten-get-axis joylisten axis) 1))))))
    (when (> s 0.5) (set! s 0.5))
    (set! s (* s 2))
    (scale (vector s s s))
    (ungrab))
    ; deadzone
    (cond
        ((or (or (> (vector-ref (joylisten-get-axis joylisten axis) 0) deadzone)
                 (< (vector-ref (joylisten-get-axis joylisten axis) 0) (- deadzone)))
             (or (> (vector-ref (joylisten-get-axis joylisten axis) 1) deadzone)
                 (< (vector-ref (joylisten-get-axis joylisten axis) 1) (- deadzone))))
            
            (menu-show menu)
                                    
            (select-fn menu (inexact->exact (round (* (length (menu-get-items menu))
                (/ (ang (vector-ref (joylisten-get-axis joylisten axis) 0)
                          (vector-ref (joylisten-get-axis joylisten axis) 1)) (* 3.141 2)))))))
        (else
            (menu-hide menu))))

(define (menu-select menu selected)
    (set! selected (modulo selected (length (menu-get-items menu))))
    (grab (list-ref (menu-get-objs menu) (menu-get-selected menu)))
    (translate (vector 0 0 -0.1))
    (colour menu-colour)    
    (scale (vector 0.5 0.5 0.5))
    (ungrab)
    (menu-set-selected! menu selected)
    (grab (list-ref (menu-get-objs menu) (menu-get-selected menu)))
    (scale (vector 2 2 2))
    (colour menu-hi-colour)    
    (translate (vector 0 0 0.1))
    (ungrab))

(define (menu-show menu)
    (grab (menu-get-root menu))
    (hide 0)
    (ungrab)
    (menu-set-shown! menu #t))
    
(define (menu-hide menu)
    (grab (menu-get-root menu))
    (hide 1)
    (ungrab)
    (menu-set-shown! menu #f))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; text ring menu - same as normal ring menu without the boxes

(define (text-menu-build menu)
    (define (loop n size)
        (push)
        (rotate (vector 0 0 (* 360 (/ n size))))
        (translate (vector 2 0 0))
        (rotate (vector 0 0 (- (* 360 (/ n size)))))
        (if (zero? n) 
            (translate (vector 0 0 0.1)) ; compensate for the selection
            (scale (vector 0.5 0.5 1))) ; don't scale the selected one
        (menu-set-objs! menu (cons (gui-byte-make-text (list-ref (menu-get-items menu) n))
            (menu-get-objs menu)))
        (pop)
        (if (zero? n)
            0
            (loop (- n 1) size)))
    
    (let ((size (length (menu-get-items menu))))
    (push)
    (colour menu-colour)
    (translate (vector 0 0 1))
    (menu-set-root! menu (build-locator))
    (parent (menu-get-root menu))
    (loop (- size 1) size))
    (pop))
    
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; ring slider - for values, same as ring menu mostly

(define (make-slider position gui-heap)
    (define (loop n l)
        (set! l (cons (number->string n) l))
        (if (zero? n)
            l
            (loop (- n 1) l)))
    (let ((pointer (make-pointer 100 10)))
    (pointer-build pointer gui-heap)
    (list position (loop 256 '()) '() 0 0 0 pointer)))

(define (slider-build menu)
    (define (loop n size)
        (push)
        (rotate (vector 0 0 (* 360 (/ n size))))
        (translate (vector 2 0 0))
        (rotate (vector 0 0 (- (* 360 (/ n size)))))
        (if (zero? n) 
            (translate (vector 0 0 0.1)) ; compensate for the selection
            (scale (vector 0.5 0.5 1))) ; don't scale the selected one
        (menu-set-objs! menu (cons (car (make-gui-tile (list-ref (menu-get-items menu) n)))
            (menu-get-objs menu)))
        (pop)
        (grab (car (menu-get-objs menu)))
        (hide 1)
        (ungrab)
        (if (zero? n)
            0
            (loop (- n 1) size)))
    
    (let ((size (length (menu-get-items menu))))
    (push)
    (colour menu-colour)
    (translate (vector 0 0 1))
    (menu-set-root! menu (build-locator))
    (parent (menu-get-root menu))
    (loop (- size 1) size))
    (pop))

(define (slider-get-pointer menu)
    (list-ref menu 6))

(define (slider-select menu selected)
    (set! selected (modulo selected (length (menu-get-items menu))))
    (grab (list-ref (menu-get-objs menu) (menu-get-selected menu)))
    (translate (vector 0 0 -0.1))
    (colour menu-colour)    
    (hide 1)
    (scale (vector 0.5 0.5 0.5))
    (ungrab)
    (menu-set-selected! menu selected)
    (grab (list-ref (menu-get-objs menu) (menu-get-selected menu)))
    (scale (vector 2 2 2))
    (hide 0)
    (colour menu-hi-colour)    
    (translate (vector 0 0 0.1))
    (ungrab))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; pointer visualisation
;
; pointers visualise the memory addressing and 
; can be placed over any heap address to see what's
; going on. also used by the data menu for a 
; preview of the address you are about to write

(define (make-pointer addr id)
    (list 0 addr id))
    
(define (pointer-get-obj pointer)
    (list-ref pointer 0))

(define (pointer-set-obj! pointer s)
    (list-set! pointer 0 s))

(define (pointer-get-addr pointer)
    (list-ref pointer 1))

(define (pointer-set-addr! pointer addr)
    (list-set! pointer 1 addr))

(define (pointer-get-id pointer)
    (list-ref pointer 2))

(define (pointer-build pointer gui-heap)
    (push)
    (texture (load-texture "pointer.png"))
    (let ((p (build-line 2)))
    (pop)
    (grab p)
        (hint-unlit)   
        (colour (vector 1 1 0))
        (translate (vector 0 0 (+ 0.01 (* (pointer-get-id pointer) 0.01))))
        (pdata-set "w" 0 0.4)
        (pdata-set "w" 1 0.4)
    (ungrab)
    (pointer-set-obj! pointer p)
    (pointer-point-from pointer (pointer-get-addr pointer) gui-heap)))

(define (pointer-destroy pointer)
    (destroy (pointer-get-obj pointer)))

(define (pointer-point-from pointer addr gui-heap)
    (pointer-set-addr! pointer addr)
    (grab (car (gui-heap-get-byte gui-heap (pointer-get-addr pointer))))
        (let ((pos (vtransform (vector 0 0 0) (get-transform))))
    (ungrab)
    (grab (pointer-get-obj pointer))
        (pdata-set "p" 0 pos)
    (ungrab)))
    
(define (pointer-point-to pointer addr ptr heap gui-heap)
    (define (find-org addr n)
        (cond 
            ((equal? ORG (vector-ref heap n)) ; badness, breaking heap's encapsulation
                n)
            (else
                (if (equal? n (modulo (+ addr 1) 256)) ; looped all the way round, so exit
                    0                                  ; and return zero for now
                    (find-org addr (modulo (- n 1) 256))))))
                    
    (let ((addr (pointer-get-addr pointer)))
    (let ((org (find-org addr addr)))
    (grab (car (gui-heap-get-byte gui-heap (modulo (+ ptr org) 256))))
        (let ((topos (vtransform (vector 0 0 0) (get-transform))))
    (ungrab)
    (grab (pointer-get-obj pointer))
        (pdata-set "p" 1 topos)
    (ungrab)))))
    
(define (pointer-update pointer heap gui-heap)
    (pointer-point-to pointer (pointer-get-addr pointer)
        (vector-ref heap (pointer-get-addr pointer)) heap gui-heap))

(define (pointer-hide pointer)
    (grab (pointer-get-obj pointer))
    (hide 1)
    (ungrab))

(define (pointer-show pointer)
    (grab (pointer-get-obj pointer))
    (hide 0)
    (ungrab))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~
; pointers control    
;
; a controller to keep track of all the pointers,
; and keep them updating per frame

(define (make-pointers)
    (list (list)))
    
(define (pointers-get-pointers pointers)
    (list-ref pointers 0))

(define (pointers-set-pointers! pointers s)
    (list-set! pointers 0 s))

(define (pointers-add pointers addr gui-heap)
    (let ((pointer (make-pointer addr (length (pointers-get-pointers pointers)))))
    (pointer-build pointer gui-heap)
    (pointers-set-pointers! pointers (cons pointer (pointers-get-pointers pointers)))))

(define (pointers-remove pointers addr)
    (define (remove pointers addr out)
        (if (null? pointers)
            out
            (cond 
                ((equal? (pointer-get-addr (car pointers)) addr)
                    (pointer-destroy (car pointers))
                    (remove (cdr pointers) addr out))
                (else
                    (remove (cdr pointers) addr (cons (car pointers) out))))))                
    (pointers-set-pointers! pointers
        (remove (pointers-get-pointers pointers) addr '())))

(define (pointers-toggle pointers addr gui-heap)
    (define (find l)
        (cond 
            ((null? l) #f)
            ((equal? addr (pointer-get-addr (car l)))
                #t)
            (else
                (if (null? (cdr l))
                    #f
                    (find (cdr l))))))
    (cond 
        ((find (pointers-get-pointers pointers))
            (pointers-remove pointers addr))
        (else
            (pointers-add pointers addr gui-heap))))
                
(define (pointers-update pointers heap gui-heap)
    (define (update pointers)
           (pointer-update (car pointers) heap gui-heap)
        (if (null? (cdr pointers))
            0
            (update (cdr pointers))))
    
    (let ((pointers (pointers-get-pointers pointers)))
    (when (not (null? pointers)) ; maybe we have no pointers - this is ok
        (update pointers))))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~
; thread control    
;
; multithreading 

(define (make-thread-control)
    (list (list) 0))
    
(define (thread-control-get-threads thrctrl)
    (list-ref thrctrl 0))

(define (thread-control-get-current-vox thrctrl)
    (list-ref thrctrl 1))

(define (thread-control-inc-current-vox thrctrl)
    (list-set! thrctrl 1 (+ (list-ref thrctrl 1) 1)))

(define (thread-control-set-threads! thrctrl threads)
    (list-set! thrctrl 0 threads))

(define (thread-control-add thrctrl addr)
    (thread-control-set-threads! thrctrl 
        (cons (make-thr addr (thread-control-get-current-vox thrctrl)) 
            (thread-control-get-threads thrctrl)))    
    ; use a different default voice for every thread 
    (thread-control-inc-current-vox thrctrl))


(define (thread-control-remove thrctrl addr)
    (define (remove threads addr out)
        (if (null? threads)
            out
            (cond 
                ; fixme when mem>256!
                ((equal? (modulo (thr-get-pc-global (car threads)) 256) addr)
                    (remove (cdr threads) addr out))
                (else
                    (remove (cdr threads) addr (cons (car threads) out))))))            
    (thread-control-set-threads! thrctrl 
        (remove (thread-control-get-threads thrctrl) addr '())))

(define (thread-control-sync thrctrl)
    (define (loop threads)
        (thr-set-pc! (car threads) 0)      
        (if (null? (cdr threads))
            0
            (loop (cdr threads))))
    (loop (thread-control-get-threads thrctrl)))
              
(define (thread-control-update thrctrl gui-heap heap time)
    (define (update threads)
        (let ((opinfo (thr-update (car threads) heap time)))

        ; display the executed code
        ; don't display nop's - clutters things up a little
        (if (not (zero? (opinfo-get-opcode opinfo)))
            (if (< (opinfo-get-opcode opinfo) (length gui-opcodes))
                (gui-byte-set-op! (gui-heap-get-byte gui-heap (opinfo-get-pc opinfo)) 
                    (list-ref gui-opcodes (opinfo-get-opcode opinfo)))
                   ; unknown opcode
                (gui-byte-set-op! (gui-heap-get-byte gui-heap (opinfo-get-pc opinfo)) "???"))))
                
        (if (null? (cdr threads))
            0
            (update (cdr threads))))
    
    (let ((threads (thread-control-get-threads thrctrl)))
    (when (not (null? threads)) ; maybe we have no threads running - this is ok
        (update threads))))    
    
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; codestream is in charge of loading code from disk

(define (make-codestream)
    (list block-code-location (files->strings block-code-location)))    

(define (codestream-get-path codestream)
    (list-ref codestream 0))

(define (codestream-get-filenames codestream)
    (list-ref codestream 1))

(define (codestream-load codestream heap start slot)
    (define (put-code pos l)
        (poke! heap pos (car l))
        (if (null? (cdr l))
            0
            (put-code (+ pos 1) (cdr l))))
    
    (let ((file (open-input-file (string-append (codestream-get-path codestream)
        (list-ref (codestream-get-filenames codestream) slot)))))
    (put-code start (read file))
    (close-input-port file)))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; copy/paste clipboard

(define (make-clipboard)
    (list 0 10 '()))
    
(define (clipboard-get-start clipboard)
    (list-ref clipboard 0))
    
(define (clipboard-set-start! clipboard start)
    (list-set! clipboard 0 start))

(define (clipboard-get-end clipboard)
    (list-ref clipboard 1))
    
(define (clipboard-set-end! clipboard end)
    (list-set! clipboard 1 end))

(define (clipboard-get-buffer clipboard)
    (list-ref clipboard 2))
    
(define (clipboard-set-buffer! clipboard buffer)
    (list-set! clipboard 2 buffer))

(define (clipboard-save clipboard filename)       
    (let ((file (open-output-file filename)))
    (write (clipboard-get-buffer clipboard) file)
    (close-output-port file)))
    
(define (clipboard-copy clipboard heap)
    (define (loop pos end)
        (clipboard-set-buffer! clipboard
            (append (clipboard-get-buffer clipboard) (list (peek heap pos))))
        (if (eq? pos end)
            0
            (loop (+ pos 1) end)))
    
    (clipboard-set-buffer! clipboard '())
    
    (if (< (clipboard-get-start clipboard) (clipboard-get-end clipboard))
        (loop (clipboard-get-start clipboard) (clipboard-get-end clipboard))
        (loop (clipboard-get-end clipboard) (clipboard-get-start clipboard))))

(define (clipboard-paste clipboard addr heap)
    (define (loop pos l)
        (poke! heap pos (car l))
        (if (null? (cdr l))
            0
            (loop (+ pos 1) (cdr l))))
            
    (loop addr (clipboard-get-buffer clipboard)))
    
(define (clipboard-update clipboard gui-heap)
    (define (loop pos end)
        (grab (gui-byte-get-obj (gui-heap-get-byte gui-heap pos)))
        (let ((tx (get-transform)))
        (ungrab)
        (push)
        (concat tx)
        (translate (vector 0 0 0.1))
        (opacity 0.5)
        (colour (vector 1 0 0))
        (draw-plane)
        (pop)
        (if (eq? pos end)
            0
            (loop (+ pos 1) end))))
            
    (if (< (clipboard-get-start clipboard) (clipboard-get-end clipboard))
        (loop (clipboard-get-start clipboard) (clipboard-get-end clipboard))
        (loop (clipboard-get-end clipboard) (clipboard-get-start clipboard))))

    
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; util functions for patch menu

(define (files->strings path)
    (define (convert in out)
        (if (null? in)
            out
            (convert (cdr in) (append out (list (path->string (car in)))))))
            
    (convert (list->mlist (directory-list path)) '()))

(define (patch-eval path id)
    (load (string-append path (list-ref (files->strings path) id))))
            
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; camera control

(define (make-camera)
    (set-camera-transform (mtranslate (vector 0 0 -10)))
    (list 10 0))

(define (camera-get-zoom camera)
    (list-ref camera 0))

(define (camera-set-zoom! camera zoom)
    (list-set! camera 0 zoom))

(define (camera-get-x camera)
    (list-ref camera 1))

(define (camera-set-x! camera x)
    (list-set! camera 1 x))

(define (camera-update camera joylisten)
    
    (camera-set-zoom! camera (+ (camera-get-zoom camera) 
        (* (vector-ref (joylisten-get-axis joylisten joymap-rstick) 1) 0.1)))

    (camera-set-x! camera (+ (camera-get-x camera) 
        (* (vector-ref (joylisten-get-axis joylisten joymap-rstick) 0) 0.1)))
    
    (set-camera-transform (minverse (mtranslate (vector (camera-get-x camera) 0 
        (camera-get-zoom camera))))))

    
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; collect all the bits into the application

     
(define (make-bb)
    (let ((heap (make-heap 256)))
    (let ((gui-heap (make-gui-heap heap 16)))
    (list current-time 
          heap  
          (make-thread-control) 
          gui-heap 
          (make-gui-cursor) 
          (make-joylisten)
          (make-menu (vector 0 0 0) gui-opcodes)
          (make-slider (vector 0 0 0) gui-heap)
          (make-menu (vector 0 0 0) (files->strings block-code-location))
          (make-menu (vector 0 0 0) (files->strings block-patch-location))
          (make-pointers)
          (make-codestream)
          (make-clipboard)
          current-time
          (make-camera)
          0
          current-time))))
  
(define (bb-get-next-time bb)
    (list-ref bb 0))

(define (bb-set-next-time! bb time)
    (list-set! bb 0 time))

(define (bb-get-heap bb)
    (list-ref bb 1))

(define (bb-get-thread-control bb)
    (list-ref bb 2))

(define (bb-get-gui-heap bb)
    (list-ref bb 3))

(define (bb-get-cursor bb)
    (list-ref bb 4))

(define (bb-get-joylisten bb)
    (list-ref bb 5))

(define (bb-get-opmenu bb)
    (list-ref bb 6))

(define (bb-get-slider bb)
    (list-ref bb 7))

(define (bb-get-filemenu bb)
    (list-ref bb 8))

(define (bb-get-patchmenu bb)
    (list-ref bb 9))

(define (bb-get-pointers bb)
    (list-ref bb 10))

(define (bb-get-codestream bb)
    (list-ref bb 11))

(define (bb-get-clipboard bb)
    (list-ref bb 12))

(define (bb-get-next-highlight-time bb)
    (list-ref bb 13))

(define (bb-set-next-highlight-time! bb time)
    (list-set! bb 13 time))

(define (bb-get-camera bb)
    (list-ref bb 14))

(define (bb-get-sync-count bb)
    (list-ref bb 15))

(define (bb-set-sync-count! bb s)
    (list-set! bb 15 s))

(define (bb-get-beat-time bb)
    (list-ref bb 16))

(define (bb-set-beat-time! bb s)
    (list-set! bb 16 s))

(define (bb-init bb)
    (gui-cursor-move (bb-get-cursor bb) 100 (bb-get-gui-heap bb))
    (set-poke-hook! gui-heap-update (bb-get-gui-heap bb))
    (set-peek-hook! gui-heap-display-peek (bb-get-gui-heap bb))
    (set-note-hook! gui-heap-trigger (bb-get-gui-heap bb))
    (menu-build (bb-get-opmenu bb))
    (menu-hide (bb-get-opmenu bb))
    (slider-build (bb-get-slider bb))
    (menu-hide (bb-get-slider bb))
    (text-menu-build (bb-get-filemenu bb))
    (menu-hide (bb-get-filemenu bb))    
    (text-menu-build (bb-get-patchmenu bb))
    (menu-hide (bb-get-patchmenu bb))
)

(define gui-cursor-debounce 0)

(define (bb-gui-update bb)
    (let ((cursor (bb-get-cursor bb))
        (gui-heap (bb-get-gui-heap bb))
        (width 16)
        (heap (bb-get-heap bb))
        (menu (bb-get-opmenu bb))
        (slider (bb-get-slider bb))
        (filemenu (bb-get-filemenu bb))
        (patchmenu (bb-get-patchmenu bb))
        (joylisten (bb-get-joylisten bb))
        (thrctrl (bb-get-thread-control bb))
        (pointers (bb-get-pointers bb))
        (clipboard (bb-get-clipboard bb)))
  
    ; debouncing gives us the button action we want - rapid keypresses work fast, 
    ; but holding down repeats are spaced out with the timer
    (define (debounce)
        (set! gui-cursor-debounce 1)
        (gui-cursor-set-next-time! cursor (+ current-time key-repeat)))

    (define (set-opcode addr value)
        (poke! heap addr value)
        (when (< value (length gui-opcodes))
            (gui-byte-set-op! (gui-heap-get-byte gui-heap addr) (list-ref gui-opcodes value))))
        
    ; update the gui-heap for the note triggers
    (gui-heap-frame-update gui-heap)

    (camera-update (bb-get-camera bb) joylisten)
        
    (cond ((>= current-time (gui-cursor-get-next-time cursor))
        (gui-cursor-set-next-time! cursor (+ current-time 0.1))
        (set! gui-cursor-debounce 0)))
        
    (let ((addr (gui-cursor-get-addr cursor)))
    
    (grab (gui-cursor-get-obj cursor))                
    (let ((pos (vtransform (vector 0 0 0) (get-transform))))
    (ungrab)
       
    ; clipboard    
    (cond 
        ; clipboard mode button 
        ((> (joylisten-get-button joylisten joymap-r2) 0)
            (cond
                ; don't wanna do stuff when we are trying to use the menu
                ((not (menu-get-shown menu))

                    ; slightly convoluted logic, to allow this to happen on the minimum of buttons:
                    ; if one of the directional keys is pressed (as well as the mode button above)
                    (when (or (< 0.1 (abs (vector-ref (joylisten-get-axis joylisten joymap-dpad) 0)))
                            (< 0.1 (abs (vector-ref (joylisten-get-axis joylisten joymap-dpad) 1))))

                        ; then find the closest endpoint of the clipboard selection
                        (if (< (abs (- (clipboard-get-start clipboard) addr))
                               (abs (- (clipboard-get-end clipboard) addr)))
                            (clipboard-set-start! clipboard addr)
                            (clipboard-set-end! clipboard addr)))

                    (when (> (joylisten-get-button joylisten joymap-a) 0)
                        (clipboard-paste clipboard addr heap))

                    (when (> (joylisten-get-button joylisten joymap-b) 0)
                        (clipboard-copy clipboard heap))
                        
                    (when (> (joylisten-get-button joylisten joymap-select) 0)
                        (clipboard-save clipboard "clipboard.asm"))))
                
            ; display the selection
            (clipboard-update clipboard gui-heap)))

    ; decide which menu mode we are in
    (cond 
        ((> (joylisten-get-button joylisten joymap-r1) 0)
            (menu-hide menu)
            (menu-hide filemenu)
            (menu-hide patchmenu)
            (menu-set-position! slider pos)
            (menu-update slider joylisten joymap-lstick slider-select))
        ((> (joylisten-get-button joylisten joymap-l1) 0)
            (menu-hide menu)
            (menu-hide slider)
            (menu-hide patchmenu)
            (menu-set-position! filemenu pos)
            (menu-update filemenu joylisten joymap-lstick menu-select))
        ((> (joylisten-get-button joylisten joymap-l2) 0)
            (menu-hide menu)
            (menu-hide slider)
            (menu-hide filemenu)
            (menu-set-position! patchmenu pos)
            (menu-update patchmenu joylisten joymap-lstick menu-select))
        (else
            (menu-hide filemenu)
            (menu-hide slider)
            (menu-hide patchmenu)
            (menu-set-position! menu pos)               
            (menu-update menu joylisten joymap-lstick menu-select))))
   
        
    ; update the data sliders pointer
    (cond 
        ((menu-get-shown slider)
            (let ((pointer (slider-get-pointer slider)))
            (pointer-show pointer)
            (pointer-point-from pointer addr gui-heap)
            (pointer-point-to pointer addr (menu-get-selected slider) heap gui-heap)))
        (else
            (pointer-hide (slider-get-pointer slider))))
    
    (pointers-update pointers heap gui-heap)
        
    (cond 
        ((< (vector-ref (joylisten-get-axis joylisten joymap-dpad) 0) 0)
            (cond ((zero? gui-cursor-debounce) 
                (set! addr (- addr width)) (debounce))))
                    
        ((< (vector-ref (joylisten-get-axis joylisten joymap-dpad) 1) 0)
            (cond ((zero? gui-cursor-debounce)            
                (set! addr (- addr 1)) (debounce))))
                
        ((> (vector-ref (joylisten-get-axis joylisten joymap-dpad) 0) 0)
            (cond ((zero? gui-cursor-debounce)            
                (set! addr (+ addr width)) (debounce))))
                
        ((> (vector-ref (joylisten-get-axis joylisten joymap-dpad) 1) 0)
            (cond ((zero? gui-cursor-debounce)            
                (set! addr (+ addr 1)) (debounce))))

        ((> (joylisten-get-button joylisten joymap-c) 0)
            (cond ((zero? gui-cursor-debounce)  
                (if (menu-get-shown slider) ; slider menu dec
                    (poke! heap addr (- (peek heap addr) 1))          
                    (thread-control-add thrctrl addr)) 
                (debounce))))

        ((> (joylisten-get-button joylisten joymap-d) 0)
            (cond ((zero? gui-cursor-debounce)            
                (if (menu-get-shown slider) ; slider menu inc
                    (poke! heap addr (+ (peek heap addr) 1))
                    (thread-control-remove thrctrl addr))
                (debounce))))
         
        ; toggle pointers view, if not in clipboard mode  
        ((and (< (joylisten-get-button joylisten joymap-r2) 1) 
              (> (joylisten-get-button joylisten joymap-b) 0))
            (cond ((zero? gui-cursor-debounce)            
                  (pointers-toggle pointers addr gui-heap) (debounce))))
                       
        ; main do things button
         ((> (joylisten-get-button joylisten joymap-a) 0)
            (cond ((zero? gui-cursor-debounce)    
                (cond 
                    ((menu-get-shown slider)
                        (poke! heap addr (menu-get-selected slider)) (debounce))
                    ((menu-get-shown filemenu)
                        (codestream-load (bb-get-codestream bb) heap addr 
                            (menu-get-selected filemenu))
                        (debounce))
                    ((menu-get-shown patchmenu)
                        (patch-eval block-patch-location (menu-get-selected patchmenu)))
                    (else
                        (set-opcode addr (menu-get-selected menu)) (debounce))))))
          
         ; manual sync   
         ((> (joylisten-get-button joylisten joymap-f) 0)
            (cond ((zero? gui-cursor-debounce)    
                (thread-control-sync thrctrl)
                (debounce))))
              
              
        (else (set! gui-cursor-debounce 0)))
    
    (gui-cursor-move cursor addr gui-heap))))

; figures out the offset to the nearest tick    
(define (calc-offset timenow synctime tick)
  (let ((p (/ (- synctime timenow) tick)))
    (let ((f (- p (floor p))))
      (if (< f 0.5)
          (* f tick)
          (- (* (- 1 f) tick))))))

(define (bb-sync bb)
    (cond 
        ((osc-msg "/sync")
            (let ((t (vector (osc 0) (osc 1))) (bpm (* bpm-multiplier (osc 3))))
            (let ((tick (/ 1 (/ bpm 60))))
            
            ; if the bpm has changed
            (when (not (equal? global-speed (/ bpm 60)))
                (bb-set-sync-count! bb 0)) ; reset the counter
                
            (set! global-speed (/ bpm 60))
            (let ((newtime (+ sync-offset (timestamp->time t))))
            (let ((offset (calc-offset (bb-get-next-time bb) newtime tick)))
              (bb-set-next-time! bb  (+ (bb-get-next-time bb) offset))
              (display "got /sync bpm is ")(display bpm)
              (display " error is ")(display offset)(newline))))))))

(define (bb-update bb)
  
    (joylisten-update (bb-get-joylisten bb))
    (gui-cursor-animate (bb-get-cursor bb))
    (bb-gui-update bb)
    (bb-sync bb)
                        
    ; update the vm
    (cond 
        ((> current-time (- (bb-get-next-time bb) global-timewarp))
            (unhighlight highlight)
            (set! highlight '())
            
            (bb-set-next-time! bb (+ (bb-get-next-time bb) (/ 1 global-speed))) 
            
            ; do the beat quantizing
            (cond 
             ((zero? (bb-get-sync-count bb))
                 (bb-set-sync-count! bb sync-quantize)
             ;    (display (- (bb-get-beat-time bb) (bb-get-next-time bb)))(newline)
                 (bb-set-beat-time! bb (bb-get-next-time bb))))
                  
            (bb-set-sync-count! bb (- (bb-get-sync-count bb) 1))
                         
            (thread-control-update (bb-get-thread-control bb) 
                (bb-get-gui-heap bb) (bb-get-heap bb) (bb-get-beat-time bb))
            (bb-update bb))))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
  
(define (make-osc-reader filename dest)
  (define file 0)
  (define count 0)
  (define current '())
  (define offset current-time)
  
  (define (read-word file)
    (define (inner-read-token str)
      (let ((c (read-char file)))
        (cond
          ((eof-object? c)
           str)
          ((char-whitespace? c)
           str)
          (else
           (inner-read-token (string-append str (string c)))))))   
    (inner-read-token ""))
  
  (define (init)
    (set! file (open-input-file filename))
    (read-word file)
    (set! count (string->number (read-word file))))
  
  (define (update)
    (cond 
      ((or (null? current) (> current-time (+ offset (string->number (list-ref current 1)))))
       (cond 
           ((not (null? current))
            (osc-destination dest)
               (display (- current-time offset))(display " ")
               (display (list-ref current 1))(display " sending: ")(display (list-ref current 0))(display " f ")(display (list (string->number (list-ref current 4))))
               (newline)
               (osc-sendm (list-ref current 0) "f" (list (string->number (list-ref current 4))))))
       (set! current (list (read-word file)(read-word file)(read-word file)(read-word file)(read-word file)(read-word file)))
       (update))))
  
  (define (dispatch m)
    (cond
      ((eq? m 'update) update)
      (else
       (error "unknown method " m))))
  (init)
  dispatch)  


;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; run the program

(clear)
;(clear-colour back-colour)
(itchyscratchy-init)
(show-fps 0)

(load-scale-lut block-tuning)

(define betablocker (make-bb))
(bb-init betablocker)

;(define osc-reader (make-osc-reader "bb004.osc" "osc.udp://localhost:4444"))

(define (animate)
    ;(set! current-time (+ current-time (delta)))
    ;((osc-reader 'update))
    (set! current-time (/ (current-inexact-milliseconds) 1000))
    (bb-update betablocker))

;(process "bb004.wav")
;(start-framedump "frames/bb004-" "jpg")


(every-frame (animate))