; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; treetris game prototype
; -----------------------
;
; use the cursor keys to play tetris and grow a tree
; 

(clear-texture-cache)
(define-struct grid (width height root bgcol))

(define (feq? a b)
    (let ((dif (vsub a b)))
        (and 
            (< (abs (vx dif)) 0.01)
            (< (abs (vy dif)) 0.01)
            (< (abs (vz dif)) 0.01))))

(define (build-grid w h bgcol)
    (with-state  
        (hint-unlit)
        (hint-vertcols)
        ;(texture (load-texture "textures/tetris.png"))
        (let ((p (build-polygons (* w h 4) 'quad-list)))
            
            (with-primitive p
                (pdata-index-map!
                    (lambda (i p)
                        (let* ((v (modulo i 4))
                                (b (quotient i 4))
                                (q (quotient b w))
                                (c (cond 
                                        ((eq? v 0) b)
                                        ((eq? v 1) (+ b 1))
                                        ((eq? v 2) (+ b 1))
                                        ((eq? v 3) b)))
                                (rq (if (or (eq? v 2) (eq? v 3)) (+ q 1) q)))
                            
                            (vector 
                                (* rq (sin (* (/ (modulo c w) w) 6.282)))
                                (* rq (cos (* (/ (modulo c w) w) 6.282)))
                                0)))
                    "p")
                (pdata-index-map!
                    (lambda (i t)
                        (let ((v (modulo i 4)))
                            (cond 
                                ((eq? v 0) (vector 0 0 0))
                                ((eq? v 1) (vector 1 0 0))
                                ((eq? v 2) (vector 1 1 0))
                                ((eq? v 3) (vector 0 1 0)))))
                    "t")
                (pdata-map!
                    (lambda (c)
                        bgcol)
                    "c"))
            
            (let ((g (make-grid w h p bgcol)))
                (for ((i (in-range 0 w)))
                    (grid-poke g i 5 (vector 0 0.3 0)))
                g))))

(define (grid-row-filled? grid row)
    (not (foldl
            (lambda (pos gap-found)
                (if gap-found
                    #t
                    (feq? (grid-bgcol grid) 
                        (grid-peek grid (vector-ref pos 0) (vector-ref pos 1)))))
            #f
            (build-list (grid-width grid) (lambda (x) (vector x row))))))

(define (grid-row-block? grid row)
    (foldl
        (lambda (pos block-found)
            (if block-found
                #t
                (not (feq? (grid-bgcol grid)
                        (grid-peek grid (vector-ref pos 0) (vector-ref pos 1))))))
        #f
        (build-list (grid-width grid) (lambda (x) (vector x row)))))

(define (grid-copy-row grid src dst)
    (for ((col (in-range 0 (grid-width grid))))
        (grid-poke grid col dst (grid-peek grid col src))))

(define (grid-delete-row grid row)
    (for ((y (in-range 6 (- (grid-height grid) 1))))
        (when (>= y row)
            (grid-copy-row grid (+ y 1) y))))

(define (grid-look-for-rows grid on-row)
    (for ((row (in-range 6 (grid-height grid))))
        (when (grid-row-filled? grid row)
            (grid-delete-row grid row)
            (on-row row))))

(define (grid-clear grid)
    (for ((row (in-range 6 (grid-height grid))))
        (for ((col (in-range 0 (grid-width grid))))
            (grid-poke grid col row (grid-bgcol grid)))))

(define (grid-poke grid x y s)
    (let* ((x (modulo x (grid-width grid)))
            (b (* 4 (+ x (* y (grid-width grid))))))
        (when (and (>= y 0) (< y (grid-height grid)))
            (with-primitive (grid-root grid)
                (pdata-set! "c" b s)
                (pdata-set! "c" (+ b 1) s)
                (pdata-set! "c" (+ b 2) s)
                (pdata-set! "c" (+ b 3) s)))))

(define (grid-peek grid x y)
    (let* ((x (modulo x (grid-width grid)))
            (b (* 4 (+ x (* y (grid-width grid))))))
        (if (and (>= y 0) (< y (grid-height grid)))
            (with-primitive (grid-root grid)
                (pdata-ref "c" b))
            (vector 0 0 0))))

; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(define-struct shape (cells colour))

(define shapes
    (list (make-shape (list (vector 0 1) (vector 0 0) (vector 1 0) (vector -1 0)) (vector 0 1 0))
        (make-shape (list (vector -1 1) (vector -1 0) (vector 0 0) (vector 0 -1)) (vector 1 0 0))
        (make-shape (list (vector -1 0) (vector 0 0) (vector 1 0) (vector 2 0)) (vector 0 0 1))
        (make-shape (list (vector 0 0) (vector 1 0) (vector 0 1) (vector 1 1)) (vector 1 1 0))
        (make-shape (list (vector 0 0) (vector 1 0) (vector 0 1) (vector 0 2)) (vector 0 1 1))))

(define (random-shape)
    (list-ref shapes (random (length shapes))))

; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(define-struct block ((pos #:mutable) (shape #:mutable) colour))

(define (block-write block grid s)
    (for-each
        (lambda (pos)
            (grid-poke grid (+ (vector-ref (block-pos block) 0) (vector-ref pos 0))
                (+ (vector-ref (block-pos block) 1) (vector-ref pos 1)) s))
        (block-shape block)))

(define (block-rotate-ccw block)
    (set-block-shape! block
        (map
            (lambda (pos)
                (vector (vector-ref pos 1) (- (vector-ref pos 0))))
            (block-shape block))))

(define (block-rotate-cw block)
    (set-block-shape! block
        (map
            (lambda (pos)
                (vector (- (vector-ref pos 1)) (vector-ref pos 0)))
            (block-shape block))))

(define (block-move! block vec)
    (set-block-pos! block (vector (+ (vector-ref vec 0) (vector-ref (block-pos block) 0))
            (+ (vector-ref vec 1) (vector-ref (block-pos block) 1)))))

(define debounce #t)

(define (block-deal-with-input block grid)
    (block-write block grid (grid-bgcol grid)) ; clear the block
    
    ; do rotations here...
    (when (and debounce (key-special-pressed 103)) ; rotate ccw
        (set! debounce #f)
        (block-move! b (vector 0 -1))
        (when (block-check block grid)
            (block-move! b (vector 0 1))))
    
    (when (and debounce (key-special-pressed 101)) ; rotate cw
        (set! debounce #f)
        (block-rotate-cw b)
        (when (block-check block grid)
            (block-rotate-ccw b))) ; can't rotate
    
    (when (and debounce (key-special-pressed 100)) ; move left
        (set! debounce #f)
        (block-move! block (vector -1 0))
        (when (block-check block grid)
            (block-move! block (vector 1 0))))
    
    (when (and debounce (key-special-pressed 102)) ; move right
        (set! debounce #f)
        (block-move! block (vector 1 0))
        (when (block-check block grid)
            (block-move! block (vector -1 0))))
    
    (when (null? (keys-special-down))
        (set! debounce #t))
    
    (block-write block grid (block-colour block))) ; write the block

; hack
(define reset #f)

(define (block-update block grid)
    (block-write block grid (grid-bgcol grid)) ; clear the block
    
    (block-move! block (vector 0 -1))
    
    (cond ((block-check block grid)
            ; reverse!
            (block-move! block (vector 0 1))            
            (block-write block grid (block-colour block)) ; write the block
            (when (grid-row-block? grid (- (grid-height grid) 1))
                (grid-clear grid)
                (set! reset #t))
            #f)
        (else
            (block-write block grid (block-colour block)) ; write the block
            #t)))

(define (block-check block grid)
    (foldl
        (lambda (pos found)
            (if (not found)
                (not (feq? (grid-bgcol grid) (grid-peek grid (+ (vector-ref (block-pos block) 0) (vector-ref pos 0))
                            (+ (vector-ref (block-pos block) 1) (vector-ref pos 1)))))
                #t))
        #f
        (block-shape block)))

; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


; try all the rules on this character - 
; returns #f if none are matched
(define (lsys-run-rules char rules)
    (foldl
        (lambda (rule str)
            (if str ; if str is not #f
                str ; then we have already found a rule, return it
                (if (char=? char (string-ref (car rule) 0)) ; check this rule
                    (cadr rule) ; return the string
                    #f))) ; no match
        #f
        rules))

; runs the lsystem rules on every character in a string, 
; returns the new string
(define (lsys-search-replace str rules pos result)
    (cond 
        ((>= pos (string-length str)) result)
        (else
            (let ((ret (lsys-run-rules (string-ref str pos) rules)))
                (if (string? ret)
                    (lsys-search-replace str rules (+ pos 1) 
                        (string-append result ret))
                    (lsys-search-replace str rules (+ pos 1) 
                        (string-append result (string (string-ref str pos)))))))))

; runs the search-replace multiple (n) times on a string
(define (ls-generate n str rules)
    (cond 
        ((zero? n) str)
        (else
            (ls-generate (- n 1) 
                (lsys-search-replace str rules 0 "") rules))))

; builds objects from a string
(define (ls-build string angle branch-scale branch-col leaf-col)
    (with-state
        (rotate (vector 0 180 0))
        (hint-depth-sort)
        (for-each 
            (lambda (char)
                (cond 
                    ((char=? #\F char)
                        (with-state
                            (translate (vmul (crndvec) 0.01))
                            (scale (vector 1.2 1 1))
                            (rotate (vector 0 90 0))         
                            (colour branch-col)
                            
                            (with-primitive (build-ribbon 2)
                                ;                            (texture (load-texture "../textures/fade4.png"))
                                ;                                       (hint-unlit)
                                (pdata-set! "w" 0 0.1)
                                (pdata-set! "w" 1 0.07)
                                (pdata-set! "p" 0 (vector 0 0 0.9))
                                (pdata-set! "p" 1 (vector 0 0 0))))
                        (translate (vector 1 0 0)))
                    ((char=? #\L char)
                        (for ((i (in-range 1 2)))
                            (with-state
                                (translate (vmul (srndvec) 0.3))
                                (scale (* (rndf) 0.5))
                                (colour leaf-col)
                                ;                    (texture (load-texture "../textures/leaf.png"))
                                (build-sphere 3 3)))
                        #;(translate (vector 1 0 0)))
                    ((char=? #\f char)
                        (translate (vector 1 0 0)))
                    ((char=? #\/ char)
                        (rotate (vector angle 0 0)))
                    ((char=? #\\ char)
                        (rotate (vector (- angle) 0 0)))
                    ((char=? #\+ char)
                        (rotate (vector 0 angle 0)))
                    ((char=? #\- char)
                        (rotate (vector 0 (- angle) 0)))
                    ((char=? #\^ char)
                        (rotate (vector 0 0 (- angle))))
                    ((char=? #\& char)
                        (rotate (vector 0 0 angle)))
                    ((char=? #\| char)
                        (rotate (vector 0 0 180)))
                    ((char=? #\[ char)
                            (push)
                            (scale (vector branch-scale branch-scale branch-scale)))
                        ((char=? #\] char)
                        (pop))))
            (string->list string))))

(define (make-plant p n)
    (let ((root (build-locator)))
        (with-state
            (parent root)
            (translate p)
            (scale 10)
            (rotate (vector 0 90 0))
            ;        (concat (maim n (vector 0 1 0)))
            (scale 0.4)
            (ls-build (ls-generate 1 "F" '(("F" "F[^F][+/&FL]"))) 45 0.77
                ;(vector 1 0.5 0.2)
                ;(vector 0.5 1 0.5)
                (vector 1 (rndf) (* (rndf) 0.4)) 
                (vector (rndf) 1 (rndf))
                root
                ))))

(define (build-tree size)
    (let ((root (build-locator)))
        (with-state
            (parent root)
            (scale 3)
            ;(opacity 0.5)
            (hint-depth-sort)
            (rotate (vector 0 90 0))
            (ls-build (ls-generate size "F" '(("F" "F[^F][+/&FL]"))) 45 0.77
                (vector 1 (rndf) (* (rndf) 0.4)) 
                (vector (rndf) 1 (rndf))))
        root))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(define (particles-init particles)
    (with-primitive particles
        (pdata-add "vel" "v")
        (pdata-map!
            (lambda (c)
                (vector 0 (rndf) 0))
            "c")
        (pdata-map!
            (lambda (c)
                (vector 1 1 0))
            "s")
        (pdata-map!
            (lambda (vel)
                (vmul (vector (crndf) (crndf) (rndf)) 0.5))
            "vel")))


(define (particles-explode particles)
    (with-primitive particles
        (pdata-map!
            (lambda (p)
                (vector 0 0 0))
            "p")))

(define (particles-update particles)
    (with-primitive particles
        (pdata-op "+" "p" "vel")))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(define grass (vector 0.2 0.4 0.2))
(define sky (vector 0.5 0.6 1))

(clear)
;(hint-unlit)
(clear-colour sky)
(define grid-x 30)
(define grid-y 20)
(define g (build-grid grid-x grid-y grass))
(define b (make-block (vector 2 (- grid-y 2)) 
        (shape-cells (car shapes)) 
        (shape-colour (car shapes))))
(define next-time (flxtime))

(define particles (with-state
        (hint-none)
        (hint-points)
        (hint-anti-alias)
        (point-width 10)
        ;    (texture (load-texture "textures/blob.png"))
        (build-particles 200)))
(particles-init particles)

(define camera (with-state
        ;    (hint-origin)
        (build-locator)))
(lock-camera camera)
(camera-lag 0.5)

(light-diffuse 0 (vector 0 0 0))
(define l (make-light 'point 'free))
(light-diffuse l (vector 1 1 1))
(light-position l (vector 10 50 20))

(for ((i (in-range 1 30)))
    (with-state
        (rotate (vector 0 0 (random 360)))
        (translate (vector (+ 20 (random 5)) 0 0))
        (scale 3)
        (rotate (vector 0 90 0))
        (ls-build (ls-generate (+ 1 (random 3)) "F" '(("F" "F[^F][+/&FL]"))) (+ 10 (random 25)) 0.77
            (vmul (vector 1 (rndf) (* (rndf) 0.4)) 0.4)
            (vector (* 0.5 (rndf)) 1 (* 0.5 (rndf))))))

(define tree-size 1)
(define tree (build-tree tree-size))

(with-state
    (hint-unlit)
    (colour grass)
    (translate (vector 0 0 -0.2))
    (rotate (vector 90 0 0))
    (scale (vector 30 0.1 30))
    (build-cylinder 1 30))

(define tick 0.5)

(define (update)
    (particles-update particles)
    (block-deal-with-input b g)
    
    (with-primitive camera
        (identity)
        (rotate (vector 0 0 (* -360 (/ (vx (block-pos b)) grid-x))))
        (rotate (vector -50 0 0))
        (translate (vector 0 -20 8)))
    
    (when (> (flxtime) next-time)
        (set! next-time (+ next-time tick))
        (when (not (block-update b g))
            (let ((x (random grid-x))
                    (s (random-shape)))
                (set! b (make-block (vector x (- grid-y 2)) (shape-cells s) 
                        (shape-colour s)))))
        (when reset
            (set! reset #f)
            (destroy tree)
            (set! tree-size 1)
            (set! tree (build-tree tree-size)))
        
        (grid-look-for-rows g
            (lambda (n)
                (destroy tree)
                (set! tree-size (+ tree-size 1))
                (set! tree (build-tree tree-size))
                (particles-explode particles)))))

(define running #f)

(define start-time (time))

(define intro-root (build-locator))

(define splash2
    (with-state 
        (texture (load-texture "textures/gw.png"))
        (hint-unlit)
;        (colour 0)
        (scale (vmul (vector 3 2.25 1) 12.5))
        (translate (vector 0 0 0.9))
        ;       (rotate (vector 90 0 0))
        (build-plane)))

(define splash
    (with-state 
        (texture (load-texture "textures/foam.png"))
        (hint-unlit)
;         (colour 0)
        (scale (vmul (vector 3 2 1) 14))
        (translate (vector 0 0 1))
        ;       (rotate (vector 90 0 0))
        (build-plane)))


(set-camera-transform (mtranslate (vector 0 0 -30)))

(define splash-time 8)

(define (animate)
    (when (not running)
        
        (when (< (time) (+ start-time (/ splash-time 2)))
            (with-primitive splash 
                (scale 1.001)
                (colour (- 1 (/ (- (+ start-time (/ splash-time 2)) (time)) (/ splash-time 2))))))
        
        (when (> (time) (+ start-time (/ splash-time 2)))
            (with-primitive splash 
                (scale 1.001)
                (opacity (- 1 (/ (- (time) (+ start-time (/ splash-time 2))) 2)))))
        
        (when (> (time) (+ start-time splash-time)) 
            (with-primitive splash (hide 1)))
        
        (when (or (not (zero? (length (keys-down)))) (not (zero? (length (keys-special-down)))))
            (set-camera-transform (mrotate (vector -90 0 0)))
            (set! running #t)  
            (set! next-time (flxtime))
            (with-primitive intro-root (hide 1))
            (with-primitive splash (hide 1))
            (with-primitive splash2 (hide 1))))
    
    (when running (update)))


(every-frame (animate))