├── .gitignore ├── sbcl-make-executable.run ├── package.lisp ├── cl-tetris3d.asd ├── README.md ├── COPYING └── tetris.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | cl-tetris3d 2 | package.fasl 3 | -------------------------------------------------------------------------------- /sbcl-make-executable.run: -------------------------------------------------------------------------------- 1 | #!/usr/bin/sbcl --script 2 | 3 | (load "~/.sbclrc") 4 | ;;(require 'asdf) 5 | ;;(asdf:oos 'asdf:load-op :cl-tetris3d) 6 | (ql:quickload :cl-tetris3d) 7 | (cl-tetris3d:make-executable) 8 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Clone of the original game a tetris. 2 | ;;;; 3 | ;;;; Author: Nedokushev Michael 4 | ;;;; 5 | ;;;; This file released under some license restrictions, 6 | ;;;; see COPYING file. 7 | 8 | (defpackage #:cl-tetris3d 9 | (:use :cl #:iterate) 10 | (:export #:run #:make-executable)) 11 | -------------------------------------------------------------------------------- /cl-tetris3d.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Lisp -*- 2 | ;;;; 3 | ;;;; Clone of the original game a tetris. 4 | ;;;; 5 | ;;;; Author: Nedokushev Michael 6 | ;;;; 7 | ;;;; This file released under some license restrictions, 8 | ;;;; see COPYING file. 9 | 10 | (defpackage #:cl-tetris3d-asd 11 | (:use :cl :asdf)) 12 | 13 | (in-package #:cl-tetris3d-asd) 14 | 15 | (defsystem cl-tetris3d 16 | :name "cl-tetris3d" 17 | :version "0.0.1" 18 | :maintainer "Nedokushev Michael " 19 | :author "Nedokushev Michael " 20 | :license "MIT (also see COPYING file for details)" 21 | :description "Yet another 3D Tetris clone" 22 | :depends-on (#:cl-opengl #:lispbuilder-sdl #:cl-glu #:iterate) 23 | :serial t 24 | :components ((:file "package") 25 | (:file "tetris"))) 26 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # cl-tetris3d 2 | 3 | Yet another 3D tetris. 4 | 5 | ![Screenshot](https://paste.opensuse.org/images/53051428.jpg) 6 | 7 | ## How to run: 8 | 9 | ``` lisp 10 | > (ql:quickload :cl-tetris3d) 11 | > (cl-tetris3d:run) 12 | ``` 13 | 14 | Enjoy! 15 | 16 | ## Controls: 17 | 18 | * A - move figure left 19 | * D - move figure right 20 | * S - move figure down 21 | * space - immediately land figure 22 | * Q - rotate figure counterclockwise 23 | * E - rotate figure clockwise 24 | 25 | * P - pause/unpause 26 | * Esc - quit 27 | * left, right, up, down, page up, page down -- rotate and zoom camera 28 | 29 | 30 | ## Make executable (SBCL Only!): 31 | 32 | There are two ways to do it: 33 | 34 | 1. Run interpeter from shell (it doesn't work within Slime), 35 | and run the following commands from REPL: 36 | ``` 37 | > (ql:quickload :cl-tetris3d) 38 | > (cl-tetris3d:make-executable) 39 | ``` 40 | 41 | 2. Run ```./sbcl-make-executable.run``` script 42 | 43 | After that you should get the ```./cl-tetris3d``` binary. 44 | 45 | 46 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | /******************** Terms of the license of the lispbuilder-sdl **************************/ 2 | CFFI SDL Wrapper and sample code 3 | (C)2006 Justin Heyes-Jones 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of this 6 | software and associated documentation files (the .Software.), to deal in the Software 7 | without restriction, including without limitation the rights to use, copy, modify, merge, 8 | publish, distribute, sublicense, and/or sell copies of the Software, and to permit 9 | persons to whom the Software is furnished to do so, subject to the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included in all copies or 12 | substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED .AS IS., WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING 15 | BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 16 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, 17 | DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 19 | 20 | /********************** Terms of the license of the cl-opengl ***************************/ 21 | Copyright (c) 2004, Oliver Markovic 22 | All rights reserved. 23 | 24 | Redistribution and use in source and binary forms, with or without 25 | modification, are permitted provided that the following conditions are met: 26 | 27 | o Redistributions of source code must retain the above copyright notice, 28 | this list of conditions and the following disclaimer. 29 | o Redistributions in binary form must reproduce the above copyright 30 | notice, this list of conditions and the following disclaimer in the 31 | documentation and/or other materials provided with the distribution. 32 | o Neither the name of the author nor the names of the contributors may be 33 | used to endorse or promote products derived from this software without 34 | specific prior written permission. 35 | 36 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 37 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 38 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 39 | ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE 40 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 41 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 42 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 43 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 44 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 45 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 46 | POSSIBILITY OF SUCH DAMAGE. 47 | -------------------------------------------------------------------------------- /tetris.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Clone of the original game "Tetris". 2 | ;;;; 3 | ;;;; Author: Nedokushev Michael arena (figure arena) 183 | (:method ((figure figure) (arena arena)) 184 | (with-slots (x y body color) figure 185 | (with-slots (field) arena 186 | (do-dotimes-twice ((array-dimension body 0) (array-dimension body 1)) 187 | (when (= (aref body h w) 1) 188 | (setf (aref field (+ y h) (+ x w)) color))))))) 189 | 190 | (defgeneric draw-world (arena figure &key x y z) 191 | (:method ((arena arena) (figure figure) &key x y z) 192 | (with-slots (width height) arena 193 | (gl:clear :color-buffer-bit :depth-buffer-bit) 194 | (gl:push-matrix) 195 | (gl:load-identity) 196 | (gl:translate (- (/ width 2)) (- (/ height 2)) z) 197 | (gl:rotate x 1 0 0) 198 | (gl:rotate y 0 1 0) 199 | (draw-arena arena) 200 | (draw-figure figure arena) 201 | (gl:pop-matrix) 202 | (gl:flush)))) 203 | 204 | (defgeneric draw-figure (figure arena) 205 | (:method ((figure figure) (arena arena)) 206 | (with-slots (x y color body) figure 207 | (with-slots (width height) arena 208 | (case color 209 | (:red (gl:color 1 0 0)) 210 | (:yellow (gl:color 1 1 0)) 211 | (:blue (gl:color 0 0 1))) 212 | (gl:polygon-mode :front-and-back :fill) 213 | (do-dotimes-twice ((array-dimension body 0) (array-dimension body 1)) 214 | (when (= (aref body h w) 1) 215 | (gl:push-matrix) 216 | (gl:translate (+ (* w 2) (* x 2)) (+ (* h 2) (* y 2)) 0) 217 | (build-cube height width) 218 | (gl:pop-matrix))))))) 219 | 220 | (defgeneric move-figure (figure arena &key move-sideways) 221 | (:method ((figure figure) (arena arena) &key move-sideways) 222 | (flet ((walls-collision-p (figure arena) 223 | (with-slots (x y x-d body) figure 224 | (with-slots (width height field) arena 225 | (let ((figure-h (array-dimension body 0)) 226 | (figure-w (array-dimension body 1)) 227 | (next-x (+ x x-d))) 228 | (when (or (< next-x 0) 229 | (> (+ next-x figure-w) width) 230 | (block walls 231 | (do-dotimes-twice (figure-h figure-w) 232 | (when (and (< (+ y h) height) (= (aref body h w) 1)) 233 | (when (not (null (aref field (+ y h) (+ next-x w)))) 234 | (return-from walls t)))))) 235 | t))))) 236 | (floor-collision-p (figure arena) 237 | (with-slots (x y body) figure 238 | (with-slots (width height field) arena 239 | (let ((next-y (1- y)) 240 | (figure-h (array-dimension body 0)) 241 | (figure-w (array-dimension body 1))) 242 | (if (< next-y 0) 243 | t 244 | (do-dotimes-twice (figure-h figure-w) 245 | (when (and (< (+ next-y h) height) (= (aref body h w) 1)) 246 | (when (not (null (aref field (+ next-y h) (+ x w)))) 247 | (return-from floor-collision-p t)))))))))) 248 | (with-slots (x y x-d body) figure 249 | (with-slots (width height field) arena 250 | (let ((terminate nil)) 251 | (when (not (walls-collision-p figure arena)) 252 | (setf x (+ x x-d))) 253 | (if (not move-sideways) 254 | (if (not (floor-collision-p figure arena)) 255 | (setf y (- y 1)) 256 | (setf terminate t))) 257 | (setf x-d 0) 258 | terminate)))))) 259 | 260 | (defgeneric rotate-collision-p (figure arena) 261 | (:method ((figure figure) (arena arena)) 262 | (with-slots (width height field) arena 263 | (with-slots (x y body) figure 264 | (do-dotimes-twice ((array-dimension body 0) (array-dimension body 1)) 265 | (when (and (= (aref body h w) 1) (< (+ y h) height)) 266 | (when (or (< (+ x w) 0) 267 | (>= (+ x w) width) 268 | (< (+ y h) 0) 269 | (not (null (aref field (+ y h) (+ x w))))) 270 | (return-from rotate-collision-p t)))))))) 271 | 272 | (defgeneric choose-figure (figure arena) 273 | (:method ((figure figure) (arena arena)) 274 | (setf *random-state* (make-random-state t)) 275 | (let ((choise (random 7))) 276 | (with-slots (x y) figure 277 | (with-slots (width height) arena 278 | (setf x (1- (floor (/ width 2))) 279 | y height))) 280 | (setf (body figure) (nth choise *figures*)) 281 | figure))) 282 | 283 | (defun run (&key (width 480) (height 640) (bpp 32)) 284 | (sdl:with-init () 285 | (unless (sdl:window width height 286 | :bpp bpp 287 | :opengl t 288 | :opengl-attributes '((:sdl-gl-doublebuffer 1))) 289 | (error "~&Unable to create a SDL window~%")) 290 | (setf (sdl:frame-rate) 40) 291 | (sdl:enable-key-repeat 50 50) 292 | (gl-init width height) 293 | 294 | ;; Print "Key Bindings" 295 | (format t "Key Bindings:~%~ 296 | a: move figure λeft ~%~ 297 | d: move current figure right ~%~ 298 | s: move current figure down ~%~ 299 | q: rotate figure counterclockwise ~%~ 300 | e: rotate figure clockwise ~%~ 301 | space: immediateλy land figure ~%~ 302 | λeft: rotate camera left ~%~ 303 | right: rotate camera right ~%~ 304 | down: rotate camera down ~%~ 305 | up: rotate camera up ~%~ 306 | page down: zoom in camera ~%~ 307 | page up: zoom out camera ~%~ 308 | p: pause/unpause ~%~ 309 | Esc: quit ~%~%") 310 | (format t "Get ready! We start the game!~%~%") 311 | 312 | (let* ((arena 313 | (make-instance 'arena 314 | :width 10 315 | :height 18 316 | :field (make-array '(18 10) :initial-element nil))) 317 | (figure (choose-figure (make-instance 'figure) arena)) 318 | (ticks (sdl:system-ticks)) 319 | (run t) 320 | (score 0) 321 | (level-score 0) 322 | (hz 3) 323 | (level 0) 324 | (z -42) 325 | (x 8) 326 | (y -18)) 327 | (sdl:with-events () 328 | (:quit-event () t) 329 | (:key-down-event (:key key) 330 | (cond ((eq key :SDL-KEY-ESCAPE) 331 | (sdl:push-quit-event)) 332 | ((eq key :SDL-KEY-p) 333 | (if run 334 | (progn 335 | (format t "~%Game is paused!~%") 336 | (setf run nil)) 337 | (progn 338 | (format t "Game is unpaused!~%~%") 339 | (setf run t)))) 340 | ((eq key :SDL-KEY-PAGEUP) 341 | (unless (> (+ z 2) -38) 342 | (setf z (+ z 2)))) 343 | ((eq key :SDL-KEY-PAGEDOWN) 344 | (when (> (- z 2) -80) 345 | (setf z (- z 2)))) 346 | ((eq key :SDL-KEY-RIGHT) 347 | (setf y (+ y 2))) 348 | ((eq key :SDL-KEY-LEFT) 349 | (setf y (- y 2))) 350 | ((eq key :SDL-KEY-UP) 351 | (setf x (+ x 2))) 352 | ((eq key :SDL-KEY-DOWN) 353 | (setf x (- x 2))) 354 | ((eq key :SDL-KEY-SPACE) 355 | (do () 356 | ((move-figure figure arena)))) 357 | ((eq key :SDL-KEY-a) 358 | (setf (slot-value figure 'x-d) -1) 359 | (move-figure figure arena :move-sideways t)) 360 | ((eq key :SDL-KEY-d) 361 | (setf (slot-value figure 'x-d) 1) 362 | (move-figure figure arena :move-sideways t)) 363 | ((eq key :SDL-KEY-s) 364 | (move-figure figure arena)) 365 | ((eq key :SDL-KEY-e) 366 | (with-slots (x y color body) figure 367 | (let ((tmp (make-instance 'figure 368 | :x x 369 | :y y 370 | :color color 371 | :body body))) 372 | (rotate-figure-clockwise tmp) 373 | (unless (rotate-collision-p tmp arena) 374 | (rotate-figure-clockwise figure))))) 375 | ((eq key :SDL-KEY-q) 376 | (with-slots (x y color body) figure 377 | (let ((tmp (make-instance 'figure 378 | :x x 379 | :y y 380 | :color color 381 | :body body))) 382 | (rotate-figure-counterclockwise tmp) 383 | (unless (rotate-collision-p tmp arena) 384 | (rotate-figure-counterclockwise figure))))))) 385 | 386 | (:idle () 387 | (when run 388 | (when (> (- (sdl:system-ticks) ticks) (/ 1000 hz)) 389 | (when (move-figure figure arena) 390 | (if (> (+ (slot-value figure 'y) 391 | (array-dimension (slot-value figure 'body) 0)) 392 | (slot-value arena 'height)) 393 | (progn 394 | (format t "~%ᴪᴪᴪ Game Over ᴪᴪᴪ~%") 395 | (sdl:push-quit-event)) 396 | (progn 397 | (figure->arena figure arena) 398 | (let ((lines (vanish-lines arena))) 399 | (case lines 400 | (4 (progn (incf score 1000) 401 | (incf level-score 1000))) 402 | (3 (progn (incf score 600) 403 | (incf level-score 600))) 404 | (2 (progn (incf score 300) 405 | (incf level-score 300))) 406 | (1 (progn (incf score 100) 407 | (incf level-score 100))))) 408 | (when (> level-score (* hz (* hz 100))) 409 | (format t "~%You have reached λevel ~d! Congratuλations!~%~%" (+ level 1)) 410 | (incf hz) 411 | (incf level) 412 | (setf level-score 0)) 413 | (setf figure (choose-figure figure arena)) 414 | (setf (slot-value figure 'color) (random-color)) 415 | (format t "λevel: ~d | speed: ~d | score: ~d.~%" 416 | level hz score) 417 | (finish-output)))) 418 | (setf ticks (sdl:system-ticks)))) 419 | (draw-world arena figure :x x :y y :z z) 420 | (sdl:update-display)))))) 421 | 422 | (defun make-executable () 423 | #+sbcl (sb-ext:save-lisp-and-die "cl-tetris3d" :toplevel #'cl-tetris3d:run :executable t)) 424 | --------------------------------------------------------------------------------