4 (let ((color '(1 0 0)))
5 `((,color ,color ,color ,color))))
8 (let ((color '(1 0.5 0)))
9 `((,color ,color ,color)
13 (let ((color '(1 0 1)))
15 (,color ,color ,color))))
18 (let ((color '(0 0 1)))
23 (let ((color '(0 1 0)))
25 (,color ,color nil))))
28 (let ((color '(0.5 0 0)))
29 `((,color ,color ,color)
33 (let ((color '(0 1 1)))
35 (nil ,color ,color))))
37 (defun random-tetramine ()
39 (cond ((= n 0) (tetramine-i))
40 ((= n 1) (tetramine-j))
41 ((= n 2) (tetramine-l))
42 ((= n 3) (tetramine-o))
43 ((= n 4) (tetramine-s))
44 ((= n 5) (tetramine-t))
45 ((= n 6) (tetramine-z)))))
47 (defun draw-cell (cell)
48 (cond ((null cell) nil)
49 (t (draw-color cell) (draw-square :size 20))))
52 (mapcar (lambda (cell) (draw-cell cell) (translate 23 0)) row))
54 (defun draw-grid (grid)
55 (mapcar (lambda (row) (draw-row row) (translate (* -23 (length row)) -23)) grid))
57 (defun join-rows (source destination &optional (offset 0))
58 (cond ((null source) destination)
59 ((null destination) nil)
60 ((> offset 0) (cons (car destination) (join-rows source (cdr destination) (- offset 1))))
61 (t (cons (or (car source) (car destination))
62 (join-rows (cdr source) (cdr destination) offset)))))
64 (defun join-grids (source destination &optional (x 0) (y 0))
65 (cond ((null source) destination)
66 ((null destination) nil)
67 ((> y 0) (cons (car destination)
68 (join-grids source (cdr destination) x (- y 1))))
69 (t (cons (join-rows (car source) (car destination) x)
70 (join-grids (cdr source) (cdr destination) x y)))))
72 (defun collide-rows (row1 row2 &optional (offset 0))
73 (cond ((not (or row1 row2)) nil)
74 ((> offset 0) (collide-rows row1 (cdr row2) (- offset 1)))
75 (t (or (and (car row1) (car row2)) (collide-rows (cdr row1) (cdr row2))))))
77 (defun collide-grids (grid1 grid2 &optional (x 0) (y 0))
78 (cond ((not (or grid1 grid2)) nil)
79 ((> y 0) (collide-grids grid1 (cdr grid2) x (- y 1)))
80 (t (or (collide-rows (car grid1) (car grid2) x)
81 (collide-grids (cdr grid1) (cdr grid2) x y)))))
83 (defun rotate-tetramine (grid)
84 (labels ((rot (grid res)
85 (cond ((null grid) res)
86 (t (rot (cdr grid) (mapcar #'cons (car grid) res))))))
87 (rot grid (make-list (length (car grid))))))
89 (defun row-completed (row)
91 (t (and (car row) (row-completed (cdr row))))))
93 (defun remove-rows-completed (grid)
94 (let ((res (remove-if (lambda (x) (row-completed x)) grid)))
95 (labels ((fill (grid n)
97 (t (fill (cons (make-list 14) grid) (- n 1))))))
98 (fill res (- 20 (length res))))))
100 (let ((tetramine (random-tetramine)) (x 6) (y 0)
101 (next (random-tetramine))
103 (grid (make-list 20 :initial-element (make-list 14)))
104 (background (draw-image-function "fondo_tetris.png")))
106 (cond ((eq (timer-state timer) 'stopped) (start-timer timer)))
109 (cond ((not (collide-grids tetramine grid (+ x 1) y))
112 (cond ((not (collide-grids tetramine grid (- x 1) y))
114 (cond ((< x 0) (setq x 0))
115 ((> (+ x (length (car tetramine))) 14) (setq x (- 14 (length (car tetramine))))))
117 (cond ((key-pressed? 'up)
118 (let ((t1 (rotate-tetramine tetramine)))
119 (cond ((not (collide-grids t1 grid x y))
120 (setq tetramine t1))))))
122 (cond ((or (key? 'down) (> (get-time timer) 5000))
123 (cond ((or (collide-grids tetramine grid x (+ y 1))
124 (> (+ y 1 (length tetramine)) 20))
125 (setq grid (remove-rows-completed (join-grids tetramine grid x y)))
126 (setq tetramine next x 6 y 0)
127 (setq next (random-tetramine)))
128 (t (incf y) (start-timer timer)))))
130 ; (draw-square :size 200)))
131 (funcall background)))
132 ; (translate -288 218)
133 ; (draw-grid (join-grids tetramine grid x y))
134 ; (translate 440 440)
137 (let ((frame 0.0) (fps (make-timer)) (update (make-timer)))
140 (run-game "Gacela Tetris"
143 (cond ((> (get-time update) 1000) (print (/ frame (/ (get-time fps) 1000.0))) (start-timer update)))))