#lang scheme
; j a m

; todo
; * fix vehicle toonshading

; keys:
;
; world edit mode (default)
; cursors : move around world
; space : place note trigger
; t : place a road cone to indicate a road to be built
; r : build road from cones
; b : add a building here
; c : add vehicle
; v : enter vehicle edit mode on nearest vehicle
;
; vehicle edit mode
; cursors : add instruction (forward, left, right, u-turn)
; l : clear instructions
; z : slow down
; x : speed up
; v : return to world edit mode
;
; camera controls (work in both modes)
; - : zoom out
; = : zoom in
; o/p : rotate y axis
; u/i : rotate x axis

(require fluxus-017/fluxus)
(require scheme/class)
(require fluxus-017/fluxa)
(require fluxus-017/time)
(require fluxus-017/tricks)
(require fluxus-017/planetarium)

(provide (all-defined-out))

(define dome-mode #f)

(define (set-dome-mode! s)
    (set! dome-mode s))

(define (jam-set-camera-transform m) 
    (if dome-mode
        (dome-set-camera-transform m) 
        (set-camera-transform m)))
        
(define (jam-set-fov a b c) 
    (when (not dome-mode)
        (set-fov a b c)))
        
(define (jam-lock-camera s)
    (if dome-mode
        (dome-lock-camera s)
        (lock-camera s)))

(osc-source "4444")

(define (choose l)
    (list-ref l (random (length l))))

(define (quant-up s t d)
    (cond 
        ((> t s) t)
        (else (quant-up s (+ t d) d))))

(define (assoc-remove k l)
  (cond
    ((null? l) '())
    ((equal? (car (car l)) k)
     (assoc-remove k (cdr l)))
    (else
     (cons (car l) (assoc-remove k (cdr l))))))
     
(define (list-contains? k l)
  (cond 
    ((null? l) #f)
    ((equal? (car l) k) #t)
    (else (list-contains? k (cdr l)))))

(define (list-remove k l)
  (cond
    ((null? l) '())
    ((equal? (car l) k)
     (list-remove k (cdr l)))
    (else
     (cons (car l) (list-remove k (cdr l))))))

;------------------------------------------------------------

(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/"))
                (make-sample-list (string-append sample-location "tabla/"))))
        
        (define/public (preload-samples)
            (for-each 
                (lambda (sample-list)
                    (for-each
                        (lambda (sample-name)
                            (play-now (mul 0 (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 0.2 (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 0.2 (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 0.2 (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))))))
           (list
                (lambda (n) (mul 0.2 (sample (get-sample n samples) 440)))
                (lambda (n) (mul (adsr 0 0.1 0.1 1) 
                    (mooglp (add (saw (note n)) (saw (note (+ n 5)))) 0.2 0.6)))
                (lambda (n) 
                (mooglp (mul (adsr 0.2 0.1 0.5 2) (add (squ (note n)) (saw (add (mul (sine 2) 4) (note n))))) 
 (mul 0.5 (adsr 0.4 0.1 0.5 0.5)) 0.40)
                    )
                (lambda (n) 
                (mooghp (mul (adsr 0.3 0.1 0.2 1) (add (squ (add (mul (sine 2.5) 2) (* (note n) 0.5))) 
 (add (squ (note n)) (squ (add (mul (sine 2) 4) (note n)))))) 0.8 0.2)
                    )
                (lambda (n)
            (crush (mul (adsr 0.4 0.1 0.2 1) (add (sine (note n)) (sine (add (mul (sine 4) 4) (note n))))) 3 6)
                    ))))

;                    (mul (adsr 0.5 0.1 0.1 1) 
;                    (mooglp (mul (add (saw (add (mul (sine (adsr 0.2 0.2 0 0)) 50) (note n))) 
;                            (saw (note (+ n 2)))) 0.2) 0.9 0.1)))
;                (lambda (n) (mul (adsr 0 0.1 0.1 1) 
;                    (mooglp (mul (add (saw (note n)) (add (saw (note (+ n 10))) (saw (note (+ n 12))))) 0.2) 
;                        (add 1 (sine (mul 20 (adsr 0.2 0.2 0 0)))) 0.4)))
;                (lambda (n) (mul (adsr 0 0.1 0.2 3) 
;                    (mooglp (mul (add (saw (note n)) (add (squ (note (+ n 10))) (squ (note (+ n 12))))) 0.2) 
;                        (add 1 (sine (mul 20 (adsr 0.6 0.2 0 0)))) 0.3))))))
        
        (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))))
        
        (super-new)
        (init)))


;------------------------------------------------------------

