528 lines
18 KiB
Scheme
528 lines
18 KiB
Scheme
; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
; 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))
|