gacela_tetris.lisp

   1 (in-package :gacela)
   2
   3 (defun tetramine-i ()
   4   (let ((color '(1 0 0)))
   5     `((,color ,color ,color ,color))))
   6
   7 (defun tetramine-j ()
   8   (let ((color '(1 0.5 0)))
   9     `((,color ,color ,color)
  10       (nil nil ,color))))
  11
  12 (defun tetramine-l ()
  13   (let ((color '(1 0 1)))
  14     `((nil nil ,color)
  15       (,color ,color ,color))))
  16
  17 (defun tetramine-o ()
  18   (let ((color '(0 0 1)))
  19     `((,color ,color)
  20       (,color ,color))))
  21
  22 (defun tetramine-s ()
  23   (let ((color '(0 1 0)))
  24     `((nil ,color ,color)
  25       (,color ,color nil))))
  26
  27 (defun tetramine-t ()
  28   (let ((color '(0.5 0 0)))
  29     `((,color ,color ,color)
  30       (nil ,color nil))))
  31
  32 (defun tetramine-z ()
  33   (let ((color '(0 1 1)))
  34     `((,color ,color nil)
  35       (nil ,color ,color))))
  36
  37 (defun random-tetramine ()
  38   (let ((n (random 7)))
  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)))))
  46
  47 (defun draw-cell (cell)
  48   (cond ((null cell) nil)
  49         (t (draw-color cell) (draw-square :size 20))))
  50
  51 (defun draw-row (row)
  52   (mapcar (lambda (cell) (draw-cell cell) (translate 23 0)) row))
  53
  54 (defun draw-grid (grid)
  55   (mapcar (lambda (row) (draw-row row) (translate (* -23 (length row)) -23)) grid))
  56
  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)))))
  63
  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)))))
  71
  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))))))
  76
  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)))))
  82
  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))))))
  88
  89 (defun row-completed (row)
  90   (cond ((null row) t)
  91         (t (and (car row) (row-completed (cdr row))))))
  92
  93 (defun remove-rows-completed (grid)
  94   (let ((res (remove-if (lambda (x) (row-completed x)) grid)))
  95     (labels ((fill (grid n)
  96                    (cond ((< n 1) grid)
  97                          (t (fill (cons (make-list 14) grid) (- n 1))))))
  98             (fill res (- 20 (length res))))))
  99
 100 (let ((tetramine (random-tetramine)) (x 6) (y 0)
 101       (next (random-tetramine))
 102       (timer (make-timer))
 103       (grid (make-list 20 :initial-element (make-list 14)))   ;320x460
 104       (background (draw-image-function "fondo_tetris.png")))
 105   (defun tetramine ()
 106     (cond ((eq (timer-state timer) 'stopped) (start-timer timer)))
 107
 108     (cond ((key? 'right)
 109            (cond ((not (collide-grids tetramine grid (+ x 1) y))
 110                   (incf x)))))
 111     (cond ((key? 'left)
 112            (cond ((not (collide-grids tetramine grid (- x 1) y))
 113                   (decf x)))))
 114     (cond ((< x 0) (setq x 0))
 115           ((> (+ x (length (car tetramine))) 14) (setq x (- 14 (length (car tetramine))))))
 116
 117     (cond ((key-pressed? 'up)
 118            (let ((t1 (rotate-tetramine tetramine)))
 119              (cond ((not (collide-grids t1 grid x y))
 120                     (setq tetramine t1))))))
 121
 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)))))
 129
 130     (funcall background)
 131     (translate -288 218)
 132     (draw-grid (join-grids tetramine grid x y))
 133     (translate 440 440)
 134     (draw-grid next)))
 135
 136 (run-game "Gacela Tetris" (tetramine))