From: Javier Sancho Date: Fri, 31 May 2013 11:38:08 +0000 (+0200) Subject: Preparing new version 0.6 X-Git-Url: https://git.jsancho.org/?a=commitdiff_plain;h=4cb735ffd3fddfdc53fd1b944756c6ec6616b819;p=gacela.git Preparing new version 0.6 --- diff --git a/games/asteroids/asteroids.scm b/games/asteroids/asteroids.scm deleted file mode 100644 index a12c1de..0000000 --- a/games/asteroids/asteroids.scm +++ /dev/null @@ -1,154 +0,0 @@ -#!/usr/bin/guile \ --e gacela-script -s -!# - -(use-modules (gacela gacela) - (gacela math)) -(init-gacela) - -(set-game-properties! #:title "Gacela Asteroids") - -(define max-x (/ (assoc-ref (get-game-properties) 'width) 2)) -(define min-x (- max-x)) -(define max-y (/ (assoc-ref (get-game-properties) 'height) 2)) -(define min-y (- max-y)) - - -;;; Asteroids - -(define-checking-mobs (asteroid-shots x y size) (shot (sx x) (sy y)) - (if (< (distance-between-points (list sx sy) (list x y)) size) 1 0)) - -(define (asteroid-killed? x y size) - (> (apply + (asteroid-shots x y size)) 0)) - -(define-mob (asteroid - (image (load-texture "Asteroid.png")) - (x 0) (y 0) (angle 0) (dir 0) (size 100)) - (cond ((asteroid-killed? x y size) - (kill-me)) - (else - (let ((r (degrees-to-radians (- dir)))) - (set! x (+ x (sin r))) - (set! y (+ y (cos r)))) - (set! angle (+ angle 1)) - - (cond ((or (> x max-x) (< x min-x)) - (set! dir (* -1 dir)))) - (cond ((or (> y max-y) (< y min-y)) - (set! dir (- 180 dir)))))) - - (translate x y) - (rotate angle) - (draw-texture image)) - - -;;; Ship - -(define-mob (ship - (ship1 (load-texture "Ship1.png")) - (ship2 (load-texture "Ship2.png")) - (x 0) (y 0) (angle 0) - (moving #f)) - (cond ((key? 'left) (set! angle (+ angle 5))) - ((key? 'right) (set! angle (- angle 5)))) - (cond ((key? 'up) - (let ((r (degrees-to-radians (- angle)))) - (set! x (+ x (* 4 (sin r)))) - (set! y (+ y (* 4 (cos r))))) - (cond ((> x max-x) (set! x min-x)) - ((< x min-x) (set! x max-x))) - (cond ((> y max-y) (set! y min-y)) - ((< y min-y) (set! y max-y))) - (set! moving #t)) - (else - (set! moving #f))) - (cond ((key-pressed? 'space) - (show-mob (make-shot #:x x #:y y #:angle angle)))) - - (translate x y) - (rotate angle) - (draw-texture (if moving ship2 ship1))) - - -;;; Shots - -(define-checking-mobs (impacted-shots x y) (asteroid (ax x) (ay y) (size size)) - (if (< (distance-between-points (list ax ay) (list x y)) size) 1 0)) - -(define (shot-killed? x y) - (> (apply + (impacted-shots x y)) 0)) - -(define-mob (shot (x 0) (y 0) (angle 0)) - (cond ((shot-killed? x y) - (kill-me)) - (else - (let ((r (degrees-to-radians (- angle)))) - (set! x (+ x (* 10 (sin r)))) - (set! y (+ y (* 10 (cos r)))) - (cond ((or (> x max-x) - (< x min-x) - (> y max-y) - (< y min-y)) - (kill-me)))))) - - (translate x y) - (rotate angle) - (draw-line 10)) - - -;;; Game - -(define (init-asteroids n) - (cond ((> n 0) - (let ((x (- (random (* max-x 2)) max-x)) - (y (- (random (* max-y 2)) max-y))) - (cond ((< (distance-between-points (list x y) '(0 0)) 120) - (init-asteroids n)) - (else - (let ((angle (random 360)) (dir (- (random 360) 180))) - (show-mob (make-asteroid #:x x #:y y #:angle angle #:dir dir))) - (init-asteroids (- n 1)))))))) - - -(init-asteroids 2) -(show-mob (make-ship)) - -(let ((font (load-font "../tetris/lazy.ttf" #:size 20))) - (game - (render-text (format #f "Mobs: ~a" (length (get-active-mobs))) font))) - - -;; (define (new-game n) -;; (set! asteroids (make-asteroids n)) -;; (set! ship '((x . 0) (y . 0) (angle . 0) (moving . #f))) -;; (set! shots '())) - -;; (new-game 2) - -;; (define (killed-ship? s a) -;; (cond ((null? a) #f) -;; (else -;; (or (< (distance-between-points (list (assoc-ref s 'x) (assoc-ref s 'y)) -;; (list (assoc-ref (car a) 'x) (assoc-ref (car a) 'y))) -;; (assoc-ref (car a) 'size)) -;; (killed-ship? s (cdr a)))))) - - -;; (let ((asteroids #f) (ship #f) (shots #f)) - -;; (run-game -;; (cond ((killed-ship? ship asteroids) -;; (new-game 2))) -;; (receive (s a) (kill-asteroids shots asteroids) -;; (set! shots s) -;; (set! asteroids a)) -;; (set! asteroids (map move-asteroid asteroids)) -;; (set! ship (move-ship (alist-copy ship))) -;; (let ((shot (ship-shot ship))) -;; (cond (shot -;; (set! shots (cons shot shots))))) -;; (set! shots (move-shots shots)) -;; (for-each draw-asteroid asteroids) -;; (for-each draw-shot shots) -;; (draw-ship ship))) diff --git a/games/guybrush/guybrush.scm b/games/guybrush/guybrush.scm deleted file mode 100644 index 66e58e3..0000000 --- a/games/guybrush/guybrush.scm +++ /dev/null @@ -1,23 +0,0 @@ -#!/usr/bin/guile \ --e gacela-script -s -!# - -(use-modules (gacela gacela)) -(init-gacela) - -(set-game-properties! #:title "Guybrush") - -(define-mob (guybrush - (guy (load-texture "guybrush.png")) - (x 0) - (y (+ (- (/ (assoc-ref (get-game-properties) 'height) 2)) - (/ (assoc-ref (get-texture-properties guy) 'height) 2)))) - - (cond ((key? 'left) (set! x (- x 10)))) - (cond ((key? 'right) (set! x (+ x 10)))) - - (translate x y) - (draw-texture guy)) - -(show-mob (guybrush)) - diff --git a/games/tetris/tetris.scm b/games/tetris/tetris.scm deleted file mode 100644 index ce7e774..0000000 --- a/games/tetris/tetris.scm +++ /dev/null @@ -1,200 +0,0 @@ -#!/usr/bin/guile \ --e gacela-script -s -!# - -(use-modules (gacela gacela) - (gacela widgets timer)) -(init-gacela) - -(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-func #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-func - (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) - (game - (game-func) - (set! frame (+ frame 1)) - (cond ((> (get-time update) 1000) - (display (/ frame (/ (get-time fps) 1000.0))) - (newline) - (start-timer update))))) diff --git a/src/Makefile.am b/src/Makefile.am deleted file mode 100644 index 4d253b9..0000000 --- a/src/Makefile.am +++ /dev/null @@ -1,10 +0,0 @@ -lib_LTLIBRARIES = libguile-gacela-sdl.la libguile-gacela-gl.la libguile-gacela-ftgl.la -libguile_gacela_sdl_la_SOURCES = sdl.c -libguile_gacela_sdl_la_LIBADD = $(SDL_LIBS) -libguile_gacela_sdl_la_CFLAGS = $(GUILE_CFLAGS) -libguile_gacela_gl_la_SOURCES = gl.c -libguile_gacela_gl_la_LIBADD = $(GL_LIBS) -libguile_gacela_gl_la_CFLAGS = $(GUILE_CFLAGS) -libguile_gacela_ftgl_la_SOURCES = ftgl.c -libguile_gacela_ftgl_la_LIBADD = $(FTGL_LIBS) -libguile_gacela_ftgl_la_CFLAGS = $(GUILE_CFLAGS) -I/usr/include/freetype2 diff --git a/src/addons.scm b/src/addons.scm deleted file mode 100644 index 864495d..0000000 --- a/src/addons.scm +++ /dev/null @@ -1,23 +0,0 @@ -;;; Gacela, a GNU Guile extension for fast games development -;;; Copyright (C) 2009 by Javier Sancho Fernandez -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation, either version 3 of the License, or -;;; (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see . - - -(define-module (gacela addons) - #:export-syntax (define-addon)) - -(define-macro (define-addon head . body) - (let ((addon-name (car head)) - (attr (map (lambda (a) (if (list? a) a (list a #f))) (cdr head))) \ No newline at end of file diff --git a/src/audio.scm b/src/audio.scm deleted file mode 100644 index 5d91ece..0000000 --- a/src/audio.scm +++ /dev/null @@ -1,34 +0,0 @@ -;;; Gacela, a GNU Guile extension for fast games development -;;; Copyright (C) 2009 by Javier Sancho Fernandez -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation, either version 3 of the License, or -;;; (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see . - - -(define-module (gacela audio) - #:use-module (gacela sdl) - #:export (init-audio - quit-audio)) - - -(define audio #f) - -(define (init-audio) - (cond ((not audio) - (SDL_Init SDL_INIT_AUDIO) - (set! audio (Mix_OpenAudio 22050 MIX_DEFAULT_FORMAT 2 4096))))) - -(define (quit-audio) - (cond (audio - (Mix_CloseAudio) - (set! audio #f)))) diff --git a/src/events.scm b/src/events.scm deleted file mode 100644 index 716425b..0000000 --- a/src/events.scm +++ /dev/null @@ -1,172 +0,0 @@ -;;; Gacela, a GNU Guile extension for fast games development -;;; Copyright (C) 2009 by Javier Sancho Fernandez -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation, either version 3 of the License, or -;;; (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see . - - -(define-module (gacela events) - #:use-module (gacela sdl) - #:export (process-events - quit-signal? - key? - key-pressed? - key-released?)) - - -(define (get-event events types) - (cond ((null? events) '()) - (else - (let ((res (get-event (cdr events) types)) - (event (car events))) - (cond ((member (assoc-ref event 'type) types) (cons event res)) - (else res)))))) - -(define (poll-events) - (let ((event (SDL_PollEvent))) - (cond ((null? event) '()) - (else (cons event (poll-events)))))) - -(define (process-events) - (let ((events (poll-events))) - (process-screen-events (get-event events `(,SDL_QUIT))) - (process-keyboard-events (get-event events `(,SDL_KEYDOWN ,SDL_KEYUP))))) - - -;;; Screen Events - -(define quit-signal #f) - -(define (process-screen-events events) - (set! quit-signal #f) - (process-screen-events-recursive events)) - -(define (process-screen-events-recursive events) - (cond ((not (null? events)) - (let ((event (car events))) - (cond ((= (assoc-ref event 'type) SDL_QUIT) (set! quit-signal #t)))) - (process-screen-events-recursive (cdr events))))) - -(define (quit-signal?) - quit-signal) - - -;;; Keyboard Events - -(define keymap (make-hash-table)) -(define pressed (make-hash-table)) -(define released (make-hash-table)) - -(define (process-keyboard-events events) - (clear-key-state) - (process-keyboard-events-recursive events)) - -(define (process-keyboard-events-recursive events) - (cond ((not (null? events)) - (let ((event (car events))) - (cond ((= (assoc-ref event 'type) SDL_KEYDOWN) (key-press (assoc-ref event 'key.keysym.sym))) - ((= (assoc-ref event 'type) SDL_KEYUP) (key-release (assoc-ref event 'key.keysym.sym))))) - (process-keyboard-events-recursive (cdr events))))) - -(define (key? key) - (hash-ref keymap (get-keycode key))) - -(define (key-pressed? key) - (hash-ref pressed (get-keycode key))) - -(define (key-released? key) - (hash-ref released (get-keycode key))) - -(define (key-press key-code) - (hash-set! keymap key-code #t) - (hash-set! pressed key-code #t) - (hash-set! released key-code #f)) - -(define (key-release key-code) - (hash-set! keymap key-code #f) - (hash-set! pressed key-code #f) - (hash-set! released key-code #t)) - -(define (clear-keymap) - (hash-clear! keymap)) - -(define (clear-key-state) - (hash-clear! pressed) - (hash-clear! released)) - - -(define keys - '((8 . backspace) - (9 . tab) - (12 . clear) - (13 . return) - (19 . pause) - (27 . escape) - (32 . space) - (33 . exclaim) - (34 . quotedbl) - (35 . hash) - (36 . dollar) - (38 . ampersand) - (39 . quote) - (40 . leftparen) - (41 . rightparen) - (42 . asterisk) - (43 . plus) - (44 . comma) - (45 . minus) - (46 . period) - (47 . slash) - (48 . 0) - (49 . 1) - (50 . 2) - (51 . 3) - (52 . 4) - (53 . 5) - (54 . 6) - (55 . 7) - (56 . 8) - (57 . 9) - (58 . colon) - (59 . semicolon) - (60 . less) - (61 . equals) - (62 . greater) - (63 . question) - (64 . at) - (269 . kp-minus) - (270 . kp-plus) - (273 . up) - (274 . down) - (275 . right) - (276 . left) - (282 . f1) - (283 . f2) - (284 . f3) - (285 . f4) - (286 . f5) - (287 . f6) - (288 . f7) - (289 . f8) - (290 . f9) - (291 . f10) - (292 . f11) - (293 . f12))) - -(define keynames (map (lambda (k) (cons (cdr k) (car k))) keys)) - -(define (get-keycode keyname) - (assoc-ref keynames keyname)) - -(define (get-keyname keycode) - (assoc-ref keys keycode)) diff --git a/src/freeimage.scm b/src/freeimage.scm deleted file mode 100644 index 79fe107..0000000 --- a/src/freeimage.scm +++ /dev/null @@ -1,20 +0,0 @@ -;;; Gacela, a GNU Guile extension for fast games development -;;; Copyright (C) 2009 by Javier Sancho Fernandez -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation, either version 3 of the License, or -;;; (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see . - - -(define-module (gacela freeimage) - #:use-module (system foreign)) - diff --git a/src/ftgl.c b/src/ftgl.c deleted file mode 100644 index ca39ad9..0000000 --- a/src/ftgl.c +++ /dev/null @@ -1,171 +0,0 @@ -/* Gacela, a GNU Guile extension for fast games development - Copyright (C) 2009 by Javier Sancho Fernandez - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . -*/ - -#include -#include - -struct font -{ - SCM filename; - FTGLfont *font_address; - int size; -}; - -static scm_t_bits font_tag; - -SCM -make_font (SCM file, SCM size, FTGLfont *font_address) -{ - SCM smob; - struct font *font; - - font = (struct font *) scm_gc_malloc (sizeof (struct font), "font"); - - font->filename = SCM_BOOL_F; - font->size = scm_to_int (size); - font->font_address = NULL; - - SCM_NEWSMOB (smob, font_tag, font); - - font->filename = file; - font->font_address = font_address; - - return smob; -} - -FTGLfont * -get_font_address (SCM font_smob) -{ - struct font *font; - - scm_assert_smob_type (font_tag, font_smob); - font = (struct font *) SCM_SMOB_DATA (font_smob); - return font->font_address; -} - -SCM -get_font_size (SCM font_smob) -{ - struct font *font; - - scm_assert_smob_type (font_tag, font_smob); - font = (struct font *) SCM_SMOB_DATA (font_smob); - return scm_from_int (font->size); -} - -SCM -mark_font (SCM font_smob) -{ - struct font *font = (struct font *) SCM_SMOB_DATA (font_smob); - - scm_gc_mark (font->filename); - - return SCM_BOOL_F; -} - -size_t -free_font (SCM font_smob) -{ - struct font *font = (struct font *) SCM_SMOB_DATA (font_smob); - - ftglDestroyFont (font->font_address); - scm_gc_free (font, sizeof (struct font), "font"); - - return 0; -} - -static int -print_font (SCM font_smob, SCM port, scm_print_state *pstate) -{ - struct font *font = (struct font *) SCM_SMOB_DATA (font_smob); - - scm_puts ("#filename, port); - scm_puts ("\", size ", port); - scm_display (scm_from_int (font->size), port); - scm_puts (">", port); - - /* non-zero means success */ - return 1; -} - - -SCM -gacela_ftglCreateTextureFont (SCM file, SCM size) -{ - FTGLfont *font_address = ftglCreateTextureFont (scm_to_locale_string (file)); - - if (font_address) { - return make_font (file, size, font_address); - } - else { - return SCM_BOOL_F; - } -} - -SCM -gacela_ftglSetFontFaceSize (SCM font, SCM size, SCM res) -{ - return scm_from_int (ftglSetFontFaceSize (get_font_address (font), scm_to_int (size), scm_to_int (res))); -} - -SCM -gacela_ftglGetFontFaceSize (SCM font) -{ - return scm_from_int (ftglGetFontFaceSize (get_font_address (font))); -} - -SCM -gacela_ftglSetFontCharMap (SCM font, SCM encoding) -{ - return scm_from_int (ftglSetFontCharMap (get_font_address (font), scm_to_int (encoding))); -} - -SCM -gacela_ftglRenderFont (SCM font, SCM string, SCM mode) -{ - ftglRenderFont (get_font_address (font), scm_to_locale_string(string), scm_to_int (mode)); - return SCM_UNSPECIFIED; -} - - -void -init_gacela_ftgl (void *data) -{ - font_tag = scm_make_smob_type ("font", sizeof (struct font)); - scm_set_smob_mark (font_tag, mark_font); - scm_set_smob_free (font_tag, free_font); - scm_set_smob_print (font_tag, print_font); - // scm_set_smob_equalp (surface_tag, equalp_surface); - scm_c_define_gsubr ("font-size", 1, 0, 0, get_font_size); - - scm_c_define ("ft_encoding_unicode", scm_from_int (ft_encoding_unicode)); - scm_c_define ("FTGL_RENDER_ALL", scm_from_int (FTGL_RENDER_ALL)); - - scm_c_define_gsubr ("ftglCreateTextureFont", 2, 0, 0, gacela_ftglCreateTextureFont); - scm_c_define_gsubr ("ftglSetFontFaceSize", 3, 0, 0, gacela_ftglSetFontFaceSize); - scm_c_define_gsubr ("ftglGetFontFaceSize", 1, 0, 0, gacela_ftglGetFontFaceSize); - scm_c_define_gsubr ("ftglSetFontCharMap", 2, 0, 0, gacela_ftglSetFontCharMap); - scm_c_define_gsubr ("ftglRenderFont", 3, 0, 0, gacela_ftglRenderFont); -} - - -void -scm_init_gacela_ftgl () -{ - init_gacela_ftgl (NULL); -} diff --git a/src/ftgl.scm b/src/ftgl.scm deleted file mode 100644 index ffcacb0..0000000 --- a/src/ftgl.scm +++ /dev/null @@ -1,25 +0,0 @@ -;;; Gacela, a GNU Guile extension for fast games development -;;; Copyright (C) 2009 by Javier Sancho Fernandez -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation, either version 3 of the License, or -;;; (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see . - - -(define-module (gacela ftgl)) - -(load-extension "libguile-gacela-ftgl" "scm_init_gacela_ftgl") - -(module-map (lambda (sym var) - (if (not (eq? sym '%module-public-interface)) - (module-export! (current-module) (list sym)))) - (current-module)) diff --git a/src/gacela.scm b/src/gacela.scm deleted file mode 100644 index b9d1316..0000000 --- a/src/gacela.scm +++ /dev/null @@ -1,382 +0,0 @@ -;;; Gacela, a GNU Guile extension for fast games development -;;; Copyright (C) 2009 by Javier Sancho Fernandez -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation, either version 3 of the License, or -;;; (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see . - - -(define-module (gacela gacela) - #:use-module (gacela events) - #:use-module (gacela video) - #:use-module (gacela audio) - #:use-module (ice-9 optargs) - #:export (*title* - *width-screen* - *height-screen* - *bpp-screen* - *frames-per-second* - *mode* - set-game-properties! - get-game-properties - init-gacela - quit-gacela - game-loop - gacela-script - game-running? - show-mob-hash - hide-mob-hash - get-active-mobs - hide-all-mobs - get-current-mob-id - get-mob-function-name - map-mobs - translate-mob) - #:export-syntax (game - show-mob - hide-mob - the-mob - define-mob-function - define-mob - lambda-mob - define-checking-mobs) - #:re-export (get-frame-time - 3d-mode?)) - - -;;; Main Loop - -(define game-loop-flag #f) -(define game-loop-thread #f) -(define game-loop-procedure #f) - -(define-macro (run-in-game-loop proc) - (let ((pgl (string->symbol (string-concatenate (list (symbol->string proc) "-in-game-loop")))) - (flag-symbol (gensym)) - (value-symbol (gensym))) - `(begin - (define ,pgl ,proc) - (define (,proc . param) - (cond ((and game-loop-thread (not (eq? game-loop-thread (current-thread)))) - (let ((,flag-symbol #f)) - (define ,value-symbol) - (system-async-mark - (lambda () - (catch #t - (lambda () (set! ,value-symbol (apply ,pgl param))) - (lambda (key . args) #f)) - (set! ,flag-symbol #t)) - game-loop-thread) - (while (not ,flag-symbol)) - ,value-symbol)) - (else - (apply ,pgl param))))))) - -(run-in-game-loop load-texture) -(run-in-game-loop load-font) -(run-in-game-loop set-screen-bpp!) -(run-in-game-loop resize-screen) - -(define-macro (game . code) - `(set! game-loop-procedure - ,(if (null? code) - `#f - `(lambda (game-elements) ,@code)))) - -(define (init-gacela) -; (hide-all-mobs) - (cond ((not game-loop-thread) - (set! game-loop-thread (call-with-new-thread (lambda () (cond ((not (game-running?)) (game-loop)))))))) - (while (not game-loop-flag)) - #t) - -(define (quit-gacela) -; (hide-all-mobs) - (set! game-loop-thread #f) - (set! game-loop-flag #f) - (quit-video)) - -(define (game-loop) -; (refresh-active-mobs) - (init-video *width-screen* *height-screen* *bpp-screen* #:title *title* #:mode *mode* #:fps *frames-per-second*) - (set! game-loop-flag #t) - (let loop ((game-elements '())) - (cond (game-loop-flag - (init-frame-time) -; (check-connections) - (process-events) - (cond ((quit-signal?) - (quit-gacela)) - (else - (clear-screen) - (to-origin) -; (refresh-active-mobs) -; (run-mobs) -; (run-extensions) - (if game-loop-procedure - (catch #t - (lambda () (set! game-elements (game-loop-procedure game-elements))) - (lambda (key . args) #f))) - (process-game-elements game-elements) - (flip-screen) - (delay-frame) - (loop game-elements))))))) - -(define (game-running?) - game-loop-flag) - -(define (process-game-elements elements) - (cond ((not (list? elements)) - (process-game-elements (list elements))) - (else - (draw-meshes (filter (lambda (e) (mesh? e)) elements))))) - -(define (draw-meshes meshes) - (cond ((null? meshes) #t) - (else - (catch #t - (lambda () (mesh-draw (car meshes))) - (lambda (key . args) #f)) - (draw-meshes (cdr meshes))))) - -;;; Extensions to main loop - -(define extensions '()) - -(define (add-extension! proc pri) - "Add an extension with a priority to the main loop" - (set! extensions - (sort (assoc-set! extensions proc pri) - (lambda (a b) - (< (cdr a) (cdr b)))))) - -(define (remove-extension! proc) - "Remove an extension from the main loop" - (set! extensions - (assoc-remove! extensions proc))) - -(define (run-extensions) - (for-each (lambda (x) ((car x))) extensions)) - - -;;; Game Properties - -(define *title* "Gacela") -(define *width-screen* 640) -(define *height-screen* 480) -(define *bpp-screen* 32) -(define *frames-per-second* 20) -(define *mode* '2d) -(define *fullscreen* 'off) - -(define* (set-game-properties! #:key title width height bpp fps mode fullscreen) - (if title - (set-screen-title! title)) - (if bpp - (set-screen-bpp! bpp)) - (if (or width height) - (begin - (if (not width) (set! width (get-screen-width))) - (if (not height) (set! height (get-screen-height))) - (resize-screen width height))) - (if fps - (set-frames-per-second! fps)) - (if mode - (if (eq? mode '3d) (set-3d-mode) (set-2d-mode))) - (if fullscreen - (set-fullscreen! fullscreen)) - (get-game-properties)) - -(define (get-game-properties) - `((title . ,(get-screen-title)) (width . ,(get-screen-width)) (height . ,(get-screen-height)) (bpp . ,(get-screen-bpp)) (fps . ,(get-frames-per-second)) (mode . ,(if (3d-mode?) '3d '2d)) (fullscreen . ,(get-fullscreen)))) - - -;;; Mobs Factory - -(define mobs-table (make-hash-table)) -(define active-mobs '()) -(define mobs-changed #f) - -(define (show-mob-hash mob) - (hash-set! mobs-table (mob 'get-mob-id) mob) - (set! mobs-changed #t)) - -(define (hide-mob-hash mob-id) - (hash-remove! mobs-table mob-id) - (set! mobs-changed #t)) - -(define (refresh-active-mobs) - (cond (mobs-changed - (set! mobs-changed #f) - (set! active-mobs (hash-map->list (lambda (k v) v) mobs-table))))) - -(define (get-active-mobs) - active-mobs) - -(define (hide-all-mobs) - (set! mobs-changed #t) - (hash-clear! mobs-table)) - -(define (mobs-changed?) - mobs-changed) - - -(define-macro (show-mob mob) - (cond ((list? mob) - `(let ((m ,mob)) - (show-mob-hash m))) - (else - `(show-mob-hash (lambda* (#:optional (option #f)) (,mob option)))))) - -(define-macro (hide-mob mob) - (cond ((list? mob) - `(let ((m ,mob)) - (hide-mob-hash (m 'get-mob-id)))) - (else - `(hide-mob-hash (,mob 'get-mob-id))))) - -(define current-mob-id #f) - -(define translate-mob translate) - -(define (get-current-mob-id) - current-mob-id) - -(define* (run-mobs #:optional (mobs (get-active-mobs))) - (let ((sorted-mobs (sort mobs (lambda (m1 m2) (< (m1 'get-z-index) (m2 'get-z-index)))))) - (for-each - (lambda (m) - (set! current-mob-id (m 'get-mob-id)) - (glmatrix-block (m))) - sorted-mobs) - (set! current-mob-id #f))) - - -;;; Making mobs - -(define mob-functions (make-hash-table)) - -(define (get-mob-function-name mob-name) - (let ((name (hash-ref mob-functions mob-name))) - (cond ((not name) - (set! name (gensym)) - (hash-set! mob-functions mob-name name))) - name)) - -(define-macro (the-mob mob-name init-data) - `(let ((mob-id (gensym)) - (mob-z-index 0) - (mob-time 0) - (mob-data ,init-data) - (saved-data ,init-data)) - (lambda* (#:optional (option #f)) - (define (save-data) - (let ((time (get-frame-time))) - (cond ((not (= time mob-time)) - (set! mob-time time) - (set! saved-data mob-data))))) - (case option - ((get-mob-id) - mob-id) - ((get-z-index) - mob-z-index) - ((get-type) - (procedure-name ,mob-name)) - ((get-data) - (save-data) - saved-data) - (else - (cond ((keyword? option) - (assoc-ref saved-data (keyword->symbol option))) - (else - (save-data) - (let ((res (,mob-name mob-id mob-data))) - (set! mob-z-index (car res)) - (set! mob-data (cadr res)))))))))) - -(define-macro (define-mob-function attr . body) - (let ((attr (map (lambda (a) (if (list? a) a (list a #f))) attr)) - (mob-id-symbol (gensym)) - (mob-id-z-index (gensym)) - (data-symbol (gensym))) - `(lambda (,mob-id-symbol ,data-symbol) - (let ((,mob-id-z-index 0)) - (define (kill-me) - (hide-mob-hash ,mob-id-symbol)) - (define* (translate x y #:optional (z 0)) - (cond ((3d-mode?) - (translate-mob x y z)) - (else - (set! ,mob-id-z-index (+ ,mob-id-z-index z)) - (translate-mob x y)))) - (let* ,attr - ,@(map - (lambda (a) - `(let ((val (assoc-ref ,data-symbol ',(car a)))) - (cond (val (set! ,(car a) val))))) - attr) - (catch #t - (lambda* () ,@body) - (lambda (key . args) #f)) - (list ,mob-id-z-index (list ,@(map (lambda (a) `(cons ',(car a) ,(car a))) attr)))))))) - -(define-macro (define-mob mob-head . body) - (let* ((name (car mob-head)) - (attr (cdr mob-head)) - (make-fun-symbol (gensym)) - (mob-fun-symbol (gensym)) - (params-symbol (gensym))) - `(define (,name . ,params-symbol) - (define ,make-fun-symbol - (lambda* ,(if (null? attr) '() `(#:key ,@attr)) - (the-mob ,name (list ,@(map (lambda (a) `(cons ',(car a) ,(car a))) attr))))) - (define ,mob-fun-symbol - (define-mob-function ,attr ,@body)) - (cond ((or (null? ,params-symbol) (keyword? (car ,params-symbol))) - (apply ,make-fun-symbol ,params-symbol)) - (else - (apply ,mob-fun-symbol ,params-symbol)))))) - -(define-macro (lambda-mob attr . body) - (let ((fun-name (gensym))) - `(begin - (define-mob-function ,(cons fun-name attr) ,@body) - (the-mob 'undefined '() ,fun-name)))) - - -;;; Functions for checking mobs (collisions and more) - -(define (map-mobs fun type) - (let ((mobs (filter (lambda (m) (and (eq? (m 'get-type) type) (not (eq? (m 'get-mob-id) (get-current-mob-id))))) (get-active-mobs)))) - (map (lambda (m) (fun (m 'get-data))) mobs))) - -(define-macro (define-checking-mobs head mob-def . body) - (let ((type (car mob-def)) (attr (cdr mob-def))) - `(define ,head - (map-mobs - (lambda (m) - (let ,(map (lambda (a) `(,(car a) (assoc-ref m ',(cadr a)))) attr) - ,@body)) - ',type)))) - - -;;; Scenes - -(define-macro (define-scene name . body) - `(define (,name) - ,@body)) - - -(module-map (lambda (sym var) - (if (not (eq? sym '%module-public-interface)) - (module-export! (current-module) (list sym)))) - (current-module)) diff --git a/src/gl.c b/src/gl.c deleted file mode 100644 index ffdc4e8..0000000 --- a/src/gl.c +++ /dev/null @@ -1,489 +0,0 @@ -/* Gacela, a GNU Guile extension for fast games development - Copyright (C) 2009 by Javier Sancho Fernandez - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . -*/ - -#include -#include -#include - -struct glTexture -{ - GLuint texture_id; - int width, height; -}; - -static scm_t_bits glTexture_tag; - -SCM -make_glTexture (GLuint texture_id) -{ - SCM smob; - struct glTexture *glTexture; - - glTexture = (struct glTexture *) scm_gc_malloc (sizeof (struct glTexture), "glTexture"); - - glTexture->texture_id = 0; - - SCM_NEWSMOB (smob, glTexture_tag, glTexture); - - glTexture->texture_id = texture_id; - - return smob; -} - -GLuint -get_glTexture_id (SCM glTexture_smob) -{ - struct glTexture *glTexture; - - scm_assert_smob_type (glTexture_tag, glTexture_smob); - glTexture = (struct glTexture *) SCM_SMOB_DATA (glTexture_smob); - return glTexture->texture_id; -} - -SCM -get_glTexture_width (SCM glTexture_smob) -{ - struct glTexture *glTexture; - - scm_assert_smob_type (glTexture_tag, glTexture_smob); - glTexture = (struct glTexture *) SCM_SMOB_DATA (glTexture_smob); - return scm_from_int (glTexture->width); -} - -SCM -get_glTexture_height (SCM glTexture_smob) -{ - struct glTexture *glTexture; - - scm_assert_smob_type (glTexture_tag, glTexture_smob); - glTexture = (struct glTexture *) SCM_SMOB_DATA (glTexture_smob); - return scm_from_int (glTexture->height); -} - -SCM -set_glTexture_size (SCM glTexture_smob, SCM width, SCM height) -{ - struct glTexture *glTexture; - - scm_assert_smob_type (glTexture_tag, glTexture_smob); - glTexture = (struct glTexture *) SCM_SMOB_DATA (glTexture_smob); - glTexture->width = scm_to_int (width); - glTexture->height = scm_to_int (height); - return SCM_UNSPECIFIED; -} - -size_t -free_glTexture (SCM glTexture_smob) -{ - struct glTexture *glTexture = (struct glTexture *) SCM_SMOB_DATA (glTexture_smob); - GLuint text[1]; - - text[0] = glTexture->texture_id; - glDeleteTextures (1, &text[0]); - scm_gc_free (glTexture, sizeof (struct glTexture), "glTexture"); - - return 0; -} - - -SCM -gacela_glBegin (SCM mode) -{ - glBegin (scm_to_int (mode)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glClear (SCM mask) -{ - glClear (scm_to_int (mask)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glClearColor (SCM red, SCM green, SCM blue, SCM alpha) -{ - glClearColor (scm_to_double (red), scm_to_double (green), scm_to_double (blue), scm_to_double (alpha)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glClearDepth (SCM depth) -{ - glClearDepth (scm_to_double (depth)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glColor3f (SCM red, SCM green, SCM blue) -{ - glColor3f (scm_to_double (red), scm_to_double (green), scm_to_double (blue)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glColor4f (SCM red, SCM green, SCM blue, SCM alpha) -{ - glColor4f (scm_to_double (red), scm_to_double (green), scm_to_double (blue), scm_to_double (alpha)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glDepthFunc (SCM func) -{ - glDepthFunc (scm_to_int (func)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glEnable (SCM cap) -{ - glEnable (scm_to_int (cap)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glDisable (SCM cap) -{ - glDisable (scm_to_int (cap)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glEnd (void) -{ - glEnd (); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glHint (SCM target, SCM mode) -{ - glHint (scm_to_int (target), scm_to_int (mode)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glLoadIdentity (void) -{ - glLoadIdentity (); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glMatrixMode (SCM mode) -{ - glMatrixMode (scm_to_int (mode)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glRotatef (SCM angle, SCM x, SCM y, SCM z) -{ - glRotatef (scm_to_double (angle), scm_to_double (x), scm_to_double (y), scm_to_double (z)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glShadeModel (SCM mode) -{ - glShadeModel (scm_to_int (mode)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glTranslatef (SCM x, SCM y, SCM z) -{ - glTranslatef (scm_to_double (x), scm_to_double (y), scm_to_double (z)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glVertex2f (SCM x, SCM y) -{ - glVertex2f (scm_to_double (x), scm_to_double (y)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glVertex3f (SCM x, SCM y, SCM z) -{ - glVertex3f (scm_to_double (x), scm_to_double (y), scm_to_double (z)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glViewport (SCM x, SCM y, SCM width, SCM height) -{ - glViewport (scm_to_int (x), scm_to_int (y), scm_to_int (width), scm_to_int (height)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glGenTextures (SCM n) -{ - SCM textures; - int nint = scm_to_int (n); - GLuint text[nint]; - int i; - - textures = scm_list_n (SCM_UNDEFINED); - glGenTextures (nint, &text[0]); - - for (i = nint - 1; i >= 0; i--) { - textures = scm_cons (make_glTexture (text[i]), textures); - } - - return textures; -} - -SCM -gacela_glDeleteTextures (SCM n, SCM textures) -{ - int nint = scm_to_int (n); - GLuint text[nint]; - int i; - - for (i = 0; i < nint; i++) { - text[i] = scm_to_int (scm_list_ref (textures, scm_from_int (i))); - } - - glDeleteTextures (nint, &text[0]); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glBindTexture (SCM target, SCM texture) -{ - glBindTexture (scm_to_int (target), get_glTexture_id (texture)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glTexImage2D (SCM target, SCM level, SCM internalFormat, SCM width, SCM height, SCM border, SCM format, SCM type, SCM pixels) -{ - glTexImage2D (scm_to_int (target), scm_to_int (level), scm_to_int (internalFormat), scm_to_int (width), \ - scm_to_int (height), scm_to_int (border), scm_to_int (format), scm_to_int (type), \ - (GLvoid *)scm_to_int (pixels)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glTexParameteri (SCM target, SCM pname, SCM param) -{ - glTexParameteri (scm_to_int (target), scm_to_int (pname), scm_to_int (param)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glTexCoord2f (SCM s, SCM t) -{ - glTexCoord2f (scm_to_double (s), scm_to_double (t)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glLightfv (SCM light, SCM pname, SCM params) -{ - int n = scm_to_int (scm_length (params)); - GLfloat gl_params[n]; - int i; - - for (i = 0; i < n; i++) { - gl_params[i] = scm_to_double (scm_list_ref (params, scm_from_int (i))); - } - - glLightfv (scm_to_int (light), scm_to_int (pname), gl_params); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glNormal3f (SCM nx, SCM ny, SCM nz) -{ - glNormal3f (scm_to_double (nx), scm_to_double (ny), scm_to_double (nz)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glBlendFunc (SCM sfactor, SCM dfactor) -{ - glBlendFunc (scm_to_int (sfactor), scm_to_int (dfactor)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glOrtho (SCM left, SCM right, SCM bottom, SCM top, SCM near_val, SCM far_val) -{ - glOrtho (scm_to_double (left), scm_to_double (right), scm_to_double (bottom), scm_to_double (top), \ - scm_to_double (near_val), scm_to_double (far_val)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glPushMatrix (void) -{ - glPushMatrix (); - return SCM_UNSPECIFIED; -} - -SCM -gacela_glPopMatrix (void) -{ - glPopMatrix (); - return SCM_UNSPECIFIED; -} - -SCM -gacela_gluPerspective (SCM fovy, SCM aspect, SCM zNear, SCM zFar) -{ - gluPerspective (scm_to_double (fovy), scm_to_double (aspect), scm_to_double (zNear), scm_to_double (zFar)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_gluBuild2DMipmaps (SCM target, SCM internalFormat, SCM width, SCM height, SCM format, SCM type, SCM data) -{ - return scm_from_int (gluBuild2DMipmaps (scm_to_int (target), scm_to_int (internalFormat), scm_to_int (width), \ - scm_to_int (height), scm_to_int (format), scm_to_int (type), \ - (void *)scm_to_int (data))); -} - -SCM -gacela_gluLookAt (SCM eyeX, SCM eyeY, SCM eyeZ, SCM centerX, SCM centerY, SCM centerZ, SCM upX, SCM upY, SCM upZ) -{ - gluLookAt (scm_to_double (eyeX), scm_to_double (eyeY), scm_to_double (eyeZ), \ - scm_to_double (centerX), scm_to_double (centerY), scm_to_double (centerZ), \ - scm_to_double (upX), scm_to_double (upY), scm_to_double (upZ)); - return SCM_UNSPECIFIED; -} - - -void -init_gacela_gl (void *data) -{ - glTexture_tag = scm_make_smob_type ("glTexture", sizeof (struct glTexture)); - scm_set_smob_free (glTexture_tag, free_glTexture); - scm_c_define_gsubr ("texture-w", 1, 0, 0, get_glTexture_width); - scm_c_define_gsubr ("texture-h", 1, 0, 0, get_glTexture_height); - scm_c_define_gsubr ("set-texture-size!", 3, 0, 0, set_glTexture_size); - - // Data types - scm_c_define ("GL_UNSIGNED_BYTE", scm_from_int (GL_UNSIGNED_BYTE)); - - // Primitives - scm_c_define ("GL_POINTS", scm_from_int (GL_POINTS)); - scm_c_define ("GL_LINES", scm_from_int (GL_LINES)); - scm_c_define ("GL_LINE_LOOP", scm_from_int (GL_LINE_LOOP)); - scm_c_define ("GL_LINE_STRIP", scm_from_int (GL_LINE_STRIP)); - scm_c_define ("GL_TRIANGLES", scm_from_int (GL_TRIANGLES)); - scm_c_define ("GL_TRIANGLE_STRIP", scm_from_int (GL_TRIANGLE_STRIP)); - scm_c_define ("GL_TRIANGLE_FAN", scm_from_int (GL_TRIANGLE_FAN)); - scm_c_define ("GL_QUADS", scm_from_int (GL_QUADS)); - scm_c_define ("GL_QUAD_STRIP", scm_from_int (GL_QUAD_STRIP)); - scm_c_define ("GL_POLYGON", scm_from_int (GL_POLYGON)); - - // Matrix Mode - scm_c_define ("GL_MODELVIEW", scm_from_int (GL_MODELVIEW)); - scm_c_define ("GL_PROJECTION", scm_from_int (GL_PROJECTION)); - - // Depth buffer - scm_c_define ("GL_LEQUAL", scm_from_int (GL_LEQUAL)); - scm_c_define ("GL_DEPTH_TEST", scm_from_int (GL_DEPTH_TEST)); - - // Lighting - scm_c_define ("GL_LIGHTING", scm_from_int (GL_LIGHTING)); - scm_c_define ("GL_LIGHT1", scm_from_int (GL_LIGHT1)); - scm_c_define ("GL_AMBIENT", scm_from_int (GL_AMBIENT)); - scm_c_define ("GL_DIFFUSE", scm_from_int (GL_DIFFUSE)); - scm_c_define ("GL_POSITION", scm_from_int (GL_POSITION)); - scm_c_define ("GL_SMOOTH", scm_from_int (GL_SMOOTH)); - - // Blending - scm_c_define ("GL_BLEND", scm_from_int (GL_BLEND)); - scm_c_define ("GL_ONE", scm_from_int (GL_ONE)); - scm_c_define ("GL_ONE_MINUS_SRC_ALPHA", scm_from_int (GL_ONE_MINUS_SRC_ALPHA)); - scm_c_define ("GL_SRC_ALPHA", scm_from_int (GL_SRC_ALPHA)); - - // Fog - scm_c_define ("GL_LINEAR", scm_from_int (GL_LINEAR)); - - // Buffers, Pixel Drawing/Reading - scm_c_define ("GL_RGB", scm_from_int (GL_RGB)); - scm_c_define ("GL_RGBA", scm_from_int (GL_RGBA)); - - // Hints - scm_c_define ("GL_PERSPECTIVE_CORRECTION_HINT", scm_from_int (GL_PERSPECTIVE_CORRECTION_HINT)); - scm_c_define ("GL_NICEST", scm_from_int (GL_NICEST)); - - // Texture mapping - scm_c_define ("GL_TEXTURE_2D", scm_from_int (GL_TEXTURE_2D)); - scm_c_define ("GL_TEXTURE_MAG_FILTER", scm_from_int (GL_TEXTURE_MAG_FILTER)); - scm_c_define ("GL_TEXTURE_MIN_FILTER", scm_from_int (GL_TEXTURE_MIN_FILTER)); - scm_c_define ("GL_LINEAR_MIPMAP_NEAREST", scm_from_int (GL_LINEAR_MIPMAP_NEAREST)); - scm_c_define ("GL_NEAREST", scm_from_int (GL_NEAREST)); - - // glPush/PopAttrib bits - scm_c_define ("GL_DEPTH_BUFFER_BIT", scm_from_int (GL_DEPTH_BUFFER_BIT)); - scm_c_define ("GL_COLOR_BUFFER_BIT", scm_from_int (GL_COLOR_BUFFER_BIT)); - - // OpenGL 1.2 - scm_c_define ("GL_BGR", scm_from_int (GL_BGR)); - scm_c_define ("GL_BGRA", scm_from_int (GL_BGRA)); - - - scm_c_define_gsubr ("glBegin", 1, 0, 0, gacela_glBegin); - scm_c_define_gsubr ("glClear", 1, 0, 0, gacela_glClear); - scm_c_define_gsubr ("glClearColor", 4, 0, 0, gacela_glClearColor); - scm_c_define_gsubr ("glClearDepth", 1, 0, 0, gacela_glClearDepth); - scm_c_define_gsubr ("glColor3f", 3, 0, 0, gacela_glColor3f); - scm_c_define_gsubr ("glColor4f", 4, 0, 0, gacela_glColor4f); - scm_c_define_gsubr ("glDepthFunc", 1, 0, 0, gacela_glDepthFunc); - scm_c_define_gsubr ("glEnable", 1, 0, 0, gacela_glEnable); - scm_c_define_gsubr ("glDisable", 1, 0, 0, gacela_glDisable); - scm_c_define_gsubr ("glEnd", 0, 0, 0, gacela_glEnd); - scm_c_define_gsubr ("glHint", 2, 0, 0, gacela_glHint); - scm_c_define_gsubr ("glLoadIdentity", 0, 0, 0, gacela_glLoadIdentity); - scm_c_define_gsubr ("glMatrixMode", 1, 0, 0, gacela_glMatrixMode); - scm_c_define_gsubr ("glRotatef", 4, 0, 0, gacela_glRotatef); - scm_c_define_gsubr ("glShadeModel", 1, 0, 0, gacela_glShadeModel); - scm_c_define_gsubr ("glTranslatef", 3, 0, 0, gacela_glTranslatef); - scm_c_define_gsubr ("glVertex2f", 2, 0, 0, gacela_glVertex2f); - scm_c_define_gsubr ("glVertex3f", 3, 0, 0, gacela_glVertex3f); - scm_c_define_gsubr ("glViewport", 4, 0, 0, gacela_glViewport); - scm_c_define_gsubr ("glGenTextures", 1, 0, 0, gacela_glGenTextures); - scm_c_define_gsubr ("glDeleteTextures", 2, 0, 0, gacela_glDeleteTextures); - scm_c_define_gsubr ("glBindTexture", 2, 0, 0, gacela_glBindTexture); - scm_c_define_gsubr ("glTexImage2D", 9, 0, 0, gacela_glTexImage2D); - scm_c_define_gsubr ("glTexParameteri", 3, 0, 0, gacela_glTexParameteri); - scm_c_define_gsubr ("glTexCoord2f", 2, 0, 0, gacela_glTexCoord2f); - scm_c_define_gsubr ("glLightfv", 3, 0, 0, gacela_glLightfv); - scm_c_define_gsubr ("glNormal3f", 3, 0, 0, gacela_glNormal3f); - scm_c_define_gsubr ("glBlendFunc", 2, 0, 0, gacela_glBlendFunc); - scm_c_define_gsubr ("glOrtho", 6, 0, 0, gacela_glOrtho); - scm_c_define_gsubr ("glPushMatrix", 0, 0, 0, gacela_glPushMatrix); - scm_c_define_gsubr ("glPopMatrix", 0, 0, 0, gacela_glPopMatrix); - - scm_c_define_gsubr ("gluPerspective", 4, 0, 0, gacela_gluPerspective); - scm_c_define_gsubr ("gluBuild2DMipmaps", 7, 0, 0, gacela_gluBuild2DMipmaps); - scm_c_define_gsubr ("gluLookAt", 9, 0, 0, gacela_gluLookAt); -} - -void -scm_init_gacela_gl () -{ - init_gacela_gl (NULL); -} diff --git a/src/gl.scm b/src/gl.scm deleted file mode 100644 index 0d6541d..0000000 --- a/src/gl.scm +++ /dev/null @@ -1,25 +0,0 @@ -;;; Gacela, a GNU Guile extension for fast games development -;;; Copyright (C) 2009 by Javier Sancho Fernandez -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation, either version 3 of the License, or -;;; (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see . - - -(define-module (gacela gl)) - -(load-extension "libguile-gacela-gl" "scm_init_gacela_gl") - -(module-map (lambda (sym var) - (if (not (eq? sym '%module-public-interface)) - (module-export! (current-module) (list sym)))) - (current-module)) diff --git a/src/math.scm b/src/math.scm deleted file mode 100644 index 64317dd..0000000 --- a/src/math.scm +++ /dev/null @@ -1,59 +0,0 @@ -;;; Gacela, a GNU Guile extension for fast games development -;;; Copyright (C) 2009 by Javier Sancho Fernandez -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation, either version 3 of the License, or -;;; (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see . - - -(define-module (gacela math) - #:export (*pi* - degrees-to-radians - radians-to-degrees - distance-between-points - nearest-power-of-two)) - - -;;; Constants - -(define *pi* (* (asin 1) 2)) - - -;;; Geometry - -(define (degrees-to-radians angle) - (/ (* angle *pi*) 180)) - -(define (radians-to-degrees angle) - (/ (* angle 180) *pi*)) - -(define (distance-between-points p1 p2) - (define (add-power-of-two p1 p2) - (cond ((null? p1) - 0) - (else - (+ (expt (- (car p1) (car p2)) 2) - (add-power-of-two (cdr p1) (cdr p2)))))) - - (cond ((not (= (length p1) (length p2))) - #f) - (else - (sqrt (add-power-of-two p1 p2))))) - - -;;; Functions - -(define (nearest-power-of-two n) - (define (power p n) - (cond ((> (* p 2) n) p) - (else (power (* p 2) n)))) - (power 1 n)) diff --git a/src/sdl.c b/src/sdl.c deleted file mode 100644 index 4fba1ff..0000000 --- a/src/sdl.c +++ /dev/null @@ -1,550 +0,0 @@ -/* Gacela, a GNU Guile extension for fast games development - Copyright (C) 2009 by Javier Sancho Fernandez - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . -*/ - -#include -#include -#include -#include -#include -#include - -struct surface -{ - SCM filename; - SDL_Surface *surface_address; -}; - -static scm_t_bits surface_tag; - -SCM -make_surface (SCM file, SDL_Surface *surface_address) -{ - SCM smob; - struct surface *surface; - - surface = (struct surface *) scm_gc_malloc (sizeof (struct surface), "surface"); - - surface->filename = SCM_BOOL_F; - surface->surface_address = NULL; - - SCM_NEWSMOB (smob, surface_tag, surface); - - surface->filename = file; - surface->surface_address = surface_address; - - return smob; -} - -SDL_Surface * -get_surface_address (SCM surface_smob) -{ - struct surface *surface; - - scm_assert_smob_type (surface_tag, surface_smob); - surface = (struct surface *) SCM_SMOB_DATA (surface_smob); - return surface->surface_address; -} - -SCM -get_surface_filename (SCM surface_smob) -{ - struct surface *surface; - - scm_assert_smob_type (surface_tag, surface_smob); - surface = (struct surface *) SCM_SMOB_DATA (surface_smob); - return surface->filename; -} - -SCM -get_surface_width (SCM surface_smob) -{ - SDL_Surface *surface = get_surface_address (surface_smob); - - return scm_from_int (surface->w); -} - -SCM -get_surface_height (SCM surface_smob) -{ - SDL_Surface *surface = get_surface_address (surface_smob); - - return scm_from_int (surface->h); -} - -SCM -get_surface_pixels (SCM surface_smob) -{ - SDL_Surface *surface = get_surface_address (surface_smob); - - return scm_from_int ((int)surface->pixels); -} - -SCM -get_surface_format_BytesPerPixel (SCM surface_smob) -{ - SDL_Surface *surface = get_surface_address (surface_smob); - - return scm_from_int (surface->format->BytesPerPixel); -} - -SCM -mark_surface (SCM surface_smob) -{ - struct surface *surface = (struct surface *) SCM_SMOB_DATA (surface_smob); - - scm_gc_mark (surface->filename); - - return SCM_BOOL_F; -} - -size_t -free_surface (SCM surface_smob) -{ - struct surface *surface = (struct surface *) SCM_SMOB_DATA (surface_smob); - - SDL_FreeSurface (surface->surface_address); - scm_gc_free (surface, sizeof (struct surface), "surface"); - - return 0; -} - -static int -print_surface (SCM surface_smob, SCM port, scm_print_state *pstate) -{ - struct surface *surface = (struct surface *) SCM_SMOB_DATA (surface_smob); - - scm_puts ("#filename, port); - scm_puts ("\">", port); - - /* non-zero means success */ - return 1; -} - - -SCM -gacela_SDL_Init (SCM flags) -{ - return scm_from_int (SDL_Init (scm_to_int (flags))); -} - -SCM -gacela_SDL_Quit (void) -{ - SDL_Quit (); - return SCM_UNSPECIFIED; -} - -SCM -gacela_SDL_SetVideoMode (SCM width, SCM height, SCM bpp, SCM flags) -{ - SDL_Surface *screen = SDL_SetVideoMode (scm_to_int (width), scm_to_int (height), \ - scm_to_int (bpp), scm_to_int (flags)); - - if (screen) { - return make_surface (scm_from_locale_string ("screen"), screen); - } - else { - return SCM_BOOL_F; - } -} - -SCM -gacela_SDL_FreeSurface (SCM surface) -{ - return scm_from_int (free_surface (surface)); -} - -SCM -gacela_SDL_WM_SetCaption (SCM title, SCM icon) -{ - SDL_WM_SetCaption (scm_to_locale_string(title), scm_to_locale_string(icon)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_SDL_WM_ToggleFullScreen(SCM surface) -{ - return scm_from_int (SDL_WM_ToggleFullScreen (get_surface_address (surface))); -} - -SCM -gacela_SDL_Flip (SCM screen) -{ - return scm_from_int (SDL_Flip (get_surface_address (screen))); -} - -SCM -gacela_SDL_Delay (SCM ms) -{ - SDL_Delay ((int)scm_to_double (ms)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_SDL_GetTicks (void) -{ - return scm_from_int (SDL_GetTicks ()); -} - -SCM -gacela_SDL_GetError (void) -{ - return scm_from_locale_string (SDL_GetError ()); -} - -SCM -gacela_SDL_DisplayFormat (SCM surface) -{ - SDL_Surface *new = SDL_DisplayFormat (get_surface_address (surface)); - - if (new) { - return make_surface (get_surface_filename (surface), new); - } - else { - return SCM_BOOL_F; - } -} - -SCM -gacela_SDL_DisplayFormatAlpha (SCM surface) -{ - SDL_Surface *new = SDL_DisplayFormatAlpha (get_surface_address (surface)); - - if (new) { - return make_surface (get_surface_filename (surface), new); - } - else { - return SCM_BOOL_F; - } -} - -SCM -gacela_SDL_MapRGB (SCM format, SCM r, SCM g, SCM b) -{ - return scm_from_int (SDL_MapRGB ((SDL_PixelFormat *)scm_to_int (format), scm_to_int (r), scm_to_int (g), scm_to_int (b))); -} - -SCM -gacela_SDL_SetColorKey (SCM surface, SCM flag, SCM key) -{ - return scm_from_int (SDL_SetColorKey (get_surface_address (surface), scm_to_int (flag), scm_to_int (key))); -} - -SCM -gacela_SDL_SetAlpha (SCM surface, SCM flag, SCM alpha) -{ - return scm_from_int (SDL_SetAlpha (get_surface_address (surface), scm_to_int (flag), scm_to_int (alpha))); -} - -SCM -gacela_SDL_LoadBMP (SCM file) -{ - SDL_Surface *image = SDL_LoadBMP (scm_to_locale_string (file)); - - if (image) { - return make_surface (file, image); - } - else { - return SCM_BOOL_F; - } -} - -SCM -gacela_IMG_Load (SCM filename) -{ - SDL_Surface *image = IMG_Load (scm_to_locale_string (filename)); - - if (image) { - return make_surface (filename, image); - } - else { - return SCM_BOOL_F; - } -} - -SCM -gacela_SDL_GetVideoInfo (void) -{ - const SDL_VideoInfo *info; - SCM vi; - - info = SDL_GetVideoInfo (); - vi = scm_list_n (SCM_UNDEFINED); - - vi = scm_cons (scm_cons (scm_from_utf8_symbol ("blit_hw"), scm_from_int (info->blit_hw)), vi); - vi = scm_cons (scm_cons (scm_from_utf8_symbol ("hw_available"), scm_from_int (info->hw_available)), vi); - - return vi; -} - -SCM -gacela_SDL_GL_SetAttribute (SCM attr, SCM value) -{ - return scm_from_int (SDL_GL_SetAttribute (scm_to_int (attr), scm_to_int (value))); -} - -SCM -gacela_SDL_PollEvent (void) -{ - SDL_Event sdl_event; - SCM event; - - event = scm_list_n (SCM_UNDEFINED); - - if (SDL_PollEvent (&sdl_event)) { - switch (sdl_event.type) { - case SDL_KEYDOWN: - case SDL_KEYUP: - event = scm_cons (scm_cons (scm_from_locale_symbol ("key.keysym.sym"), scm_from_int (sdl_event.key.keysym.sym)), event); - break; - } - event = scm_cons (scm_cons (scm_from_locale_symbol ("type"), scm_from_int (sdl_event.type)), event); - } - - return event; -} - -SCM -gacela_SDL_GL_SwapBuffers (void) -{ - SDL_GL_SwapBuffers (); - return SCM_UNSPECIFIED; -} - -SCM -gacela_SDL_EnableKeyRepeat (SCM delay, SCM interval) -{ - return scm_from_int (SDL_EnableKeyRepeat (scm_to_int (delay), scm_to_int (interval))); -} - -SCM -gacela_zoomSurface (SCM src, SCM zoomx, SCM zoomy, SCM smooth) -{ - SDL_Surface *image = zoomSurface (get_surface_address (src), scm_to_double (zoomx), scm_to_double (zoomy), scm_to_int (smooth)); - - if (image) { - return make_surface (get_surface_filename (src), image); - } - else { - return SCM_BOOL_F; - } -} - -SCM -gacela_Mix_OpenAudio (SCM frequency, SCM format, SCM channels, SCM chunksize) -{ - return scm_from_int (Mix_OpenAudio (scm_to_int (frequency), scm_to_int (format), scm_to_int (channels), scm_to_int (chunksize))); -} - -SCM -gacela_Mix_LoadMUS (SCM file) -{ - return scm_from_int ((int)Mix_LoadMUS (scm_to_locale_string (file))); -} - -SCM -gacela_Mix_LoadWAV (SCM file) -{ - return scm_from_int ((int)Mix_LoadWAV (scm_to_locale_string (file))); -} - -SCM -gacela_Mix_PlayChannel (SCM channel, SCM chunk, SCM loops) -{ - return scm_from_int (Mix_PlayChannel (scm_to_int (channel), (Mix_Chunk *)scm_to_int (chunk), scm_to_int (loops))); -} - -SCM -gacela_Mix_PlayMusic (SCM music, SCM loops) -{ - return scm_from_int (Mix_PlayMusic ((Mix_Music *)scm_to_int (music), scm_to_int (loops))); -} - -SCM -gacela_Mix_PlayingMusic (void) -{ - return scm_from_int (Mix_PlayingMusic ()); -} - -SCM -gacela_Mix_PausedMusic (void) -{ - return scm_from_int (Mix_PausedMusic ()); -} - -SCM -gacela_Mix_PauseMusic (void) -{ - Mix_PauseMusic (); - return SCM_UNSPECIFIED; -} - -SCM -gacela_Mix_ResumeMusic (void) -{ - Mix_ResumeMusic (); - return SCM_UNSPECIFIED; -} - -SCM -gacela_Mix_HaltMusic (void) -{ - return scm_from_int (Mix_HaltMusic ()); -} - -SCM -gacela_Mix_FreeMusic (SCM music) -{ - Mix_FreeMusic ((Mix_Music *)scm_to_int (music)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_Mix_FreeChunk (SCM chunk) -{ - Mix_FreeChunk ((Mix_Chunk *)scm_to_int (chunk)); - return SCM_UNSPECIFIED; -} - -SCM -gacela_Mix_CloseAudio (void) -{ - Mix_CloseAudio (); - return SCM_UNSPECIFIED; -} - - -void -init_gacela_sdl (void *data) -{ - surface_tag = scm_make_smob_type ("surface", sizeof (struct surface)); - scm_set_smob_mark (surface_tag, mark_surface); - scm_set_smob_free (surface_tag, free_surface); - scm_set_smob_print (surface_tag, print_surface); - scm_c_define_gsubr ("surface-file", 1, 0, 0, get_surface_filename); - scm_c_define_gsubr ("surface-w", 1, 0, 0, get_surface_width); - scm_c_define_gsubr ("surface-h", 1, 0, 0, get_surface_height); - scm_c_define_gsubr ("surface-pixels", 1, 0, 0, get_surface_pixels); - scm_c_define_gsubr ("surface-format-BytesPerPixel", 1, 0, 0, get_surface_format_BytesPerPixel); - - scm_c_define ("SDL_INIT_TIMER", scm_from_int (SDL_INIT_TIMER)); - scm_c_define ("SDL_INIT_AUDIO", scm_from_int (SDL_INIT_AUDIO)); - scm_c_define ("SDL_INIT_VIDEO", scm_from_int (SDL_INIT_VIDEO)); - scm_c_define ("SDL_INIT_CDROM", scm_from_int (SDL_INIT_CDROM)); - scm_c_define ("SDL_INIT_JOYSTICK", scm_from_int (SDL_INIT_JOYSTICK)); - scm_c_define ("SDL_INIT_NOPARACHUTE", scm_from_int (SDL_INIT_NOPARACHUTE)); - scm_c_define ("SDL_INIT_EVENTTHREAD", scm_from_int (SDL_INIT_EVENTTHREAD)); - scm_c_define ("SDL_INIT_EVERYTHING", scm_from_int (SDL_INIT_EVERYTHING)); - - scm_c_define ("SDL_SWSURFACE", scm_from_int (SDL_SWSURFACE)); - scm_c_define ("SDL_HWSURFACE", scm_from_int (SDL_HWSURFACE)); - scm_c_define ("SDL_ASYNCBLIT", scm_from_int (SDL_ASYNCBLIT)); - - scm_c_define ("SDL_ANYFORMAT", scm_from_int (SDL_ANYFORMAT)); - scm_c_define ("SDL_HWPALETTE", scm_from_int (SDL_HWPALETTE)); - scm_c_define ("SDL_DOUBLEBUF", scm_from_int (SDL_DOUBLEBUF)); - scm_c_define ("SDL_FULLSCREEN", scm_from_int (SDL_FULLSCREEN)); - scm_c_define ("SDL_OPENGL", scm_from_int (SDL_OPENGL)); - scm_c_define ("SDL_OPENGLBLIT", scm_from_int (SDL_OPENGLBLIT)); - scm_c_define ("SDL_RESIZABLE", scm_from_int (SDL_RESIZABLE)); - scm_c_define ("SDL_NOFRAME", scm_from_int (SDL_NOFRAME)); - - scm_c_define ("SDL_HWACCEL", scm_from_int (SDL_HWACCEL)); - scm_c_define ("SDL_SRCCOLORKEY", scm_from_int (SDL_SRCCOLORKEY)); - - scm_c_define ("SDL_GL_DOUBLEBUFFER", scm_from_int (SDL_GL_DOUBLEBUFFER)); - - scm_c_define ("SDL_DEFAULT_REPEAT_DELAY", scm_from_int (SDL_DEFAULT_REPEAT_DELAY)); - scm_c_define ("SDL_DEFAULT_REPEAT_INTERVAL", scm_from_int (SDL_DEFAULT_REPEAT_INTERVAL)); - - scm_c_define ("SDL_LIL_ENDIAN", scm_from_int (SDL_LIL_ENDIAN)); - scm_c_define ("SDL_BIG_ENDIAN", scm_from_int (SDL_BIG_ENDIAN)); - scm_c_define ("SDL_BYTEORDER", scm_from_int (SDL_BYTEORDER)); - - scm_c_define ("MIX_DEFAULT_FORMAT", scm_from_int (MIX_DEFAULT_FORMAT)); - - scm_c_define ("SDL_NOEVENT", scm_from_int (SDL_NOEVENT)); - scm_c_define ("SDL_ACTIVEEVENT", scm_from_int (SDL_ACTIVEEVENT)); - scm_c_define ("SDL_KEYDOWN", scm_from_int (SDL_KEYDOWN)); - scm_c_define ("SDL_KEYUP", scm_from_int (SDL_KEYUP)); - scm_c_define ("SDL_MOUSEMOTION", scm_from_int (SDL_MOUSEMOTION)); - scm_c_define ("SDL_MOUSEBUTTONDOWN", scm_from_int (SDL_MOUSEBUTTONDOWN)); - scm_c_define ("SDL_MOUSEBUTTONUP", scm_from_int (SDL_MOUSEBUTTONUP)); - scm_c_define ("SDL_JOYAXISMOTION", scm_from_int (SDL_JOYAXISMOTION)); - scm_c_define ("SDL_JOYBALLMOTION", scm_from_int (SDL_JOYBALLMOTION)); - scm_c_define ("SDL_JOYHATMOTION", scm_from_int (SDL_JOYHATMOTION)); - scm_c_define ("SDL_JOYBUTTONDOWN", scm_from_int (SDL_JOYBUTTONDOWN)); - scm_c_define ("SDL_JOYBUTTONUP", scm_from_int (SDL_JOYBUTTONUP)); - scm_c_define ("SDL_QUIT", scm_from_int (SDL_QUIT)); - scm_c_define ("SDL_SYSWMEVENT", scm_from_int (SDL_SYSWMEVENT)); - scm_c_define ("SDL_EVENT_RESERVEDA", scm_from_int (SDL_EVENT_RESERVEDA)); - scm_c_define ("SDL_EVENT_RESERVEDB", scm_from_int (SDL_EVENT_RESERVEDB)); - scm_c_define ("SDL_VIDEORESIZE", scm_from_int (SDL_VIDEORESIZE)); - scm_c_define ("SDL_VIDEOEXPOSE", scm_from_int (SDL_VIDEOEXPOSE)); - scm_c_define ("SDL_EVENT_RESERVED2", scm_from_int (SDL_EVENT_RESERVED2)); - scm_c_define ("SDL_EVENT_RESERVED3", scm_from_int (SDL_EVENT_RESERVED3)); - scm_c_define ("SDL_EVENT_RESERVED4", scm_from_int (SDL_EVENT_RESERVED4)); - scm_c_define ("SDL_EVENT_RESERVED5", scm_from_int (SDL_EVENT_RESERVED5)); - scm_c_define ("SDL_EVENT_RESERVED6", scm_from_int (SDL_EVENT_RESERVED6)); - scm_c_define ("SDL_EVENT_RESERVED7", scm_from_int (SDL_EVENT_RESERVED7)); - scm_c_define ("SDL_USEREVENT", scm_from_int (SDL_USEREVENT)); - scm_c_define ("SDL_NUMEVENTS", scm_from_int (SDL_NUMEVENTS)); - - scm_c_define_gsubr ("SDL_Init", 1, 0, 0, gacela_SDL_Init); - scm_c_define_gsubr ("SDL_Quit", 0, 0, 0, gacela_SDL_Quit); - scm_c_define_gsubr ("SDL_SetVideoMode", 4, 0, 0, gacela_SDL_SetVideoMode); - scm_c_define_gsubr ("SDL_FreeSurface", 1, 0, 0, gacela_SDL_FreeSurface); - scm_c_define_gsubr ("SDL_WM_SetCaption", 2, 0, 0, gacela_SDL_WM_SetCaption); - scm_c_define_gsubr ("SDL_WM_ToggleFullScreen", 1, 0, 0, gacela_SDL_WM_ToggleFullScreen); - scm_c_define_gsubr ("SDL_Flip", 1, 0, 0, gacela_SDL_Flip); - scm_c_define_gsubr ("SDL_Delay", 1, 0, 0, gacela_SDL_Delay); - scm_c_define_gsubr ("SDL_GetTicks", 0, 0, 0, gacela_SDL_GetTicks); - scm_c_define_gsubr ("SDL_GetError", 0, 0, 0, gacela_SDL_GetError); - scm_c_define_gsubr ("SDL_DisplayFormat", 1, 0, 0, gacela_SDL_DisplayFormat); - scm_c_define_gsubr ("SDL_DisplayFormatAlpha", 1, 0, 0, gacela_SDL_DisplayFormatAlpha); - scm_c_define_gsubr ("SDL_MapRGB", 4, 0, 0, gacela_SDL_MapRGB); - scm_c_define_gsubr ("SDL_SetColorKey", 3, 0, 0, gacela_SDL_SetColorKey); - scm_c_define_gsubr ("SDL_SetAlpha", 3, 0, 0, gacela_SDL_SetAlpha); - scm_c_define_gsubr ("SDL_LoadBMP", 1, 0, 0, gacela_SDL_LoadBMP); - scm_c_define_gsubr ("IMG_Load", 1, 0, 0, gacela_IMG_Load); - scm_c_define_gsubr ("SDL_GetVideoInfo", 0, 0, 0, gacela_SDL_GetVideoInfo); - scm_c_define_gsubr ("SDL_GL_SetAttribute", 2, 0, 0, gacela_SDL_GL_SetAttribute); - scm_c_define_gsubr ("SDL_PollEvent", 0, 0, 0, gacela_SDL_PollEvent); - scm_c_define_gsubr ("SDL_GL_SwapBuffers", 0, 0, 0, gacela_SDL_GL_SwapBuffers); - scm_c_define_gsubr ("SDL_EnableKeyRepeat", 2, 0, 0, gacela_SDL_EnableKeyRepeat); - scm_c_define_gsubr ("zoomSurface", 4, 0, 0, gacela_zoomSurface); - scm_c_define_gsubr ("Mix_OpenAudio", 4, 0, 0, gacela_Mix_OpenAudio); - scm_c_define_gsubr ("Mix_LoadMUS", 1, 0, 0, gacela_Mix_LoadMUS); - scm_c_define_gsubr ("Mix_LoadWAV", 1, 0, 0, gacela_Mix_LoadWAV); - scm_c_define_gsubr ("Mix_PlayChannel", 3, 0, 0, gacela_Mix_PlayChannel); - scm_c_define_gsubr ("Mix_PlayMusic", 2, 0, 0, gacela_Mix_PlayMusic); - scm_c_define_gsubr ("Mix_PlayingMusic", 0, 0, 0, gacela_Mix_PlayingMusic); - scm_c_define_gsubr ("Mix_PausedMusic", 0, 0, 0, gacela_Mix_PausedMusic); - scm_c_define_gsubr ("Mix_PauseMusic", 0, 0, 0, gacela_Mix_PauseMusic); - scm_c_define_gsubr ("Mix_ResumeMusic", 0, 0, 0, gacela_Mix_ResumeMusic); - scm_c_define_gsubr ("Mix_HaltMusic", 0, 0, 0, gacela_Mix_HaltMusic); - scm_c_define_gsubr ("Mix_FreeMusic", 1, 0, 0, gacela_Mix_FreeMusic); - scm_c_define_gsubr ("Mix_FreeChunk", 1, 0, 0, gacela_Mix_FreeChunk); - scm_c_define_gsubr ("Mix_CloseAudio", 0, 0, 0, gacela_Mix_CloseAudio); -} - -void -scm_init_gacela_sdl () -{ - init_gacela_sdl (NULL); -} diff --git a/src/sdl.scm b/src/sdl.scm deleted file mode 100644 index 056a1dc..0000000 --- a/src/sdl.scm +++ /dev/null @@ -1,25 +0,0 @@ -;;; Gacela, a GNU Guile extension for fast games development -;;; Copyright (C) 2009 by Javier Sancho Fernandez -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation, either version 3 of the License, or -;;; (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see . - - -(define-module (gacela sdl)) - -(load-extension "libguile-gacela-sdl" "scm_init_gacela_sdl") - -(module-map (lambda (sym var) - (if (not (eq? sym '%module-public-interface)) - (module-export! (current-module) (list sym)))) - (current-module)) diff --git a/src/server.scm b/src/server.scm deleted file mode 100644 index 1e54001..0000000 --- a/src/server.scm +++ /dev/null @@ -1,102 +0,0 @@ -;;; Gacela, a GNU Guile extension for fast games development -;;; Copyright (C) 2009 by Javier Sancho Fernandez -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation, either version 3 of the License, or -;;; (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see . - - -(define-module (gacela server) - #:use-module (ice-9 optargs) - #:export (eval-from-client)) - - -(define start-server #f) -(define check-connections #f) -(define clean-closed-connections #f) -(define eval-from-clients #f) -(define stop-server #f) - -(let ((server-socket #f) (clients '()) - (server-pipes #f)) - (set! start-server - (lambda* (#:key (port #f) (pipes #f)) - (cond (port - (set! server-socket (socket PF_INET SOCK_STREAM 0)) - (setsockopt server-socket SOL_SOCKET SO_REUSEADDR 1) - (bind server-socket AF_INET INADDR_ANY port) - (listen server-socket 5)) - (pipes - (set! server-pipes pipes))) - (cond ((not (game-running?)) - (game-loop))))) - - - (set! clean-closed-connections - (lambda (conns) - (cond ((null? conns) '()) - (else - (let* ((cli (car conns)) (sock (car cli))) - (cond ((port-closed? sock) - (clean-closed-connections (cdr conns))) - (else - (cons cli (clean-closed-connections (cdr conns)))))))))) - - (set! check-connections - (lambda () - (set! clients (clean-closed-connections clients)) - (catch #t - (lambda () - (cond ((char-ready? server-socket) - (set! clients (cons (accept server-socket) clients))))) - (lambda (key . args) #f)))) - - (set! eval-from-clients - (lambda () - (cond (server-pipes - (eval-from-client (car server-pipes) (cdr server-pipes)))) - (for-each - (lambda (cli) (eval-from-client (car cli) (car cli))) - clients))) - - (set! stop-server - (lambda () - (cond (server-socket - (close server-socket) - (set! server-socket #f))) - (for-each (lambda (cli) (close (car cli))) clients) - (set! clients '())))) - -(define (eval-from-client rec-channel send-channel) - (cond ((char-ready? rec-channel) - (catch #t - (lambda () - (display "leido")(newline) - (let ((exp (read rec-channel))) - (cond ((eof-object? exp) - (close rec-channel)) - (else - (let ((result (eval-string exp))) - (write (if (eq? result *unspecified*) "" (format #f "~a" result)) send-channel)))))) - (lambda (key . args) - (let ((fmt (string-concatenate (list (cadr args) "~%"))) - (params (caddr args))) - (write - (if params - (apply format (cons #f (cons fmt params))) - (format #f fmt)) - send-channel)))) - (force-output send-channel)))) - - -(define (connect-to-server client-socket hostname port) - (connect client-socket AF_INET (car (hostent:addr-list (gethost hostname))) port)) diff --git a/src/utils.scm b/src/utils.scm deleted file mode 100644 index ed09712..0000000 --- a/src/utils.scm +++ /dev/null @@ -1,177 +0,0 @@ -;;; Gacela, a GNU Guile extension for fast games development -;;; Copyright (C) 2009 by Javier Sancho Fernandez -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation, either version 3 of the License, or -;;; (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see . - - -(define-module (gacela utils) - #:export (use-cache-with - arguments-calling - arguments-apply - bound? - names-arguments - make-producer)) - - -;;; Cache for procedures - -(define (use-cache-with proc) - "Cache for procedures" - (let ((cache (make-weak-value-hash-table))) - (lambda (. param) - (let* ((key param) - (res (hash-ref cache key))) - (cond (res res) - (else - (set! res (apply proc param)) - (hash-set! cache key res) - res)))))) - - -;;; Playing with procedures arguments - -(define undefined) -(define (bound? var) (not (eq? var undefined))) - -(define (required-arguments args values) - "Return an alist with required arguments and their values" - (define (f vars values) - (cond ((null? vars) '()) - ((null? values) (assoc-set! (f (cdr vars) '()) - (car vars) - undefined)) - (else (assoc-set! (f (cdr vars) (cdr values)) - (car vars) - (car values))))) - (f (assoc-ref args 'required) values)) - -(define (optional-arguments args values) - "Return an alist with optional arguments and their values" - (define (f vars values) - (cond ((null? vars) '()) - ((null? values) (assoc-set! (f (cdr vars) '()) - (car vars) - undefined)) - (else (assoc-set! (f (cdr vars) (cdr values)) - (car vars) - (car values))))) - (f (assoc-ref args 'optional) - (list-tail values - (min (length (assoc-ref args 'required)) - (length values))))) - -(define (keyword-arguments args values) - "Return an alist with keyword arguments and their values" - (define (f vars values) - (cond ((null? vars) '()) - (else - (let ((val (member (car vars) values))) - (assoc-set! (f (cdr vars) values) - (keyword->symbol (car vars)) - (if val (cadr val) undefined)))))) - (f (map (lambda (x) (car x)) (assoc-ref args 'keyword)) values)) - -(define (rest-arguments args values) - "Return an alist with rest arguments" - (let ((rest (assoc-ref args 'rest))) - (cond (rest (assoc-set! '() - rest - (list-tail values - (min (+ (length (assoc-ref args 'required)) - (length (assoc-ref args 'optional))) - (length values))))) - (else '())))) - -(define (arguments-calling proc values) - "Return an alist with procedure arguments and their values" - (let ((args ((@ (ice-9 session) procedure-arguments) proc))) - (append (required-arguments args values) - (optional-arguments args values) - (keyword-arguments args values) - (rest-arguments args values)))) - -(define (required-arguments-apply args values) - "Return a list with required arguments for use with apply" - (define (f vars values) - (cond ((null? vars) '()) - (else - (cons (assoc-ref values (car vars)) - (f (cdr vars) values))))) - (f (assoc-ref args 'required) values)) - -(define (optional-arguments-apply args values) - "Return a list with optional arguments for use with apply" - (define (f vars values) - (cond ((null? vars) '()) - (else (let ((a (f (cdr vars) values)) - (val (assoc (car vars) values))) - (cond ((and val (bound? (cdr val))) - (cons (cdr val) a)) - (else a)))))) - (f (assoc-ref args 'optional) values)) - -(define (keyword-arguments-apply args values) - "Return a list with keyword arguments for use with apply" - (define (f vars values) - (cond ((null? vars) '()) - (else (let ((a (f (cdr vars) values)) - (val (assoc (keyword->symbol (car vars)) values))) - (cond ((and val (bound? (cdr val))) - (cons (car vars) (cons (cdr val) a))) - (else a)))))) - (f (map (lambda (x) (car x)) (assoc-ref args 'keyword)) values)) - -(define (rest-arguments-apply args values) - "Return a list with rest arguments for use with apply" - (let ((rest (assoc-ref args 'rest))) - (cond (rest (assoc-ref values rest)) - (else '())))) - -(define (arguments-apply proc values) - "Return a list for use with apply" - (let ((args ((@ (ice-9 session) procedure-arguments) proc))) - (append (required-arguments-apply args values) - (optional-arguments-apply args values) - (keyword-arguments-apply args values) - (rest-arguments-apply args values)))) - -(define (names-arguments args) - (map (lambda (x) (if (list? x) (car x) x)) - (filter (lambda (x) (not (keyword? x))) - (pair-to-list args)))) - - -;;; Continuations and coroutines - -(define (make-producer body) - (define resume #f) - (lambda (real-send) - (define send-to real-send) - (define (send value-to-send) - (set! send-to - (call/cc - (lambda (k) - (set! resume k) - (send-to value-to-send))))) - (if resume - (resume real-send) - (body send)))) - - -;;; Miscellaneous - -(define (pair-to-list pair) - (cond ((null? pair) '()) - ((not (pair? pair)) (list pair)) - (else (cons (car pair) (pair-to-list (cdr pair)))))) diff --git a/src/video.scm b/src/video.scm deleted file mode 100644 index 1d423bb..0000000 --- a/src/video.scm +++ /dev/null @@ -1,616 +0,0 @@ -;;; Gacela, a GNU Guile extension for fast games development -;;; Copyright (C) 2009 by Javier Sancho Fernandez -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation, either version 3 of the License, or -;;; (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see . - - -(define-module (gacela video) - #:use-module (gacela sdl) -; #:use-module (gacela gl) - #:use-module (figl gl) - #:use-module (figl glx) - #:use-module (figl glu) - #:use-module (gacela ftgl) - #:use-module (gacela math) - #:use-module (gacela utils) - #:use-module (ice-9 optargs) - #:use-module (ice-9 receive) - #:use-module (srfi srfi-9) - #:use-module (system foreign) - #:export (init-video - get-screen-height - get-screen-width - get-screen-bpp - set-screen-bpp! - resize-screen - quit-video - clear-screen - flip-screen - set-screen-title! - get-screen-title - set-2d-mode - set-3d-mode - 3d-mode? - get-frames-per-second - set-frames-per-second! - get-fullscreen - set-fullscreen! - init-frame-time - get-frame-time - delay-frame - get-current-color - set-current-color - with-color - with-textures - draw - load-texture - load-texture-without-cache - get-texture-properties - draw-texture - draw-line - draw-quad - draw-rectangle - draw-square - draw-cube - translate - rotate - to-origin - add-light - set-camera - camera-look - load-font - load-font-without-texture - render-text) - #:re-export (with-gl-push-matrix)) - - - -;;; Screen - -(define screen #f) -(define flags 0) - -(define* (init-video width height bpp #:key (mode '2d) (title "") (fps 20) (fullscreen 'off)) - (SDL_Init SDL_INIT_VIDEO) - (let ((info (SDL_GetVideoInfo))) - (SDL_GL_SetAttribute SDL_GL_DOUBLEBUFFER 1) - (set! flags (+ SDL_OPENGL SDL_GL_DOUBLEBUFFER SDL_HWPALETTE SDL_RESIZABLE - (if (= (assoc-ref info 'hw_available) 0) SDL_SWSURFACE SDL_HWSURFACE) - (if (= (assoc-ref info 'blit_hw) 0) 0 SDL_HWACCEL) - (if (eq? fullscreen 'on) SDL_FULLSCREEN 0))) - (set! screen (SDL_SetVideoMode width height bpp flags)) - (set-screen-title! title) - (set-frames-per-second! fps) - (set-fullscreen! fullscreen #f) - (init-gl) - (if (eq? mode '3d) (set-3d-mode) (set-2d-mode)))) - -(define (get-screen-height) - (surface-h screen)) - -(define (get-screen-width) - (surface-w screen)) - -(define (get-screen-bpp) - (* (surface-format-BytesPerPixel screen) 8)) - -(define (set-screen-bpp! bpp) - (cond (screen - (set! screen (SDL_SetVideoMode (get-screen-width) (get-screen-height) (get-screen-bpp) flags))))) - -(define (resize-screen width height) - (cond (screen - (set! screen (SDL_SetVideoMode width height (get-screen-bpp) flags)) - (resize-screen-GL width height)))) - -(define (quit-video) - (cond (screen - (SDL_FreeSurface screen) - (set! screen #f) - (SDL_Quit)))) - -(define (clear-screen) - (gl-clear (clear-buffer-mask color-buffer depth-buffer))) - -(define (flip-screen) - (SDL_GL_SwapBuffers)) - - -(define screen-title "") - -(define (set-screen-title! title) - (set! screen-title title) - (SDL_WM_SetCaption title "")) - -(define (get-screen-title) - screen-title) - - -(define mode '2d) - -(define (set-2d-mode) - (set! mode '2d) - (gl-disable (enable-cap depth-test)) - (resize-screen-GL (get-screen-width) (get-screen-height))) - -(define (set-3d-mode) - (set! mode '3d) - (set-gl-clear-depth 1) - (gl-enable (enable-cap depth-test)) - (set-gl-depth-function (depth-function lequal)) - (resize-screen-GL (get-screen-width) (get-screen-height))) - -(define (3d-mode?) - (eq? mode '3d)) - - -(define fullscreen 'off) - -(define* (set-fullscreen! fs #:optional (toggle #t)) - (cond ((or (and (eq? fullscreen 'on) (eq? fs 'off)) - (and (eq? fullscreen 'off) (eq? fs 'on))) - (set! fullscreen fs) - (cond (toggle - (SDL_WM_ToggleFullScreen screen)))))) - -(define (get-fullscreen) - fullscreen) - - -(define (init-gl) - (set-gl-shade-model (shading-model smooth)) - (set-gl-clear-color 0 0 0 0) - (gl-enable (enable-cap blend)) - (set-gl-blend-function (blending-factor-dest src-alpha) (blending-factor-dest one-minus-src-alpha)) - (set-gl-hint (hint-target perspective-correction-hint) (hint-mode nicest))) - -(define (resize-screen-GL width height) - (gl-viewport 0 0 width height) - (set-gl-matrix-mode (matrix-mode projection)) - (gl-load-identity) - (cond ((3d-mode?) - (let ((ratio (if (= height 0) width (/ width height)))) - (glu-perspective 45 ratio 0.1 100))) - (else - (let* ((w (/ width 2)) (h (/ height 2))) - (gl-ortho (- w) w (- h) h 0 1)))) - (set-gl-matrix-mode (matrix-mode modelview)) - (gl-load-identity)) - - -;;; Frames per second - -(define time 0) -(define frames-per-second 20) -(define time-per-frame 50) ;in ms - -(define (get-frames-per-second) - frames-per-second) - -(define (set-frames-per-second! fps) - (set! frames-per-second fps) - (set! time-per-frame (/ 1000.0 fps))) - -(define (init-frame-time) - (set! time (SDL_GetTicks))) - -(define (get-frame-time) - time) - -(define (delay-frame) - (let ((frame-time (- (SDL_GetTicks) time))) - (cond ((< frame-time time-per-frame) - (SDL_Delay (- time-per-frame frame-time)))))) - - -;;; Textures - -(define-record-type - (texture id width height) - texture? - (id texture-id) - (width texture-width set-texture-width) - (height texture-height set-texture-height)) - -(define-macro (with-textures . code) - `(let ((result #f)) - (gl-enable (oes-framebuffer-object texture-2d)) - (set! result (begin ,@code)) - (gl-disable (oes-framebuffer-object texture-2d)) - result)) - -(define (load-image filename) - (let ((image (IMG_Load filename))) - (cond (image - (SDL_DisplayFormatAlpha image))))) - -(define (load-image-for-texture filename) - (let ((image (load-image filename))) - (cond (image - (let* ((width (surface-w image)) (height (surface-h image)) - (power-2 (nearest-power-of-two (min width height))) - (resized-image #f)) - (cond ((and (= width power-2) (= height power-2)) (values image width height)) - (else (set! resized-image (resize-surface image power-2 power-2)) - (if resized-image (values resized-image width height)))))) - (else - (values #f 0 0))))) - -(define (resize-surface surface width height) - (let ((old-width (surface-w surface)) (old-height (surface-h surface))) - (cond ((and (= width old-width) (= height old-height)) surface) - (else (let ((zoomx (/ (+ width 0.5) old-width)) (zoomy (/ (+ height 0.5) old-height))) - (zoomSurface surface zoomx zoomy 0)))))) - -(define* (load-texture-without-cache filename #:key (min-filter (texture-min-filter linear)) (mag-filter (texture-mag-filter linear))) - (with-textures - (receive - (image real-w real-h) (load-image-for-texture filename) - (cond (image - (let ((width (surface-w image)) (height (surface-h image)) - (byteorder (if (= SDL_BYTEORDER SDL_LIL_ENDIAN) - (if (= (surface-format-BytesPerPixel image) 3) (ext-bgra bgr-ext) (ext-bgra bgra-ext)) - (if (= (surface-format-BytesPerPixel image) 3) (pixel-format rgb) (pixel-format rgba)))) - (texture-id (gl-generate-texture)) - (image-pointer (make-pointer - (if (> (surface-pixels image) 0) - (surface-pixels image) - (+ ($expt 2 32) (surface-pixels image)))))) - - (gl-bind-texture (oes-framebuffer-object texture-2d) texture-id) - (set-gl-texture-image (oes-framebuffer-object texture-2d) 0 4 0 byteorder (data-type unsigned-byte) image-pointer width height) - (set-gl-texture-parameter (oes-framebuffer-object texture-2d) (texture-parameter-name texture-min-filter) min-filter) - (set-gl-texture-parameter (oes-framebuffer-object texture-2d) (texture-parameter-name texture-mag-filter) mag-filter) - (texture texture-id real-w real-h))))))) - -(define load-texture (use-cache-with load-texture-without-cache)) - - -;;; Drawing - -(define current-color '(1 1 1 1)) - -(define (get-current-color) - current-color) - -(define* (set-current-color red green blue #:optional (alpha 1)) - (set! current-color (list red green blue alpha)) - (gl-color red green blue alpha)) - -(define-macro (with-color color . code) - `(cond (,color - (let ((original-color (get-current-color)) - (result #f)) - (apply set-current-color ,color) - (set! result (begin ,@code)) - (apply set-current-color original-color) - result)) - (else (begin ,@code)))) - -(define (draw . vertexes) - (gl-begin - (let ((number-of-points (length vertexes))) - (cond ((= number-of-points 2) (begin-mode lines)) - ((= number-of-points 3) (begin-mode triangles)) - ((= number-of-points 4) (begin-mode quads)) - ((> number-of-points 4) (begin-mode polygon)))) - (draw-vertexes vertexes))) - -(define (draw-vertexes vertexes) - (cond ((not (null? vertexes)) - (apply draw-vertex (if (list? (caar vertexes)) (car vertexes) (list (car vertexes)))) - (draw-vertexes (cdr vertexes))))) - -(define* (draw-vertex vertex #:key texture-coord) - (cond (texture-coord (apply gl-texture-coordinates texture-coord))) - (apply gl-vertex vertex)) - -(define* (draw-texture texture #:key (zoom 1) (sprite '((0 0) (1 1)))) - (cond (texture - (let ((width (texture-width texture)) - (height (texture-height texture))) - (draw-rectangle (* zoom width (- (caadr sprite) (caar sprite))) - (* zoom height (- (cadadr sprite) (cadar sprite))) - #:texture texture - #:texture-coord sprite))))) - -(define* (draw-line length) - (let ((l (/ length 2))) - (draw (list 0 l) (list 0 (- l))))) - -(define (draw-circle radius) - (gl-begin - (begin-mode polygon) - (do ((i 0 (1+ i))) - ((>= i 360)) - (let ((a (degrees-to-radians i))) - (draw-vertex (list (* radius (cos a)) (* radius (sin a)))))))) - -(define* (draw-quad v1 v2 v3 v4 #:key texture (texture-coord '((0 0) (1 1)))) - (cond (texture - (with-textures - (gl-bind-texture (oes-framebuffer-object texture-2d) (texture-id texture)) - (draw (list v1 #:texture-coord (car texture-coord)) - (list v2 #:texture-coord (list (caadr texture-coord) (cadar texture-coord))) - (list v3 #:texture-coord (cadr texture-coord)) - (list v4 #:texture-coord (list (caar texture-coord) (cadadr texture-coord)))))) - (else - (draw v1 v2 v3 v4)))) - -(define* (draw-rectangle width height #:key texture texture-coord) - (let ((w (/ width 2)) (h (/ height 2))) - (draw-quad (list (- w) h 0) - (list w h 0) - (list w (- h) 0) - (list (- w) (- h) 0) - #:texture texture - #:texture-coord texture-coord))) - -(define* (draw-square size #:key texture) - (draw-rectangle size size #:texture texture)) - -(define* (draw-cube #:key (size 1) - texture texture-1 texture-2 texture-3 texture-4 texture-5 texture-6 - color-1 color-2 color-3 color-4 color-5 color-6) - (let ((-size (- size))) - (with-textures - (gl-normal 0 0 1) - (with-color color-1 (draw-quad (list -size size size) (list size size size) (list size -size size) (list -size -size size) #:texture (or texture-1 texture))) - (gl-normal 0 0 -1) - (with-color color-2 (draw-quad (list -size -size -size) (list size -size -size) (list size size -size) (list -size size -size) #:texture (or texture-2 texture))) - (gl-normal 0 1 0) - (with-color color-3 (draw-quad (list size size size) (list -size size size) (list -size size -size) (list size size -size) #:texture (or texture-3 texture))) - (gl-normal 0 -1 0) - (with-color color-4 (draw-quad (list -size -size size) (list size -size size) (list size -size -size) (list -size -size -size) #:texture (or texture-4 texture))) - (gl-normal 1 0 0) - (with-color color-5 (draw-quad (list size -size -size) (list size -size size) (list size size size) (list size size -size) #:texture (or texture-5 texture))) - (gl-normal -1 0 0) - (with-color color-6 (draw-quad (list -size -size size) (list -size -size -size) (list -size size -size) (list -size size size) #:texture (or texture-6 texture)))))) - -(define* (gtranslate x y #:optional (z 0)) - (gl-translate x y z)) - -(define (grotate . rot) - (cond ((3d-mode?) - (apply 3d-rotate rot)) - (else - (2d-rotate (car (last-pair rot)))))) - -(define (3d-rotate xrot yrot zrot) - (gl-rotate xrot 1 0 0) - (gl-rotate yrot 0 1 0) - (gl-rotate zrot 0 0 1)) - -(define (2d-rotate rot) - (gl-rotate rot 0 0 1)) - -(define (to-origin) - (gl-load-identity) - (cond ((3d-mode?) (camera-look)))) - - -;;; Lights - -;; (define* (add-light #:key light position ambient (id GL_LIGHT1) (turn-on t)) -;; (init-lighting) -;; (and light (glLightfv id GL_DIFFUSE (car light) (cadr light) (caddr light) (cadddr light))) -;; (and light position (glLightfv GL_POSITION (car position) (cadr position) (caddr position) (cadddr position))) -;; (and ambient (glLightfv id GL_AMBIENT (car ambient) (cadr ambient) (caddr ambient) (cadddr ambient))) -;; (and turn-on (gl-enable id)) -;; id) - - -;;; Camera - -(define camera-eye '(0 0 0)) -(define camera-center '(0 0 -100)) -(define camera-up '(0 1 0)) - -(define* (set-camera #:key eye center up) - (cond (eye (set! camera-eye eye))) - (cond (center (set! camera-center center))) - (cond (up (set! camera-up up)))) - -(define (camera-look) - (apply glu-look-at (append camera-eye camera-center camera-up))) - - -;;; Text and fonts - -(define* (load-font-without-cache font-file #:key (size 40) (encoding ft_encoding_unicode)) - (let ((font (ftglCreateTextureFont font-file size))) - (ftglSetFontFaceSize font size 72) - (ftglSetFontCharMap font encoding) - font)) - -(define load-font (use-cache-with load-font-without-cache)) - -(define* (render-text text font #:key (size #f)) - (cond (size - (cond ((not (= (ftglGetFontFaceSize font) size)) - (ftglSetFontFaceSize font size 72)))) - ((not (= (ftglGetFontFaceSize font) (font-size font))) - (ftglSetFontFaceSize font (font-size font) 72))) - (ftglRenderFont font text FTGL_RENDER_ALL)) - - -;;; Meshes - -(define mesh-type - (make-record-type "mesh" - '(draw translate turn rotate color inner-properties inner-property properties properties-set! property property-set!) - (lambda (record port) - (format port "#" port)))) - -(define mesh? (record-predicate mesh-type)) - -(define (make-mesh type proc) - (apply - (record-constructor mesh-type) - (let ((px 0) (py 0) (pz 0) - (ax 0) (ay 0) (az 0) - (rx 0) (ry 0) (rz 0) - (color #f) - (properties '())) - (let ((inner-properties - (lambda () - `((type . ,type) (color . ,color) - (x . ,px) (y . ,py) (z . ,pz) - (ax . ,ax) (ay . ,ay) (az . ,az) - (rx . ,rx) (ry . ,ry) (rz . ,rz))))) - (list - (lambda () - "draw" - (with-gl-push-matrix - (grotate ax ay az) - (gtranslate px py pz) - (grotate rx ry rz) - (with-color color (proc properties)))) - (lambda (x y z) - "translate" - (set! px (+ px x)) - (set! py (+ py y)) - (set! pz (+ pz z))) - (lambda (x y z) - "turn" - (set! ax (+ ax x)) - (set! ay (+ ay y)) - (set! az (+ az z))) - (lambda (x y z) - "rotate" - (set! rx (+ rx x)) - (set! ry (+ ry y)) - (set! rz (+ rz z))) - (lambda (c) - "color" - (set! color c)) - (lambda () - "inner-properties" - (inner-properties)) - (lambda (prop-name) - "inner-property" - (assoc-ref (inner-properties) prop-name)) - (lambda () - "properties" - properties) - (lambda (new-properties) - "properties-set!" - (set! properties new-properties)) - (lambda (prop-name) - "property" - (assoc-ref properties prop-name)) - (lambda (prop-name value) - "property-set!" - (set! properties (assoc-set! properties prop-name value)))))))) - -(define (mesh-draw mesh) - (((record-accessor mesh-type 'draw) mesh))) - -(define (mesh-inner-properties mesh) - (((record-accessor mesh-type 'inner-properties) mesh))) - -(define (mesh-inner-property mesh prop-name) - (((record-accessor mesh-type 'inner-property) mesh) prop-name)) - -(define (mesh-properties mesh) - (((record-accessor mesh-type 'properties) mesh))) - -(define (mesh-properties-set! mesh new-properties) - (((record-accessor mesh-type 'properties-set!) mesh) new-properties)) - -(define (mesh-property mesh prop-name) - (((record-accessor mesh-type 'property) mesh) prop-name)) - -(define (mesh-property-set! mesh prop-name value) - (((record-accessor mesh-type 'property-set!) mesh) prop-name value)) - -(define* (translate mesh x y #:optional (z 0)) - (((record-accessor mesh-type 'translate) mesh) x y z) - mesh) - -(define (turn mesh . params) - (apply ((record-accessor mesh-type 'turn) mesh) - (if (>= (length params) 3) - params - (list 0 0 (car params)))) - mesh) - -(define (rotate mesh . params) - (apply ((record-accessor mesh-type 'rotate) mesh) - (if (>= (length params) 3) - params - (list 0 0 (car params)))) - mesh) - -(define (color mesh c) - (((record-accessor mesh-type 'color) mesh) c) - mesh) - - -;;; Advanced meshes - -(define (mesh-join . meshes) - (make-mesh - 'joined-meshes - (lambda (props) - (for-each (lambda (m) (with-gl-push-matrix (mesh-draw m))) meshes)))) - - -;;; Primitives - -(define-macro (primitive header . body) - (let* ((type (car header)) - (args (cdr header)) - (list-args (names-arguments args))) - `(lambda* ,args - (let ((m (make-mesh - ',type - (lambda (props) - (apply (lambda* ,(cons #:key list-args) ,@body) - (list - ,@(let get-params ((l list-args)) - (cond ((null? l) '()) - (else - (cons (symbol->keyword (car l)) - (cons `(assoc-ref props ',(car l)) - (get-params (cdr l))))))))))))) - (mesh-properties-set! m (list ,@(map (lambda (a) `(cons ',a ,a)) list-args))) - m)))) - -(define-macro (define-primitive header . body) - `(define ,(car header) (primitive ,header ,@body))) - - -;;; Primitives definition - -(define-primitive (square size #:key texture) - (draw-square size #:texture texture)) - -(define-primitive (rectangle width height #:key texture texture-coord) - (draw-rectangle width height #:texture texture #:texture-coord texture-coord)) - -(define-primitive (circle radius) - (draw-circle radius)) - -(define-primitive (picture filename #:key (min-filter (texture-min-filter linear)) (mag-filter (texture-mag-filter linear)) (zoom 1) (sprite '((0 0) (1 1)))) - (draw-texture (load-texture filename #:min-filter min-filter #:mag-filter mag-filter) #:zoom zoom #:sprite sprite)) - - -(module-map (lambda (sym var) - (if (not (eq? sym '%module-public-interface)) - (module-export! (current-module) (list sym)))) - (current-module)) \ No newline at end of file diff --git a/src/views.scm b/src/views.scm deleted file mode 100644 index 8e2c21c..0000000 --- a/src/views.scm +++ /dev/null @@ -1,259 +0,0 @@ -;;; Gacela, a GNU Guile extension for fast games development -;;; Copyright (C) 2009 by Javier Sancho Fernandez -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation, either version 3 of the License, or -;;; (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see . - - -(define-module (gacela views) - #:use-module (gacela gacela) - #:use-module ((gacela video) #:renamer (symbol-prefix-proc 'video:)) - #:use-module ((gacela gl) #:select (glPushMatrix glPopMatrix)) - #:use-module (ice-9 optargs)) - - -;;; Views - -(define view-type - (make-record-type "view" - '(id controllers meshes priority) - (lambda (record port) - (format port "#" - (length (view-meshes record)))))) - -(define (make-view controllers meshes priority) ((record-constructor view-type) (gensym) controllers meshes priority)) -(define view? (record-predicate view-type)) -(define view-id (record-accessor view-type 'id)) -(define view-meshes (record-accessor view-type 'meshes)) -(define view-meshes-set! (record-modifier view-type 'meshes)) -(define view-controllers (record-accessor view-type 'controllers)) -(define view-controllers-set! (record-modifier view-type 'controllers)) -(define view-priority (record-accessor view-type 'priority)) - -(defmacro* view (#:key (priority 0) . elements) - `(let ((e (view-elements ,@elements))) - (make-view (car e) (cadr e) ,priority))) - -(define-macro (view-elements . elements) - (cond ((null? elements) `'(() ())) - (else - `(let ((l (view-elements ,@(cdr elements)))) - ,(let ((e (car elements))) - `(cond ((mesh? ,e) - (list (car l) (cons ,e (cadr l)))) - ((procedure? ,e) - (list (cons ,(if (list? e) e `(lambda () (,e))) (car l)) - (cadr l))) - (else l))))))) - -(define (controllers-list list controllers) - (cond ((null? controllers) - list) - ((list? (car controllers)) - (assoc-set! (controllers-list list (cdr controllers)) (caar controllers) (cadar controllers))) - (else - (assoc-set! (controllers-list list (cdr controllers)) (gensym) (car controllers))))) - -(define activated-views '()) - -(define (sort-views views-alist) - (sort views-alist - (lambda (v1 v2) - (< (view-priority (cdr v1)) (view-priority (cdr v2)))))) - -(define (activate-view view) - (set! activated-views - (sort-views (assoc-set! activated-views (view-id view) view))) - view) - -(define (view-actived? view) - (and (assoc (view-id view) activated-views) #t)) - -(define (view-priority-set! view priority) - ((record-modifier view-type 'priority) view priority) - (if (view-actived? view) - (set! activated-views (sort-views activated-views)))) - -(define current-view #f) - -(define* (run-views #:optional (views activated-views)) - (cond ((not (null? views)) - (set! current-view (cdar views)) - ;((view-body current-view)) - (draw-meshes (view-meshes current-view)) - (run-views (cdr views))))) - -(define (draw-meshes meshes) - (cond ((not (null? meshes)) - (catch #t - (lambda () (mesh-draw (cdar meshes))) - (lambda (key . args) #f)) - (draw-meshes (cdr meshes))))) - - -;(define default-view (activate-view (make-view (lambda () #f)))) - - -;;; Meshes - -(define mesh-type - (make-record-type "mesh" - '(draw translate turn rotate inner-properties inner-property properties properties-set! property property-set!) - (lambda (record port) - (format port "#" port)))) - -(define mesh? (record-predicate mesh-type)) - -(define* (make-mesh proc #:optional type) - (apply - (record-constructor mesh-type) - (let ((px 0) (py 0) (pz 0) - (ax 0) (ay 0) (az 0) - (rx 0) (ry 0) (rz 0) - (id (gensym)) - (properties '())) - (let ((inner-properties - (lambda () - `((id . ,id) (type . ,type) (x . ,px) (y . ,py) (z . ,pz) (ax . ,ax) (ay . ,ay) (az . ,az) (rx . ,rx) (ry . ,ry) (rz . ,rz))))) - (list - (lambda () - "draw" - (video:glmatrix-block - (video:rotate ax ay az) - (video:translate px py pz) - (video:rotate rx ry rz) - (proc properties))) - (lambda (x y z) - "translate" - (set! px (+ px x)) - (set! py (+ py y)) - (set! pz (+ pz z))) - (lambda (x y z) - "turn" - (set! ax (+ ax x)) - (set! ay (+ ay y)) - (set! az (+ az z))) - (lambda (x y z) - "rotate" - (set! rx (+ rx x)) - (set! ry (+ ry y)) - (set! rz (+ rz z))) - (lambda () - "inner-properties" - (inner-properties)) - (lambda (prop-name) - "inner-property" - (assoc-ref (inner-properties) prop-name)) - (lambda () - "properties" - properties) - (lambda (new-properties) - "properties-set!" - (set! properties new-properties)) - (lambda (prop-name) - "property" - (assoc-ref properties prop-name)) - (lambda (prop-name value) - "property-set!" - (set! properties (assoc-set! properties prop-name value)))))))) - -(define (mesh-draw mesh) - (((record-accessor mesh-type 'draw) mesh))) - -(define (mesh-inner-properties mesh) - (((record-accessor mesh-type 'inner-properties) mesh))) - -(define (mesh-inner-property mesh prop-name) - (((record-accessor mesh-type 'inner-property) mesh) prop-name)) - -(define (mesh-properties mesh) - (((record-accessor mesh-type 'properties) mesh))) - -(define (mesh-properties-set! mesh new-properties) - (((record-accessor mesh-type 'properties-set!) mesh) new-properties)) - -(define (mesh-property mesh prop-name) - (((record-accessor mesh-type 'property) mesh) prop-name)) - -(define (mesh-property-set! mesh prop-name value) - (((record-accessor mesh-type 'property-set!) mesh) prop-name value)) - -(define* (show mesh #:optional (view current-view)) - (let ((id (mesh-inner-property mesh 'id)) - (table (view-meshes view))) - (if (not (assoc-ref table id)) - (view-meshes-set! view (assoc-set! table id mesh)))) - mesh) - -(define* (hide mesh #:optional (view current-view)) - (let ((id (mesh-inner-property mesh 'id)) - (table (view-meshes view))) - (if (assoc-ref table id) - (view-meshes-set! view (assoc-remove! table id)))) - mesh) - -(define* (translate mesh x y #:optional (z 0)) - (((record-accessor mesh-type 'translate) mesh) x y z) - mesh) - -(define (turn mesh . params) - (apply ((record-accessor mesh-type 'turn) mesh) - (if (>= (length params) 3) - params - (list 0 0 (car params)))) - mesh) - -(define (rotate mesh . params) - (apply ((record-accessor mesh-type 'rotate) mesh) - (if (>= (length params) 3) - params - (list 0 0 (car params)))) - mesh) - - -;;; Primitives - -(defmacro* define-primitive (proc #:optional type) - `(lambda (. params) - (let ((m (make-mesh (lambda (props) (apply ,proc ((@ (gacela utils) arguments-apply) ,proc props))) ,type))) - (mesh-properties-set! m ((@ (gacela utils) arguments-calling) ,proc params)) - m))) - -(define-macro (define-primitives . symbols) - (cond ((null? symbols) - `#t) - (else - (let ((origin (caar symbols)) - (dest (cadar symbols))) - `(begin - (define ,origin (define-primitive ,dest ',origin)) - (define-primitives ,@(cdr symbols))))))) - -(define-primitives - (rectangle video:draw-rectangle) - (square video:draw-square)) - - -;;; Adding extensions to the main loop -(add-extension! run-views 10) - - -(module-map (lambda (sym var) - (if (not (eq? sym '%module-public-interface)) - (module-export! (current-module) (list sym)))) - (current-module)) diff --git a/src/widgets/timer.scm b/src/widgets/timer.scm deleted file mode 100755 index 39899f7..0000000 --- a/src/widgets/timer.scm +++ /dev/null @@ -1,74 +0,0 @@ -;;; Gacela, a GNU Guile extension for fast games development -;;; Copyright (C) 2009 by Javier Sancho Fernandez -;;; -;;; This program is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation, either version 3 of the License, or -;;; (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see . - - -(define-module (gacela widgets timer) - #:use-module (gacela sdl) - #:export (make-timer - start-timer - stop-timer - get-time - get-state - pause-timer - resume-timer)) - - -(define (make-timer) - (let ((start 0) (paused 0) (state 'stopped)) - (lambda (op) - (case op - ((start-timer) - (set! start (SDL_GetTicks)) - (set! state 'running)) - - ((stop-timer) - (set! state 'stopped)) - - ((get-time) - (cond ((eq? state 'stopped) 0) - ((eq? state 'paused) paused) - (else (- (SDL_GetTicks) start)))) - - ((get-state) - state) - - ((pause-timer) - (cond ((eq? state 'running) - (set! paused (- (SDL_GetTicks) start)) - (set! state 'paused)))) - - ((resume-timer) - (cond ((eq? state 'paused) - (set! start (- (SDL_GetTicks) paused)) - (set! state 'running)))))))) - -(define (start-timer timer) - (timer 'start-timer)) - -(define (stop-timer timer) - (timer 'stop-timer)) - -(define (get-time timer) - (timer 'get-time)) - -(define (get-state timer) - (timer 'get-state)) - -(define (pause-timer timer) - (timer 'pause-timer)) - -(define (resume-timer timer) - (timer 'resume-timer))