; AL-JAZARI ; ; family edition for biacs3, granada ;(define (delta) ; (/ 1764 44100)) ;(define current-time (time)) ;(define (time) ; current-time) (require scheme/class) (require srfi/1) (require fluxus-015/time) (require fluxus-015/joylisten) (require fluxus-015/tricks) (require fluxus-015/gui) ;(require fluxus-015/drflux) (define test-mode #f) (define start-voice 1) (desiredfps 25) ; fix for fluxus 0.13 (define current-time (/ (current-inexact-milliseconds) 1000)) (define (time) current-time) (define bg-colour (vector 0 0 0)) (define pen-colour (vector 0 0 0)) (define paper-colour (vector 0.2 0.6 1.0)) (define trigger-colour (vector 1 0.6 0.2)) ;(define paper-colour (vector 0.5 0.3 0.1)) (define cursor-colour (vector 1 1 1)) (define cube-trigger-colour (vector 1 0 0)) (define cube-highlight-colour (vector 0 1 0)) (define bot-trigger-colour (vector 1 1 0)) (define signal-seen-colour (vector 1 1 1)) (define code-length 8) (define code-states 1) (define code-width 4) (define code-height 2) (define climb-height 10) (define itchy-url "osc.udp://localhost:4001") (define scratchy-url "osc.udp://localhost:4002") (define bpm-multiplier 2) (define sync-offset 0.01) (define swing-beat 1.0) (define sync-freq (* 20 60)) ; for syncing itchy & scratchy (define inactive-bot-time (if test-mode 10 (* 1 60))) ;(set! pen-colour (vector 1 1 1)) ;(set! paper-colour (vector 0 0 0)) ;(set! trigger-colour (vector 0.5 0.1 0)) ;(set! cube-trigger-colour (vector 0.2 0.4 0)) ;(set! cube-highlight-colour (vector 0.5 0.3 0)) ;(set! bot-trigger-colour (vector 0.2 0.5 0)) ;(set! signal-seen-colour (vector 1 1 1)) (osc-source "4444") (reset-camera) ; mapping for saitek p2600 joypad (define joymap-a 0) (define joymap-b 1) (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) (define max-voice 3) (define terrain-patterns '( #;(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) #;(-2 0 0 0 1 1 0 0 0 -2 0 2 2 3 3 3 3 2 2 0 0 2 4 4 4 4 4 4 2 0 0 3 4 6 6 6 6 4 3 0 1 3 4 6 8 8 6 4 3 1 1 3 4 6 8 8 6 4 3 1 0 3 4 6 6 6 6 4 3 0 0 2 4 4 4 4 4 4 2 0 0 2 2 3 3 3 3 2 2 0 -2 0 0 0 1 1 0 0 0 -2) (6 8 6 4 2 2 4 6 8 6 8 8 8 6 4 4 6 8 8 8 6 8 6 4 2 2 4 6 8 6 4 6 4 2 0 0 2 4 6 4 2 4 2 0 0 0 0 2 4 2 2 4 2 0 0 0 0 2 4 2 4 6 4 2 0 0 2 4 6 4 6 8 6 4 2 2 4 6 8 6 8 8 8 6 4 4 6 8 8 8 6 8 6 4 3 3 4 6 8 6) (4 6 4 2 0 -2 -4 -6 -8 -10 6 8 6 4 2 0 -2 -4 -6 -8 4 6 8 6 4 2 0 -2 -4 -6 2 4 6 8 6 4 2 0 -2 -4 0 2 4 6 8 6 4 2 0 -2 -2 0 2 4 6 8 6 4 2 0 -4 -2 0 2 4 6 8 6 4 2 -6 -4 -2 0 2 4 6 8 6 4 -8 -6 -4 -2 0 2 4 6 8 6 -10 -8 -6 -4 -2 0 2 4 6 4) (10 8 6 4 2 0 1 3 5 7 10 8 6 4 2 0 1 3 5 7 8 6 4 2 0 1 3 5 7 9 8 6 4 2 0 1 3 5 7 9 6 4 2 0 1 3 5 7 9 7 6 4 2 0 1 3 5 7 9 7 4 2 0 1 3 5 7 9 7 5 4 2 0 1 3 5 7 9 7 5 2 0 1 3 5 7 9 7 5 3 2 0 1 3 5 7 9 7 5 3) )) (define trigger-patterns '( #;(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) (1 1 0 1 1 1 0 1 1 1 1 1 1 0 1 1 1 0 1 1 0 1 1 1 0 1 1 1 0 1 1 0 1 1 1 0 1 1 1 0 1 1 0 1 1 1 0 1 1 1 1 1 1 0 1 1 1 0 1 1 0 1 1 1 0 1 1 1 0 1 1 0 1 1 1 0 1 1 1 0 1 1 0 1 1 1 0 1 1 1 1 1 1 0 1 1 1 0 1 1) (1 1 1 1 1 1 1 1 1 1 1 0 1 0 1 0 1 0 1 0 1 1 1 1 1 1 1 1 1 1 .0 1 0 1 0 1 0 1 0 1 0 1 1 1 1 1 1 1 1 1 1 1 0 1 0 1 0 1 0 1 0 1 1 1 1 1 1 1 1 1 1 1 0 1 0 1 0 1 0 1 0 1 1 1 1 1 1 1 1 1 1 1 0 1 0 1 0 1 0 1 0) (1 0 1 0 1 0 1 0 1 0 1 1 1 1 1 1 1 1 1 1 0 1 0 1 0 1 0 1 0 1 1 1 1 1 1 1 1 1 1 1 1 0 1 0 1 0 1 0 1 0 1 1 1 1 1 1 1 1 1 1 0 1 0 1 0 1 0 1 0 1 1 1 1 1 1 1 1 1 1 1 1 0 1 0 1 0 1 0 1 0 1 1 1 1 1 1 1 1 1 1) )) (define patches '( ( "tabla" ("decaya" 9/125 "decayb" 9/125 "cutoff" 0 "typea" 148/125 "volumea" 1 "typeb" 1717/500 "freqa" 4 "freqb" 4 "sustaina" 0 "sustainb" 0 "mainvolume" 1931/1000) ("modtype" 1043/250 "decay" 1/25 "attack" 0 "sustain" 0 "release" 0 "mainvolume" 53/200 "freq" 4 "modfreq" 2 "poly" 0 "modvolume" 0 "type" 588/125) ("cutoff" 0 "freqa" 3 "typea" 9/2 "typeb" 296/125 "decaya" 9/125 "attacka" 0 "sustaina" 0 "releasea" 0 "attackb" 0 "decayb" 9/125 "sustainb" 0 "releaseb" 0 "volumeb" 1 "freqb" 2) ("modvolume" 1901/500 "type" 9/2 "mainvolume" 239/500 "freq" 8 "modfreq" 1/250 "modtype" 4909/1000 "moddecay" 291/500 "sustain" 0 "poly" 2187/1000 "decay" 2/25 "crushbits" 0 "crushfreq" 0 "distort" 0) ("cutoff" 0 "typea" 6 "typeb" 27/4 "decaya" 18/125 "attacka" 0 "sustaina" 0 "releasea" 0 "attackb" 0 "decayb" 9/125 "sustainb" 0 "releaseb" 0 "mainvolume" 142/125) "electro_d") ("808" ("mainvolume" 5 "typea" 921/125 "typeb" 7263/1000 "ftype" 1987/500 "decaya" 18/125 "distort" 1671/1000 "cutoff" 813/1000 "lfodepth" 703/500 "lfofreq" 303/1000) ("mainvolume" 797/1000 "type" 1939/500 "modtype" 4509/1000 "modfreq" 71/1000 "modvolume" 729/1000 "freq" 8 "fbdecay" 0 "decay" 2/25 "delayfb" 0 "delay" 0 "moddecay" 121/500 "modattack" 0 "sustain" 1/8 "release" 949/1000 "poly" 5703/1000) ("mainvolume" 159/200 "freqa" 2 "attacka" 0 "decaya" 18/125 "sustaina" 0 "releasea" 0 "attackb" 0 "decayb" 18/125 "sustainb" 0 "releaseb" 0 "cutoff" 213/1000 "ftype" 141/100 "resonance" 291/1000 "attackf" 0 "decayf" 0 "sustainf" 0 "releasef" 0 "lfodepth" 281/1000 "lfofreq" 227/500 "freqb" 2 "typeb" 3263/1000 "typea" 4421/1000 "poly" 0) ("mainvolume" 53/250 "freq" 1 "fbdecay" 0 "decay" 359/1000 "modfreq" 1/2 "modattack" 343/1000 "moddecay" 97/200 "modvolume" 677/1000 "modtype" 2327/500 "type" 0 "sustain" 0 "release" 0 "poly" 0 "pan" 551/1000) ("mainvolume" 681/1000 "ftype" 0 "freqa" 1/2 "typea" 863/200 "typeb" 789/500 "freqb" 251/125 "decaya" 507/1000 "attackb" 0 "decayb" 217/1000 "sustainb" 0 "releaseb" 0 "volumeb" 1 "attacka" 0 "sustaina" 0 "volumea" 1 "crushfreq" 0 "crushbits" 0 "ring" 0 "distort" 154/125) "electro_d") ("808" ("mainvolume" 159/200 "typea" 2421/1000 "typeb" 1263/500 "ftype" 641/250 "cutoff" 173/1000 "freqb" 1/2 "resonance" 28/125 "lfodepth" 0 "lfofreq" 0 "attackf" 107/250 "decayf" 633/1000 "volumef" 7/50 "freqa" 51/50 "decaya" 18/125 "decayb" 18/125 "distort" 0) ("mainvolume" 101/100 "modattack" 539/1000 "moddecay" 631/1000 "modsustain" 81/1000 "modfreq" 4 "modvolume" 151/50 "decay" 1/25 "sustain" 0 "release" 0 "attack" 0) ("mainvolume" 159/200 "typea" 4631/1000 "typeb" 3473/1000 "ftype" 833/500 "cutoff" 693/1000 "resonance" 52/125 "lfodepth" 3/8 "freqa" 2051/1000 "freqb" 4 "decaya" 9/125 "decayb" 18/125 "sustainb" 0 "sustaina" 0 "releasea" 0 "attacka" 73/1000 "ring" 0 "distort" 0 "releaseb" 357/500 "attackf" 107/500 "decayf" 281/1000 "sustainf" 121/1000 "releasef" 307/1000 "volumef" 781/1000 "attackb" 0 "lfofreq" 53/50) ("mainvolume" 53/250 "modattack" 147/500 "decay" 2/25 "sustain" 0 "release" 747/1000 "modvolume" 4687/1000 "modfreq" 4 "modtype" 4727/1000 "fbattack" 0 "fbvolume" 87/200 "fbdecay" 0 "fbsustain" 0 "fbrelease" 0 "crushfreq" 6/25 "crushbits" 988/125) ("mainvolume" 909/500 "cutoff" 153/500 "ftype" 2179/1000 "crushbits" 8727/1000 "lfofreq" 303/500 "lfodepth" 31/500 "freqa" 2 "freqb" 4 "resonance" 341/1000 "attackf" 0 "decayf" 7/50 "sustainf" 0 "crushfreq" 827/1000 "decayb" 18/125 "decaya" 18/125) "electro_d") #;("kip" ("typea" 3789/1000 "typeb" 2421/500 "cutoff" 53/1000 "decaya" 217/1000 "attackb" 0 "freqb" 2013/1000 "freqa" 499/250 "ftype" 673/500 "lfodepth" 0 "lfofreq" 0 "volumef" 7/50 "mainvolume" 142/125 "sustainb" 0 "sustaina" 0 "decayb" 289/1000 "distort" 493/500 "resonance" 391/1000 "attackf" 0 "decayf" 7/50 "sustainf" 0 "pan" 1/2 "crushbits" 1159/125 "crushfreq" 103/1000) ("mainvolume" 851/1000 "type" 0 "modtype" 4509/1000 "poly" 0 "freq" 1 "modvolume" 3281/1000 "fbvolume" 1 "fbsustain" 1/5 "fbdecay" 13/100 "fbrelease" 149/125 "fbattack" 0 "moddecay" 241/1000 "modattack" 0 "modfreq" 4 "sustain" 0 "decay" 4/25 "distort" 221/200 "crushfreq" 0 "crushbits" 0) ("mainvolume" 2159/1000 "cutoff" 439/1000 "volumef" 937/1000 "decayf" 44/125 "decaya" 289/1000 "decayb" 217/500 "resonance" 2/5 "attackb" 0 "typea" 821/200 "typeb" 921/250 "freqb" 126/125 "freqa" 1997/1000 "distort" 0 "crushbits" 10 "crushfreq" 11/40) ("mainvolume" 531/1000 "attack" 0 "modvolume" 729/250 "crushbits" 0 "crushfreq" 0 "distort" 0 "poly" 3281/1000 "freq" 4 "modfreq" 8 "decay" 2/25 "sustain" 1/40 "release" 21/100 "modattack" 147/1000 "moddecay" 291/1000 "modsustain" 51/1000 "modrelease" 567/500 "fbvolume" 0 "fbattack" 0 "fbdecay" 0 "fbsustain" 0) ("mainvolume" 5/4 "freqa" 4 "freqb" 2019/1000 "ftype" 0 "cutoff" 393/500 "resonance" 27/250 "poly" 5641/1000 "decaya" 3913/1000 "decayb" 797/200 "distort" 821/1000 "typea" 3263/1000 "typeb" 3473/1000) "electro_d") #;("rip" ("crushfreq" 0 "crushbits" 10 "decaya" 18/125 "decayb" 18/125 "typea" 3789/1000 "typeb" 3789/1000 "distort" 0 "cutoff" 213/500 "volumef" 109/1000 "resonance" 449/1000 "ftype" 689/250 "decayf" 7/50 "delay" 2/125 "delayfb" 0 "mainvolume" 1363/1000 "freqa" 41/40 "poly" 0 "freqb" 41/40 "releasef" 0 "sustainf" 0 "lfodepth" 1/4 "lfofreq" 151/1000 "ring" 0) ("mainvolume" 159/1000 "crushfreq" 0 "crushbits" 0 "type" 2727/1000 "modtype" 509/1000 "fbattack" 131/1000 "fbvolume" 1 "fbdecay" 239/500 "fbsustain" 9/1000 "modfreq" 1 "freq" 2029/1000 "decay" 6/25 "sustain" 77/125 "release" 773/1000 "poly" 3437/1000 "volume" 161/250 "modvolume" 5 "moddecay" 449/250 "attack" 161/500) ("mainvolume" 71/125 "ftype" 0 "cutoff" 93/1000 "resonance" 449/1000 "ring" 0 "typea" 3157/1000 "typeb" 3473/1000 "volumef" 593/1000 "distort" 397/500 "sustainf" 17/125 "decaya" 579/1000 "sustaina" 1 "releasea" 357/250 "sustainb" 1 "decayb" 181/250 "attackb" 0 "releaseb" 1111/500 "attackf" 0 "crushfreq" 43/500 "crushbits" 1909/250 "decayf" 88/125 "freqb" 2 "freqa" 1001/1000 "lfodepth" 39/125 "lfofreq" 7/250 "releasef" 0 "poly" 487/200) ("mainvolume" 93/250 "modvolume" 5 "fbvolume" 1 "fbdecay" 2347/1000 "fbattack" 0 "fbsustain" 69/200 "fbrelease" 1697/1000 "crushbits" 0 "crushfreq" 0 "attack" 161/1000 "decay" 2/25 "poly" 0 "moddecay" 97/200 "modattack" 343/1000 "freq" 101/100 "modfreq" 2 "distort" 0 "type" 1727/500 "modtype" 509/250 "sustain" 1 "release" 0 "delayfb" 0 "delay" 0 "volume" 54/125) ("mainvolume" 1477/1000 "resonance" 283/1000 "cutoff" 253/1000 "ftype" 2051/1000 "lfodepth" 39/250 "lfofreq" 151/1000 "delay" 0 "delayfb" 0 "decaya" 289/1000 "decayf" 211/1000 "attackf" 0 "attacka" 0 "sustaina" 0 "releasea" 1587/1000 "sustainf" 0 "releasef" 0 "volumef" 109/500 "decayb" 289/1000 "poly" 0 "ring" 767/500 "typea" 421/125 "typeb" 921/250 "freqa" 4 "freqb" 2051/1000) "electro_d"))) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; helper functions (define (rotate-left direction) (cond ((eq? direction 'north) 'west) ((eq? direction 'west) 'south) ((eq? direction 'south) 'east) ((eq? direction 'east) 'north))) (define (rotate-right direction) (cond ((eq? direction 'north) 'east) ((eq? direction 'east) 'south) ((eq? direction 'south) 'west) ((eq? direction 'west) 'north))) (define (position-clamp min max v) (vector (if (< (vx v) (vx min)) (vx min) (if (> (vx v) (vx max)) (vx max) (vx v))) (if (< (vy v) (vy min)) (vy min) (if (> (vy v) (vy max)) (vy max) (vy v))))) (define (position-add a b) (position-clamp (vector 0 0) (vector 9 9) (vector (+ (vector-ref a 0) (vector-ref b 0)) (+ (vector-ref a 1) (vector-ref b 1))))) (define scan-pattern-north (list (vector 0 1) (vector -1 2) (vector 0 2) (vector 1 2) (vector -2 3) (vector -1 3) (vector 0 3) (vector 1 3) (vector 2 3))) (define scan-pattern-south (list (vector 0 -1) (vector -1 -2) (vector 0 -2) (vector 1 -2) (vector -2 -3) (vector -1 -3) (vector 0 -3) (vector 1 -3) (vector 2 -3))) (define scan-pattern-east (list (vector 1 0) (vector 2 -1) (vector 2 0) (vector 2 1) (vector 3 -2) (vector 3 -1) (vector 3 0) (vector 3 1) (vector 3 2))) (define scan-pattern-west (list (vector -1 0) (vector -2 -1) (vector -2 0) (vector -2 1) (vector -3 -2) (vector -3 -1) (vector -3 0) (vector -3 1) (vector -3 2))) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; a client for itchy and scratchy (define itchy-client% (class object% (init-field (itchy-osc-url "") (scratchy-osc-url "")) (field (current-osc-url 0) (sample-location "/home/aljazari/samples/") ; where samples are (voice-count 7) (sample-id 0)) (define/public (init) (osc-dest itchy-osc-url) (osc-send "/clear" "" '()) (osc-send "/setclock" "" '()) (osc-dest scratchy-osc-url) (osc-send "/clear" "" '()) (osc-send "/setclock" "" '()) (osc-send "/addsearchpath" "s" (list sample-location)) (voice-volume 3) (sample-volume 3)) (define/public (sync) (osc-dest itchy-osc-url) (osc-send "/setclock" "" '()) (osc-dest scratchy-osc-url) (osc-send "/setclock" "" '())) (define/public (osc-dest new) (cond (#t ;(not (equal? current-osc-url new)) (set! current-osc-url new) (osc-destination current-osc-url)))) (define/public (voice 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)))) (osc-dest itchy-osc-url) (osc-send "/addinstrument" "is" (list id type)) (set! keyvalue (cons id keyvalue)) (set! keyvalue (cons "map" keyvalue)) (osc-send "/modify" (build-argsstr keyvalue "i") (append (list id) keyvalue))) ; set voice volume (define/public (voice-volume vol) (osc-dest itchy-osc-url) (osc-send "/globalvolume" "f" (list vol))) (define/public (load-scale-lut filename) (let ((f (open-input-file filename))) (set! scale-lut (read f)) (close-input-port f))) (define/public (play notetime note voice) (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) ;(display "playing ")(display voice)(newline) (osc-dest itchy-osc-url) (osc-send "/play" "iiiffffi" (list (vector-ref timestamp 0) (vector-ref timestamp 1) (+ 1 (modulo (- voice 1) voice-count)) freq 0 1 0.5 79)) (osc-dest scratchy-osc-url) (osc-send "/play" "iiiffffi" (list (vector-ref timestamp 0) (vector-ref timestamp 1) (+ 1 (modulo (- voice 1) voice-count)) freq 0 1 0.5 79))))) ; load a sample into a voice (define/public (sample id file) (osc-dest scratchy-osc-url) (set! sample-id (+ sample-id 1)) (osc-send "/addtoqueue" "is" (list sample-id file)) (osc-send "/loadqueue" "" '()) (osc-send "/map" "ii" (list sample-id id))) ; set global properties for a sample (define/public (sample-globals id vol freq pan) (osc-dest scratchy-osc-url) (osc-send "/setglobals" "ifff" (list id vol freq pan))) ; sets the global sampler volume (define/public (sample-volume vol) (osc-dest scratchy-osc-url) (osc-send "/globalvolume" "f" (list vol))) ; sets the global pitch of the sampler (define/public (sample-pitch pitch) (osc-dest scratchy-osc-url) (osc-send "/globalpitch" "f" (list pitch))) (define/public (sample-unmap) (osc-dest scratchy-osc-url) (osc-send "/unmapall" "" '())) ; 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/public (samples 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! sample-id (+ sample-id 1)) (osc-send "/addtoqueue" "is" (list sample-id (string-append dir "/" (car l)))) (osc-send "/map" "ii" (list sample-id id)) (if (eq? (cdr l) '()) 0 (load-list id dir (cdr l))))) (osc-dest scratchy-osc-url) (osc-send "/unmap" "i" (list id)) (load-list id dir (get-samples (directory-list (string-append sample-location dir)) '())) (osc-send "/loadqueue" "" '())) ; sort this mess out - load directly from scala (define scale-lut (list 58.2705 61.7354 65.4064 69.2957 73.4162 77.7817 82.4069 87.3071 92.4986 97.9989 103.826 110 116.541 123.471 130.813 138.591 146.832 155.563 164.814 174.614 184.997 195.998 207.652 220 233.082 246.942 261.626 277.183 293.665 311.127 329.628 349.228 369.994 391.995 415.305 440 466.164 493.883 523.251 554.365 587.33 622.254 659.255 698.456 739.989 783.991 830.609 880 932.328 987.767 1046.5 1108.73 1174.66 1244.51 1318.51 1396.91 1479.98 1567.98 1661.22 1760 1864.66 1975.53 2093 2217.46 2349.32 2489.02 2637.02 2793.83 2959.96 3135.96 3322.44 3520 3729.31 3951.07 4186.01 4434.92 4698.64 4978.03 5274.04 5587.65 5919.91 6271.93 6644.88 7040 7458.62 7902.13 8372.02 8869.84 9397.27 9956.06 10548.1 11175.3 11839.8 12543.9 13289.8 14080 14917.2 15804.3 16744 17739.7 18794.5 19912.1 21096.2 22350.6 23679.6 25087.7 26579.5 28160 29834.5 31608.5 33488.1 35479.4 37589.1 39824.3 42192.3 44701.2 47359.3 50175.4 53159 56320)) ;(define scale-lut '(58.2705 61.7354 65.4064 69.2957 73.4162 77.7817 82.4069 87.3071 92.4986 97.9989 103.826 ;110 116.541 123.471 130.813 138.591 146.832 155.563 164.814 174.614 184.997 195.998 207.652 220 233.082 ;246.942 261.626 277.183 293.665 311.127 329.628 349.228 369.994 391.995 415.305 440 466.164 493.883 523.251 ;554.365 587.33 622.254 659.255 698.456 739.989 783.991 830.609 880 932.328 987.767 1046.5 1108.73 1174.66 ;1244.51 1318.51 1396.91 1479.98 1567.98 1661.22 1760 1864.66 1975.53 2093 2217.46 2349.32 2489.02 2637.02 ;2793.83 2959.96 3135.96 3322.44 3520 3729.31 3951.07 4186.01 4434.92 4698.64 4978.03 5274.04 5587.65 ;5919.91 6271.93 6644.88 7040 7458.62 7902.13 8372.02 8869.84 9397.27 9956.06 10548.1 11175.3 11839.8 ;12543.9 13289.8 14080 14917.2 15804.3 16744 17739.7 18794.5 19912.1 21096.2 22350.6 23679.6 25087.7 26579.5 ;28160 29834.5 31608.5 33488.1 35479.4 37589.1 39824.3 42192.3 44701.2 47359.3 50175.4 53159 56320 58.2705 ;61.7354 65.4064 69.2957 73.4162 77.7817 82.4069 87.3071 92.4986 97.9989 103.826 110 116.541 123.471 130.813 ;138.591 146.832 155.563 164.814 174.614 184.997 195.998 207.652 220 233.082 246.942 261.626 277.183 293.665 ;311.127 329.628 349.228 369.994 391.995 415.305 440 466.164 493.883 523.251 554.365 587.33 622.254 659.255 ;698.456 739.989 783.991 830.609 880 932.328 987.767 1046.5 1108.73 1174.66 1244.51 1318.51 1396.91 1479.98 ;1567.98 1661.22 1760 1864.66 1975.53 2093 2217.46 2349.32 2489.02 2637.02 2793.83 2959.96 3135.96 3322.44 ;3520 3729.31 3951.07 4186.01 4434.92 4698.64 4978.03 5274.04 5587.65 5919.91 6271.93 6644.88 7040 7458.62 ;7902.13 8372.02 8869.84 9397.27 9956.06 10548.1 11175.3 11839.8 12543.9 13289.8 14080 14917.2 15804.3 16744 ;17739.7 18794.5 19912.1 21096.2 22350.6 23679.6 25087.7 26579.5 28160 29834.5 31608.5 33488.1 35479.4 ;37589.1 39824.3 42192.3 44701.2 47359.3 50175.4 53159 56320 58.2705 61.7354 65.4064 69.2957 73.4162 77.7817 ;82.4069 87.3071 92.4986 97.9989 103.826 110 116.541 123.471 130.813 138.591)) (super-new) (init))) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; the core is where all the logic is run, no fluxus code allowed here, ; as the core is run ahead of time, so changes will be out of step ; with the rest of the system ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; core-block (define core-block% (class object% (init-field (height 0) (trigger #f)) (define/public (get-height) height) (define/public (set-height s) (set! height s)) (define/public (raise) (set! height (+ height 1))) (define/public (lower) (set! height (- height 1))) (define/public (get-trigger) trigger) (define/public (set-trigger s) (set! trigger s)) (define/public (print) (display trigger)) (super-new))) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; grid of blocks (define core-blockgrid% (class object% (init-field (w 0) (h 0)) (define/public (make-grid) (define (loop v n) (vector-set! v n (make-object core-block%)) (if (zero? n) v (loop v (- n 1)))) (let ((v (make-vector (* w h) (make-object core-block%)))) (loop v (- (* w h) 1)))) (field (grid (make-grid))) (define/public (get-block x y) (cond ((or (>= x w) (< x 0) (>= y h) (< y 0)) #f) (else (vector-ref grid (+ (modulo x w) (* y w)))))) (define/public (print) (define (line y) (define (element x y) (send (get-block x y) print) (display " ") (if (zero? x) 0 (element (- x 1) y))) (element (- w 1) y) (newline) (if (zero? y) 0 (line (- y 1)))) (line (- h 1))) (super-new))) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; core-entity (define core-entity% (class object% (init-field (id 0) (position (vector 0 0)) (direction 'north)) (field (blocked #f)) (define/public (get-id) id) (define/public (get-position) position) (define/public (set-position s) (set! position s)) (define/public (get-direction) direction) (define/public (get-blocked) blocked) (define/public (update command entity-list blockgrid) (let ((trigger #f) (pitch 0)) (cond ((or (eq? command 'forward) (eq? command 'back)) (let ((newpos (vector 0 0))) (cond ((eq? command 'forward) (cond ((eq? direction 'north) (set! newpos (position-add position (vector 0 1)))) ((eq? direction 'south) (set! newpos (position-add position (vector 0 -1)))) ((eq? direction 'east) (set! newpos (position-add position (vector 1 0)))) ((eq? direction 'west) (set! newpos (position-add position (vector -1 0)))))) ((eq? command 'back) (cond ((eq? direction 'north) (set! newpos (position-add position (vector 0 -1)))) ((eq? direction 'south) (set! newpos (position-add position (vector 0 1)))) ((eq? direction 'east) (set! newpos (position-add position (vector -1 0)))) ((eq? direction 'west) (set! newpos (position-add position (vector 1 0))))))) (let ((block (send blockgrid get-block (vector-ref newpos 0) (vector-ref newpos 1)))) (cond ; if a block exists at destination, and it's not occupied ((and block (not (send entity-list occupied newpos))) ; find the height difference (let ((height-dif (- (send block get-height) (send (send blockgrid get-block (vector-ref position 0) (vector-ref position 1)) get-height)))) ; check that we can climb up to it (cond ((< height-dif climb-height) ; ok, we can move ; see if it's a trigger (cond ((send block get-trigger) (set! trigger #t) (set! pitch (send block get-height)))) (set! position newpos) (set! blocked #f)) (else (set! blocked #t) (set! command 'stuck))))) (else (set! blocked #t) (set! command 'stuck)))))) ((eq? command 'left) (set! direction (rotate-left direction))) ((eq? command 'right) (set! direction (rotate-right direction)))) (list command trigger pitch))) (define/pubment (print) (display "entity: ") (display position) (display direction) (newline) (inner (void) print)) (super-new))) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; core-entity-list (define core-entity-list% (class object% (init-field (entities '())) ; signals handled here, and is global, ; common to all bots (field (signal-length 4) (signal-time -1)) (define/public (add entity) (set! entities (cons entity entities))) ; todo: store id's in list so we can use assq (define/public (get id) (define (inner-get elist) (if (null? elist) #f (if (eq? (send (car elist) get-id) id) (car elist) (inner-get (cdr elist))))) (inner-get entities)) (define/public (remove id) (define (inner-remove elist) (if (null? elist) elist (if (eq? (send (car elist) get-id) id) (inner-remove (cdr elist)) (cons (car elist) (inner-remove (cdr elist)))))) (set! entities (inner-remove entities))) (define/public (occupied position) (define (inner-occupied elist) (if (null? elist) #f (if (equal? (send (car elist) get-position) position) #t (inner-occupied (cdr elist))))) (inner-occupied entities)) ; scan a list of positions relative to our own (define (scan-pattern position scanlist) (cond ((occupied (position-add position (car scanlist))) #t) (else (if (null? (cdr scanlist)) #f (scan-pattern position (cdr scanlist)))))) ; look for entities in the direction specified (define/public (scan position direction) (cond ((eq? direction 'north) (scan-pattern position scan-pattern-north)) ((eq? direction 'south) (scan-pattern position scan-pattern-south)) ((eq? direction 'east) (scan-pattern position scan-pattern-east)) ((eq? direction 'west) (scan-pattern position scan-pattern-west)))) (define/public (print) (display entities)) (define/public (update blockgrid) (define (inner-update elist out) (set! out (append out (list (list (send (car elist) get-id) (send (car elist) update-bot this blockgrid))))) (if (null? (cdr elist)) out (inner-update (cdr elist) out))) (when (>= signal-time 0) (set! signal-time (- signal-time 1))) (if (null? entities) '() (inner-update entities '()))) (define/public (set-signal) (set! signal-time signal-length)) (define/public (get-signal) (>= signal-time 0)) (super-new))) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; core-bot (define core-bot% (class core-entity% (init-field (code-length 0) (code-states 0)) (field (state 0) (pc 0) (code (make-code))) (inherit get-position get-direction get-blocked) (define/public (make-code) (define (loop code addr) (vector-set! code addr 'nop) (if (zero? addr) code (loop code (- addr 1)))) (let ((code (make-vector (* code-length code-states) 'nop))) (loop code (- (* code-length code-states) 1)))) (define/public (get-code s) code) (define/public (get-current-instr) (vector-ref code (+ (modulo pc code-length) (* state code-length)))) (define/public (set-instr position state s) (vector-set! code (+ (modulo position code-length) (* state code-length)) s)) (define/public (inc-position) (set! pc (+ pc 1)) (when (>= pc code-length) (set! pc 0))) (define/public (update-bot entity-list blockgrid) (let ((instr (get-current-instr))) (let ((state-packet (list instr #f 0))) ; default state packet (inc-position) (cond ((eq? instr 'stuck) ; if we are not stuck, skip next instruction (when (not (get-blocked)) (inc-position))) ((eq? instr 'look-forward) ; if there is nothing there, skip next instruction (when (not (send entity-list scan (get-position) (get-direction))) (inc-position))) ((eq? instr 'look-right) (when (not (send entity-list scan (get-position) (rotate-right (get-direction)))) (inc-position))) ((eq? instr 'look-back) (when (not (send entity-list scan (get-position) (rotate-right (rotate-right (get-direction))))) (inc-position))) ((eq? instr 'look-left) (when (not (send entity-list scan (get-position) (rotate-left (get-direction)))) (inc-position))) ((eq? instr 'look-signal) (if (send entity-list get-signal) (set! state-packet (list 'signal-seen #f 0)) (inc-position))) ((eq? instr 'signal) (send entity-list set-signal)) ((eq? instr 'jump-circle) (set! pc 0) (set! state 0)) ((eq? instr 'jump-triangle) (set! pc 0) (set! state 1)) ((eq? instr 'jump-square) (set! pc 0) (set! state 2)) ((eq? instr 'jump-pentagon) (set! pc 0) (set! state 3)) (else (set! state-packet (send this update instr entity-list blockgrid)))) (append state-packet (list (vector pc state)))))) (define/augment (print) (display "bot: ") (display pc)(display " ") (display code)(display " ")) (super-new))) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; core (define core% (class object% (init-field (w 0) (h 0)) (field (map (make-object core-blockgrid% w h)) (entities (make-object core-entity-list% '())) (current-id 0) (clock 0) (tick 0.5) (swing #f)) (define/public (set-time s) (set! clock s)) (define/public (set-tick s) (set! tick s)) (define/public (get-tick) tick) (define/public (get-time) clock) (define/public (get-block position) (send map get-block (vector-ref position 0) (vector-ref position 1))) (define/public (add-bot position direction) (set! current-id (+ current-id 1)) (send entities add (make-object core-bot% code-length code-states current-id position direction)) current-id) (define/public (remove-bot id) (send entities remove id)) (define/public (set-bot-code id position state instr) (send (send entities get id) set-instr position state instr)) (define/public (set-bot-position id position) (send (send entities get id) set-position position)) (define/public (update) (set! clock (+ clock tick)) (list clock (send entities update map))) (define/public (print) (send map print)) (super-new))) ; fluxus code starts here ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; renderer-bot ; contains all the bot information for the renderer (define renderer-bot% (class object% (init-field (id 0) (position (vector 0 0)) (direction 'north) (col (vector 1 0 0)) (camera 0)) (field (object 0) (cloud 0) (marker 0) (signal 0) (signal-seen 0) (code 0) (state 'none) (trigger #f) (code-position (vector 0 0)) (last-state 'none) (last-trigger #f) (last-code-position (vector 0 0)) (tick 0.5) (selected #f) (onboard #f) (ring-menu 0) (animate-direction (vector 0 0 0)) (signal-time 0) (signal-ticks 4) (signal-seen-time 0)) ; sets the visual selection cue (define/public (set-selected s o) (set! selected s) (set! onboard o)) ; accessors (define/public (get-id) id) (define/public (get-position) position) (define/public (set-position s) (set! position s)) (define/public (set-tick s) (set! tick s)) (define/public (get-cloud) cloud) (define/public (get-model) object) (define/public (get-code) code) (define/public (get-ring-menu) ring-menu) ; helper to set the transform given the current state (define/public (bot-transform renderer) (concat (send renderer block-transform position)) (cond ((eq? direction 'north) (rotate (vector 0 90 0))) ((eq? direction 'east) (rotate (vector 0 0 0))) ((eq? direction 'south) (rotate (vector 0 270 0))) ((eq? direction 'west) (rotate (vector 0 180 0)))) (translate (vector 0 0.4 0))) ; converts an instruction into the corresponding texture coordinates (define/public (instr->tex instr) (cond ((eq? instr 'forward) (vector 0 0 0)) ((eq? instr 'back) (vector 0.25 0 0)) ((eq? instr 'right) (vector 0.5 0 0)) ((eq? instr 'left) (vector 0.75 0 0)) ((eq? instr 'signal) (vector 0 0.25 0)) ((eq? instr 'look-forward) (vector 0.25 0.25 0)) ((eq? instr 'look-left) (vector 0.5 0.25 0)) ((eq? instr 'look-back) (vector 0.75 0.25 0)) ((eq? instr 'look-right) (vector 0 0.5 0)) ((eq? instr 'stuck) (vector 0.25 0.5 0)) ((eq? instr 'look-signal) (vector 0.5 0.5 0)) ((eq? instr 'jump-circle) (vector 0.75 0.5 0)) ((eq? instr 'jump-triangle) (vector 0 0.75 0)) ((eq? instr 'jump-square) (vector 0.25 0.75 0)) ((eq? instr 'jump-pentagon) (vector 0.5 0.75 0)) (else (vector 0.75 0.75 0)))) ; convert code position to first vertex of the quad (define/public (pos->vert pos) (* (vector-ref pos 0) 4)) ; get the object space position of the code (define/public (get-code-pos position) (grab code) (let ((vert (pos->vert position))) (let ((ret (pdata-ref "p" vert))) (ungrab) ret))) ; sets the colour of an instruction (define/public (set-code-col addr state col) (let ((col (vmul col 2))) (grab code) (let ((vert (pos->vert (vector addr state)))) (pdata-set! "c" vert col) (pdata-set! "c" (+ vert 1) col) (pdata-set! "c" (+ vert 2) col) (pdata-set! "c" (+ vert 3) col) (ungrab)))) ; sets an instruction on the bot's code cloud (define/public (poke addr state instr) (grab code) (let ((vert (pos->vert (vector addr state))) (tex (instr->tex instr))) (pdata-set! "t" (+ vert 0) tex) (pdata-set! "t" (+ vert 3) (vadd tex (vector 0.25 0 0))) (pdata-set! "t" (+ vert 2) (vadd tex (vector 0.25 0.25 0))) (pdata-set! "t" (+ vert 1) (vadd tex (vector 0 0.25 0)))) (ungrab)) ; resets the code cloud (define/public (clear-code) (define (loop-add a s) (poke a s 0) (set-code-col a s (vmul col 0.5)) (if (zero? a) 0 (loop-add (- a 1) s))) (loop-add code-length 0)) ; builds and sets up all the fluxus primitives for the bot (define/public (build renderer) ; bot model (push) (colour col) (rotate (vector 90 180 180)) (scale (vector 0.3 0.3 0.3)) (set! object (load-primitive "meshes/bot.obj")) (pop) (apply-transform object) (grab object) (bot-transform renderer) (recalc-normals 1) (ungrab) (cheap-toon object 0.03 pen-colour) (with-primitive object (recalc-normals 0)) ; cloud (push) (hint-unlit) ;(hint-ignore-depth) (hint-depth-sort) (colour (vadd col (vector 0.5 0.5 0.5))) (texture (load-texture "textures/think2.png")) (translate (vector -0.5 0 0.1)) (scale (vector 0.75 1 1)) (set! cloud (build-plane)) (pop) (with-primitive cloud (apply-transform) (current-camera camera) (hide 1) (camera-hide 0)) ; code (push) (parent cloud) (hint-unlit) ; (blend-mode "src-alpha" "zero") (hint-vertcols) ;(hint-depth-sort) (texture (load-texture "textures/opcodes-mp.png")) (translate (vector -0.7 0.35 -0.1)) (scale (vector 0.4 0.7 0.75)) (rotate (vector 180 0 0)) (set! code (build-seg-plane code-height code-width)) (pop) (apply-transform code) (clear-code) ; marker (push) (texture (load-texture "textures/marker.png")) (parent code) (colour (vector 1 1 1)) (opacity 0.5) (hint-unlit) (hint-depth-sort) (translate (vector 0.04 -0.04 0)) (scale (vector 0.15 0.15 1)) (set! marker (build-plane)) (pop) (apply-transform marker) ; signal (push) (rotate (vector 0 0 -90)) (hide 1) (texture (load-texture "textures/signal.png")) (colour (vector 1 1 1)) (hint-unlit) (hint-depth-sort) (set! signal (build-plane)) (pop) (apply-transform signal) ; signal seen (push) (rotate (vector 0 0 -90)) (hide 1) (texture (load-texture "textures/signal-seen.png")) (colour signal-seen-colour) (hint-unlit) (hint-depth-sort) (set! signal-seen (build-plane)) (pop) (apply-transform signal-seen) ; build the ring menu (set! ring-menu (make-object ringmenu% code (vector 0 0 0) (load-texture "textures/opcodes-mp.png") (list (instr->tex 'forward) (instr->tex 'back) (instr->tex 'left) (instr->tex 'right) (instr->tex 'nop)))) (send ring-menu set-item-size 2) ((class-field-mutator ringmenu% menu-hi-colour) ring-menu col) (with-state (scale 3) (send ring-menu build))) (define/public (destroy-bot) (destroy object) (destroy cloud)) (define/public (next-position state position direction) (cond ((eq? state 'forward) (cond ((eq? direction 'north) (position-add position (vector 0 1))) ((eq? direction 'south) (position-add position (vector 0 -1))) ((eq? direction 'east) (position-add position (vector 1 0))) ((eq? direction 'west) (position-add position (vector -1 0))))) ((eq? state 'back) (cond ((eq? direction 'north) (position-add position (vector 0 -1))) ((eq? direction 'south) (position-add position (vector 0 1))) ((eq? direction 'east) (position-add position (vector -1 0))) ((eq? direction 'west) (position-add position (vector 1 0))))) (else position))) (define/public (move-marker position) (grab code) (let ((pos (pdata-ref "p" (pos->vert position)))) (ungrab) (grab marker) (identity) (translate (vector 0.06 -0.05 -0.02)) (translate pos) (ungrab))) ; highlight a list of positions relative to our own (define/public (highlight-blocks renderer position blocklist) (send renderer highlight-block (position-add position (car blocklist))) (if (null? (cdr blocklist)) 0 (highlight-blocks renderer position (cdr blocklist)))) (define (highlight-scan renderer direction) (cond ((eq? direction 'north) (highlight-blocks renderer position scan-pattern-north)) ((eq? direction 'south) (highlight-blocks renderer position scan-pattern-south)) ((eq? direction 'east) (highlight-blocks renderer position scan-pattern-east)) ((eq? direction 'west) (highlight-blocks renderer position scan-pattern-west)))) ; notify the bot that our state has changed (define/public (change-state renderer state-packet) (set! last-state state) (set! last-trigger trigger) (set! last-code-position code-position) (set! trigger (cadr state-packet)) (set! state (car state-packet)) (set! code-position (list-ref state-packet 3)) (set! position (next-position last-state position direction)) (move-marker last-code-position) (cond ((eq? last-state 'left) (set! direction (rotate-left direction))) ((eq? last-state 'right) (set! direction (rotate-right direction)))) ; get the positions of the current and next block (let ((start (vtransform (vector 0 0 0) (send renderer block-transform position))) (end (vtransform (vector 0 0 0) (send renderer block-transform (next-position state position direction))))) ; get the vector between them (set! animate-direction (vsub end start))) (grab object) (identity) (bot-transform renderer) ; convert from world space to object (set! animate-direction (vtransform-rot animate-direction (minverse (get-transform)))) (ungrab) (cond ((eq? state 'look-forward) (highlight-scan renderer direction)) ((eq? state 'look-left) (highlight-scan renderer (rotate-left direction))) ((eq? state 'look-right) (highlight-scan renderer (rotate-right direction))) ((eq? state 'look-back) (highlight-scan renderer (rotate-right (rotate-right direction)))) ((eq? state 'signal) (set! signal-time (* signal-ticks tick))) ((eq? state 'signal-seen) (set! signal-seen-time (* signal-ticks tick)))) (cond (last-trigger (send renderer trigger-block position)))) (define/public (camera-orient pos drift) (let ((last (vtransform (vector 0 0 0) (get-transform)))) (identity) (let ((c (vnormalise (vtransform (vector 0 0 1) (get-camera))))) (let ((s (vcross c (vector 0 1 0)))) (let ((u (vcross c s))) (translate (vadd (vmul pos (- 1 drift)) (vmul last drift))) (translate (vector 0 0.1 0)) (scale (vector 2 2 2)) (concat (maim u c))))))) ; update blends the state changes to give us a smooth animation (define/public (update) (grab object) (let ((pos (vtransform (vector 0 0 0) (get-transform)))) (ungrab) (if last-trigger (colour bot-trigger-colour) (colour paper-colour)) ; deal with the signal animation (cond ((> signal-time 0) (set! signal-time (- signal-time (delta))) (let ((t (/ signal-time (* signal-ticks tick)))) (grab signal) (hide 0) (camera-orient pos 0) (translate (vector -0.5 0 -1)) (scale (vmul (vector 1 1 1) (+ 0.5 (- 1 t)))) (opacity t)) (ungrab)) (else (grab signal) (identity) (hide 1) (ungrab))) ; deal with the signal seen animation (cond ((> signal-seen-time 0) (set! signal-seen-time (- signal-seen-time (delta))) (let ((t (/ signal-seen-time (* signal-ticks tick)))) (grab signal-seen) (hide 0) (camera-orient pos 0) (translate (vector -0.3 0 -1)) (scale (vmul (vector 1 1 1) (* 0.5 (+ 0.1 (- 1 t))))) (opacity t)) (ungrab)) (else (grab signal-seen) (identity) (hide 1) (ungrab))) (grab object) (when (eq? state 'forward) (translate (vmul animate-direction (/ (delta) tick)))) (when (eq? state 'back) (translate (vmul animate-direction (/ (delta) tick)))) (when (eq? state 'left) (rotate (vector 0 (/ (* (delta) 90) tick) 0))) (when (eq? state 'right) (rotate (vector 0 (/ (* (delta) -90) tick) 0))) (ungrab) (grab cloud) (camera-orient pos 0) (translate (vector 0.05 0 -3)) (when (not selected) (scale 0.5) (translate (vector -0.3 0 0))) (ungrab))) (super-new))) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; the block visualisation (define renderer-block% (class object% (field (object 0) (trigger 0) (trigger-length 0.5) (trigger-time -1) (highlight-length 0.8) (highlight-time -1) (scale-correct 1) (current-colour paper-colour) (tx 0)) (define/public (get-object) object) (define/public (build) (push) (colour current-colour) (hint-wire) (wire-colour pen-colour) ; (hint-unlit) (line-width 3) (set! object (build-cube)) (pop) (with-primitive object (set! tx (get-transform))) (push) (hint-none) (hint-solid) (colour cube-trigger-colour) (parent object) (identity) (hint-depth-sort) (set! trigger (build-cube)) (pop) (grab trigger) (hide 1) (ungrab)) (define/public (update) (cond ((> trigger-time 0) (set! trigger-time (- trigger-time (delta))) (grab trigger) (opacity (/ trigger-time trigger-length)) (scale (vector 1.05 1.05 1.05)) (ungrab)) (else (grab trigger) (identity) (hide 1) (ungrab))) (cond ((> highlight-time 0) (set! highlight-time (- highlight-time (delta))) (grab object) (let ((t (/ highlight-time highlight-length))) (colour (vadd (vmul current-colour (- 1 t)) (vmul cube-highlight-colour t))) (ungrab))) (else (grab object) (colour current-colour) (ungrab)))) (define/public (start-trigger) (grab trigger) (identity) (hide 0) (ungrab) (set! trigger-time trigger-length)) (define/public (highlight) (set! highlight-time highlight-length)) (define/public (raise) (grab object) (translate (vector 0 0.1 0)) (ungrab)) (define/public (lower) (grab object) (translate (vector 0 -0.1 0)) (ungrab)) (define/public (set-height s) (with-primitive object (identity) (concat tx) (translate (vector 0 (* s 0.1) 0)))) (define/public (set-trigger s) (if s (set! current-colour trigger-colour) (set! current-colour paper-colour))) (super-new) (build))) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; the main renderer is in charge of the visual display of everything ; this code is run in realtime, and reads updates from the core (define renderer% (class object% (init-field (w 0) (h 0)) (field (terrain '()) (bots '()) (zoom 30)) ; simple accessors (define/public (get-zoom) zoom) (define/public (set-zoom s) (set! zoom s)) ; update all gui bots (define/public (set-tick s) (define (loop bot-list) (send (car (cdr (car bot-list))) set-tick s) (if (null? (cdr bot-list)) 0 (loop (cdr bot-list)))) (when (not (null? bots)) (loop bots))) ; builds the grid of blocks (define (build-terrain) (define (build-grid y) (define (build-row x) (push) (translate (vector x 0 y)) (set! terrain (cons (make-object renderer-block%) terrain)) (pop) (if (zero? x) 0 (build-row (- x 1)))) (build-row (- w 1)) (if (zero? y) 0 (build-grid (- y 1)))) (build-grid (- h 1))) (define (update-terrain terrain) (send (car terrain) update) (if (null? (cdr terrain)) 0 (update-terrain (cdr terrain)))) ; builds all the blocks, and the cursor and sets up the camera (define/public (build) (build-terrain)) (define/public (get-block position) (send (get-renderer-block position) get-object)) (define/public (get-renderer-block position) (let ((index (+ (vector-ref position 0) (* (vector-ref position 1) w)))) (if (and (>= index 0) (< index (length terrain))) (list-ref terrain index) #f))) ; gets the transform matrix for the block at this position (define/public (block-transform position) (grab (get-block position)) (let ((tx (get-transform))) (ungrab) tx)) ; returns the renderer bot at the specified position, or #f ; if none exist there (define/public (get-bot-at position) (define (loop b) (if (equal? position (send (car (cdr (car b))) get-position)) (car (cdr (car b))) (if (null? (cdr b)) #f (loop (cdr b))))) (if (null? bots) #f (loop bots))) (define/public (remove-bot id) (define (inner-remove elist) (if (null? elist) elist (if (eq? (car (car elist)) id) (inner-remove (cdr elist)) (cons (car elist) (inner-remove (cdr elist)))))) (send (get-bot id) destroy-bot) (set! bots (inner-remove bots))) (define/public (trigger-block position) (send (get-renderer-block position) start-trigger)) (define/public (highlight-block position) (let ((renderer-block (get-renderer-block position))) ; can be called with invalid block positions (when renderer-block (send renderer-block highlight)))) ; returns the specified renderer bot (define/public (get-bot id) (let ((p (assq id bots))) (cond (p (cadr p)) (else #f)))) ; adds a new bot to the renderer (define/public (add-bot id bot) (send bot build this) (set! bots (cons (list id bot) bots))) ; update all gui bots (define/public (update) (define (inner-update bot-list) (send (car (cdr (car bot-list))) update) (if (null? (cdr bot-list)) 0 (inner-update (cdr bot-list)))) (when (not (null? bots)) (inner-update bots)) (update-terrain terrain)) (super-new))) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (define player% (class object% (init-field (player-id 0) (player-colour (vector 1 0 0)) (w 0) (h 0) (cam-x 0) (cam-y 0) (cam-w 1) (cam-h 1)) (field (joylisten (make-object joylisten%)) (selected #f) (mybot #f) (mycorebot #f) (debounce #t) (cursor 0) (code-cursor 0) (cursor-pos (vector (+ 2 player-id) 5)) (code-cursor-pos (vector 0 0)) (camera 0) (inactive-time 0) (program-reset #f) (home (vector 0 0))) (define/public (get-cursor) cursor) (define/public (get-inactive-time) inactive-time) (define/public (get-cursor-pos) cursor-pos) (define/public (get-code-cursor-pos) code-cursor-pos) (define/public (get-selected) selected) (define (player-new) (super-new) (send joylisten set-device-num! (number->string player-id))) ; builds all the blocks, and the cursor and sets up the camera (define/public (build renderer) (if (zero? player-id) (set! camera 0) (set! camera (build-camera))) (current-camera camera) (set-ortho-zoom (* (send renderer get-zoom) -0.1)) (ortho) (viewport cam-x cam-y cam-w cam-h) (push) ;(hint-unlit) (colour (vector 1 1 1)) (texture (load-texture "textures/cursor.png")) (scale (vector 1.02 1.02 1.02)) (set! cursor (build-cube)) (scale (vector 10 10 10)) (set! code-cursor (build-sphere 10 10)) (pop) (grab code-cursor) (hide 1) (ungrab) ; setup the camera (apply-transform cursor) (update-cursor renderer) (lock-camera cursor) (camera-lag 0.1) (set-camera (mmul (mtranslate (vector 0 -0.7 -10)) (mrotate (vector 25 20 0))))) (define/public (update renderer core) (current-camera camera) (set-ortho-zoom (* (send renderer get-zoom) -0.1)) (set! inactive-time (+ inactive-time (delta))) (send joylisten update) (deal-with-input renderer core) (update-cursor renderer)) ; selects a bot at the cursor position, clears the ; previously selected bot (define/public (select-bot renderer onboard) (set! selected mybot) (send selected set-selected #t #t)) ; flips out of bot edit mode (define/public (unselect-bot) (cond (selected ; clear the cursor as we are about to leave bot-edit mode (send selected set-code-col (vector-ref code-cursor-pos 0) (vector-ref code-cursor-pos 1) (vector 0.5 0.5 0.5)) (send selected set-selected #f #f) ; in case the camera is in onboard mode (current-camera camera) (ortho) (lock-camera cursor) (set-camera-transform (mmul (mtranslate (vector 0 -0.7 -10)) (mrotate (vector 25 20 0)))))) (set! selected #f)) ; animates and places the cursor over the correct block (define/public (update-cursor renderer) (let ((col (vmul player-colour 0.5))) (when (> (sin (* (time) 30)) 0) (set! col cursor-colour)) (grab cursor) (colour col) (identity) (cond ; if we are in bot livecode mode: (selected (hide 1) ; hide the block cursor (grab (send selected get-model)) (let ((pos (vtransform (vector 0 0 0) (get-transform)))) (ungrab) (translate pos)) ; ??? ; highlight the code cursor position (send selected set-code-col (vector-ref code-cursor-pos 0) (vector-ref code-cursor-pos 1) col) ; move the ringmenu to here (send (send selected get-ring-menu) set-position (vadd (send selected get-code-pos code-cursor-pos) (vector 0.055 -0.05 0)))) ; add some to get it in the centre (else (hide 0) (concat (send renderer block-transform cursor-pos)))) (ungrab))) (define/public (deal-with-input renderer core) ; a function to turn a number from the menu into a intruction (define (index->instr n) (cond ((eq? n 0) 'forward) ((eq? n 1) 'back) ((eq? n 2) 'left) ((eq? n 3) 'right) ((eq? n 4) 'nop))) (current-camera camera) (cond ; button a is the main 'doing' button ((> (send joylisten get-button joymap-a) 0) (cond (debounce ; are we in bot edit mode? (let ((selected (get-selected))) (cond ; are we in bot edit mode with the menu shown? ((and selected (send (send selected get-ring-menu) get-shown)) (let ((id (send selected get-id))) (let ((pos (get-code-cursor-pos))) (let ((index (send (send selected get-ring-menu) get-selected))) (set-bot-instr renderer core id (vector-ref pos 0) (vector-ref pos 1) (index->instr index)))))) ;disabling world edit! -> #;(else (if selected (unselect-bot) ; hold r1 to board the bot (select-bot renderer (> (send joylisten get-button joymap-r1) 0)))))))) (set! debounce #f)) ; button c sets/clears a trigger ((> (send joylisten get-button joymap-c) 0) (cond (debounce ; are we not in bot edit mode? (cond ((not (get-selected)) (let ((block (send core get-block (get-cursor-pos)))) (cond ((send block get-trigger) (send block set-trigger #f) (send (send renderer get-renderer-block (get-cursor-pos)) set-trigger #f)) (else (send block set-trigger #t) (send (send renderer get-renderer-block (get-cursor-pos)) set-trigger #t)))))))) (set! debounce #f)) ; button l1 raises the current block ((> (send joylisten get-button joymap-l1) 0) (cond (debounce ; are we not in bot edit mode? (cond ((not (get-selected)) (let ((block (send core get-block (get-cursor-pos)))) (send block raise)) (send (send renderer get-renderer-block (get-cursor-pos)) raise))))) (set! debounce #f)) ; button l2 lowers the current block ((> (send joylisten get-button joymap-l2) 0) (cond (debounce ; are we not in bot edit mode? (cond ((not (get-selected)) (let ((block (send core get-block (get-cursor-pos)))) (send block lower)) (send (send renderer get-renderer-block (get-cursor-pos)) lower))))) (set! debounce #f)) ; deal with the directional pad to move the cursor ((< (vector-ref (send joylisten get-axis joymap-dpad) 0) 0) (when debounce (move-cursor 'north)) (set! debounce #f)) ((> (vector-ref (send joylisten get-axis joymap-dpad) 0) 0) (when debounce (move-cursor 'south)) (set! debounce #f)) ((< (vector-ref (send joylisten get-axis joymap-dpad) 1) 0) (when debounce (move-cursor 'west)) (set! debounce #f)) ((> (vector-ref (send joylisten get-axis joymap-dpad) 1) 0) (when debounce (move-cursor 'east)) (set! debounce #f)) (else (set! debounce #t))) (when (not debounce) (set! program-reset #f) (set! inactive-time 0)) (when (and (not program-reset) (> inactive-time (- inactive-bot-time 1))) (set-program renderer core '(none none none none none none none none)) (set! program-reset #t)) (when (> inactive-time inactive-bot-time) (send core set-bot-position (send mybot get-id) home) (send mybot set-position home)) (when (and test-mode (zero? (random 500))) (set! inactive-time 0) (set! program-reset #f) (set-program renderer core (random-program))) ; do the ring menus (let ((selected (get-selected))) (when selected (send (send selected get-ring-menu) update joylisten 0)))) (define (random-program) (list-tabulate 8 (lambda (n) (let ((l (list 'none 'forward 'back 'left 'right))) (list-ref l (random (length l))))))) (define/public (set-program renderer core program) (let ((p 0)) (for-each (lambda (instr) (set-bot-instr renderer core (send selected get-id) p 0 instr) (set! p (+ p 1))) program))) ; adds a new bot - updates the core, and renderer (define/public (add-bot renderer core position direction) (set! home position) (let ((id (send core add-bot position direction))) (send renderer add-bot id (make-object renderer-bot% id position direction player-colour camera)) (send (send renderer get-bot id) set-tick (send core get-tick)) (set! selected (send renderer get-bot id)) (set! mybot selected) (send selected set-selected #t #t) id)) ; deletes a bot - updates the core, and renderer (define/public (remove-bot renderer core position) (let ((bot (send renderer get-bot-at position))) (cond (bot (send core remove-bot (send bot get-id)) (send renderer remove-bot (send bot get-id)))))) ; sets an instruction for the specified bot, updates the core (define/public (set-bot-instr renderer core id position state instr) (send core set-bot-code id position state instr) (send (send renderer get-bot id) poke position state instr)) (define/public (move-cursor direction) (cond ; which cursor do we want to move? (selected ; set the previous position's colour to clear the cursor (send selected set-code-col (vector-ref code-cursor-pos 0) (vector-ref code-cursor-pos 1) (vmul player-colour 0.5)) (cond ((eq? direction 'north) (when (>= (vector-ref code-cursor-pos 0) code-width) (set! code-cursor-pos (position-add code-cursor-pos (vector (- code-width) 0))))) ((eq? direction 'south) (when (< (vector-ref code-cursor-pos 0) code-width) (set! code-cursor-pos (position-add code-cursor-pos (vector code-width 0))))) ((eq? direction 'west) (set! code-cursor-pos (position-add code-cursor-pos (vector -1 0)))) ((eq? direction 'east) (set! code-cursor-pos (position-add code-cursor-pos (vector 1 0)))))) (else (cond ((eq? direction 'north) (set! cursor-pos (position-add cursor-pos (vector 0 -1)))) ((eq? direction 'south) (set! cursor-pos (position-add cursor-pos (vector 0 1)))) ((eq? direction 'west) (set! cursor-pos (position-add cursor-pos (vector -1 0)))) ((eq? direction 'east) (set! cursor-pos (position-add cursor-pos (vector 1 0))))))) ; clamp the cursors (cond (selected (when (< (vector-ref code-cursor-pos 0) 0) (vector-set! code-cursor-pos 0 0)) (when (< (vector-ref code-cursor-pos 1) 0) (vector-set! code-cursor-pos 1 0)) (when (>= (vector-ref code-cursor-pos 0) code-length) (vector-set! code-cursor-pos 0 (- code-length 1))) (when (>= (vector-ref code-cursor-pos 1) code-states) (vector-set! code-cursor-pos 1 (- code-states 1)))) (else (when (< (vector-ref cursor-pos 0) 0) (vector-set! cursor-pos 0 0)) (when (< (vector-ref cursor-pos 1) 0) (vector-set! cursor-pos 1 0)) (when (>= (vector-ref cursor-pos 0) w) (vector-set! cursor-pos 0 (- w 1))) (when (>= (vector-ref cursor-pos 1) h) (vector-set! cursor-pos 1 (- h 1)))))) (player-new))) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; glue the renderer and the core together. this object also handles all input ; and dispatches messages to all effected objects (define aljazari% (class object% (init-field (w 0) (h 0)) (field (core (make-object core% w h)) (renderer (make-object renderer% w h)) (update-list '()) (itchy (make-object itchy-client% itchy-url scratchy-url)) (set-number 0) (current-bpm 0) (current-tick 0.2) (voice-items (vector (vector 0 0 0) (vector 0.25 0 0) (vector 0.5 0 0) (vector 0.75 0 0) (vector 0 0.25 0) (vector 0.25 0.25 0) (vector 0.5 0.25 0) (vector 0.75 0.25 0) (vector 0 0.5 0))) (voices (vector 0 0 0 0 0 0 0)) (player-list (list (make-object player% 0 (vector 1 0 0) w h 0 0 0.5 0.5) (make-object player% 1 (vector 0 1 0) w h 0.5 0 0.5 0.5) (make-object player% 2 (vector 0 0.5 1) w h 0 0.5 0.5 0.5) (make-object player% 3 (vector 1 1 0) w h 0.5 0.5 0.5 0.5))) (inactive-time 100000) (terraform-terrain 0) (terraform-trigger 0) (terraform-pos 100000) (current-voice start-voice) (sync-time 0)) ; sets the time between clock updates (the beat) (define/public (set-tick s) (send core set-tick s) (send renderer set-tick s)) (define/public (get-itchy) itchy) (define/public (add-bot player pos dir) (send (list-ref player-list player) add-bot renderer core pos dir)) (define/public (camera-orient pos drift) (let ((last (vtransform (vector 0 0 0) (get-transform)))) (identity) (let ((c (vnormalise (vtransform (vector 0 0 1) (get-camera))))) (let ((s (vcross c (vector 0 1 0)))) (let ((u (vcross c s))) (translate (vadd (vmul pos (- 1 drift)) (vmul last drift))) (translate (vector 0 0.1 0)) (scale (vector 2 2 2)) (concat (maim u c))))))) (define (init) (super-new) (send renderer build) (send core set-time (time)) (set-tick current-tick) (for-each (lambda (player) (send player build renderer)) player-list)) ; updates the renderer given a list of events from the core (define/public (update-from-list updates) (cond ((null? updates) 0) ((null? (car updates)) 0) (else (let ((bot (send renderer get-bot (caar updates)))) (when bot ; it's possible the bot has been deleted since this update was sent (send bot change-state renderer (car (cdr (car updates)))))) (update-from-list (cdr updates))))) ; handles gamepad input and passes messages around (define/public (deal-with-input) ; 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)))))) ; check for external syncs (cond ((osc-msg "/sync") (let ((t (vector (osc 0) (osc 1))) (bpm (* bpm-multiplier (osc 3)))) (let ((tick (/ 1 (/ bpm 60)))) (set-tick tick) (let ((newtime (+ sync-offset (timestamp->time t)))) (let ((offset (calc-offset (send core get-time) newtime tick))) (send core set-time (+ (send core get-time) offset)) (display "got /sync bpm is ")(display bpm) (display " error is ")(display offset)(newline)))))))) ; updates everything (define/public (update) ; first time? then do a core update (when (null? update-list) (set! update-list (append update-list (list (send core update))))) (deal-with-input) (send renderer update) (for-each (lambda (player) (send player update renderer core)) player-list) ; see if the oldest event list is ready to go yet (cond ((> (time) (car (car update-list))) (update-from-list (car (cdr (car update-list)))) (set! update-list (cdr update-list)) ; get a new list now, by running the core (set! update-list (append update-list (list (send core update)))) (make-noise (car update-list)))) ; deal with doing things due to inactivity (when (> inactive-time inactive-bot-time) (set! inactive-time 0) (set! terraform-terrain (list-ref terrain-patterns (random (length terrain-patterns)))) (set! terraform-trigger (list-ref trigger-patterns (random (length trigger-patterns)))) (set! terraform-pos 0) (printf "using voices:~a~n" current-voice) (change-patches current-voice) (set! current-voice (modulo (+ current-voice 1) max-voice))) ; count up inactive time (set! inactive-time (+ inactive-time (delta))) (for-each (lambda (player) (when (< (send player get-inactive-time) 1) (set! inactive-time 0))) player-list) ; periodically sync the synths to the real time ; (sample counting is innacurate over long periods) (when (> (time) sync-time) (set! sync-time (+ (time) sync-freq)) (send itchy sync)) (terraform)) (define (terraform) (when (< terraform-pos (* w h)) (let* ((pos (vector (modulo terraform-pos w) (quotient terraform-pos w))) (block (send core get-block pos))) (send block set-height (list-ref terraform-terrain terraform-pos)) (send (send renderer get-renderer-block pos) set-height (list-ref terraform-terrain terraform-pos)) (cond ((eq? 1 (list-ref terraform-trigger terraform-pos)) (send block set-trigger #t) (send (send renderer get-renderer-block pos) set-trigger #t)) (else (send block set-trigger #f) (send (send renderer get-renderer-block pos) set-trigger #f)))) (set! terraform-pos (+ terraform-pos 1)))) (define (change-patches num) (for-each (lambda (voice) (let ((patch (list-ref (list-ref patches num) voice))) (if (or (eq? voice 0) (eq? voice 6)) (send itchy samples (+ voice 1) patch) (if (or (eq? voice 2) (eq? voice 4)) (send itchy voice (+ voice 1) "fm" patch) (send itchy voice (+ voice 1) "sub" patch))))) (list 0 1 2 3))) ; make-noise is run as soon as we get an update packet from the core, ; this means we can dispatch the osc messages with plenty of time for them ; to be triggered (and is the whole idea of this architecture) (define/public (make-noise updates) (define timestamp 0) (define (loop updates) (let ((bot-packet (car updates))) (let ((bot-id (car bot-packet)) (bot-commands (car (cdr bot-packet)))) (cond ((and (not (null? bot-commands)) (car (cdr bot-commands))) ; do we have a trigger? (let ((note (car (cdr (cdr bot-commands))))) (send itchy play (+ timestamp (send core get-tick)) (+ note 40) bot-id)))))) (if (null? (cdr updates)) 0 (loop (cdr updates)))) (set! timestamp (car updates)) (when (not (null? (cadr updates))) (loop (cadr updates)))) (init))) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; main script (clear) (colour paper-colour) (clear-colour bg-colour) (set-camera-update #f) (define aljazari (make-object aljazari% 10 10)) ; preload (send (send aljazari get-itchy) samples 1 "tabla") (send (send aljazari get-itchy) samples 1 "rip") (send (send aljazari get-itchy) samples 1 "kip") (send (send aljazari get-itchy) samples 1 "808") (send (send aljazari get-itchy) samples 1 "electro_d") (send (send aljazari get-itchy) sample-unmap) ; set up the voices (send (send aljazari get-itchy) voice 2 "sub" (list-ref (list-ref patches 0) 1)) (send (send aljazari get-itchy) voice 3 "fm" (list-ref (list-ref patches 0) 2)) (send (send aljazari get-itchy) voice 4 "sub" (list-ref (list-ref patches 0) 3)) (send (send aljazari get-itchy) voice 5 "fm" (list-ref (list-ref patches 0) 4)) (send (send aljazari get-itchy) voice 6 "sub" (list-ref (list-ref patches 0) 5)) (send aljazari add-bot 0 (vector 1 1) 'north) (send aljazari add-bot 1 (vector 1 8) 'north) (send aljazari add-bot 2 (vector 8 8) 'north) (send aljazari add-bot 3 (vector 8 1) 'north) ;(define osc-reader (make-osc-reader "doc/aj1/001.osc" "osc.udp://localhost:4444")) (define (animate) ;(set! current-time (+ current-time (delta))) ;((osc-reader 'update)) (set! current-time (/ (current-inexact-milliseconds) 1000)) (send aljazari update)) ;(process "doc/aj1/aj1.wav") ;(start-framedump "doc/aj1/blah" "jpg") (every-frame (animate))