;#lang scheme
; t r a f f i c
;------------------------------------------------------------


(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-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-struct veh (dir tile-x tile-y) #:mutable)

(define (build-veh tile-x tile-y)
    (make-veh (choose '(north east south west)) tile-x tile-y))

(define (veh-tile veh city)
    (city-tile city (veh-tile-x veh) (veh-tile-y veh)))

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

(define (veh-update veh city)
    ; move to next tile
    ; todo, check if tile jammed
    (let ((tile (veh-tile veh city))
            (exits '())
            (dir (veh-dir veh)))
        (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-veh-tile-x! veh (random (city-w city)))
                (set-veh-tile-y! veh (random (city-h city))))
            (else
                (let ((dir (choose exits)))
                    (cond
                        ((eq? dir 'north) 
                            (set-veh-dir! veh 'north)
                            (set-veh-tile-y! veh (- (veh-tile-y veh) 1)))
                        ((eq? dir 'east) 
                            (set-veh-dir! veh 'east)
                            (set-veh-tile-x! veh (+ (veh-tile-x veh) 1)))
                        ((eq? dir 'south)
                            (set-veh-dir! veh 'south)
                            (set-veh-tile-y! veh (+ (veh-tile-y veh) 1)))
                        ((eq? dir 'west) 
                            (set-veh-dir! veh 'west)
                            (set-veh-tile-x! veh (- (veh-tile-x veh) 1)))))))))

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

(define-struct city (w h (tiles #:mutable) vehicles))

(define (build-city w h vehicle-count)
    (make-city w h (build-list (* w h) 
            (lambda (_) (make-tile 
                    (zero? (random 2))                                        
                    (zero? (random 2))                                                          
                    (zero? (random 2))   
                    (zero? (random 2)))))
        (build-list vehicle-count
            (lambda (_) (build-veh (random w) (random h))))))

(define (city-tile city x y)
    (cond ; check bounds and return an empty tile if out
        ((or (< x 0) (>= x (city-w city))
                (< y 0) (>= y (city-h city)))
            (make-tile #f #f #f #f))
        (else
            (list-ref (city-tiles city) (+ x (* y (city-w city)))))))

(define (city-print city)
    (for ((y (in-range 0 (city-h city))))
        (for ((x (in-range 0 (city-w city))))
            (printf "~a" (if (tile-north (city-tile city x y)) 1 0))
            (printf "~a" (if (tile-east (city-tile city x y)) 1 0))
            (printf "~a" (if (tile-south (city-tile city x y)) 1 0))
            (printf "~a " (if (tile-west (city-tile city x y)) 1 0)))
        (printf "~n")))

(define (city-filter-tiles! city)
    (set-city-tiles! city
        (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)))
            (city-tiles city))))

; cut neighbouring tiles together if they need to
; returns true if it didn't need to change any - the city is finished
(define (city-dissolve-tiles! city)
    (let ((clean #t))
        (set-city-tiles! city
            (map
                (lambda (n)
                    (let* ((x (modulo n (city-w city)))
                            (y (quotient n (city-w city)))
                            (tile (city-tile city x y))
                            (north-tile (city-tile city x (- y 1)))
                            (east-tile (city-tile city (+ x 1) y))
                            (south-tile (city-tile city x (+ y 1)))
                            (west-tile (city-tile city (- 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 (* (city-w city) (city-h city)) (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 (city-join-tiles! city)
    (let ((clean #t))
        (set-city-tiles! city
            (map
                (lambda (n)
                    (let* ((x (modulo n (city-w city)))
                            (y (quotient n (city-w city)))
                            (tile (city-tile city x y))
                            (north-tile (city-tile city x (- y 1)))
                            (east-tile (city-tile city (+ x 1) y))
                            (south-tile (city-tile city x (+ y 1)))
                            (west-tile (city-tile city (- 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 (* (city-w city) (city-h city)) (lambda (n) n))))
        clean))


(define (city-generate-step! city)
    (city-filter-tiles! city)
    (when (not (city-dissolve-tiles! city))
        (city-generate-step! city)))

(define (city-generate! city)
    (city-join-tiles! city)
    (city-generate-step! city))




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

(define-struct vcity (city tiles 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 (build-vcity city root)
    (let ((tiles '()))
        
        (with-state
            (parent root)
            (for ((y (in-range (city-h city))))
                (with-state
                    (for ((x (in-range (city-w city))))                     
                        (let ((texture-name (tile->texture-name (city-tile city 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")))
                                        (load-primitive (string-append "meshes/00" num ".obj"))))))
                        
                        (translate (vector 1 0 0))))
                (translate (vector 0 0 1))))
        (make-vcity city (reverse tiles)
            (map 
                (lambda (veh)
                    (build-vveh veh))
                (city-vehicles city)))))

(define (vcity-tile vcity x y)
    (list-ref (vcity-tiles vcity) (+ x (* y (city-w (vcity-city vcity))))))

(define (vcity-update vcity)
    (for-each
        (lambda (vveh)
            (vveh-update vveh vcity))
        (vcity-vehicles vcity)))

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

(define-struct vveh (pos dir dest-pos dest-dir veh time tick root detector) #:mutable)

(define (build-vveh veh)
    (let ((root (with-state
                    (colour (hsv->rgb (vector (rndf) 0.5 1)))
                    (translate (vector 0.5 0 0))
                    (scale (vector 0.4 0.7 1))
                    (build-cube)))
            (detector (with-state             
                    (translate (vector 0.3 0 1))
                    (build-locator))))
        
        (with-primitive root
            (apply-transform))
        
        (with-primitive detector
            (parent root)
            (locator-bounding-radius 0.2))
        
        (make-vveh (vector 0 0 0) (vector 0 0 0) 
            (vmul (rndvec) 100) (vector 0 0 0) veh (time) (+ 0.3 (rndf)) root detector)))

(define (vveh-tile vveh vcity)
    (vcity-tile vcity (veh-tile-x (vveh-veh vveh)) (veh-tile-y (vveh-veh vveh))))

(define (vveh-update vveh vcity)
    ; animate...
    (let ((collided (with-primitive (vveh-detector vveh)
                    (recalc-bb)
                    (foldl
                        (lambda (v r)
                            (with-primitive (vveh-root v)
                                (recalc-bb))
                            (if r r (if (not (eq? v vveh))
                                    (bb/bb-intersect? (vveh-root v) 0) #f)))
                        #f
                        (vcity-vehicles vcity)))))

        (when collided                         
            (set-vveh-time! vveh (+ (vveh-time vveh) 0.02)))

        (when (or #t (not collided))
            (with-primitive (vveh-root vveh)
                (identity)
                (let* ((t (- 1 (/ (- (vveh-time vveh) (time)) (vveh-tick vveh))))
                        (h (hermite-tangent t (vveh-pos vveh) (vveh-dest-pos vveh)
                                (vveh-dir vveh) (vveh-dest-dir vveh))))
                    (translate (car h))
                    (concat (maim (vector 0 1 0) (vnormalise (cadr h))))
                    (scale 0.2))))

        (when (> (time) (vveh-time vveh))
            (set-vveh-time! vveh (+ (vveh-time vveh) (vveh-tick vveh)))
            (veh-update (vveh-veh vveh) (vcity-city vcity))
            (let ((tile-pos (vtransform (vector 0 0 0) (with-primitive (vveh-tile vveh vcity)
                                (get-transform)))))
                (set-vveh-pos! vveh (vveh-dest-pos vveh))
                (set-vveh-dir! vveh (vveh-dest-dir vveh))
                (cond 
                    ((eq? (veh-dir (vveh-veh vveh)) 'north) 
                        (set-vveh-dest-pos! vveh (vadd (vector -0.1 0 0.5) tile-pos))
                        (set-vveh-dest-dir! vveh (vector 0 0 -1)))
                    ((eq? (veh-dir (vveh-veh vveh)) 'east) 
                        (set-vveh-dest-pos! vveh (vadd (vector -0.5 0 -0.1) tile-pos))
                        (set-vveh-dest-dir! vveh (vector 1 0 0)))
                    ((eq? (veh-dir (vveh-veh vveh)) 'south) 
                        (set-vveh-dest-pos! vveh (vadd (vector 0.1 0 -0.5) tile-pos))
                        (set-vveh-dest-dir! vveh (vector 0 0 1)))
                    ((eq? (veh-dir (vveh-veh vveh)) 'west) 
                        (set-vveh-dest-pos! vveh (vadd (vector 0.5 0 0.1) tile-pos))
                        (set-vveh-dest-dir! vveh (vector -1 0 0))))))))

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

(clear)
(clear-colour (vector 1 1 1))
(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 (build-city 10 10 60))
(city-generate! mycity)

#;(set-city-tiles! mycity (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)))


(define root (build-locator))
(define myvcity (build-vcity mycity root))

(define (animate)
    (set! ttt (+ ttt 0.02))
    (vcity-update myvcity))

(every-frame (animate))