; AL-JAZARI ; family edition for royal drinking parties ; Copyright (C) 2009 Dave Griffiths GPLv3 [See LICENCE] (require scheme/class) (require srfi/1) (require fluxus-016/time) (require fluxus-016/joylisten) (require fluxus-016/tricks) (require fluxus-016/gui) (require fluxus-016/fluxa) (define test-mode #t) (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 bpm-multiplier 2) (define sync-offset 0.01) (define swing-beat 1.0) (define sync-freq (* 20 60)) ; for syncing fluxa (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) )) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; 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))) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; the sound object (define sound% (class object% (field (sample-location "samples/") ; where samples are (current 0)) (define/public (set-current s) (set! current s)) (define/public (init) (osc-send "/setclock" "" '())) (define/public (sync) (osc-send "/setclock" "" '())) (define (make-sample-list path) (filter (lambda (filename) (and (> (string-length filename) 4) (or (string=? (substring filename (- (string-length filename) 4)) ".wav") (string=? (substring filename (- (string-length filename) 4)) ".WAV")))) (map (lambda (file) (string-append path (path->string file))) (directory-list path)))) (define samples (list (make-sample-list (string-append sample-location "808/")) (make-sample-list (string-append sample-location "tabla/")) (make-sample-list (string-append sample-location "electro_d/")))) (define/public (preload-samples) (for-each (lambda (sample-list) (for-each (lambda (sample-name) (play-now (mul 10 (sample sample-name 440))) (sleep 0.1)) sample-list)) samples) (sleep 0.1) (osc-send "/loadqueue" "" '())) (define (get-sample n l) ;(printf "~a~n" (list-ref (list-ref l current) (modulo n (length (list-ref l current))))) (list-ref (list-ref l current) (modulo n (length (list-ref l current))))) (define voices (list (list (lambda (n) (mul 1 (sample (get-sample n samples) 440))) (lambda (n) (mul (adsr 0 0.1 0 0) (moogbp (add (saw (note n)) (saw (* 0.333333 (note n)))) (adsr 0 0.1 0 0) 0.3))) (lambda (n) (mul (adsr 0 0.1 0 0) (mooglp (squ (* 0.25 (note n))) (adsr 0.1 0 0 0) 0.4))) (lambda (n) (mul (adsr 0 0.1 0.05 1) (sine (add (mul 100 (sine (* 0.3333 (note n)))) (note n)))))) (list (lambda (n) (mul 1 (sample (get-sample n samples) 440))) (lambda (n) (mul (adsr 0 0.1 0 0) (mul (saw (note n)) (sine (mul (mul 0.1 (adsr 0.4 0.3 0 0)) (note n)))))) (lambda (n) (mul (adsr 0 0.1 0.05 1) (sine (add (mul (mul 1000 (adsr 0 0.1 0.3 1)) (sine (* 0.3333 (note n)))) (note n))))) (lambda (n) (mul (adsr 0 0.1 0.05 1) (moogbp (add (saw (note n)) (saw (* 0.333333 (note n)))) (* 0.1 (random 10)) 0.48)))) (list (lambda (n) (mul 1 (sample (get-sample n samples) 440))) (lambda (n) (mul (adsr 0 0.1 0.1 1) (crush (sine (add (mul 100 (sine 0.3)) (note n))) 5 0.6))) (lambda (n) (mul (adsr 0 0.1 0 0) (moogbp (add (saw (note n)) (saw (* 0.333333 (note n)))) (* 0.1 (random 10)) 0.48))) #;(lambda (n) (mul (adsr 0 0.1 0 0) (add (sine (* 0.5 (note n))) (sine (* 5 (note n)))))) (lambda (n) (mul (adsr 0 0.1 0.05 1) (sine (add (mul 1000 (sine (* 0.3333 (note n)))) (note n)))))))) (define/public (play-note notetime note voice) (let ((patch (list-ref voices (modulo current (length voices))))) (play notetime ((list-ref patch (modulo voice (length patch))) (- note 20))))) (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 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) (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)) (translate (vector -0.5 0 0)) (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) ((class-field-mutator ringmenu% deadzone) ring-menu 0.5) (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 (dec-player-id) (set! player-id (- player-id 1)) (when (< player-id 0) (set! player-id 3)) (send joylisten set-device-num! (number->string player-id))) (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 50))) (set! inactive-time 0) (set! program-reset #f) ;(set-program renderer core (random-program)) (set-program renderer core (list 'forward 'back 'forward 'back 'forward 'back 'forward 'back)))h ; 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 '()) (sound (make-object sound%)) (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) (patch-change-time 10) (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-sound) sound) (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) (send sound preload-samples) (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))) ; added for xxxxx performance (when (< patch-change-time 0) (set! patch-change-time (* 60 5)) ; 5 minutes (printf "auto patch change :~a~n" current-voice) (change-patches current-voice) (set! current-voice (modulo (+ current-voice 1) max-voice))) (set! patch-change-time (- patch-change-time (delta))) ; 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 sound sync)) (terraform) ; check for joypad switch (when (mouse-button 1) (for-each (lambda (player) (send player dec-player-id)) player-list))) (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) (send sound set-current num)) ; 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 sound play-note (+ 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)) (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))