;#lang scheme
; j a m

(require scheme/class)
(require fluxus-016/fluxa)

(define ttt 0)
(define (time) ttt)

; slow implementation of hermite curves for animation
(define (hermite s p1 p2 t1 t2)
    ; the bernstein polynomials
    (define (h1 s)
        (+ (- (* 2 (expt s 3))
                (* 3 (expt s 2))) 1))
    
    (define (h2 s)
        (+ (* -2 (expt s 3))
            (* 3 (expt s 2))))
    
    (define (h3 s)
        (+ (- (expt s 3) (* 2 (expt s 2))) s))
    
    (define (h4 s)
        (- (expt s 3) (expt s 2)))
    
    (vadd
        (vadd 
            (vmul p1 (h1 s))
            (vmul p2 (h2 s)))
        (vadd
            (vmul t1 (h3 s))
            (vmul t2 (h4 s)))))

; slow, stupid version for getting the tangent - not in the mood for
; maths today to see how you derive it directly, must be pretty simple
(define (hermite-tangent t p1 p2 t1 t2)
    (let ((p (hermite t p1 p2 t1 t2)))
        (list p (vsub (hermite (- t 0.01) p1 p2 t1 t2) p))))

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

(define (contains? k l)
    (cond
        ((null? l) #f)
        ((eq? k (car l)) #t)
        (else (contains? k (cdr l)))))

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

(define-struct tile (north east south west))

(define (tile-eq? tile other)
    (and 
        (eq? (tile-north tile) (tile-north other))
        (eq? (tile-east tile) (tile-east other))
        (eq? (tile-south tile) (tile-south other))
        (eq? (tile-west tile) (tile-west other))))

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

(define veh%
    (class object%
        (init-field
            (tile-x 0)
            (tile-y 0))
        (field 
            (dir (choose '(north east south west)))
            (max-instructions 4)
            (instructions '()))
        
        (define/public (get-dir)
            dir)
        
        (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))
                        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 
                        (printf "trying ~a~n" ins)
                        (let ((desired-dir (dir-from-instruction ins)))
                            (if (contains? desired-dir exits)
                                desired-dir
                                (choose exits)))) ; can't go in this direction!
                    (else (choose exits))))) ; no instructions = random direction
        
        (define/public (get-tile city)
            (send city get-tile tile-x tile-y))
        
        (define/public (get-tile-x)
            tile-x)
        
        (define/public (get-tile-y)
            tile-y)
        
        (define/public (update city)
            ; move to next tile
            ; todo, check if tile jammed
            (let ((tile (get-tile city))
                    (exits '()))
                (when (and (not (eq? dir 'south)) (tile-north tile)) 
                    (set! exits (cons 'north exits))) 
                (when (and (not (eq? dir 'west)) (tile-east tile))
                    (set! exits (cons 'east exits))) 
                (when (and (not (eq? dir 'north)) (tile-south tile))
                    (set! exits (cons 'south exits))) 
                (when (and (not (eq? dir 'east)) (tile-west tile))
                    (set! exits (cons 'west exits)))
                
                (cond 
                    ((null? exits)
                        (printf "erk! got stuck, teleporting~n")
                        (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 '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 '()))
        
        (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 (build vehicle-count)
            (set! tiles (build-list (* w h) 
                    (lambda (_) (make-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)))))
            (for-each
                (lambda (v)
                    (send v push-instruction 'left)
                    (send v push-instruction 'left)
                    (send v push-instruction 'left)
                    (send v push-instruction 'left))
                vehicles))
        
        (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-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 (tile-north (get-tile x y)) 1 0))
                    (printf "~a" (if (tile-east (get-tile x y)) 1 0))
                    (printf "~a" (if (tile-south (get-tile x y)) 1 0))
                    (printf "~a " (if (tile-west (get-tile x y)) 1 0)))
                (printf "~n")))
        
        (define/public (filter-tiles!)
            (set! tiles
                (map 
                    (lambda (tile)
                        (cond
                            ((tile-eq? (make-tile #t #f #f #f) tile) (make-tile #f #f #f #f))
                            ((tile-eq? (make-tile #f #t #f #f) tile) (make-tile #f #f #f #f))
                            ((tile-eq? (make-tile #f #f #t #f) tile) (make-tile #f #f #f #f))
                            ((tile-eq? (make-tile #f #f #f #t) tile) (make-tile #f #f #f #f))
                            (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 (tile-eq? tile (make-tile #t #t #t #t))
                                        (zero? 1 #;(random 30)))
                                    (make-tile #f #f #f #f)    
                                    (make-tile
                                        (cond ((and (tile-north tile) (not (tile-south north-tile)))
                                                (set! clean #f) #f)
                                            (else (tile-north tile)))
                                        (cond ((and (tile-east tile) (not (tile-west east-tile)))
                                                (set! clean #f) #f)
                                            (else (tile-east tile)))
                                        (cond ((and (tile-south tile) (not (tile-north south-tile)))
                                                (set! clean #f) #f)
                                            (else (tile-south tile)))
                                        (cond ((and (tile-west tile) (not (tile-east west-tile)))
                                                (set! clean #f) #f)
                                            (else (tile-west tile)))))))
                        (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-tile
                                    (cond ((and (not (tile-north tile)) (tile-south north-tile))
                                            (set! clean #f) #t)
                                        (else (tile-north tile)))
                                    (cond ((and (not (tile-east tile)) (tile-west east-tile))
                                            (set! clean #f) #t)
                                        (else (tile-east tile)))
                                    (cond ((and (not (tile-south tile)) (tile-north south-tile))
                                            (set! clean #f) #t)
                                        (else (tile-south tile)))
                                    (cond ((and (not (tile-west tile)) (tile-east west-tile))
                                            (set! clean #f) #t)
                                        (else (tile-west tile))))))
                        
                        (build-list (* w h) (lambda (n) n))))
                clean))
        
        
        (define/public (generate-step!)
            (filter-tiles!)
            (when (not (dissolve-tiles!))
                (generate-step!)))
        
        (define/public (generate!)
            (join-tiles!)
            (generate-step!))
        
        (super-new)))

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

(define vcity% 
    (class object% 
        (init-field
            (city #f))
        
        (field
            (tiles '())
            (vehicles '()))
        
        (define/public (get-city)
            city)
        
        (define/public (get-vehicles)
            vehicles)
        
        (define (tile->texture-name tile)
            (string-append 
                (if (tile-north tile) "1" "0")
                (if (tile-east tile) "1" "0")
                (if (tile-south tile) "1" "0")
                (if (tile-west tile) "1" "0")
                ".png"))
        
        (define/public (build root)                
            (with-state
                (parent root)
                (for ((y (in-range (send city get-h))))
                    (with-state
                        (for ((x (in-range (send city get-w))))
                            (let ((texture-name (tile->texture-name (send city get-tile x y))))
                                (with-state
                                    ;                                (hint-wire)
                                    (ambient (vector 0.5 0.5 0.5))
                                    (texture-params 0 '(min nearest))
                                    (texture (load-texture 
                                            (string-append "textures/" texture-name)))
                                    (rotate (vector -90 0 0))
                                    (set! tiles (cons (build-plane) tiles)))
                                (when (string=? "0000.png" texture-name)
                                    (with-state
                                        (ambient (vector 0.5 0.5 0.5))
                                        (let ((num (number->string (+ 1 (random 4)))))
                                            (hint-cast-shadow)
                                            (rotate (vector 0 (* 90 (random 4)) 0))
                                            ;(scale 0.3)
                                            ;                                    (hint-unlit)
                                            ;(texture (load-texture (string-append "textures/00" num ".occ.png")))
                                            (build-cube)#;(load-primitive (string-append "meshes/00" num ".obj"))))))
                            
                            (translate (vector 1 0 0))))
                    (translate (vector 0 0 1))))
            (set! tiles (reverse tiles))
            (set! vehicles
                (map 
                    (lambda (veh)
                        (let ((v (make-object vveh% veh)))
                            (send v build)
                            v))
                    (send city get-vehicles))))
        
        (define/public (get-tile x y)
            (list-ref tiles (+ x (* y (send city get-w)))))
        
        (define/public (update)
            (for-each
                (lambda (vveh)
                    (send vveh update this))
                vehicles))
        
        (super-new)))

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

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

(define satnav%
    (class object%
        (init-field
            (max-instructions 4))
        (field
            (root (let ((p (with-state
                                (translate (vector 0.9 0 0))
                                (scale (vector 0.9 0.2 1))
                                (build-plane))))
                    (with-primitive p 
                        (apply-transform) 
                        (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
                                                (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)
                                (vector 2 0 0)
                                (index->pos (length instructions))
                                ))))))
        
        (define/public (pop-instruction)
            (when (not (null? 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))))
        
        (define/public (update)
            (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))
        (field
            (pos (vmul (srndvec) 100))
            (dir (vector 0 0 0))
            (dest-pos (vmul (srndvec) 100))
            (dest-dir (vector 0 0 0))
            (t (time))
            (tick (+ 0.3 (rndf)))
            (root #f)
            (detector #f)
            (reversing #f)
            (reverse-t 0)
            (collided-last-update #f)
            (collide-count 0)
            (satnav #f)) 
        
        (define/public (get-root)
            root)
        
        (define/public (build)
            (set! root (with-state
                    (colour (hsv->rgb (vector (rndf) 0.5 1)))
                    (scale 0.2)
                    (scale (vector 1 0.7 1))
                    (build-cube)))
            
            (set! detector (with-state             
                    ;(hint-origin)
                    (translate (vector 0 0 0.15))
                    (build-locator)))
            
            (with-primitive root
                (apply-transform))
            
            ;(lock-camera root)
            
            (with-primitive detector
                (parent root)
                (locator-bounding-radius 0.05))
            
            (with-state
                (parent root)
                (set! satnav (make-object satnav% (send veh get-max-instructions)))))
        
        
        (define/public (get-tile vcity)
            (send vcity get-tile (send veh get-tile-x)
                (send veh get-tile-y)))
        
        (define/public (update vcity)
            (with-primitive detector (recalc-bb))
            (with-primitive root (recalc-bb))
                            
            ; animate...
            (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)
                                                (with-primitive root (bb/bb-intersect? (send v get-root) 0)))
                                             #f)))
                                #f
                                (send vcity get-vehicles)))))
                
                (when (and collided  (not collided-last-update))                
                    (play-now (mul (adsr 0 0.1 0 0) (pink (* 10 (rndf))))))

                (when collided
                    (set! collided-last-update #t)
                    (set! reversing #t)
                    (set! reverse-t (* (* collide-count 0.1) (rndf))))                

                (when (not collided) (set! collided-last-update #f))

                (when (and (< collide-count 10) collided)
                    ;     (printf "~a~n" collide-count)
                    (set! collide-count (+ collide-count 1)))
                ; (set! reversing #f))
            
            (when reversing                         
                (set! t (+ t 0.021))
                (set! reverse-t (- reverse-t 0.02))
                (when (< reverse-t 0) (set! reversing #f)))
            
            (when (or #t (not collided))
                (with-primitive root
                    (identity)
                    (let* ((t (- 1 (/ (- t (time)) tick)))
                            (h (hermite-tangent t pos dest-pos dir dest-dir)))
                        (translate (car h))
                        (concat (maim (vector 0 1 0) (vnormalise (cadr h))))
                        #;(scale 0.2))))
            
            (when (send satnav empty?) (set! t (+ t 0.02)))

            (when (> (time) t)
                (send satnav pop-instruction)
                (set! collide-count 0)
                (set! t (+ t tick))
                (send veh update (send vcity get-city))
                (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))))))
            
            (when (key-special-pressed 100) 
                (send satnav push-instruction 'left)
                (send veh push-instruction 'left))
            (when (key-special-pressed 101) 
                (send satnav push-instruction 'forward)
                (send veh push-instruction 'forward))
            (when (key-special-pressed 102) 
                (send satnav push-instruction 'right)
                (send veh push-instruction 'right))
            (when (key-special-pressed 103) 
                (send satnav push-instruction 'uie)
                (send veh push-instruction 'uie))

            (send satnav update)))
    
    (super-new)))

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

(clear)
(clear-colour 0)
(define l (make-light 'point 'free))
(light-diffuse 0 (vector 0.3 0.3 0.3))
(light-diffuse l (vector 0.6 0.6 0.6))
(light-position l (vector 50 90 80))
(light-ambient l (vector 0.5 0.5 0.5))
(shadow-light l)
;(ortho)
;(zoom-ortho 2)

(define mycity (make-object city% 5 5))
(send mycity build 10)
(send mycity generate!)

#;(send mycity set-tiles! (list
        (make-tile #f #f #f #f)
        (make-tile #f #t #t #f)
        (make-tile #f #f #t #t)
        
        (make-tile #f #f #f #f)
        (make-tile #t #f #t #f)
        (make-tile #t #f #t #f)
        
        (make-tile #f #f #f #f)
        (make-tile #t #t #f #f)
        (make-tile #t #f #f #t)))

(camera-lag 0.1)
(define root (build-locator))
(define myvcity (make-object vcity% mycity))
(send myvcity build root)

(define (animate)
    (set! ttt (+ ttt 0.02))
    (send myvcity update))

(every-frame (animate))