(no commit message)

diff --git a/gacela_tetris.scm b/gacela_tetris.scm
new file mode 100644 (file)
index 0000000..b8c3b57
--- /dev/null
+++ b/gacela_tetris.scm
@@ -0,0 +1,192 @@
+(set-game-properties #:title "Gacela Tetris" #:fps 15)
+
+(define (tetramine-i)
+  (let ((color '(1 0 0)))
+    `((,color ,color ,color ,color))))
+
+(define (tetramine-j)
+  (let ((color '(1 0.5 0)))
+    `((,color ,color ,color)
+      (#f #f ,color))))
+
+(define (tetramine-l)
+  (let ((color '(1 0 1)))
+    `((#f #f ,color)
+      (,color ,color ,color))))
+
+(define (tetramine-o)
+  (let ((color '(0 0 1)))
+    `((,color ,color)
+      (,color ,color))))
+
+(define (tetramine-s)
+  (let ((color '(0 1 0)))
+    `((#f ,color ,color)
+      (,color ,color #f))))
+
+(define (tetramine-t)
+  (let ((color '(0.5 0 0)))
+    `((,color ,color ,color)
+      (#f ,color #f))))
+
+(define (tetramine-z)
+  (let ((color '(0 1 1)))
+    `((,color ,color #f)
+      (#f ,color ,color))))
+
+(define (random-tetramine)
+  (let ((n (random 7)))
+    (cond ((= n 0) (tetramine-i))
+         ((= n 1) (tetramine-j))
+         ((= n 2) (tetramine-l))
+         ((= n 3) (tetramine-o))
+         ((= n 4) (tetramine-s))
+         ((= n 5) (tetramine-t))
+         ((= n 6) (tetramine-z)))))
+
+(define (draw-cell cell)
+  (cond ((null? cell) #f)
+       (else (with-color cell (draw-square #:size 20)))))
+
+(define (draw-row row)
+  (for-each (lambda (cell) (draw-cell cell) (translate 23 0)) row))
+
+(define (draw-grid grid)
+  (for-each (lambda (row) (draw-row row) (translate (* -23 (length row)) -23)) grid))
+
+(define* (join-rows source destination #:optional (offset 0))
+  (cond ((null? source) destination)
+       ((null? destination) '())
+       ((> offset 0) (cons (car destination) (join-rows source (cdr destination) (- offset 1))))
+       (else (cons (or (car source) (car destination))
+                   (join-rows (cdr source) (cdr destination) offset)))))
+
+(define* (join-grids source destination #:optional (x 0) (y 0))
+  (cond ((null? source) destination)
+       ((null? destination) '())
+       ((> y 0) (cons (car destination)
+                      (join-grids source (cdr destination) x (- y 1))))
+       (else (cons (join-rows (car source) (car destination) x)
+                   (join-grids (cdr source) (cdr destination) x y)))))
+
+(define* (collide-rows row1 row2 #:optional (offset 0))
+  (cond ((not (or row1 row2)) #f)
+       ((> offset 0) (collide-rows row1 (cdr row2) (- offset 1)))
+       (else (or (and (car row1) (car row2)) (collide-rows (cdr row1) (cdr row2))))))
+
+(define* (collide-grids grid1 grid2 #:optional (x 0) (y 0))
+  (cond ((not (or grid1 grid2)) nil)
+       ((> y 0) (collide-grids grid1 (cdr grid2) x (- y 1)))
+       (else (or (collide-rows (car grid1) (car grid2) x)
+                 (collide-grids (cdr grid1) (cdr grid2) x y)))))
+
+(define (rotate-tetramine grid)
+  (define (rot grid res)
+    (cond ((null? grid) res)
+         (else (rot (cdr grid) (mapcar #'cons (car grid) res)))))
+  (rot grid (make-list (length (car grid)))))
+
+(define (row-completed row)
+  (cond ((null? row) #t)
+       (else (and (car row) (row-completed (cdr row))))))
+
+(define (remove-rows-completed grid)
+  (let ((res (remove-if (lambda (x) (row-completed x)) grid)))
+    (inc-points (- (length grid) (length res)))
+    (define (fill grid n)
+      (cond ((< n 1) grid)
+           (else (fill (cons (make-list 14) grid) (- n 1)))))
+    (fill res (- 20 (length res)))))
+
+(define get-points #f)
+(define get-lines #f)
+(define inc-points #f)
+
+(let ((points 0) (lines 0))
+  (set! get-points
+       (lambda ()
+         points))
+
+  (set! get-lines
+       (lambda ()
+         lines))
+
+  (set! inc-points
+       (lambda (l)
+         (define (more-lines-better n)
+           (cond ((= n 0) n)
+                 (else (+ n (more-lines-better (- n 1))))))
+         (set! points (+ points (* (more-lines-better l) 10)))
+         (set! lines (+ lines l)))))
+
+(define game #f)
+(define game-over #f)
+(define tetramine #f)
+
+(let ((current-tetramine (random-tetramine)) (x 6) (y 0)
+      (next (random-tetramine))
+      (timer (make-timer))
+      (grid (make-list 20 (make-list 14)))
+      (background (load-texture "fondo_tetris.png"))
+      (font (load-font "lazy.ttf" #:size 20))
+      (game-over #f))
+
+  (set! game
+       (lambda ()
+         (if game-over (game-over) (tetramine))))
+
+  (set! game-over
+       (lambda ()
+         (translate -100 0)
+         (render-text "Game Over" font #:size 50)))
+
+  (set! tetramine
+       (lambda ()
+         (cond ((eq? (timer-state timer) 'stopped) (start-timer timer)))
+
+         (cond ((key? 'right)
+                (cond ((not (collide-grids current-tetramine grid (+ x 1) y))
+                       (set! x (+ x 1))))))
+         (cond ((key? 'left)
+                (cond ((not (collide-grids current-tetramine grid (- x 1) y))
+                       (set! x (- x 1))))))
+         (cond ((< x 0) (set! x 0))
+               ((> (+ x (length (car current-tetramine))) 14) (set! x (- 14 (length (car current-tetramine))))))
+
+         (cond ((key-pressed? 'up)
+                (let ((t1 (rotate-tetramine current-tetramine)))
+                  (cond ((not (collide-grids t1 grid x y))
+                         (set! current-tetramine t1))))))
+
+         (cond ((or (key? 'down) (> (get-time timer) 5000))
+                (cond ((or (collide-grids current-tetramine grid x (+ y 1))
+                           (> (+ y 1 (length current-tetramine)) 20))
+                       (set! grid (remove-rows-completed (join-grids current-tetramine grid x y)))
+                       (set! current-tetramine next x 6 y 0)
+                       (cond ((collide-grids current-tetramine grid x y) (set! game-over t)))
+                       (set! next (random-tetramine)))
+                      (else
+                       (set! y (+ y 1))
+                       (start-timer timer)))))
+         (draw-texture background)
+         (translate -288 218)
+         (draw-grid (join-grids current-tetramine grid x y))
+         (translate 440 440)
+         (draw-grid next)
+         (translate -40 -100)
+         (render-text (format nil "Points: ~d" (get-points)) font)
+         (translate 0 -30)
+         (render-text (format nil "Lines: ~d" (get-lines)) font))))
+
+(define (run-gacela-tetris)
+  (let ((frame 0.0) (fps (make-timer)) (update (make-timer)))
+    (start-timer update)
+    (start-timer fps)
+    (run-game
+     (game)
+     (set! frame (+ frame 1))
+     (cond ((> (get-time update) 1000)
+           (display (/ frame (/ (get-time fps) 1000.0)))
+           (newline)
+           (start-timer update))))
+    (quit-game)))

diff --git a/src/gacela_widgets.scm b/src/gacela_widgets.scm
index 04f2dcb2a3088c7965ed2c8c236e12e02fd0f085..fedc56338bc3b62e993cba76839896d69b742d31 100755 (executable)
--- a/src/gacela_widgets.scm
+++ b/src/gacela_widgets.scm
@@ -18,26 +18,23 @@
 ;;; Timers
 
 (define (make-timer)
-  '((start . 0) (paused . 0) (state . stopped)))
-
-(define (start-timer timer)
-  (assoc-set! timer 'start (SDL_GetTicks))
-  (assoc-set! timer state 'running))
-
-(define (stop-timer timer)
-  (assoc-set! timer 'state 'stopped))
-
-(define (get-time timer)
-  (cond ((eq? (assoc 'state timer) 'stopped) 0)
-        ((eq? (assoc 'state timer) 'paused) (assoc 'paused timer))
-        (else (- (SDL_GetTicks) (assoc 'start timer)))))
-
-(define (pause-timer timer)
-  (cond ((eq? (assoc 'state timer) 'running)
-         (assoc-set! timer 'paused (- (SDL_GetTicks) (assoc 'start timer)))
-         (assoc-set! timer 'state 'paused))))
-
-(define (resume-timer timer)
-  (cond ((eq? (assoc 'state timer) 'paused)
-         (assoc-set! timer 'start (- (SDL_GetTicks) (assoc 'paused timer)))
-         (assoc-set! timer 'state 'running))))
+  (let ((start 0) (paused 0) (state 'stopped))
+    (lambda (op)
+      (case op
+       (('start-timer)
+        (set! start (SDL_GetTicks))
+        (set! state 'running))
+       (('stop-timer)
+        (set! state 'stopped))
+       (('get-time)
+        (cond ((eq? state 'stopped) 0)
+              ((eq? state 'paused) paused)
+              (else (- (SDL_GetTicks) start))))
+       (('pause-timer)
+        (cond ((eq? state 'running)
+               (set! paused (- (SDL_GetTicks) start))
+               (set! state 'paused))))
+       (('resume-timer)
+        (cond ((eq? state 'paused)
+               (set! start (- (SDL_GetTicks) paused))
+               (set! state 'running))))))))