; AL-JAZARI ; ; livecoding for royal drinking parties ; ; L1/L2 : Raise/Lower block ; DPad : Move cursor ; Left Stick : Patch/Code menu ; Right Stick : Zoom camera ; Button 1 : Make a new robot ; Button 2 : Enter/leave livecode mode, select ring menu item ; Button 3 : Toggle audio trigger on/off ; Button 4 : Delete robot ;(define (delta) ; (/ 1764 44100)) ;(define current-time (time)) ;(define (time) ; current-time) (require scheme/class) (require fluxus-017/time) (require fluxus-017/joylisten) (require fluxus-017/tricks) (require fluxus-017/gui) (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 1 0)) (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 4) (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.0) (define swing-beat 1.0) ;(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 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) (define max-voice 5) (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-add a b) (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/dave/noiz/pattern-cascade/") ; 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 (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 (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 (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 (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)) (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-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) (* (vector-ref pos 1) code-length)) code-states)) ; 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) (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 (vector 0.5 0.5 0.5)) (if (zero? a) 0 (loop-add (- a 1) s))) (define (loop-state s) (loop-add 7 s) (if (zero? s) 0 (loop-state (- s 1)))) (loop-state 3)) ; builds and sets up all the fluxus primitives for the bot (define/public (build renderer) ; bot model (push) (colour paper-colour) (rotate (vector -90 0 0)) (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) (colour (vector 1 1 1)) (hint-unlit) ;(hint-ignore-depth) (hint-depth-sort) (colour (vector 1 1 1)) (texture (load-texture "textures/think2.png")) (translate (vector 0 0 0.1)) (scale (vector 0.9 1 1)) (set! cloud (build-plane)) (pop) (apply-transform cloud) ; code (push) (parent cloud) (hint-unlit) ; (blend-mode "src-alpha" "zero") (hint-vertcols) ;(hint-depth-sort) (texture (load-texture "textures/opcodes3.png")) (scale (vector 0.45 0.8 0.75)) (translate (vector -0.05 0 0)) (rotate (vector 180 0 0)) (set! code (build-seg-plane code-states code-length)) (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) (scale (vector 0.1 0.1 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/opcodes3.png") (list (instr->tex 'forward) (instr->tex 'back) (instr->tex 'left) (instr->tex 'right) (instr->tex 'signal) (instr->tex 'look-forward) (instr->tex 'look-back) (instr->tex 'look-left) (instr->tex 'look-right) (instr->tex 'look-signal) (instr->tex 'stuck) (instr->tex 'jump-circle) (instr->tex 'jump-triangle) (instr->tex 'jump-square) (instr->tex 'jump-pentagon) (instr->tex 'nop)))) (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) (minverse (get-camera-transform)))))) (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) (when selected (set! pos (vtransform (vector 0 0 0) (get-locked-matrix)))) (grab cloud) (if selected (camera-orient pos 0) (camera-orient pos 0.95)) (cond (selected (translate (vector 0.05 0 -3)) (scale (vector 2 2 2)))) (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)) (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) (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-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 '()) (selected #f) (cursor 0) (code-cursor 0) (cursor-pos (vector 5 5)) (code-cursor-pos (vector 0 0)) (zoom 50)) ; simple accessors (define/public (get-cursor) cursor) (define/public (get-cursor-pos) cursor-pos) (define/public (get-code-cursor-pos) code-cursor-pos) (define/public (get-zoom) zoom) (define/public (set-zoom s) (set! zoom s)) (define/public (get-selected) selected) ; 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) (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) (lock-camera cursor) (camera-lag 0.1) (set-camera-transform (mmul (mtranslate (vector 0 -0.7 -10)) (mrotate (vector 25 -20 0))))) (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)))) ; animates and places the cursor over the correct block (define/public (update-cursor) (let ((col paper-colour)) (when (> (sin (* (time) 15)) 0) (set! col bot-trigger-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 (block-transform cursor-pos)))) (ungrab))) ; 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))) ; selects a bot at the cursor position, clears the ; previously selected bot (define/public (select-bot onboard) (let ((bot (get-bot-at cursor-pos))) (cond (bot (send bot set-selected #t onboard) (set! code-cursor-pos (vector 0 0)) (cond (onboard ; if we are getting on board the bot, set up the camera (persp) (camera-lag 0.1) (lock-camera (send bot get-model)) (set-camera-transform (mmul (mtranslate (vector 0 -1 -2)) (mrotate (vector 10 -270 0)))))))) (set! selected bot))) ; 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 (ortho) (camera-lag 0.1) (lock-camera cursor) (set-camera-transform (mmul (mtranslate (vector 0 -0.7 -10)) (mrotate (vector 25 -20 0)))))) (set! selected #f)) (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) (vector 0.5 0.5 0.5)) (cond ((eq? direction 'north) (set! code-cursor-pos (position-add code-cursor-pos (vector 0 -1)))) ((eq? direction 'south) (set! code-cursor-pos (position-add code-cursor-pos (vector 0 1)))) ((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)))))) ; 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) (update-cursor)) (super-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 '()) (joylisten (make-object joylisten%)) (debounce #t) (itchy (make-object itchy-client% itchy-url scratchy-url)) (set-number 0) (current-bpm 0) (voice-menu 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))) ; 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 (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) ; build the voice menu (set! voice-menu (make-object ringmenu% (send renderer get-cursor) (vector 0 0 0) (load-texture "textures/numbers.png") (list (vector 0 0 0) (vector 0 0 0) (vector 0 0 0) (vector 0 0 0) (vector 0 0 0) (vector 0 0 0) (vector 0 0 0)))) (push) (translate (vector 0 0 -3)) (send voice-menu build) (pop) (send core set-time (time)) (set-tick current-tick)) ; adds a new bot - updates the core, and renderer (define/public (add-bot position direction) (let ((id (send core add-bot position direction))) (send renderer add-bot id (make-object renderer-bot% id position direction)) (send (send renderer get-bot id) set-tick (send core get-tick)) id)) ; deletes a bot - updates the core, and renderer (define/public (remove-bot 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 id position state instr) (send core set-bot-code id position state instr) (send (send renderer get-bot id) poke position state instr)) ; 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) ; 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) 'signal) ((eq? n 5) 'look-forward) ((eq? n 6) 'look-back) ((eq? n 7) 'look-left) ((eq? n 8) 'look-right) ((eq? n 9) 'look-signal) ((eq? n 10) 'stuck) ((eq? n 11) 'jump-circle) ((eq? n 12) 'jump-triangle) ((eq? n 13) 'jump-square) ((eq? n 14) 'jump-pentagon) ((eq? n 14) 'nop))) ; 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))))))) (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 (send renderer 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 (send renderer get-code-cursor-pos))) (let ((index (send (send selected get-ring-menu) get-selected))) (set-bot-instr id (vector-ref pos 0) (vector-ref pos 1) (index->instr index)))))) (else ; if we are in the voice menu now (cond ((send voice-menu get-shown) (let ((voice (send voice-menu get-selected))) (vector-set! voices voice (modulo (+ (vector-ref voices voice) 1) max-voice)) (send voice-menu update-item voice (vector-ref voice-items (vector-ref voices voice))) ; get the right patch (let ((patch (list-ref (list-ref patches (vector-ref voices voice)) voice))) ; do the actual voice change (if (or (equal? voice 0) (equal? voice 6)) (send itchy samples (+ voice 1) patch) (if (or (equal? voice 2) (equal? voice 4)) (send itchy voice (+ voice 1) "fm" patch) (send itchy voice (+ voice 1) "sub" patch)))))) (else (if selected (send renderer unselect-bot) ; hold r1 to board the bot (send renderer select-bot (> (send joylisten get-button joymap-r1) 0)))))))))) (set! debounce #f)) ; button b adds a new bot ((> (send joylisten get-button joymap-b) 0) (cond (debounce ; are we not in bot edit mode? (cond ((not (send renderer get-selected)) (add-bot (send renderer get-cursor-pos) 'north))))) (set! debounce #f)) ; button d deletes a bot ((> (send joylisten get-button joymap-d) 0) (cond (debounce ; are we not in bot edit mode? (cond ((not (send renderer get-selected)) (remove-bot (send renderer get-cursor-pos)))))) (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 (send renderer get-selected)) (let ((block (send core get-block (send renderer get-cursor-pos)))) (cond ((send block get-trigger) (send block set-trigger #f) (send (send renderer get-renderer-block (send renderer get-cursor-pos)) set-trigger #f)) (else (send block set-trigger #t) (send (send renderer get-renderer-block (send renderer get-cursor-pos)) set-trigger #t)))))))) (set! debounce #f)) ; button l1 raises the current block ((> (send joylisten get-button joymap-l1) 0) (cond (debounce (cond ((send voice-menu get-shown) (set! current-tick (* current-tick 0.9)) (set-tick current-tick)) (else ; are we not in bot edit mode? (cond ((not (send renderer get-selected)) (let ((block (send core get-block (send renderer get-cursor-pos)))) (send block raise)) (send (send renderer get-renderer-block (send renderer get-cursor-pos)) raise))))))) (set! debounce #f)) ; button l2 lowers the current block ((> (send joylisten get-button joymap-l2) 0) (cond (debounce (cond ((send voice-menu get-shown) (set! current-tick (* current-tick 1.1)) (set-tick current-tick)) (else ; are we not in bot edit mode? (cond ((not (send renderer get-selected)) (let ((block (send core get-block (send renderer get-cursor-pos)))) (send block lower)) (send (send renderer get-renderer-block (send renderer get-cursor-pos)) lower))))))) (set! debounce #f)) ; button f is manual sync ((> (send joylisten get-button joymap-f) 0) (cond (debounce (send core set-time (+ (time) (* (send core get-tick) 2))) (display "setting time to: ")(display (+ (time) (* (send core get-tick) 2))) (newline))) (set! debounce #f)) ; button e is random note for soundchecks ((> (send joylisten get-button joymap-e) 0) (cond (debounce (send itchy play (+ (time) 1) (+ (random 50) 40) (random 7)))) (set! debounce #f)) ; deal with the directional pad to move the cursor ((< (vector-ref (send joylisten get-axis joymap-dpad) 0) 0) (when debounce (send renderer move-cursor 'north)) (set! debounce #f)) ((> (vector-ref (send joylisten get-axis joymap-dpad) 0) 0) (when debounce (send renderer move-cursor 'south)) (set! debounce #f)) ((< (vector-ref (send joylisten get-axis joymap-dpad) 1) 0) (when debounce (send renderer move-cursor 'west)) (set! debounce #f)) ((> (vector-ref (send joylisten get-axis joymap-dpad) 1) 0) (when debounce (send renderer move-cursor 'east)) (set! debounce #f)) (else (set! debounce #t))) ; do camera control (let ((axis (send joylisten get-axis joymap-rstick))) (cond ((or (> (vector-ref axis 1) 0.1) (< (vector-ref axis 1) -0.1)) (send renderer set-zoom (+ (send renderer get-zoom) (vector-ref axis 1))))) (set-ortho-zoom (* (send renderer get-zoom) -0.1))) ; do the ring menus (let ((selected (send renderer get-selected))) (when selected (send (send selected get-ring-menu) update joylisten 0))) (send voice-menu update joylisten 0)) ; 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) (send joylisten update) (grab (send voice-menu get-root)) (camera-orient (vector 0 0 0) 0.5) (ungrab) ; 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))))) ; 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) (ortho) (colour paper-colour) (clear-colour bg-colour) (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)) ;(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))