gacela_tetris.scm

   1 (set-game-properties #:title "Gacela Tetris" #:fps 15)
   2
   3 (define (tetramine-i)
   4   (let ((color '(1 0 0)))
   5     `((,color ,color ,color ,color))))
   6
   7 (define (tetramine-j)
   8   (let ((color '(1 0.5 0)))
   9     `((,color ,color ,color)
  10       (#f #f ,color))))
  11
  12 (define (tetramine-l)
  13   (let ((color '(1 0 1)))
  14     `((#f #f ,color)
  15       (,color ,color ,color))))
  16
  17 (define (tetramine-o)
  18   (let ((color '(0 0 1)))
  19     `((,color ,color)
  20       (,color ,color))))
  21
  22 (define (tetramine-s)
  23   (let ((color '(0 1 0)))
  24     `((#f ,color ,color)
  25       (,color ,color #f))))
  26
  27 (define (tetramine-t)
  28   (let ((color '(0.5 0 0)))
  29     `((,color ,color ,color)
  30       (#f ,color #f))))
  31
  32 (define (tetramine-z)
  33   (let ((color '(0 1 1)))
  34     `((,color ,color #f)
  35       (#f ,color ,color))))
  36
  37 (define (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 (define (draw-cell cell)
  48   (cond ((null? cell) #f)
  49         (else (with-color cell (draw-square #:size 20)))))
  50
  51 (define (draw-row row)
  52   (for-each (lambda (cell) (draw-cell cell) (translate 23 0)) row))
  53
  54 (define (draw-grid grid)
  55   (for-each (lambda (row) (draw-row row) (translate (* -23 (length row)) -23)) grid))
  56
  57 (define* (join-rows source destination #:optional (offset 0))
  58   (cond ((null? source) destination)
  59         ((null? destination) '())
  60         ((> offset 0) (cons (car destination) (join-rows source (cdr destination) (- offset 1))))
  61         (else (cons (or (car source) (car destination))
  62                     (join-rows (cdr source) (cdr destination) offset)))))
  63
  64 (define* (join-grids source destination #:optional (x 0) (y 0))
  65   (cond ((null? source) destination)
  66         ((null? destination) '())
  67         ((> y 0) (cons (car destination)
  68                        (join-grids source (cdr destination) x (- y 1))))
  69         (else (cons (join-rows (car source) (car destination) x)
  70                     (join-grids (cdr source) (cdr destination) x y)))))
  71
  72 (define* (collide-rows row1 row2 #:optional (offset 0))
  73   (cond ((not (or row1 row2)) #f)
  74         ((> offset 0) (collide-rows row1 (cdr row2) (- offset 1)))
  75         (else (or (and (car row1) (car row2)) (collide-rows (cdr row1) (cdr row2))))))
  76
  77 (define* (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         (else (or (collide-rows (car grid1) (car grid2) x)
  81                   (collide-grids (cdr grid1) (cdr grid2) x y)))))
  82
  83 (define (rotate-tetramine grid)
  84   (define (rot grid res)
  85     (cond ((null? grid) res)
  86           (else (rot (cdr grid) (mapcar #'cons (car grid) res)))))
  87   (rot grid (make-list (length (car grid)))))
  88
  89 (define (row-completed row)
  90   (cond ((null? row) #t)
  91         (else (and (car row) (row-completed (cdr row))))))
  92
  93 (define (remove-rows-completed grid)
  94   (let ((res (remove-if (lambda (x) (row-completed x)) grid)))
  95     (inc-points (- (length grid) (length res)))
  96     (define (fill grid n)
  97       (cond ((< n 1) grid)
  98             (else (fill (cons (make-list 14) grid) (- n 1)))))
  99     (fill res (- 20 (length res)))))
 100
 101 (define get-points #f)
 102 (define get-lines #f)
 103 (define inc-points #f)
 104
 105 (let ((points 0) (lines 0))
 106   (set! get-points
 107         (lambda ()
 108           points))
 109
 110   (set! get-lines
 111         (lambda ()
 112           lines))
 113
 114   (set! inc-points
 115         (lambda (l)
 116           (define (more-lines-better n)
 117             (cond ((= n 0) n)
 118                   (else (+ n (more-lines-better (- n 1))))))
 119           (set! points (+ points (* (more-lines-better l) 10)))
 120           (set! lines (+ lines l)))))
 121
 122 (define game #f)
 123 (define display-game-over #f)
 124 (define tetramine #f)
 125
 126 (let ((current-tetramine (random-tetramine)) (x 6) (y 0)
 127       (next (random-tetramine))
 128       (timer (make-timer))
 129       (grid (make-list 20 (make-list 14)))
 130       (background (load-texture "fondo_tetris.png"))
 131       (font (load-font "lazy.ttf" #:size 20))
 132       (game-over #f))
 133
 134   (set! game
 135         (lambda ()
 136           (if game-over (display-game-over) (tetramine))))
 137
 138   (set! display-game-over
 139         (lambda ()
 140           (translate -100 0)
 141           (render-text "Game Over" font #:size 50)))
 142
 143   (set! tetramine
 144         (lambda ()
 145           (cond ((eq? (get-state timer) 'stopped) (start-timer timer)))
 146
 147           (cond ((key? 'right)
 148                  (cond ((not (collide-grids current-tetramine grid (+ x 1) y))
 149                         (set! x (+ x 1))))))
 150           (cond ((key? 'left)
 151                  (cond ((not (collide-grids current-tetramine grid (- x 1) y))
 152                         (set! x (- x 1))))))
 153           (cond ((< x 0) (set! x 0))
 154                 ((> (+ x (length (car current-tetramine))) 14) (set! x (- 14 (length (car current-tetramine))))))
 155
 156           (cond ((key-pressed? 'up)
 157                  (let ((t1 (rotate-tetramine current-tetramine)))
 158                    (cond ((not (collide-grids t1 grid x y))
 159                           (set! current-tetramine t1))))))
 160
 161           (cond ((or (key? 'down) (> (get-time timer) 5000))
 162                  (cond ((or (collide-grids current-tetramine grid x (+ y 1))
 163                             (> (+ y 1 (length current-tetramine)) 20))
 164                         (set! grid (remove-rows-completed (join-grids current-tetramine grid x y)))
 165                         (set! current-tetramine next x 6 y 0)
 166                         (cond ((collide-grids current-tetramine grid x y) (set! game-over #t)))
 167                         (set! next (random-tetramine)))
 168                        (else
 169                         (set! y (+ y 1))
 170                         (start-timer timer)))))
 171           (draw-texture background)
 172           (translate -288 218)
 173           (draw-grid (join-grids current-tetramine grid x y))
 174           (translate 440 440)
 175           (draw-grid next)
 176           (translate -40 -100)
 177           (render-text (format #f "Points: ~a" (get-points)) font)
 178           (translate 0 -30)
 179           (render-text (format #f "Lines: ~a" (get-lines)) font))))
 180
 181 (define (run-gacela-tetris)
 182   (let ((frame 0.0) (fps (make-timer)) (update (make-timer)))
 183     (start-timer update)
 184     (start-timer fps)
 185     (run-game
 186      (game)
 187      (set! frame (+ frame 1))
 188      (cond ((> (get-time update) 1000)
 189             (display (/ frame (/ (get-time fps) 1000.0)))
 190             (newline)
 191             (start-timer update))))))