From: jsancho Date: Fri, 26 Aug 2011 11:51:39 +0000 (+0000) Subject: (no commit message) X-Git-Url: https://git.jsancho.org/?a=commitdiff_plain;h=ef93ec59bb8aef38efdace21f86da55e2dc7cd6d;p=gacela.git --- diff --git a/fondo_tetris.png b/fondo_tetris.png deleted file mode 100644 index c2530d0..0000000 Binary files a/fondo_tetris.png and /dev/null differ diff --git a/gacela_tetris.scm b/gacela_tetris.scm deleted file mode 100644 index d27a086..0000000 --- a/gacela_tetris.scm +++ /dev/null @@ -1,192 +0,0 @@ -(set-game-properties! #:title "Gacela Tetris" #:fps 15) - -(define (tetramine-i) - (let ((color '(1 0 0))) - `((,color ,color ,color ,color)))) - -(define (tetramine-j) - (let ((color '(1 0.5 0))) - `((,color ,color ,color) - (#f #f ,color)))) - -(define (tetramine-l) - (let ((color '(1 0 1))) - `((#f #f ,color) - (,color ,color ,color)))) - -(define (tetramine-o) - (let ((color '(0 0 1))) - `((,color ,color) - (,color ,color)))) - -(define (tetramine-s) - (let ((color '(0 1 0))) - `((#f ,color ,color) - (,color ,color #f)))) - -(define (tetramine-t) - (let ((color '(0.5 0 0))) - `((,color ,color ,color) - (#f ,color #f)))) - -(define (tetramine-z) - (let ((color '(0 1 1))) - `((,color ,color #f) - (#f ,color ,color)))) - -(define (random-tetramine) - (let ((n (random 7))) - (cond ((= n 0) (tetramine-i)) - ((= n 1) (tetramine-j)) - ((= n 2) (tetramine-l)) - ((= n 3) (tetramine-o)) - ((= n 4) (tetramine-s)) - ((= n 5) (tetramine-t)) - ((= n 6) (tetramine-z))))) - -(define (draw-cell cell) - (cond ((and cell (not (null? cell))) - (with-color cell (draw-square #:size 20))))) - -(define (draw-row row) - (for-each (lambda (cell) (draw-cell cell) (translate 23 0)) row)) - -(define (draw-grid grid) - (for-each (lambda (row) (draw-row row) (translate (* -23 (length row)) -23)) grid)) - -(define* (join-rows source destination #:optional (offset 0)) - (cond ((null? source) destination) - ((null? destination) '()) - ((> offset 0) (cons (car destination) (join-rows source (cdr destination) (- offset 1)))) - (else (cons (or (car source) (car destination)) - (join-rows (cdr source) (cdr destination) offset))))) - -(define* (join-grids source destination #:optional (x 0) (y 0)) - (cond ((null? source) destination) - ((null? destination) '()) - ((> y 0) (cons (car destination) - (join-grids source (cdr destination) x (- y 1)))) - (else (cons (join-rows (car source) (car destination) x) - (join-grids (cdr source) (cdr destination) x y))))) - -(define* (collide-rows row1 row2 #:optional (offset 0)) - (cond ((or (null? row1) (null? row2)) #f) - ((> offset 0) (collide-rows row1 (cdr row2) (- offset 1))) - (else (or (and (car row1) (car row2)) (collide-rows (cdr row1) (cdr row2)))))) - -(define* (collide-grids grid1 grid2 #:optional (x 0) (y 0)) - (cond ((or (null? grid1) (null? grid2)) #f) - ((> y 0) (collide-grids grid1 (cdr grid2) x (- y 1))) - (else (or (collide-rows (car grid1) (car grid2) x) - (collide-grids (cdr grid1) (cdr grid2) x y))))) - -(define (rotate-tetramine grid) - (define (rot grid res) - (cond ((null? grid) res) - (else (rot (cdr grid) (map cons (car grid) res))))) - (rot grid (make-list (length (car grid))))) - -(define (row-completed row) - (cond ((null? row) #t) - (else (and (car row) (row-completed (cdr row)))))) - -(define (remove-rows-completed grid) - (let ((res (filter (lambda (x) (not (row-completed x))) grid))) - (define (fill grid n) - (cond ((< n 1) grid) - (else (fill (cons (make-list 14 #f) grid) (- n 1))))) - (inc-points (- (length grid) (length res))) - (fill res (- 20 (length res))))) - -(define get-points #f) -(define get-lines #f) -(define inc-points #f) - -(let ((points 0) (lines 0)) - (set! get-points - (lambda () - points)) - - (set! get-lines - (lambda () - lines)) - - (set! inc-points - (lambda (l) - (define (more-lines-better n) - (cond ((= n 0) n) - (else (+ n (more-lines-better (- n 1)))))) - (set! points (+ points (* (more-lines-better l) 10))) - (set! lines (+ lines l))))) - -(define game #f) -(define display-game-over #f) -(define tetramine #f) - -(let ((current-tetramine (random-tetramine)) (x 6) (y 0) - (next (random-tetramine)) - (timer (make-timer)) - (grid (make-list 20 (make-list 14 #f))) - (background (load-texture "fondo_tetris.png")) - (font (load-font "lazy.ttf" #:size 20)) - (game-over #f)) - - (set! game - (lambda () - (if game-over (display-game-over) (tetramine)))) - - (set! display-game-over - (lambda () - (translate -100 0) - (render-text "Game Over" font #:size 50))) - - (set! tetramine - (lambda () - (cond ((eq? (get-state timer) 'stopped) (start-timer timer))) - - (cond ((key? 'right) - (cond ((not (collide-grids current-tetramine grid (+ x 1) y)) - (set! x (+ x 1)))))) - (cond ((key? 'left) - (cond ((not (collide-grids current-tetramine grid (- x 1) y)) - (set! x (- x 1)))))) - (cond ((< x 0) (set! x 0)) - ((> (+ x (length (car current-tetramine))) 14) (set! x (- 14 (length (car current-tetramine)))))) - - (cond ((key-pressed? 'up) - (let ((t1 (rotate-tetramine current-tetramine))) - (cond ((not (collide-grids t1 grid x y)) - (set! current-tetramine t1)))))) - - (cond ((or (key? 'down) (> (get-time timer) 5000)) - (cond ((or (collide-grids current-tetramine grid x (+ y 1)) - (> (+ y 1 (length current-tetramine)) 20)) - (set! grid (remove-rows-completed (join-grids current-tetramine grid x y))) - (set! current-tetramine next) - (set! x 6) - (set! y 0) - (cond ((collide-grids current-tetramine grid x y) (set! game-over #t))) - (set! next (random-tetramine))) - (else - (set! y (+ y 1)) - (start-timer timer))))) - (draw-texture background) - (translate -288 218) - (draw-grid (join-grids current-tetramine grid x y)) - (translate 440 440) - (draw-grid next) - (translate -40 -100) - (render-text (format #f "Points: ~a" (get-points)) font) - (translate 0 -30) - (render-text (format #f "Lines: ~a" (get-lines)) font)))) - -(let ((frame 0.0) (fps (make-timer)) (update (make-timer))) - (start-timer update) - (start-timer fps) - (run-game - (game) - (set! frame (+ frame 1)) - (cond ((> (get-time update) 1000) - (display (/ frame (/ (get-time fps) 1000.0))) - (newline) - (start-timer update))))) diff --git a/game.lisp b/game.lisp deleted file mode 100755 index 4431257..0000000 --- a/game.lisp +++ /dev/null @@ -1,33 +0,0 @@ -;(show-mob (make-mob :x 0 :y 0 :image (filled-rect 5 420) :tags '(wall))) -;(show-mob (make-mob :x 635 :y 0 :image (filled-rect 5 420) :tags '(wall))) -;(show-mob (make-mob :x 0 :y 0 :image (filled-rect 640 5) :tags '(wall))) - -;(show-mob (make-mob :x 280 :y 420 :image (filled-rect 80 20) :tags '(wall) -; :logic (movement-with-cursors :xvel 200 :yvel 0))) - -;(let ((xvel 100) (yvel -100)) -; (show-mob (make-mob :x 300 :y 200 :image (filled-circle 7) -; :logic (progn -; (cond ((> y 480) (setq x 300 y 200 xvel 100 yvel -100)) -; (t (let ((c (collision '(wall)))) -; (cond ((null c) nil) -; ((= c (neg (/ pi 2))) (setq yvel (neg (- yvel 10)))) -; ((= c (/ pi 2)) (setq yvel (neg (+ yvel 10)))) -; ((= c 0) (setq xvel (neg (+ xvel 10)))) -; ((= c pi) (setq xvel (neg (- xvel 10)))))))) -; (movement :xvel xvel :yvel yvel))))) - -;(run-game) -;(quit-game) - -(let ((r 0)) - (gacela::makemob cuadrado - :render (lambda () - (gacela::rotate 0 0 r) - (incf r 5) - (gacela::draw-cube :size 40)))) - -;(cuadrado :on) -(gacela::start-skin-client 1984) - -(gacela::run-game "Prueba Mobs") diff --git a/game_GL.lisp b/game_GL.lisp deleted file mode 100755 index d717a81..0000000 --- a/game_GL.lisp +++ /dev/null @@ -1,68 +0,0 @@ -(let ((rtri 0) (rquad 0)) - (defun game () - (glTranslatef -1.5 0 -10) - (glRotatef rtri 0 1 0) - (draw '((1 0 0) (0 1 0)) '((0 1 0) (-1 -1 1)) '((0 0 1) (1 -1 1))) - (draw '((1 0 0) (0 1 0)) '((0 0 1) (1 -1 1)) '((0 1 0) (1 -1 -1))) - (draw '((1 0 0) (0 1 0)) '((0 1 0) (1 -1 -1)) '((0 0 1) (-1 -1 -1))) - (draw '((1 0 0) (0 1 0)) '((0 0 1) (-1 -1 -1)) '((0 1 0) (-1 -1 1))) - - (glTranslatef 3 0 0) - (glRotatef rquad 1 0 0) - (draw-color '(0 1 0)) - (draw '(1 1 -1) '(-1 1 -1) '(-1 1 1) '(1 1 1)) - (draw-color '(1 0.5 0)) - (draw '(1 -1 1) '(-1 -1 1) '(-1 -1 -1) '(1 -1 -1)) - (draw-color '(1 0 0)) - (draw '(1 1 1) '(-1 1 1) '(-1 -1 1) '(1 -1 1)) - (draw-color '(1 1 0)) - (draw '(1 -1 -1) '(-1 -1 -1) '(-1 1 -1) '(1 1 -1)) - (draw-color '(0 0 1)) - (draw '(-1 1 1) '(-1 1 -1) '(-1 -1 -1) '(-1 -1 1)) - (draw-color '(1 0 1)) - (draw '(1 1 -1) '(1 1 1) '(1 -1 1) '(1 -1 -1)) - - (incf rtri 0.2) - (incf rquad -0.15))) - -(let ((rquad 0) (texture (load-texture "../nehe/lesson06/data/nehe.bmp"))) - (defun cube-texture () - (glTranslatef -1.5 0 -10) - (glRotatef rquad 0 1 0) - (draw-quad '(1 1 -1) '(-1 1 -1) '(-1 1 1) '(1 1 1) :texture texture) - (draw-quad '(1 -1 1) '(-1 -1 1) '(-1 -1 -1) '(1 -1 -1) :texture texture) - (draw-quad '(1 1 1) '(-1 1 1) '(-1 -1 1) '(1 -1 1) :texture texture) - (draw-quad '(1 -1 -1) '(-1 -1 -1) '(-1 1 -1) '(1 1 -1) :texture texture) - (draw-quad '(-1 1 1) '(-1 1 -1) '(-1 -1 -1) '(-1 -1 1) :texture texture) - (draw-quad '(1 1 -1) '(1 1 1) '(1 -1 1) '(1 -1 -1) :texture texture) - (incf rquad 0.2))) - -(let ((xrot 0) (yrot 0) (zrot 0) - (texture (load-texture "../nehe/lesson07/data/crate.bmp")) - (light (add-light :light '(1 1 1 1) :position '(0 0 2 1) :ambient '(0.5 0.5 0.5 1)))) - (defun quad () - (glLoadIdentity) - (glColor3f 1 1 1) - (glEnable GL_TEXTURE_2D) - (glTranslatef -2 0 -13) - (rotate xrot yrot zrot) - (draw-cube :size 1 :texture texture) - (incf xrot 0.3) - (incf yrot 0.2) - (incf zrot 0.4))) - -(let ((xrot 0) (yrot 0) (zrot 0) - (texture (load-texture "../nehe/lesson08/data/glass.bmp"))) - (defun quad2 () - (glLoadIdentity) - (glColor3f 1 1 1) - (glEnable GL_TEXTURE_2D) - (glTranslatef 2 0 -13) - (rotate xrot yrot zrot) - (draw-cube :size 1 :texture texture) - (incf xrot -0.3) - (incf yrot -0.2) - (incf zrot -0.4))) - -(run-game "GL Test" (quad) (quad2)) -(quit-game) diff --git a/game_test.lisp b/game_test.lisp deleted file mode 100755 index 280ef76..0000000 --- a/game_test.lisp +++ /dev/null @@ -1,18 +0,0 @@ -(show-mob (make-mob :x 0 :y 0 :image (filled-rect 5 420) :tags '(wall) - :logic (cond ((key 'up) (incf x 5)) - ((key 'down) (decf x 5))))) - -(show-mob (make-mob :x 635 :y 0 :image (filled-rect 5 420) :tags '(wall) - :logic (cond ((key 'up) (decf x 5)) - ((key 'down) (incf x 5))))) - -(let ((xvel 100) (yvel 0)) - (show-mob (make-mob :x 300 :y 200 :image (filled-circle 7) - :logic (progn - (cond ((key 'plus) (if (> xvel 0) (incf xvel 10) (decf xvel 10))) - ((key 'minus) (if (> xvel 0) (decf xvel 10) (incf xvel 10)))) - (cond ((collision '(wall)) (setq xvel (neg xvel)))) - (movement :xvel xvel :yvel yvel))))) - -(run-game) -(quit-game) diff --git a/games/asteroids/asteroids.scm b/games/asteroids/asteroids.scm index a1e23f6..6d477e5 100644 --- a/games/asteroids/asteroids.scm +++ b/games/asteroids/asteroids.scm @@ -1,5 +1,10 @@ (set-game-properties! #:title "Gacela Asteroids") +(define max-x (/ (cdr (assoc 'width (get-game-properties))) 2)) +(define min-x (- max-x)) +(define max-y (/ (cdr (assoc 'height (get-game-properties))) 2)) +(define min-y (- max-y)) + (define draw-asteroid (let ((asteroid (load-texture "Asteroid.png"))) (lambda (a) @@ -11,13 +16,34 @@ (let* ((x (car a)) (y (cadr a)) (vx (caddr a)) (vy (cadddr a)) (nx (+ x vx)) (ny (+ y vy))) - (cond ((> nx 320) (set! vx -1)) - ((< nx -320) (set! vx 1))) - (cond ((> ny 240) (set! vy -1)) - ((< ny -240) (set! vy 1))) + (cond ((> nx max-x) (set! vx -1)) + ((< nx min-x) (set! vx 1))) + (cond ((> ny max-y) (set! vy -1)) + ((< ny min-y) (set! vy 1))) (list (+ x vx) (+ y vy) vx vy))) -(let ((asteroids '((100 100 1 1) (-100 -100 -1 1)))) +(define draw-ship + (let ((ship1 (load-texture "Ship1.png")) + (ship2 (load-texture "Ship2.png"))) + (lambda (s) + (to-origin) + (translate (car s) (cadr s)) + (rotate (caddr s)) + (draw-texture ship1)))) + +(define (move-ship s) + (let ((x (car s)) (y (cadr s)) + (angle (caddr s)) + (vx (cadddr s)) (vy (cadddr (cdr s)))) + (cond ((key? 'left) (set! angle (+ angle 5))) + ((key? 'right) (set! angle (- angle 5)))) + (cond ((key? 'up) (set! y (+ y 3)))) + (list x y angle vx vy))) + +(let ((asteroids '((100 100 1 1) (-100 -100 -1 1))) + (ship '(0 0 0 0 0))) (run-game (set! asteroids (map move-asteroid asteroids)) - (for-each draw-asteroid asteroids))) + (set! ship (move-ship ship)) + (for-each draw-asteroid asteroids) + (draw-ship ship))) diff --git a/games/tetris/fondo_tetris.png b/games/tetris/fondo_tetris.png new file mode 100644 index 0000000..c2530d0 Binary files /dev/null and b/games/tetris/fondo_tetris.png differ diff --git a/games/tetris/lazy.ttf b/games/tetris/lazy.ttf new file mode 100644 index 0000000..eb1000b Binary files /dev/null and b/games/tetris/lazy.ttf differ diff --git a/games/tetris/tetris.scm b/games/tetris/tetris.scm new file mode 100644 index 0000000..d27a086 --- /dev/null +++ b/games/tetris/tetris.scm @@ -0,0 +1,192 @@ +(set-game-properties! #:title "Gacela Tetris" #:fps 15) + +(define (tetramine-i) + (let ((color '(1 0 0))) + `((,color ,color ,color ,color)))) + +(define (tetramine-j) + (let ((color '(1 0.5 0))) + `((,color ,color ,color) + (#f #f ,color)))) + +(define (tetramine-l) + (let ((color '(1 0 1))) + `((#f #f ,color) + (,color ,color ,color)))) + +(define (tetramine-o) + (let ((color '(0 0 1))) + `((,color ,color) + (,color ,color)))) + +(define (tetramine-s) + (let ((color '(0 1 0))) + `((#f ,color ,color) + (,color ,color #f)))) + +(define (tetramine-t) + (let ((color '(0.5 0 0))) + `((,color ,color ,color) + (#f ,color #f)))) + +(define (tetramine-z) + (let ((color '(0 1 1))) + `((,color ,color #f) + (#f ,color ,color)))) + +(define (random-tetramine) + (let ((n (random 7))) + (cond ((= n 0) (tetramine-i)) + ((= n 1) (tetramine-j)) + ((= n 2) (tetramine-l)) + ((= n 3) (tetramine-o)) + ((= n 4) (tetramine-s)) + ((= n 5) (tetramine-t)) + ((= n 6) (tetramine-z))))) + +(define (draw-cell cell) + (cond ((and cell (not (null? cell))) + (with-color cell (draw-square #:size 20))))) + +(define (draw-row row) + (for-each (lambda (cell) (draw-cell cell) (translate 23 0)) row)) + +(define (draw-grid grid) + (for-each (lambda (row) (draw-row row) (translate (* -23 (length row)) -23)) grid)) + +(define* (join-rows source destination #:optional (offset 0)) + (cond ((null? source) destination) + ((null? destination) '()) + ((> offset 0) (cons (car destination) (join-rows source (cdr destination) (- offset 1)))) + (else (cons (or (car source) (car destination)) + (join-rows (cdr source) (cdr destination) offset))))) + +(define* (join-grids source destination #:optional (x 0) (y 0)) + (cond ((null? source) destination) + ((null? destination) '()) + ((> y 0) (cons (car destination) + (join-grids source (cdr destination) x (- y 1)))) + (else (cons (join-rows (car source) (car destination) x) + (join-grids (cdr source) (cdr destination) x y))))) + +(define* (collide-rows row1 row2 #:optional (offset 0)) + (cond ((or (null? row1) (null? row2)) #f) + ((> offset 0) (collide-rows row1 (cdr row2) (- offset 1))) + (else (or (and (car row1) (car row2)) (collide-rows (cdr row1) (cdr row2)))))) + +(define* (collide-grids grid1 grid2 #:optional (x 0) (y 0)) + (cond ((or (null? grid1) (null? grid2)) #f) + ((> y 0) (collide-grids grid1 (cdr grid2) x (- y 1))) + (else (or (collide-rows (car grid1) (car grid2) x) + (collide-grids (cdr grid1) (cdr grid2) x y))))) + +(define (rotate-tetramine grid) + (define (rot grid res) + (cond ((null? grid) res) + (else (rot (cdr grid) (map cons (car grid) res))))) + (rot grid (make-list (length (car grid))))) + +(define (row-completed row) + (cond ((null? row) #t) + (else (and (car row) (row-completed (cdr row)))))) + +(define (remove-rows-completed grid) + (let ((res (filter (lambda (x) (not (row-completed x))) grid))) + (define (fill grid n) + (cond ((< n 1) grid) + (else (fill (cons (make-list 14 #f) grid) (- n 1))))) + (inc-points (- (length grid) (length res))) + (fill res (- 20 (length res))))) + +(define get-points #f) +(define get-lines #f) +(define inc-points #f) + +(let ((points 0) (lines 0)) + (set! get-points + (lambda () + points)) + + (set! get-lines + (lambda () + lines)) + + (set! inc-points + (lambda (l) + (define (more-lines-better n) + (cond ((= n 0) n) + (else (+ n (more-lines-better (- n 1)))))) + (set! points (+ points (* (more-lines-better l) 10))) + (set! lines (+ lines l))))) + +(define game #f) +(define display-game-over #f) +(define tetramine #f) + +(let ((current-tetramine (random-tetramine)) (x 6) (y 0) + (next (random-tetramine)) + (timer (make-timer)) + (grid (make-list 20 (make-list 14 #f))) + (background (load-texture "fondo_tetris.png")) + (font (load-font "lazy.ttf" #:size 20)) + (game-over #f)) + + (set! game + (lambda () + (if game-over (display-game-over) (tetramine)))) + + (set! display-game-over + (lambda () + (translate -100 0) + (render-text "Game Over" font #:size 50))) + + (set! tetramine + (lambda () + (cond ((eq? (get-state timer) 'stopped) (start-timer timer))) + + (cond ((key? 'right) + (cond ((not (collide-grids current-tetramine grid (+ x 1) y)) + (set! x (+ x 1)))))) + (cond ((key? 'left) + (cond ((not (collide-grids current-tetramine grid (- x 1) y)) + (set! x (- x 1)))))) + (cond ((< x 0) (set! x 0)) + ((> (+ x (length (car current-tetramine))) 14) (set! x (- 14 (length (car current-tetramine)))))) + + (cond ((key-pressed? 'up) + (let ((t1 (rotate-tetramine current-tetramine))) + (cond ((not (collide-grids t1 grid x y)) + (set! current-tetramine t1)))))) + + (cond ((or (key? 'down) (> (get-time timer) 5000)) + (cond ((or (collide-grids current-tetramine grid x (+ y 1)) + (> (+ y 1 (length current-tetramine)) 20)) + (set! grid (remove-rows-completed (join-grids current-tetramine grid x y))) + (set! current-tetramine next) + (set! x 6) + (set! y 0) + (cond ((collide-grids current-tetramine grid x y) (set! game-over #t))) + (set! next (random-tetramine))) + (else + (set! y (+ y 1)) + (start-timer timer))))) + (draw-texture background) + (translate -288 218) + (draw-grid (join-grids current-tetramine grid x y)) + (translate 440 440) + (draw-grid next) + (translate -40 -100) + (render-text (format #f "Points: ~a" (get-points)) font) + (translate 0 -30) + (render-text (format #f "Lines: ~a" (get-lines)) font)))) + +(let ((frame 0.0) (fps (make-timer)) (update (make-timer))) + (start-timer update) + (start-timer fps) + (run-game + (game) + (set! frame (+ frame 1)) + (cond ((> (get-time update) 1000) + (display (/ frame (/ (get-time fps) 1000.0))) + (newline) + (start-timer update))))) diff --git a/lazy.ttf b/lazy.ttf deleted file mode 100644 index eb1000b..0000000 Binary files a/lazy.ttf and /dev/null differ