(define lights%
    (class object%
        (field
            (state 'green)
            (green-time (+ 1 (* 3 (rndf))))
            (red-time (+ 1 (* 3 (rndf))))
            (current-t 0))
        
        (define/public (get-state)
            state)  
        
        (define/public (update t d)
            (cond
                ((and (eq? state 'red) (> current-t (+ green-time red-time)) )
                    (set! current-t 0) 
                    (set! state 'green))
                ((and (eq? state 'green) (> current-t green-time))
                    (set! state 'red)))        
            (set! current-t (+ current-t d)))
        
        (super-new)))

;------------------------------------------------------------

(define tile%
    (class object%
        (init-field 
            (north #f)
            (east #f)
            (south #f)
            (west #f)
            (trigger #f)
            (building #f))
        
        (field 
            (north-lights #f) 
            (east-lights #f) 
            (south-lights #f) 
            (west-lights #f))
        
        (define/public (get-north) north)
        (define/public (get-east) east)
        (define/public (get-south) south)
        (define/public (get-west) west)
        (define/public (set-north! s) (set! north s))
        (define/public (set-east! s) (set! east s))
        (define/public (set-south! s) (set! south s))
        (define/public (set-west! s) (set! west s))
        (define/public (set-all! s) 
          (set! north s) (set! east s) 
          (set! south s) (set! west s))
        (define/public (set-building s) (set! building s))
         (define/public (get-building) building)
       
        (define/public (get-north-lights) north-lights)
        (define/public (get-east-lights) east-lights)
        (define/public (get-south-lights) south-lights)
        (define/public (get-west-lights) west-lights)
        (define/public (set-north-lights! s) (set! north-lights s))
        (define/public (set-east-lights! s) (set! east-lights s))
        (define/public (set-south-lights! s) (set! south-lights s))
        (define/public (set-west-lights! s) (set! west-lights s))
        
        (define/public (set-trigger s)
          (set! trigger s))

        (define/public (get-trigger)
          trigger)

        (define/public (empty?)
            (and (not north) (not south) (not east) (not west)))
        
        (define/public (tile-eq? other)
            (and 
                (eq? north (send other get-north))
                (eq? east (send other get-east))
                (eq? south (send other get-south))
                (eq? west (send other get-west))))
        
        (define/public (update t d)
            (when north-lights (send north-lights update t d))
            (when east-lights (send east-lights update t d))
            (when south-lights (send south-lights update t d))
            (when west-lights (send west-lights update t d)))
        
        (super-new)))

;------------------------------------------------------------

(define veh%
    (class object%
        (init-field
            (tile-x 0)
            (tile-y 0))
        (field 
            (dir (choose '(north east south west)))
            (last-x 0)
            (last-y 0)
            (max-instructions 4)
            (instructions '())
            (stuck #f))
        
        (define/public (get-dir)
            dir)
            
        (define/public (stuck?)
           stuck)
           
        (define/public (no-instructions?)
          (null? instructions))

        (define/public (clear-instructions)
          (set! instructions '()))
        
        (define/public (push-instruction ins)
            (when (< (length instructions) max-instructions)
                (set! instructions (append instructions (list ins)))))
        
        (define/public (pop-instruction)
            (cond 
                ((null? instructions) #f)
                (else
                    (let ((ins (car instructions)))
                        (set! instructions (cdr instructions))
                        (set! instructions (append instructions (list ins)))
                        ins))))
        
        (define/public (get-max-instructions)
            max-instructions)
        
        (define/public (dir-from-instruction ins)
            (cond
                ((eq? ins 'forward) dir)
                ((eq? ins 'left) 
                    (cond 
                        ((eq? dir 'north) 'west)
                        ((eq? dir 'east) 'north)
                        ((eq? dir 'south) 'east)
                        ((eq? dir 'west) 'south)))
                ((eq? ins 'right) 
                    (cond 
                        ((eq? dir 'north) 'east)
                        ((eq? dir 'east) 'south)
                        ((eq? dir 'south) 'west)
                        ((eq? dir 'west) 'north)))
                ((eq? ins 'uie) 
                    (cond 
                        ((eq? dir 'north) 'south)
                        ((eq? dir 'east) 'west)
                        ((eq? dir 'south) 'north)
                        ((eq? dir 'west) 'east)))))
        
        (define/public (run-satnav exits)
            (let ((ins (pop-instruction)))                
                (cond (ins 
                        (if (eq? ins 'uie)
                            (dir-from-instruction ins) ; we can always turn around
                            (let ((desired-dir (dir-from-instruction ins)))
                                (if (list-contains? desired-dir exits)
                                    desired-dir
                                    (choose exits))))) ; can't go in this direction!
                    (else #f)))) ; no instructions
        
        (define/public (get-tile city)
            (send city get-tile tile-x tile-y))
        
        (define/public (get-last-tile city)
            (send city get-tile last-x last-y))
        
        (define/public (get-tile-x)
            tile-x)
        
        (define/public (get-tile-y)
            tile-y)
        
        (define/public (get-last-x)
            last-x)
        
        (define/public (get-last-y)
            last-y)
        
        (define/public (update city)
            (set! last-x tile-x)
            (set! last-y tile-y)
            
            ; move to next tile
            (let ((tile (get-tile city))
                    (exits '()))
                (when (and (not (eq? dir 'south)) (send tile get-north)) 
                    (set! exits (cons 'north exits))) 
                (when (and (not (eq? dir 'west)) (send tile get-east))
                    (set! exits (cons 'east exits))) 
                (when (and (not (eq? dir 'north)) (send tile get-south))
                    (set! exits (cons 'south exits))) 
                (when (and (not (eq? dir 'east)) (send tile get-west))
                    (set! exits (cons 'west exits)))
                
                (set! stuck #f)
                
                (cond 
                    ((null? exits)
                        (set! tile-x (random (send city get-w)))
                        (set! tile-y (random (send city get-h))))
                    (else
                        (let ((d (run-satnav exits)))
                            (cond
                                ((eq? d #f) (set! stuck #t))
                                ((eq? d 'north)
                                    (set! dir 'north)
                                    (set! tile-y (- tile-y 1)))
                                ((eq? d 'east) 
                                    (set! dir 'east)
                                    (set! tile-x (+ tile-x 1)))
                                ((eq? d 'south)
                                    (set! dir 'south)
                                    (set! tile-y (+ tile-y 1)))
                                ((eq? d 'west) 
                                    (set! dir 'west)
                                    (set! tile-x (- tile-x 1)))))))))
        
        (super-new)))

;------------------------------------------------------------

(define city% 
    (class object%
        (init-field
            (w 0)
            (h 0))
        
        (field
            (tiles '()) 
            (vehicles '())
            (lights-probability 3))
        
        (define/public (get-w)
            w)
        
        (define/public (get-h)
            h)
        
        (define/public (get-vehicles)
            vehicles)
        
        (define/public (set-tiles! s)
            (set! tiles s))
            
        (define/public (add-veh pos)
            (let ((veh (make-object veh% (vx pos) (vy pos))))
            (set! vehicles (cons veh vehicles))
            veh))
        
        (define/public (build vehicle-count)
            (set! tiles (build-list (* w h) 
                    (lambda (_) (make-object tile%
                            (zero? (random 2))                                        
                            (zero? (random 2))                                                          
                            (zero? (random 2))   
                            (zero? (random 2))))))
            (set! vehicles (build-list vehicle-count
                    (lambda (_) (make-object veh% (random w) (random h))))))
        
        (define/public (get-tile x y)
            (cond ; check bounds and return an empty tile if out
                ((or (< x 0) (>= x w)
                        (< y 0) (>= y h))
                    (make-object tile% #f #f #f #f))
                (else
                    (list-ref tiles (+ x (* y w))))))
        
        (define/public (print)
            (for ((y (in-range 0 h)))
                (for ((x (in-range 0 w)))
                    (printf "~a" (if (send (get-tile x y) get-north) 1 0))
                    (printf "~a" (if (send (get-tile x y) get-east) 1 0))
                    (printf "~a" (if (send (get-tile x y) get-south) 1 0))
                    (printf "~a " (if (send (get-tile x y) get-west) 1 0)))
                (printf "~n")))
        
        (define/public (filter-tiles!)
            (set! tiles
                (map 
                    (lambda (tile)
                        (cond
                            ((send tile tile-eq? (make-object tile% #t #f #f #f)) (make-object tile% #f #f #f #f (send tile get-trigger) (send tile get-building)))
                            ((send tile tile-eq? (make-object tile% #f #t #f #f)) (make-object tile% #f #f #f #f (send tile get-trigger) (send tile get-building)))
                            ((send tile tile-eq? (make-object tile% #f #f #t #f)) (make-object tile% #f #f #f #f (send tile get-trigger) (send tile get-building)))
                            ((send tile tile-eq? (make-object tile% #f #f #f #t)) (make-object tile% #f #f #f #f (send tile get-trigger) (send tile get-building)))
                            (else tile)))
                    tiles)))
        
        ; cut neighbouring tiles together if they need to
        ; returns true if it didn't need to change any - the city is finished
        (define/public (dissolve-tiles!)
            (let ((clean #t))
                (set! tiles
                    (map
                        (lambda (n)
                            (let* ((x (modulo n w))
                                    (y (quotient n w))
                                    (tile (get-tile x y))
                                    (north-tile (get-tile x (- y 1)))
                                    (east-tile (get-tile (+ x 1) y))
                                    (south-tile (get-tile x (+ y 1)))
                                    (west-tile (get-tile (- x 1) y)))                        
                                
                                (if (and (send tile tile-eq? (make-object tile% #t #t #t #t))
                                        (zero? 1 #;(random 30)))
                                    (make-object tile% #f #f #f #f)    
                                    (make-object tile%
                                        (cond ((and (send tile get-north) (not (send north-tile get-south)))
                                                (set! clean #f) #f)
                                            (else (send tile get-north)))
                                        (cond ((and (send tile get-east) (not (send east-tile get-west)))
                                                (set! clean #f) #f)
                                            (else (send tile get-east)))
                                        (cond ((and (send tile get-south) (not (send south-tile get-north)))
                                                (set! clean #f) #f)
                                            (else (send tile get-south)))
                                        (cond ((and (send tile get-west) (not (send west-tile get-east)))
                                                (set! clean #f) #f)
                                            (else (send tile get-west)))
                                        (send tile get-trigger)
                                        (send tile get-building)))))
                        (build-list (* w h) (lambda (n) n))))
                clean))
        
        ; connect neighbouring tiles together if they need to
        ; returns true if it didn't need to change any - the city is finished
        (define/public (join-tiles!)
            (let ((clean #t))
                (set! tiles
                    (map
                        (lambda (n)
                            (let* ((x (modulo n w))
                                    (y (quotient n w))
                                    (tile (get-tile x y))
                                    (north-tile (get-tile x (- y 1)))
                                    (east-tile (get-tile (+ x 1) y))
                                    (south-tile (get-tile x (+ y 1)))
                                    (west-tile (get-tile (- x 1) y)))
                                
                                (make-object tile%
                                    (cond ((and (not (send tile get-north)) (send north-tile get-south))
                                            (set! clean #f) #t)
                                        (else (send tile get-north)))
                                    (cond ((and (not (send tile get-east)) (send east-tile get-west))
                                            (set! clean #f) #t)
                                        (else (send tile get-east)))
                                    (cond ((and (not (send tile get-south)) (send south-tile get-north))
                                            (set! clean #f) #t)
                                        (else (send tile get-south)))
                                    (cond ((and (not (send tile get-west)) (send west-tile get-east))
                                            (set! clean #f) #t)
                                        (else (send tile get-west)))
                                    (send tile get-trigger)
                                    (send tile get-building))))
                        
                        (build-list (* w h) (lambda (n) n))))
                clean))
        
        (define/public (populate-lights!)
            (for-each 
                (lambda (tile)
                    (cond
                        ((and (send tile get-north) (zero? (random lights-probability)))
                            (send tile set-north-lights! (make-object lights%)))
                        ((and (send tile get-east) (zero? (random lights-probability)))
                            (send tile set-east-lights! (make-object lights%)))
                        ((and (send tile get-south) (zero? (random lights-probability)))
                            (send tile set-south-lights! (make-object lights%)))
                        ((and (send tile get-west) (zero? (random lights-probability)))
                            (send tile set-west-lights! (make-object lights%)))))
                tiles))
        
        
        (define/public (generate-step!)
            (filter-tiles!)
            (when (not (dissolve-tiles!))
                (generate-step!)))
        
        (define/public (generate!)
            (join-tiles!)
            (generate-step!)
            #;(populate-lights!))
        
        (define/public (make-start-city!)
            (set! tiles (build-list (* w h) 
                    (lambda (_) (make-object tile% #f #f #f #f))))
            
            (let ((x (quotient w 2))
                  (y (quotient h 2)))
              (send (get-tile x y) set-south! #t)
              (send (get-tile x y) set-east! #t)
              (send (get-tile x (+ y 1)) set-north! #t)
              (send (get-tile x (+ y 1)) set-east! #t)
              (send (get-tile (+ x 1) y) set-south! #t)
              (send (get-tile (+ x 1) y) set-west! #t)
              (send (get-tile (+ x 1) (+ y 1)) set-north! #t)
              (send (get-tile (+ x 1) (+ y 1)) set-west! #t)))
        
        (define/public (build-road! positions)
           (for-each 
              (lambda (pos)
                  (send (get-tile (vx pos) (vy pos)) set-all! #t))
              positions)
             (generate!))
        
        (define/public (update t d)
            (for-each
                (lambda (tile)
                    (send tile update t d))
                tiles))
        
        (super-new)))

;------------------------------------------------------------

(define vlights% 
    (class object%
        (init-field 
            (lights #f))
        (field
            (root (with-state
                    (scale (vector 0.02 0.02 0.02))             
                    (load-primitive "meshes/lights.obj")))
            (red (with-state
                    (identity)
                    (parent root)
                    (colour (vector 0 0 0))
                    (translate (vector 0 14 1))
                    (build-sphere 5 5)))
            (amber (with-state
                    (identity)
                    (parent root)
                    (colour (vector 0 0 0))
                    (translate (vector 0 12 1))
                    (build-sphere 5 5)))
            (green (with-state
                    (identity)
                    (parent root)
                    (colour (vector 0 0 0))
                    (translate (vector 0 10 1))
                    (build-sphere 5 5))))
        
        (define/public (update t d)
            (let ((state (send lights get-state)))
                (cond ((eq? state 'red)  
                        (with-primitive red (colour (vector 1 0 0))) 
                        (with-primitive amber (colour (vector 0 0 0))) 
                        (with-primitive green (colour (vector 0 0 0))))
                    (else
                        (with-primitive red (colour (vector 0 0 0))) 
                        (with-primitive amber (colour (vector 0 0 0))) 
                        (with-primitive green (colour (vector 0 1 0)))))))
        
        (super-new)))

;------------------------------------------------------------

(define trigger% 
    (class object% 
        (init-field
            par
            pos
            type
            beat)
        (field
          (col (cond 
              ((eq? type 0) (vector 1 0 0))
              ((eq? type 1) (vector 0 1 0))
              ((eq? type 2) (vector 0 0 1))
              ((eq? type 3) (vector 1 1 0))))
          (root (let ((p (with-state
                 (parent par)
                 (hint-frustum-cull)
                 (translate (vector (vx pos) (+ 0.005 (* (rndf) 0.001)) (vy pos)))
                 (rotate (vector -90 0 0))
                 (colour col)
                 (scale 0.5)
                 (opacity 0.2)
                 ;(hint-depth-sort)
                 (backfacecull 0)
                 (build-disk 10))))
                 (with-primitive p (recalc-bb)) p))
                 
          (cues (build-list 4 (lambda (_) 
             (vector -100 (let ((p (with-state
                   (parent root)
                   (translate (vector 0 0 -10))                
                 (colour col)
                 (hint-unlit)                                  
                  (hint-depth-sort)
                 ;(hint-frustum-cull)
                 (backfacecull 0)
                (build-disk 10))))
                    (with-primitive p (hide 1)) p)))))
          (next-cue 0))
        
        (define/public (get-type)
            type)
        
        (define/public (start-cue t)
          (vector-set! (list-ref cues next-cue) 0 (+ t 0));beat))
          (set! next-cue (+ next-cue 1))
          (when (>= next-cue (length cues))
            (set! next-cue 0)))
        
        (define/public (destroy-me)
          (destroy root))
        
        (define/public (update t d)
          (for-each 
            (lambda (c)
              (let* ((cue-t (vector-ref c 0))
                    (cue (vector-ref c 1))
                    (ct (- t cue-t)))
                    
                  (when (> t (+ cue-t beat))
                    (with-primitive cue
                      (identity)
                      (translate (vector 0 0 0))
                      (hide 1))
                     (vector-set! c 0 -100))

                  (when (> cue-t -100)
                    (when (> cue-t 0)
                    (with-primitive cue
                      (when (> 0 (/ ct beat)) (hide 0))
                      (identity)
                      (opacity (- 1 (/ ct beat)))
                      (colour (vmix (vector 1 1 1) col (- 1 (/ ct beat))))
                      (translate (vector 0 0 (* (/ ct beat) 2))))))))
            
            cues))
        
        (super-new)))
          
;------------------------------------------------------------

(define vcity% 
    (class object% 
        (init-field
            (city #f))
        
        (field
            (root #f)
            (tile-root #f)
            (tiles '())
            (vehicles '())
            (lights '())
            (triggers '()) ; assoc list pos -> prim
            (sync-tick-multiplier 0.25)
            (sync-offset 0.1)
            (next-clock (time-now))
            (tick 1)
            (clock-rate 1)
            (cursor #f)
            (cursor-pos (vector (quotient (send city get-w) 2) (quotient (send city get-h) 2)))
            (tiles-to-build '())
            (sound (make-object sound%))
            (next-veh-id 0)
            (sync-fluxa 0)
            (cone #f))
        
        (define/public (get-city)
            city)
            
        (define/public (get-sound)
            sound)
            
        (define/public (get-cursor)
           cursor)

        (define/public (move-cursor dir)
          (when (and (eq? dir 'north) (> (vy cursor-pos) 0))
            (set! cursor-pos (vector (vx cursor-pos) (- (vy cursor-pos) 1))))
          (when (and (eq? dir 'south) (< (vy cursor-pos) (- (send city get-h) 1)))
            (set! cursor-pos (vector (vx cursor-pos) (+ (vy cursor-pos) 1))))
          (when (and (eq? dir 'east) (> (vx cursor-pos) 0))
            (set! cursor-pos (vector (- (vx cursor-pos) 1) (vy cursor-pos))))
          (when (and (eq? dir 'west) (< (vx cursor-pos) (- (send city get-w) 1)))
            (set! cursor-pos (vector (+ (vx cursor-pos) 1) (vy cursor-pos)))))

        (define/public (add-tile-to-build)
            (if (list-contains? cursor-pos tiles-to-build)
               (set! tiles-to-build (list-remove cursor-pos tiles-to-build))
               (set! tiles-to-build (cons cursor-pos tiles-to-build))))
            
        (define/public (build-road)
            (send city build-road! tiles-to-build)
            (set! tiles-to-build '())
            (retex-tiles))
        
        (define/public (add-building)
          (let ((tile (send city get-tile (vx cursor-pos) (vy cursor-pos))))
            (when (send tile empty?)
                (with-state
                    (parent (get-tile (vx cursor-pos) (vy cursor-pos)))
                    ;(ambient (vector 0.5 0.5 0.5))
                    (let ((num (number->string (random 2))))
                        (hint-cast-shadow)
                        (rotate (vector 90 (* 90 (random 4)) 0))
                        (scale 0.8)
                        (hint-normalise)
                        ;                                    (hint-unlit)
                        ;(texture (load-texture (string-append "textures/building" num ".png")))
                        ;(load-primitive (string-append "meshes/building" num ".obj"))
                        (scale (vector 1 (+ 0.5 (* (rndf) 2)) 1))
                        (build-cube)
                        #;(cond (#t #;(zero? (random 2))                            
                            (backfacecull 0)
                            (texture (load-texture "textures/skip.png"))
                            (load-primitive "meshes/skip.obj"))
                            (else
                            (texture (load-texture "textures/house.png"))
                            (load-primitive "meshes/house.obj")))
                        
                        )))))
        
        (define/public (add-veh)
           (let* ((pos (with-primitive (get-tile (vx cursor-pos) (vy cursor-pos))
                           (vtransform (vector 0 0 0) (get-transform))))
                 (vveh (make-object vveh% (send city add-veh cursor-pos) 
                   next-veh-id pos (vadd pos (vector 1 0 0)))))
            (with-state
                (parent root)
             (send vveh build))
            (set! vehicles (cons vveh vehicles)))
        (set! next-veh-id (+ next-veh-id 1)))
        
        (define/public (find-quarter pos)
            (let ((x (/ (send city get-w) 2))
                  (y (/ (send city get-h) 2)))
            (cond
              ((and (<= (vx pos) x) (<= (vy pos) y)) 0)
              ((and (> (vx pos) x) (<= (vy pos) y)) 1)
              ((and (<= (vx pos) x) (> (vy pos) y)) 2)
              ((and (> (vx pos) x) (> (vy pos) y)) 3))))
        
        (define/public (place-trigger)
          (let ((tile (send city get-tile (vx cursor-pos) (vy cursor-pos))))
            (cond ((not (send tile get-trigger))
                (send tile set-trigger #t)
              (set! triggers (cons (list cursor-pos 
                  (make-object trigger% root cursor-pos 
                      (find-quarter cursor-pos) 
                    tick)) triggers)))
            (else
              (send tile set-trigger #f)
              (let ((t (assoc cursor-pos triggers)))
                (when t
                  (send (cadr t) destroy-me)
                  (set! triggers (assoc-remove cursor-pos triggers))))))))
          
        (define/public (trigger-cue pos t)
          (let ((trigger (assoc pos triggers)))
            (when trigger
              (send (cadr trigger) start-cue t))))
                
        (define/public (get-closest)
          (let ((pos (with-primitive cursor (vtransform (vector 0 0 0) (get-transform)))))
            (cadr (foldl
              (lambda (vveh r)
                (let ((d (vdist pos (with-primitive (send vveh get-root)
                     (vtransform (vector 0 0 0) (get-transform))))))
                  (if (< d (car r))
                     (list d vveh)
                     r)))
              (list 9999 #f)
              vehicles))))
        
        (define/public (set-sync-offset! s)
            (set! sync-offset s))
        
        (define/public (get-vehicles)
            vehicles)
        
        (define (tile->texture-name tile)
            (string-append 
                (if (send tile get-north) "1" "0")
                (if (send tile get-east) "1" "0")
                (if (send tile get-south) "1" "0")
                (if (send tile get-west) "1" "0")
                ".png"))
        
        (define/public (get-next-clock)
           next-clock)
           
        (define/public (get-tick)
           tick)
        
        (define/public (retex-tiles)
          (let ((c 0))
          (for-each
            (lambda (tile)
               (let* ((tile (send city get-tile (modulo c (send city get-w))
                                                (quotient c (send city get-h))))
                      (texture-name (tile->texture-name tile))
                      (vtile (get-tile (modulo c (send city get-w))
                                       (quotient c (send city get-h))))
                     )
                (with-primitive vtile
                  (texture (load-texture (string-append "textures/" texture-name)))))            
               (set! c (+ c 1)))
            tiles)))
        
        (define/public (build-tiles)
          (when tile-root (destroy tile-root))
          (set! tile-root (with-state (parent root) (build-locator)))
          (with-state
                (parent tile-root)
                (for ((y (in-range (send city get-h))))
                    (with-state
                        (for ((x (in-range (send city get-w))))
                            (let* ((tile (send city get-tile x y))
                                    (texture-name (tile->texture-name tile)))
                                
                                (with-state
                                    (when (send tile get-north-lights)
                                        (translate (vector -0.3 0 -0.3))
                                        (set! lights (cons (make-object vlights% (send tile get-north-lights)) lights)))
                                    (when (send tile get-east-lights)
                                        (translate (vector 0.3 0 -0.3))
                                        (rotate (vector 0 270 0))
                                        (set! lights (cons (make-object vlights% (send tile get-east-lights)) lights)))
                                    (when (send tile get-south-lights)
                                        (translate (vector 0.3 0 0.3))
                                        (rotate (vector 0 180 0))
                                        (set! lights (cons (make-object vlights% (send tile get-south-lights)) lights)))
                                    (when (send tile get-west-lights)
                                        (translate (vector -0.3 0 0.3))
                                        (rotate (vector 0 90 0))
                                        (set! lights (cons (make-object vlights% (send tile get-west-lights)) lights))))
                                
                                
                                (with-state
                                    (hint-frustum-cull)
                                    ;(hint-wire)
                                    ;(ambient (vector 0.5 0.5 0.5))
                                    (texture-params 0 '(min nearest))        
                                    ;(shader "shaders/tile.vert.glsl" "shaders/tile.frag.glsl")
                                    ;(multitexture 1 (load-texture "textures/cobbles.png"))
                                    ;(multitexture 2 (load-texture "textures/cobbles-norm.png"))
                                    ;(multitexture 3 (load-texture "textures/paving.png"))
                                    ;(multitexture 4 (load-texture "textures/paving-norm.png"))
                                    (texture (load-texture 
                                            (string-append "textures/" texture-name)))
                                    (rotate (vector -90 0 0))
                                    (set! tiles (cons (build-plane) tiles))
                                    #;(with-primitive (car tiles)
                                      (shader-set! (list "BaseMap" 1 
                                          "NormalMap" 2 
                                          "BaseMap2" 3
                                          "NormalMap2" 4 
                                          "RoadMap" 0
                                          "Roughness" 0.3 
                                          "Bumpyness" 3.0)))))
                            
                            (translate (vector 1 0 0))))
                    (translate (vector 0 0 1))))
            (set! tiles (reverse tiles)))
            
        (define/public (build r)
            (send sound preload-samples)
            
            (set! cone (let ((p (with-state 
                    (scale (vector 0.2 0.2 0.2)) 
                    (load-primitive "meshes/cone.obj"))))
                (with-primitive p (apply-transform) (hide 1)) p))
            
            (set! root r)
            (build-tiles)            
            (with-state
                (parent root)
                    (set! vehicles
                        (map 
                            (lambda (veh)
                                (set! next-veh-id (+ next-veh-id 1))                    
                                (let ((v (make-object vveh% veh next-veh-id)))
                                    (send v build)
                                    v))
                            (send city get-vehicles))))
                            
            (set! cursor (let ((p (with-state
              (parent root)
              (rotate (vector -90 0 0))
              (translate (vector 0 0 0.01))
              (scale 0.5)
              (colour (vector 1 0.5 0.5))
              (hint-depth-sort)
              (texture (load-texture "textures/cursor.png"))
              (build-plane))))
              (with-primitive p (apply-transform)) p)))
        
        (define/public (get-tile x y)
            (list-ref tiles (+ x (* y (send city get-w)))))

        (define/public (sync-now)
            (for-each
                (lambda (vveh)
                    (send vveh sync-now))
                vehicles))
      
      ; figures out the offset to the nearest tick    
      (define (calc-offset timenow synctime tick)
        (let ((p (/ (- synctime timenow) tick)))
          (let ((f (- p (floor p))))
            (if (< f 0.5)
                (* f tick)
                (- (* (- 1 f) tick))))))
      
      (define (check-sync)
        (cond ((osc-msg "/sync")
               (sync-now)
               (set! tick (* (/ 1 (osc 3)) 60))
               (set! clock-rate (* sync-tick-multiplier tick))
               (let* ((sync-time (+ sync-offset (timestamp->time (vector (osc 0) (osc 1)))))
                      (offset (calc-offset next-clock sync-time tick)))                     
                 (printf "jam time offset: ~a~n" offset)
                 (set! next-clock (+ next-clock offset))))))
        
        (define/public (update t d) 
            (when (> t sync-fluxa) 
                (send sound sync)
                (set! sync-fluxa (+ t 10)))
            
               
            (when (> t next-clock)
               (set! next-clock (+ next-clock clock-rate)))
            
            (send city update t d)
            (for-each
                (lambda (vveh)
                    (send vveh update t d this))
                vehicles)
            (for-each
                (lambda (lights)
                    (send lights update t d))
                lights)

            (for-each
              (lambda (trigger)
                (send (cadr trigger) update t d))
              triggers)
                
            (with-primitive cursor
               (identity)
               (translate (vector (vx cursor-pos) 0 (vy cursor-pos))))

            (for-each 
               (lambda (pos)
                  (with-state
                     (concat (with-primitive root (get-global-transform)))
                     (translate (vector (vx pos) 0 (vy pos)))
                     (scale 0.5)
                     (texture (load-texture "textures/cone.png"))
                     (draw-instance cone)))
               tiles-to-build)
               
            (check-sync))
                    
        
        (super-new)))

;------------------------------------------------------------

(define-struct satins (root ins (pos #:mutable) (desired-pos #:mutable)))

(define satnav%
    (class object%
        (init-field
            (max-instructions 4)
            (col (vector 1 1 1)))
        (field
            (root (let ((p (with-state
                                (colour col)
                                (hint-wire)
                                (wire-colour (vector 0 0 0))
                                (line-width 3)
                                (translate (vector 0.9 0 0))
                                (scale (vector 0.9 0.2 1))
                                (build-plane))))
                    (with-primitive p 
                        (apply-transform) 
                        (translate (vector -0.2 0 0))
                        (scale 1)
                        (hide 1))
                    p))
            (instructions '())
            (fade-in-t 0)
            (fade-out-t 0))
        
        (define (index->pos i)
            (vector (+ 0.65 (* i 0.2)) 0 0))
        
        (define/public (empty?)
            (null? instructions))
        
        (define/public (push-instruction ins)
            (when (< (length instructions) 4)
                (with-primitive root (hide 0))
                (set! instructions (append instructions 
                        (list (make-satins
                                (let ((p (with-state
                                                  (colour col)
                                                (cond
                                                    ((eq? ins 'forward) (texture (load-texture "textures/forward.png")))
                                                    ((eq? ins 'left) (texture (load-texture "textures/left.png")))
                                                    ((eq? ins 'right) (texture (load-texture "textures/right.png")))
                                                    ((eq? ins 'uie) (texture (load-texture "textures/uie.png"))))
                                                (rotate (vector 0 0 -90))
                                                (parent root)
                                                (let ((l (build-locator)))
                                                    (parent l)
                                                    (with-state 
                                                        (translate (vector 0 0 0.001))
                                                        (scale 0.15)
                                                        (build-plane))
                                                    (with-state 
                                                        (translate (vector 0 0 -0.001))
                                                        (scale 0.15)
                                                        (build-plane))
                                                    l))))
                                    (with-primitive p (apply-transform)) p)
                                ins
                                (vector 1.5 0 0)
                                (index->pos (length instructions))
                                ))))))

        (define/public (clear-instructions)
            (for-each
               (lambda (ins)
                   (destroy (satins-root ins)))
               instructions)
            (set! instructions '()))
         
        (define/public (pop-instruction)
            (when (not (null? instructions))
                (let ((ins (car instructions)))
                    (destroy (satins-root (car instructions)))
                    (set! instructions (cdr instructions))
                    (when (null? instructions) (with-primitive root (hide 1)))
                    (let ((c 0))
                        (for-each
                            (lambda (ins)
                                (set-satins-desired-pos! ins (index->pos c))
                                (set! c (+ c 1)))
                            instructions))
                    (push-instruction (satins-ins ins)))))
        
        (define/public (update t d)
            (for-each 
                (lambda (ins)
                    (when (> (vx (satins-pos ins)) (vx (satins-desired-pos ins)))
                        (set-satins-pos! ins (vadd (satins-pos ins) (vector -0.05 0 0))))
                    (with-primitive (satins-root ins)
                        (identity)
                        (translate (satins-pos ins))))
                instructions))
        
        
        
        (super-new)))

;------------------------------------------------------------

(define vveh%
    (class object%
        (init-field
            (veh #f)
            (id -1)
            (pos (vmul (srndvec) 10))
            (dest-pos (vmul (srndvec) 10)))

        (field
            (dir (vector 0 0 0))
            (dest-dir (vector 0 0 0))
            (vt 0)
            (ct 0)
            (tick 0)
            (tick-mult 1)
            (root #f)
            (detector #f)
            (reverse-t 0)
            (collided-last-update #f)
            (collide-count 0)
            (satnav #f)
            (smack #f)
            (next-smack 0)
            (state 'forward)
            (pollution #f)
            (speed-list (list 0.125 0.25 0.5 1 2 4))
            (speed 2)
            (col (vector 1 1 1)))
        
        (define/public (get-root)
            root)
        
        (define/public (speed-up)
            (when (< speed (- (length speed-list) 1)) (set! speed (+ speed 1))))

        (define/public (slow-down)
            (when (> speed 0) (set! speed (- speed 1))))
        
        (define/public (build)
            (set! col (hsv->rgb (vector (rndf) 0.5 1)))
                            
            (let ((m (mmul (mtranslate (vector 0.075 0 0)) 
                           (mscale (vector 0.02 0.02 0.02))
                           (mrotate (vector 180 180 90)))))                                      
            
            (set! root (let ((p (with-state
                    (colour col)
                    ;(hint-unlit)
                    ;(texture (load-texture "textures/car.png"))
                    (concat m)
                    (load-primitive "meshes/car.obj"))))
                    (with-primitive p (apply-transform)) p))
            
            
            (with-primitive root
                (apply-transform)
                (recalc-normals 0))
                
           (cheap-toon root 0.01 (vector 0 0 0)))
                            
            (set! detector (with-state             
                    ;(hint-origin)
                    (translate (vector 0 0 0.15))
                    (build-locator)))
            
            (set! smack (with-state
                    (hint-unlit)
                    (colour 1)
                    (hint-depth-sort)
                    (texture (load-texture "textures/smack.png"))
                    (build-particles 10)))
            
            (with-primitive smack
                (pdata-map!
                    (lambda (p)
                        (vector -1000 0 0))
                    "p")
                (pdata-map!
                    (lambda (c)
                        (vector 1 1 1))
                    "c"))
                        
            (with-primitive detector
                (parent root)
                (locator-bounding-radius 0.05))
            
            (with-state
                (parent root)
                (set! satnav (make-object satnav% (send veh get-max-instructions) col)))
                
            (set! pollution (with-state
                ; move above the ground a tiny bit for alpha sort
                (translate (vector 0 0.01 0)) 
                (hint-unlit)
                (opacity 0.5)
                (hint-depth-sort)
                ;(blend-mode 'src-alpha 'one)
                (texture (load-texture "textures/pollution.png"))                
                (build-particles 20)))
                
            (with-primitive pollution
                (pdata-map!
                    (lambda (c)
                        (vector 0.5 0.5 0.5))
                    "c")))
        
        (define/public (new-smack pos)
            (with-primitive smack
                (pdata-set! "p" next-smack (vadd pos (vector 0 0.1 0)))
                (pdata-set! "s" next-smack (vector 0.02 0.02 0.02))
                (set! next-smack (+ next-smack 1))))
        
        (define/public (update-smacks t d)
            (with-primitive smack
                (pdata-op "*" "s" 1.2)
                (pdata-index-map!
                    (lambda (i p)
                        (cond ((> (vx (pdata-ref "s" i)) 0.5)
                                (pdata-set! "s" i (vector 0.1 0.1 0.1))
                                (vector -10000 0 0))
                            (else p)))
                    "p")))
        
        (define/public (update-pollution t d)
          (with-primitive pollution
            (let ((r (random (pdata-size))))
            (pdata-set! "p" r (with-primitive root (vtransform (vector 0 0.05 -0.1) (get-transform))))
            (pdata-set! "s" r (vector 0.03 0.03 0.03))
            (pdata-set! "c" r (vector 1 1 1)))
            (pdata-op "*" "s" 1.02)
            (pdata-op "*" "c" 0.99)
            (pdata-map!
              (lambda (p)
                (let ((nz (vmul p 5)))
                (vadd p (vmul (vsub (vector (noise (vx nz) (vy nz) (vz nz)) 
                    (+ 0.1 (noise (+ 100 (vx nz)) (vy nz) (vz nz)))
                    (noise (vx nz) (+ 100 (vy nz)) (vz nz))) (vector 0.5 0.5 0.5))
                    (* 1 d)))))
              "p")))
        
        (define/public (get-tile vcity)
            (send vcity get-tile (send veh get-tile-x)
                (send veh get-tile-y)))
        
        (define/public (get-lights vcity dir)
            (let ((tile (send (send vcity get-city) get-tile (send veh get-last-x)
                            (send veh get-last-y))))
                (cond 
                    ((eq? dir 'north) (send tile get-north-lights))
                    ((eq? dir 'east) (send tile get-east-lights))
                    ((eq? dir 'south) (send tile get-south-lights))
                    ((eq? dir 'west) (send tile get-west-lights)))))        
        
        (define/public (get-upcoming-lights vcity)
            (get-lights vcity (send veh get-dir)))
        
        
        (define/public (check-collisions vcity)
            (let ((collided (with-primitive detector
                            (foldl
                                (lambda (v r)
                                    (if r r (if (not (eq? v this))
                                            (or (bb/bb-intersect? (send v get-root) 0)
                                                #f #;(with-primitive root (bb/bb-intersect? (send v get-root) 0)))
                                            #f)))
                                #f
                                (send vcity get-vehicles)))))
                
                
                (when (and collided  (not collided-last-update))                 
                    (new-smack (with-primitive detector (vtransform (vector 0 0 0) (get-global-transform))))
                    #;(play-now ((list-ref patches (modulo id (length patches)))
                            (send veh get-tile-x) (send veh get-tile-y))))
                
                (when collided
                    (set! collided-last-update #t)
                    (set! state 'reverse)
                    (set! reverse-t (* (* collide-count 0.1) (rndf))))                
                
                (when (not collided) (set! collided-last-update #f))
                
                (when (and (< collide-count 10) collided)
                    (set! collide-count (+ collide-count 1)))))
           
        (define (calc-time-step d)   
           (let* ((tleft (- (* tick tick-mult) vt))
                           (cleft (- 1 ct)))
                (* (/ cleft tleft) d)))
        
        (define (calc-safe-time-step d n)
           (let ((ts (calc-time-step d)))
             (cond 
                ((zero? n) (printf "aborted~n") ts)
                ((< ts 0.5) ts)
                (else
                  ; going too fast, make more time!
                  ;(printf "tick-mult: ~a~n" tick-mult)
                  (set! tick-mult (+ tick-mult 1))
                  (calc-safe-time-step d (- n 1))))))
        
        (define/public (move-veh d)
            (when (eq? state 'reverse)
                (set! reverse-t (- reverse-t 0.02))
                (when (< reverse-t 0) 
                    (set! state 'forward)))
            
            (when (or (eq? state 'forward) (eq? state 'reverse))
                (when (and (not (zero? tick)) (eq? state 'forward))
                    (set! ct (+ ct (calc-safe-time-step d 50))))
                (when (eq? state 'reverse)
                    (set! ct (- ct 0.01)))                       
                (with-primitive root
                    (identity)
                    (let* ((h (hermite-tangent pos dest-pos dir dest-dir ct)))
                        (translate (car h))
                        (concat (maim (vector 0 1 0) (vnormalise (cadr h))))
                        #;(scale 0.2)))))
        
        (define/public (check-lights vcity)                
            ; check the lights
            (let ((lights (get-upcoming-lights vcity)))
                (when lights
                    (when (eq? (send lights get-state) 'red)
                        (set! state 'stopped))            
                    (when (and (eq? state 'stopped) (eq? (send lights get-state) 'green))
                        (set! state 'forward)))))    
        
        (define/public (new-tick vcity t d)
            (send satnav pop-instruction)
            (set! collide-count 0)
            (set! vt (- vt (* tick-mult tick)))
            (set! ct 0)
            (set! tick-mult 1)
            (send veh update (send vcity get-city))
            
            (let* ((x (send veh get-tile-x))
                  (y (send veh get-tile-y))
                 (tile (send (send vcity get-city) get-tile x y)))
              (when (send tile get-trigger)
                (send vcity trigger-cue (vector x y) (+ t tick))
                                
                ; global patch change based on city quarter
                (send (send vcity get-sound) set-current (send vcity find-quarter (vector x y)))
                 
                (send (send vcity get-sound) play-note  
                    (+ (send vcity get-next-clock) tick) 
                    (+ 10 (send veh get-tile-x)) id)))
                        
            (let ((tile-pos (vtransform (vector 0 0 0) (with-primitive (get-tile vcity)
                                (get-transform)))))
                (set! pos dest-pos)
                (set! dir dest-dir)
                (cond 
                    ((eq? (send veh get-dir) 'north) 
                        (set! dest-pos (vadd (vector -0.1 0 0.5) tile-pos))
                        (set! dest-dir (vector 0 0 -1)))
                    ((eq? (send veh get-dir) 'east) 
                        (set! dest-pos (vadd (vector -0.5 0 -0.1) tile-pos))
                        (set! dest-dir  (vector 1 0 0)))
                    ((eq? (send veh get-dir) 'south) 
                        (set! dest-pos (vadd (vector 0.1 0 -0.5) tile-pos))
                        (set! dest-dir  (vector 0 0 1)))
                    ((eq? (send veh get-dir) 'west) 
                        (set! dest-pos (vadd (vector 0.5 0 0.1) tile-pos))
                        (set! dest-dir (vector -1 0 0))))))
        
        (define (error-from-nearest t d)
          (let ((e (fmod t d)))
            (if (< e (/ d 2)) e (- e d))))
        
        (define/public (sync-now)
            (let ((e (error-from-nearest vt tick)))
            (when (> (abs e) 0.05)
                (printf "SYNC ~a ~a~n" vt e)
                (set! vt (- vt e)))))
        
        (define/public (update t d vcity)
            (with-primitive detector (recalc-bb))
            (with-primitive root (recalc-bb))
            (set! tick (/ (send vcity get-tick) (list-ref speed-list speed)))
                        
            ; animate...
            (check-collisions vcity)
            (check-lights vcity)   
            (move-veh d)
            
            (when (and (eq? state 'forward) (send veh no-instructions?))
              (set! state 'stopped))
              
            (when (and (eq? state 'stopped) (not (send veh no-instructions?)))
              (set! state 'forward))                                       
              
            (when (and (eq? state 'forward) (> vt (* tick-mult tick)))
                (new-tick vcity t d))                        
            (when (and (not (eq? state 'forward)) (> vt (* tick-mult tick)))
                (set! tick-mult (+ tick-mult 1))) 
                        
            (set! vt (+ vt d))            
            (update-smacks t d)
            (update-pollution t d)
            (send satnav update t d))
            
        (define/public (push-instruction ins)
               (send satnav push-instruction ins)
               (send veh push-instruction ins))

        (define/public (clear-instructions)
               (send satnav clear-instructions)
               (send veh clear-instructions))
         
        (super-new)))

;------------------------------------------------------------

(define jam%
  (class object%
    (init-field 
      (w 5)
      (h 5)
      (vehicle-count 5))      
    (field
      (city (make-object city% w h))
      (vcity (make-object vcity% city))
      (mode 'world-edit)
      (db #t)
      (current-veh #f)
      (zoom -2)
      (rot 20)
      (tilt 10)
      (car-follower (build-locator)))
     
    (define/public (get-vcity)
      vcity)
      
    (define/public (build root)      
      (send city build vehicle-count)
      ;(send city generate!)
      (send city make-start-city!)
      (send vcity build root)
      (send vcity set-sync-offset! 0.18)
      (edit-world))
      
    (define/public (do-zoom)
      (if (eq? mode 'world-edit)
          (jam-set-camera-transform (mmul (mtranslate (vector 0 0 zoom))
                                    (mrotate (vector tilt rot 0))))
        (jam-set-camera-transform (mmul (mtranslate (vector 0 0 zoom))
                                    (mrotate (vector tilt rot 0))))))
                                  
    (define/public (edit-world)    
      (set! mode 'world-edit) 
      (jam-set-fov 60 0.1 1000)
      (jam-lock-camera (send vcity get-cursor))
      (jam-set-camera-transform (mmul (mtranslate (vector 0 0 zoom))
                                    (mrotate (vector tilt rot 0)))))
      
    (define/public (edit-veh vveh)
      (when vveh
          (set! mode 'veh-edit) 
          (jam-set-fov 40 0.1 1000)
          (set! current-veh vveh)
      (with-primitive car-follower
          (identity)
        (translate (with-primitive (send current-veh get-root) 
                      (vtransform (vector 0 0 0) (get-global-transform)))))        

          (jam-lock-camera car-follower)
          (jam-set-camera-transform (mmul (mtranslate (vector 0 0 zoom))
                                        (mrotate (vector tilt rot 0))))))
     
    (define/public (update t d)
      (cond 
        ((eq? mode 'world-edit) (world-edit-update t d))
        ((eq? mode 'veh-edit) (veh-edit-update t d)))
      (send vcity update t d))
        
    (define/public (world-edit-update t d)        
      (cond
        ((key-special-pressed 100) (when db (set! db #f) (send vcity move-cursor 'east)))
        ((key-special-pressed 101) (when db (set! db #f) (send vcity move-cursor 'north)))
        ((key-special-pressed 102) (when db (set! db #f) (send vcity move-cursor 'west)))
        ((key-special-pressed 103) (when db (set! db #f) (send vcity move-cursor 'south)))
        ((key-pressed " ") (when db (set! db #f) (send vcity place-trigger)))
        ((key-pressed "-") (set! zoom (* zoom 1.01)) (do-zoom))
        ((key-pressed "=") (set! zoom (* zoom 0.99)) (do-zoom))
        ((key-pressed "o") (set! rot (+ rot 1)) (do-zoom))
        ((key-pressed "p") (set! rot (- rot 1)) (do-zoom))
        ((key-pressed "u") (set! tilt (+ tilt 1)) (do-zoom))
        ((key-pressed "i") (set! tilt (- tilt 1)) (do-zoom))
        ((key-pressed "c") (when db (set! db #f) (send vcity add-veh)))
        ((key-pressed "b") (when db (set! db #f) (send vcity add-building)))
        ((key-pressed "v") (when db (set! db #f) (edit-veh (send vcity get-closest))))
        ((key-pressed "t") (when db (set! db #f) (send vcity add-tile-to-build)))
        ((key-pressed "r") (when db (set! db #f) (send vcity build-road)))
        (else (set! db #t))))

    (define/public (veh-edit-update t d)
      (with-primitive car-follower
          (identity)
        (translate (with-primitive (send current-veh get-root) 
                      (vtransform (vector 0 0 0) (get-global-transform)))))        
      (cond
        ((key-special-pressed 102) (when db (set! db #f) (send current-veh push-instruction 'right)))
        ((key-special-pressed 101) (when db (set! db #f) (send current-veh push-instruction 'forward)))
        ((key-special-pressed 100) (when db (set! db #f) (send current-veh push-instruction 'left)))
        ((key-special-pressed 103) (when db (set! db #f) (send current-veh push-instruction 'uie)))
        ((key-pressed " ") (when db (set! db #f) (send vcity place-trigger)))
        ((key-pressed "-") (set! zoom (* zoom 1.01)) (do-zoom))
        ((key-pressed "=") (set! zoom (* zoom 0.99)) (do-zoom))
        ((key-pressed "o") (set! rot (+ rot 2)) (do-zoom))
        ((key-pressed "p") (set! rot (- rot 2)) (do-zoom))
        ((key-pressed "u") (set! tilt (+ tilt 1)) (do-zoom))
        ((key-pressed "i") (set! tilt (- tilt 1)) (do-zoom))
        ((key-pressed "v") (when db (set! db #f) (edit-world)))
        ((key-pressed "x") (when db (set! db #f) (send current-veh speed-up)))
        ((key-pressed "z") (when db (set! db #f) (send current-veh slow-down)))
        ((key-pressed "l") (when db (set! db #f) (send current-veh clear-instructions)))
        (else (set! db #t))))
                      


    (super-new)))
    
    
;------------------------------------------------------------