3 (set-frames-per-second 15)
6 (let ((color '(1 0 0)))
7 `((,color ,color ,color ,color))))
10 (let ((color '(1 0.5 0)))
11 `((,color ,color ,color)
15 (let ((color '(1 0 1)))
17 (,color ,color ,color))))
20 (let ((color '(0 0 1)))
25 (let ((color '(0 1 0)))
27 (,color ,color nil))))
30 (let ((color '(0.5 0 0)))
31 `((,color ,color ,color)
35 (let ((color '(0 1 1)))
37 (nil ,color ,color))))
39 (defun random-tetramine ()
41 (cond ((= n 0) (tetramine-i))
42 ((= n 1) (tetramine-j))
43 ((= n 2) (tetramine-l))
44 ((= n 3) (tetramine-o))
45 ((= n 4) (tetramine-s))
46 ((= n 5) (tetramine-t))
47 ((= n 6) (tetramine-z)))))
49 (defun draw-cell (cell)
50 (cond ((null cell) nil)
51 (t (with-color cell (draw-square :size 20)))))
54 (mapcar (lambda (cell) (draw-cell cell) (translate 23 0)) row))
56 (defun draw-grid (grid)
57 (mapcar (lambda (row) (draw-row row) (translate (* -23 (length row)) -23)) grid))
59 (defun join-rows (source destination &optional (offset 0))
60 (cond ((null source) destination)
61 ((null destination) nil)
62 ((> offset 0) (cons (car destination) (join-rows source (cdr destination) (- offset 1))))
63 (t (cons (or (car source) (car destination))
64 (join-rows (cdr source) (cdr destination) offset)))))
66 (defun join-grids (source destination &optional (x 0) (y 0))
67 (cond ((null source) destination)
68 ((null destination) nil)
69 ((> y 0) (cons (car destination)
70 (join-grids source (cdr destination) x (- y 1))))
71 (t (cons (join-rows (car source) (car destination) x)
72 (join-grids (cdr source) (cdr destination) x y)))))
74 (defun collide-rows (row1 row2 &optional (offset 0))
75 (cond ((not (or row1 row2)) nil)
76 ((> offset 0) (collide-rows row1 (cdr row2) (- offset 1)))
77 (t (or (and (car row1) (car row2)) (collide-rows (cdr row1) (cdr row2))))))
79 (defun collide-grids (grid1 grid2 &optional (x 0) (y 0))
80 (cond ((not (or grid1 grid2)) nil)
81 ((> y 0) (collide-grids grid1 (cdr grid2) x (- y 1)))
82 (t (or (collide-rows (car grid1) (car grid2) x)
83 (collide-grids (cdr grid1) (cdr grid2) x y)))))
85 (defun rotate-tetramine (grid)
86 (labels ((rot (grid res)
87 (cond ((null grid) res)
88 (t (rot (cdr grid) (mapcar #'cons (car grid) res))))))
89 (rot grid (make-list (length (car grid))))))
91 (defun row-completed (row)
93 (t (and (car row) (row-completed (cdr row))))))
95 (defun remove-rows-completed (grid)
96 (let ((res (remove-if (lambda (x) (row-completed x)) grid)))
97 (inc-points (- (length grid) (length res)))
98 (labels ((fill (grid n)
100 (t (fill (cons (make-list 14) grid) (- n 1))))))
101 (fill res (- 20 (length res))))))
103 (let ((points 0) (lines 0))
110 (defun inc-points (l)
112 (labels ((more-lines-better
115 (let ((tetramine (random-tetramine)) (x 6) (y 0)
116 (next (random-tetramine))
118 (grid (make-list 20 :initial-element (make-list 14)))
119 (background (draw-image-function "fondo_tetris.png"))
120 (font (load-font "lazy.ttf" :size 20)))
122 (cond ((eq (timer-state timer) 'stopped) (start-timer timer)))
125 (cond ((not (collide-grids tetramine grid (+ x 1) y))
128 (cond ((not (collide-grids tetramine grid (- x 1) y))
130 (cond ((< x 0) (setq x 0))
131 ((> (+ x (length (car tetramine))) 14) (setq x (- 14 (length (car tetramine))))))
133 (cond ((key-pressed? 'up)
134 (let ((t1 (rotate-tetramine tetramine)))
135 (cond ((not (collide-grids t1 grid x y))
136 (setq tetramine t1))))))
138 (cond ((or (key? 'down) (> (get-time timer) 5000))
139 (cond ((or (collide-grids tetramine grid x (+ y 1))
140 (> (+ y 1 (length tetramine)) 20))
141 (setq grid (remove-rows-completed (join-grids tetramine grid x y)))
142 (setq tetramine next x 6 y 0)
143 (setq next (random-tetramine)))
144 (t (incf y) (start-timer timer)))))
147 (draw-grid (join-grids tetramine grid x y))
151 (render-text (format nil "Points: ~d" (get-points)) font)
153 (render-text (format nil "Lines: ~d" (get-lines)) font)))
155 (let ((frame 0.0) (fps (make-timer)) (update (make-timer)))
158 (run-game "Gacela Tetris"
161 (cond ((> (get-time update) 1000) (print (/ frame (/ (get-time fps) 1000.0))) (start-timer update)))))