+++ /dev/null
-#!/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)))
+++ /dev/null
-#!/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))
-
+++ /dev/null
-#!/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)))))
+++ /dev/null
-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
+++ /dev/null
-;;; Gacela, a GNU Guile extension for fast games development
-;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
-;;;
-;;; 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 <http://www.gnu.org/licenses/>.
-
-
-(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
+++ /dev/null
-;;; Gacela, a GNU Guile extension for fast games development
-;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
-;;;
-;;; 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 <http://www.gnu.org/licenses/>.
-
-
-(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))))
+++ /dev/null
-;;; Gacela, a GNU Guile extension for fast games development
-;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
-;;;
-;;; 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 <http://www.gnu.org/licenses/>.
-
-
-(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))
+++ /dev/null
-;;; Gacela, a GNU Guile extension for fast games development
-;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
-;;;
-;;; 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 <http://www.gnu.org/licenses/>.
-
-
-(define-module (gacela freeimage)
- #:use-module (system foreign))
-
+++ /dev/null
-/* Gacela, a GNU Guile extension for fast games development
- Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
-
- 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 <http://www.gnu.org/licenses/>.
-*/
-
-#include <libguile.h>
-#include <FTGL/ftgl.h>
-
-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 ("#<font \"", port);
- scm_display (font->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);
-}
+++ /dev/null
-;;; Gacela, a GNU Guile extension for fast games development
-;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
-;;;
-;;; 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 <http://www.gnu.org/licenses/>.
-
-
-(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))
+++ /dev/null
-;;; Gacela, a GNU Guile extension for fast games development
-;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
-;;;
-;;; 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 <http://www.gnu.org/licenses/>.
-
-
-(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))
+++ /dev/null
-/* Gacela, a GNU Guile extension for fast games development
- Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
-
- 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 <http://www.gnu.org/licenses/>.
-*/
-
-#include <libguile.h>
-#include <GL/gl.h>
-#include <GL/glu.h>
-
-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);
-}
+++ /dev/null
-;;; Gacela, a GNU Guile extension for fast games development
-;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
-;;;
-;;; 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 <http://www.gnu.org/licenses/>.
-
-
-(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))
+++ /dev/null
-;;; Gacela, a GNU Guile extension for fast games development
-;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
-;;;
-;;; 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 <http://www.gnu.org/licenses/>.
-
-
-(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))
+++ /dev/null
-/* Gacela, a GNU Guile extension for fast games development
- Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
-
- 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 <http://www.gnu.org/licenses/>.
-*/
-
-#include <libguile.h>
-#include <SDL/SDL.h>
-#include <SDL/SDL_events.h>
-#include <SDL/SDL_image.h>
-#include <SDL/SDL_mixer.h>
-#include <SDL/SDL_rotozoom.h>
-
-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 ("#<surface \"", port);
- scm_display (surface->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);
-}
+++ /dev/null
-;;; Gacela, a GNU Guile extension for fast games development
-;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
-;;;
-;;; 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 <http://www.gnu.org/licenses/>.
-
-
-(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))
+++ /dev/null
-;;; Gacela, a GNU Guile extension for fast games development
-;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
-;;;
-;;; 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 <http://www.gnu.org/licenses/>.
-
-
-(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))
+++ /dev/null
-;;; Gacela, a GNU Guile extension for fast games development
-;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
-;;;
-;;; 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 <http://www.gnu.org/licenses/>.
-
-
-(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))))))
+++ /dev/null
-;;; Gacela, a GNU Guile extension for fast games development
-;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
-;;;
-;;; 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 <http://www.gnu.org/licenses/>.
-
-
-(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>
- (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 "#<mesh: ~a" (mesh-inner-property record 'type))
- (for-each (lambda (x) (format port " ~a" x))
- (mesh-properties record))
- (display ">" 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
+++ /dev/null
-;;; Gacela, a GNU Guile extension for fast games development
-;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
-;;;
-;;; 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 <http://www.gnu.org/licenses/>.
-
-
-(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 "#<view: ~a meshes>"
- (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 "#<mesh: ~a" (mesh-inner-property record 'type))
- (for-each (lambda (x)
- (cond (((@ (gacela utils) bound?) (cdr x))
- (format port " ~a" x))))
- (mesh-properties record))
- (display ">" 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))
+++ /dev/null
-;;; Gacela, a GNU Guile extension for fast games development
-;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
-;;;
-;;; 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 <http://www.gnu.org/licenses/>.
-
-
-(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))
projects / gacela.git / commitdiff