diff options
Diffstat (limited to '2d')
| -rw-r--r-- | 2d/agenda.scm | 206 | ||||
| -rw-r--r-- | 2d/animation.scm | 119 | ||||
| -rw-r--r-- | 2d/audio.scm | 128 | ||||
| -rw-r--r-- | 2d/color.scm | 203 | ||||
| -rw-r--r-- | 2d/config.scm.in | 28 | ||||
| -rw-r--r-- | 2d/coroutine.scm | 82 | ||||
| -rw-r--r-- | 2d/event.scm | 45 | ||||
| -rw-r--r-- | 2d/font.scm | 156 | ||||
| -rw-r--r-- | 2d/fps.scm | 47 | ||||
| -rw-r--r-- | 2d/game.scm | 109 | ||||
| -rw-r--r-- | 2d/helpers.scm | 68 | ||||
| -rw-r--r-- | 2d/keyboard.scm | 88 | ||||
| -rw-r--r-- | 2d/live-reload.scm | 54 | ||||
| -rw-r--r-- | 2d/math.scm | 90 | ||||
| -rw-r--r-- | 2d/mouse.scm | 99 | ||||
| -rw-r--r-- | 2d/rect.scm | 212 | ||||
| -rw-r--r-- | 2d/repl.scm | 37 | ||||
| -rw-r--r-- | 2d/shader.scm | 331 | ||||
| -rw-r--r-- | 2d/signal.scm | 292 | ||||
| -rw-r--r-- | 2d/sprite.scm | 188 | ||||
| -rw-r--r-- | 2d/texture.scm | 224 | ||||
| -rw-r--r-- | 2d/tileset.scm | 89 | ||||
| -rw-r--r-- | 2d/transform.scm | 233 | ||||
| -rw-r--r-- | 2d/vector.scm | 157 | ||||
| -rw-r--r-- | 2d/window.scm | 118 | ||||
| -rw-r--r-- | 2d/wrappers/freeimage.scm | 263 | ||||
| -rw-r--r-- | 2d/wrappers/gl.scm | 96 | ||||
| -rw-r--r-- | 2d/wrappers/util.scm | 40 |
28 files changed, 0 insertions, 3802 deletions
diff --git a/2d/agenda.scm b/2d/agenda.scm deleted file mode 100644 index ab36f23..0000000 --- a/2d/agenda.scm +++ /dev/null @@ -1,206 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu> -;;; -;;; 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/>. - -;;; Commentary: -;; -;; Deferred procedure scheduling. -;; -;;; Code: - -(define-module (2d agenda) - #:use-module (ice-9 q) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-26) - #:use-module (2d coroutine) - #:export (make-agenda - agenda? - agenda-time - current-agenda - with-agenda - tick-agenda! - clear-agenda! - schedule - schedule-interval - schedule-each - wait)) - -;; This code is a modified version of the agenda implementation in -;; SICP. Thank you, SICP! - -;;; -;;; Time segment -;;; - -(define-record-type <time-segment> - (%make-time-segment time queue) - time-segment? - (time segment-time) - (queue segment-queue)) - -(define (make-time-segment time . callbacks) - "Create a new time segment at TIME and enqueues everything in the -list CALLBACKS." - (let ((segment (%make-time-segment time (make-q)))) - ;; Enqueue all callbacks - (for-each (cut segment-enq segment <>) callbacks) - segment)) - -(define (segment-enq segment callback) - "Add the CALLBACK procedure to SEGMENT's queue." - (enq! (segment-queue segment) callback)) - -;;; -;;; Agenda -;;; - -(define-record-type <agenda> - (%make-agenda time segments) - agenda? - (time %agenda-time set-agenda-time!) - (segments agenda-segments set-agenda-segments!)) - -(define (make-agenda) - "Create a new, empty agenda." - (%make-agenda 0 '())) - -(define (agenda-empty? agenda) - "Return #t if AGENDA has no scheduled procedures." - (null? (agenda-segments agenda))) - -(define (first-segment agenda) - "Return the first time segment in AGENDA." - (car (agenda-segments agenda))) - -(define (rest-segments agenda) - "Return everything but the first segment in AGENDA." - (cdr (agenda-segments agenda))) - -(define (agenda-add-segment agenda time callback) - "Add a new time segment to the beginning of AGENDA at the given TIME -and enqueue CALLBACK." - (set-agenda-segments! agenda - (cons (make-time-segment time callback) - (agenda-segments agenda)))) - -(define (insert-segment segments time callback) - "Insert a new time segment after the first segment in SEGMENTS." - (set-cdr! segments - (cons (make-time-segment time callback) - (cdr segments)))) - -(define (first-agenda-item agenda) - "Return the first time segment queue in AGENDA." - (if (agenda-empty? agenda) - (error "Agenda is empty") - (segment-queue (first-segment agenda)))) - -(define (agenda-time-delay agenda dt) - "Return the sum of the time delta, DT, and the current time of AGENDA." - (+ (%agenda-time agenda) (inexact->exact (round dt)))) - -(define (flush-queue! q) - "Dequeue and execute every member of Q." - (unless (q-empty? q) - ((deq! q)) ;; Execute scheduled procedure - (flush-queue! q))) - -(define (%tick-agenda! agenda) - "Move AGENDA forward in time and run scheduled procedures." - (set-agenda-time! agenda (1+ (%agenda-time agenda))) - (let next-segment () - (unless (agenda-empty? agenda) - (let ((segment (first-segment agenda))) - ;; Process time segment if it is scheduled before or at the - ;; current agenda time. - (when (>= (%agenda-time agenda) (segment-time segment)) - (flush-queue! (segment-queue segment)) - (set-agenda-segments! agenda (rest-segments agenda)) - (next-segment)))))) - -(define (%clear-agenda! agenda) - "Remove all scheduled procedures from AGENDA." - (set-agenda-segments! agenda '())) - -(define (%schedule agenda thunk delay) - "Schedule THUNK to be run after DELAY ticks of AGENDA." - (let ((time (agenda-time-delay agenda delay))) - (define (belongs-before? segments) - (or (null? segments) - (< time (segment-time (car segments))))) - - (define (add-to-segments segments) - ;; Add to existing time segment if the times match - (if (= (segment-time (car segments)) time) - (segment-enq (car segments) thunk) - ;; Continue searching - (if (belongs-before? (cdr segments)) - ;; Create new time segment and insert it where it belongs - (insert-segment segments time thunk) - ;; Continue searching - (add-to-segments (cdr segments))))) - - (if (belongs-before? (agenda-segments agenda)) - (agenda-add-segment agenda time thunk) - (add-to-segments (agenda-segments agenda))))) - -(define current-agenda - (make-parameter (make-agenda) - (lambda (val) - (if (agenda? val) - val - (error "Must be an agenda"))))) - -(define-syntax-rule (with-agenda agenda body ...) - (parameterize ((current-agenda agenda)) - body ...)) - -(define (agenda-time) - "Return the time of the current agenda." - (%agenda-time (current-agenda))) - -(define (tick-agenda!) - "Increment time for the current agenda and run scheduled -procedures." - (%tick-agenda! (current-agenda))) - -(define (clear-agenda!) - "Remove all scheduled procedures from the current agenda." - (%clear-agenda! (current-agenda))) - -(define* (schedule thunk #:optional (delay 1)) - "Schedule THUNK to be applied after DELAY ticks of the current -agenda, or 1 tick if DELAY is not specified." - (%schedule (current-agenda) thunk delay)) - -(define (schedule-interval thunk interval) - "Schedule THUNK to be applied every INTERVAL ticks of the current -agenda." - (coroutine - (while #t - (wait interval) - (thunk)))) - -(define (schedule-each thunk) - "Schedule THUNK to be applied upon every tick of the current -agenda." - (schedule-interval thunk 1)) - -(define (wait delay) - "Abort coroutine and schedule the continuation to be run after DELAY -ticks of the current agenda." - (yield (cut schedule <> delay))) diff --git a/2d/animation.scm b/2d/animation.scm deleted file mode 100644 index 4998036..0000000 --- a/2d/animation.scm +++ /dev/null @@ -1,119 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu> -;;; -;;; 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/>. - -;;; Commentary: -;; -;; Animations represent a sequence of textures and/or texture regions. -;; -;;; Code: - -(define-module (2d animation) - #:use-module (srfi srfi-9) - #:use-module (2d texture)) - -;;; -;;; Animations -;;; - -;; The <animation> type represents a vector of textures or texture -;; regions that are to be played in sequence and possibly looped. -(define-record-type <animation> - (make-animation frames frame-duration loop) - animation? - (frames animation-frames) - (frame-duration animation-frame-duration) - (loop animation-loop?)) - -(define (animation-frame animation index) - "Return the texture for the given frame INDEX of ANIMATION." - (vector-ref (animation-frames animation) index)) - -(define (animation-length animation) - "Return the number of frames in ANIMATION." - (vector-length (animation-frames animation))) - -(define (animation-duration animation) - "Return the total duration of ANIMATION in ticks." - (* (animation-length animation) - (animation-frame-duration animation))) - -(export make-animation - animation? - animation-frames - animation-frame-duration - animation-loop? - animation-frame - animation-length - animation-duration) - -;; The <animator> type encapsulates the state for playing an -;; animation. -(define-record-type <animator> - (%make-animator animation frame time playing) - animator? - (animation animator-animation) - (frame animator-frame set-animator-frame!) - (time animator-time set-animator-time!) - (playing animator-playing? set-animator-playing!)) - -(define (make-animator animation) - "Create a new animator for ANIMATION." - (%make-animator animation 0 0 #t)) - -(define (animator-frame-complete? animator) - "Return #t when ANIMATOR is done displaying the current frame." - (>= (animator-time animator) - (animation-frame-duration (animator-animation animator)))) - -(define (animator-next-frame animator) - "Return the next frame index for ANIMATOR." - (modulo (1+ (animator-frame animator)) - (animation-length (animator-animation animator)))) - -(define (animator-texture animator) - "Return a texture for the ANIMATOR's current frame." - (animation-frame (animator-animation animator) - (animator-frame animator))) - -(define (animator-next! animator) - "Advance ANIMATOR to the next frame of its animation." - (let ((next-frame (animator-next-frame animator)) - (animation (animator-animation animator))) - (set-animator-time! animator 0) - (set-animator-frame! animator next-frame) - (set-animator-playing! animator (or (not (zero? next-frame)) - (animation-loop? animation))))) - -(define (animator-update! animator) - "Increment the frame time for the ANIMATOR and advance to the next -frame when necessary." - (when (animator-playing? animator) - (set-animator-time! animator (1+ (animator-time animator))) - (when (animator-frame-complete? animator) - (animator-next! animator)))) - -(export make-animator - animator? - animator-animation - animator-frame - animator-time - animator-frame-complete? - animator-playing? - animator-next-frame - animator-texture - animator-next! - animator-update!) diff --git a/2d/audio.scm b/2d/audio.scm deleted file mode 100644 index 3accb8b..0000000 --- a/2d/audio.scm +++ /dev/null @@ -1,128 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu> -;;; -;;; 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/>. - -;;; Commentary: -;; -;; Wrappers over SDL mixer. -;; -;;; Code: - -(define-module (2d audio) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-2) - #:use-module ((sdl mixer) #:prefix SDL:) - #:export (enable-audio - load-sample - sample? - sample-audio - sample-volume - set-sample-volume - play-sample - load-music - music? - music-audio - music-volume - play-music - set-music-volume - pause-music - resume-music - rewind-music - stop-music - music-paused? - music-playing?)) - -(define (enable-audio) - (SDL:open-audio)) - -;; Used to wrap SDL audio functions whose return values should be -;; ignored. -(define-syntax-rule (ignore-value body ...) - (begin - body ... - *unspecified*)) - -;; Wrapper over SDL audio objects. -(define-record-type <sample> - (make-sample audio) - sample? - (audio sample-audio)) - -(define (load-sample filename) - "Load audio sample from FILENAME or return #f if the file cannot be -loaded" - (let ((audio (SDL:load-wave filename))) - (if audio (make-sample audio) #f))) - -(define (sample-volume) - "Return the volume that all samples are played at." - (SDL:volume)) - -(define (set-sample-volume volume) - "Set the volume that all samples are played at to VOLUME." - (ignore-value (SDL:volume volume))) - -(define (play-sample sample) - "Play the given audio SAMPLE." - (ignore-value (SDL:play-channel (sample-audio sample)))) - -;; Wrapper over SDL music objects. -(define-record-type <music> - (make-music audio) - music? - (audio music-audio)) - -(define (load-music filename) - "Load music from FILENAME or return #f if the file cannot be -loaded." - (let ((audio (SDL:load-music filename))) - (if audio (make-music audio) #f))) - -(define (music-volume) - "Return the volume that music is played at." - (SDL:music-volume)) - -(define (set-music-volume volume) - "Set the volume that music is played at to VOLUME." - (ignore-value (SDL:volume volume))) - -(define (play-music music) - "Play the given MUSIC." - (ignore-value (SDL:play-music (music-audio music)))) - -(define (pause-music) - "Pause the current music track." - (ignore-value (SDL:pause-music))) - -(define (resume-music) - "Resume the current music track." - (ignore-value (SDL:resume-music))) - -(define (rewind-music) - "Restart the current music track." - (ignore-value (SDL:rewind-music))) - -(define (stop-music) - "Stop playing the current music track." - (ignore-value (SDL:halt-music))) - -(define (music-playing?) - "Return #t if music is currently playing, otherwise return #f." - (SDL:playing-music?)) - -(define (music-paused?) - "Return #t if music is currently paused, otherwise return #f." - (SDL:paused-music?)) diff --git a/2d/color.scm b/2d/color.scm deleted file mode 100644 index d3aba00..0000000 --- a/2d/color.scm +++ /dev/null @@ -1,203 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu> -;;; -;;; 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/>. - -;;; Commentary: -;; -;; Color. -;; -;;; Code: - -(define-module (2d color) - #:use-module (gl) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-1) - #:use-module (2d math) - #:export (<color> - make-color - color? - color-r - color-g - color-b - color-a - rgba - rgb - color* - color+ - color- - color-inverse - white - black - red - green - blue - yellow - magenta - cyan - tango-light-butter - tango-butter - tango-dark-butter - tango-light-orange - tango-orange - tango-dark-orange - tango-light-chocolate - tango-chocolate - tango-dark-chocolate - tango-light-chameleon - tango-chameleon - tango-dark-chameleon - tango-light-sky-blue - tango-sky-blue - tango-dark-sky-blue - tango-light-plum - tango-plum - tango-dark-plum - tango-light-scarlet-red - tango-scarlet-red - tango-dark-scarlet-red - tango-aluminium-1 - tango-aluminium-2 - tango-aluminium-3 - tango-aluminium-4 - tango-aluminium-5 - tango-aluminium-6)) - -(define-record-type <color> - (%make-color r g b a) - color? - (r color-r) - (g color-g) - (b color-b) - (a color-a)) - -(define (make-color r g b a) - "Return a newly allocated color with the given RGBA channel values. -Each channel is clamped to the range [0, 1]." - (%make-color (clamp 0 1 r) - (clamp 0 1 g) - (clamp 0 1 b) - (clamp 0 1 a))) - -(define (color-component color-code offset) - "Return the value of an 8-bit color channel in the range [0,1] for -the integer COLOR-CODE, given an OFFSET in bits." - (let ((mask (ash #xff offset))) - (/ (ash (logand mask color-code) - (- offset)) - 255.0))) - -(define (rgba color-code) - "Translate an RGBA format string COLOR-CODE into a color object. -For example: #xffffffff will return a color with RGBA values 1, 1, 1, -1." - (%make-color (color-component color-code 24) - (color-component color-code 16) - (color-component color-code 8) - (color-component color-code 0))) - -(define (rgb color-code) - "Translate an RGB format string COLOR-CODE into a color object. -For example: #xffffff will return a color with RGBA values 1, 1, 1, -1." - (%make-color (color-component color-code 16) - (color-component color-code 8) - (color-component color-code 0) - 1)) - -(define (color* a b) - "Multiply the RGBA channels of colors A and B." - (make-color (* (color-r a) - (color-r b)) - (* (color-g a) - (color-g b)) - (* (color-b a) - (color-b b)) - (* (color-a a) - (color-a b)))) - -(define (color+ a b) - "Add the RGBA channels of colors A and B." - (make-color (+ (color-r a) - (color-r b)) - (+ (color-g a) - (color-g b)) - (+ (color-b a) - (color-b b)) - (+ (color-a a) - (color-a b)))) - -(define (color- a b) - "Subtract the RGBA channels of colors A and B." - (make-color (- (color-r a) - (color-r b)) - (- (color-g a) - (color-g b)) - (- (color-b a) - (color-b b)) - (- (color-a a) - (color-a b)))) - -(define (color-inverse color) - "Create a new color that is the inverse of COLOR. The alpha channel -is left unchanged." - (make-color (- 1 (color-r color)) - (- 1 (color-g color)) - (- 1 (color-b color)) - (color-a color))) - -;;; -;;; Pre-defined Colors -;;; - -;; Basic -(define white (rgb #xffffff)) -(define black (rgb #x000000)) -(define red (rgb #xff0000)) -(define green (rgb #x00ff00)) -(define blue (rgb #x0000ff)) -(define yellow (rgb #xffff00)) -(define magenta (rgb #xff00ff)) -(define cyan (rgb #x00ffff)) - -;; Tango color pallete -;; http://tango.freedesktop.org -(define tango-light-butter (rgb #xfce94f)) -(define tango-butter (rgb #xedd400)) -(define tango-dark-butter (rgb #xc4a000)) -(define tango-light-orange (rgb #xfcaf3e)) -(define tango-orange (rgb #xf57900)) -(define tango-dark-orange (rgb #xce5c00)) -(define tango-light-chocolate (rgb #xe9b96e)) -(define tango-chocolate (rgb #xc17d11)) -(define tango-dark-chocolate (rgb #x8f5902)) -(define tango-light-chameleon (rgb #x8ae234)) -(define tango-chameleon (rgb #x73d216)) -(define tango-dark-chameleon (rgb #x4e9a06)) -(define tango-light-sky-blue (rgb #x729fcf)) -(define tango-sky-blue (rgb #x3465a4)) -(define tango-dark-sky-blue (rgb #x204a87)) -(define tango-light-plum (rgb #xad7fa8)) -(define tango-plum (rgb #x75507b)) -(define tango-dark-plum (rgb #x5c3566)) -(define tango-light-scarlet-red (rgb #xef2929)) -(define tango-scarlet-red (rgb #xcc0000)) -(define tango-dark-scarlet-red (rgb #xa40000)) -(define tango-aluminium-1 (rgb #xeeeeec)) -(define tango-aluminium-2 (rgb #xd3d7cf)) -(define tango-aluminium-3 (rgb #xbabdb6)) -(define tango-aluminium-4 (rgb #x888a85)) -(define tango-aluminium-5 (rgb #x555753)) -(define tango-aluminium-6 (rgb #x2e3436)) diff --git a/2d/config.scm.in b/2d/config.scm.in deleted file mode 100644 index e62a2b1..0000000 --- a/2d/config.scm.in +++ /dev/null @@ -1,28 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2014 David Thompson <dthompson2@worcester.edu> -;;; -;;; Guile-2d is free software: you can redistribute it and/or modify it -;;; under the terms of the GNU Lesser General Public License as -;;; published by the Free Software Foundation, either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; Guile-2d 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 -;;; Lesser General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with this program. If not, see -;;; <http://www.gnu.org/licenses/>. - -;;; Commentary: -;; -;; Build time configuration. -;; -;;; Code: - -(define-module (2d config) - #:export (%pkgdatadir)) - -(define %pkgdatadir - (or (getenv "GUILE_2D_PKGDATADIR") "@pkgdatadir@")) diff --git a/2d/coroutine.scm b/2d/coroutine.scm deleted file mode 100644 index b8e1df9..0000000 --- a/2d/coroutine.scm +++ /dev/null @@ -1,82 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu> -;;; -;;; 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/>. - -;;; Commentary: -;; -;; Cooperative multi-tasking. -;; -;;; Code: - -(define-module (2d coroutine) - #:export (call-with-coroutine - coroutine - colambda - codefine - codefine*) - #:replace (yield)) - -(define (call-with-coroutine thunk) - "Apply THUNK with a coroutine prompt." - (define (handler cont callback . args) - (define (resume . args) - ;; Call continuation that resumes the procedure. - (call-with-prompt 'coroutine-prompt - (lambda () (apply cont args)) - handler)) - (when (procedure? callback) - (apply callback resume args))) - - ;; Call procedure. - (call-with-prompt 'coroutine-prompt thunk handler)) - -;; emacs: (put 'coroutine 'scheme-indent-function 0) -(define-syntax-rule (coroutine body ...) - "Evaluate BODY as a coroutine." - (call-with-coroutine (lambda () body ...))) - -;; emacs: (put 'colambda 'scheme-indent-function 1) -(define-syntax-rule (colambda args body ...) - "Syntacic sugar for a lambda that is run as a coroutine." - (lambda args - (call-with-coroutine - (lambda () body ...)))) - -;; emacs: (put 'codefine 'scheme-indent-function 1) -(define-syntax-rule (codefine (name ...) . body) - "Syntactic sugar for defining a procedure that is run as a -coroutine." - (define (name ...) - ;; Create an inner procedure with the same signature so that a - ;; recursive procedure call does not create a new prompt. - (define (name ...) . body) - (call-with-coroutine - (lambda () (name ...))))) - -;; emacs: (put 'codefine* 'scheme-indent-function 1) -(define-syntax-rule (codefine* (name . formals) . body) - "Syntactic sugar for defining a procedure that is run as a -coroutine." - (define (name . args) - ;; Create an inner procedure with the same signature so that a - ;; recursive procedure call does not create a new prompt. - (define* (name . formals) . body) - (call-with-coroutine - (lambda () (apply name args))))) - -(define (yield callback) - "Yield continuation to a CALLBACK procedure." - (abort-to-prompt 'coroutine-prompt callback)) diff --git a/2d/event.scm b/2d/event.scm deleted file mode 100644 index 7badf72..0000000 --- a/2d/event.scm +++ /dev/null @@ -1,45 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu> -;;; -;;; 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/>. - -;;; Commentary: -;; -;; SDL event handlers. -;; -;;; Code: - -(define-module (2d event) - #:use-module ((sdl sdl) #:prefix SDL:) - #:export (process-events - register-event-handler)) - -(define process-events - (let ((e (SDL:make-event))) - (lambda () - "Process all events in the input event queue." - (while (SDL:poll-event e) - (handle-event e))))) - -(define event-handlers (make-hash-table)) - -(define (register-event-handler event-type proc) - (hashq-set! event-handlers event-type proc)) - -(define (handle-event e) - "Run the relevant hook for the event E." - (let ((handle (hashq-get-handle event-handlers (SDL:event:type e)))) - (when handle - ((cdr handle) e)))) diff --git a/2d/font.scm b/2d/font.scm deleted file mode 100644 index 909f351..0000000 --- a/2d/font.scm +++ /dev/null @@ -1,156 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu> -;;; -;;; 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/>. - -;;; Commentary: -;; -;; Font rendering. -;; -;;; Code: - -(define-module (2d font) - #:use-module (srfi srfi-2) - #:use-module (srfi srfi-9) - #:use-module (system foreign) - #:use-module ((sdl sdl) #:prefix SDL:) - #:use-module ((sdl ttf) #:prefix SDL:) - #:use-module (gl) - #:use-module (gl contrib packed-struct) - #:use-module (2d color) - #:use-module (2d config) - #:use-module (2d shader) - #:use-module (2d signal) - #:use-module (2d texture) - #:use-module (2d vector) - #:use-module (2d window) - #:use-module (2d wrappers gl) - #:export (enable-fonts - load-font - load-default-font - font? - font-point-size - make-label - label? - label-font - label-text - label-position - label-color - draw-label)) - -;;; -;;; Font -;;; - -(define font-shader #f) - -(define (enable-fonts) - (SDL:ttf-init) - (set! font-shader - (load-shader-program - (string-append %pkgdatadir - "/shaders/font-vertex.glsl") - (string-append %pkgdatadir - "/shaders/font-fragment.glsl")))) - -(define-record-type <font> - (make-font ttf point-size) - font? - (ttf font-ttf) - (point-size font-point-size)) - -(define (load-font filename point-size) - "Load the TTF font in FILENAME with the given POINT-SIZE." - (if (file-exists? filename) - (make-font (SDL:load-font filename point-size) point-size) - (error "File not found!" filename))) - -(define* (load-default-font #:optional (point-size 12)) - "Load the guile-2d default TTF font. POINT-SIZE is an optional -argument with a default value of 12." - (load-font (string-append %pkgdatadir "/fonts/DejaVuSans.ttf") point-size)) - -(define (render-text font text) - "Return a new texture with TEXT rendered using FONT." - ;; An empty string will result in a surface value of #f, in which we - ;; want to abort the texture creation process. - (and-let* ((surface (SDL:render-utf8 (font-ttf font) text - (SDL:make-color 255 255 255) #t)) - (pixels (SDL:surface-pixels surface)) - (texture-id (gl-generate-texture))) - (with-gl-bind-texture (texture-target texture-2d) texture-id - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-min-filter) - (texture-min-filter nearest)) - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-mag-filter) - (texture-mag-filter nearest)) - (gl-texture-image-2d (texture-target texture-2d) - 0 - (pixel-format rgba) - (SDL:surface:w surface) - (SDL:surface:h surface) - 0 - (version-1-2 bgra) - (color-pointer-type unsigned-byte) - pixels)) - (make-texture texture-id #f - (SDL:surface:w surface) - (SDL:surface:h surface) - 0 0 1 1))) - -(define-record-type <label> - (%make-label font text position anchor color texture vertices) - label? - (font label-font) - (text label-text) - (position label-position) - (anchor label-anchor) - (color label-color) - (texture label-texture) - (vertices label-vertices)) - -(define (make-label-vertices texture) - "Return a packed array of vertices for TEXTURE." - (let ((vertices (make-packed-array texture-vertex 4))) - (pack-texture-vertices vertices 0 - (texture-width texture) - (texture-height texture) - (texture-s1 texture) - (texture-t1 texture) - (texture-s2 texture) - (texture-t2 texture)) - vertices)) - -(define* (make-label font text position #:optional #:key - (color white) (anchor 'top-left)) - "Return a new label containing the string TEXT rendered with FONT at -the given position. Optional arguments are COLOR with a default of -white and ANCHOR with a default of 'top-left." - (let* ((texture (render-text font text)) - (vertices (and texture (make-label-vertices texture))) - (anchor (if texture (anchor-texture texture anchor) #(0 0)))) - (%make-label font text position anchor color texture vertices))) - -(define (draw-label label) - "Draw LABEL on the screen." - (when (label-texture label) - (with-shader-program font-shader - (uniforms ((projection (signal-ref window-projection)) - (position (label-position label)) - (anchor (label-anchor label)) - (color (label-color label))) - (draw-texture-vertices (label-texture label) (label-vertices label) 1)))) - *unspecified*) diff --git a/2d/fps.scm b/2d/fps.scm deleted file mode 100644 index 12e652e..0000000 --- a/2d/fps.scm +++ /dev/null @@ -1,47 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu> -;;; -;;; 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/>. - -;;; Commentary: -;; -;; Frames per second counter. -;; -;;; Code: - -(define-module (2d fps) - #:use-module (2d game) - #:use-module (2d signal) - #:export (fps)) - -;; Current frames per second -(define-signal fps (make-signal 0)) - -(define accumulate-fps! - (let* ((elapsed-time 0) - (fps-counter 0)) - (lambda (dt alpha) - (let ((new-time (+ elapsed-time dt)) - (new-fps (1+ fps-counter))) - (if (>= new-time 1000) - (begin - (signal-set! fps new-fps) - (set! fps-counter 0) - (set! elapsed-time 0)) - (begin - (set! fps-counter new-fps) - (set! elapsed-time new-time))))))) - -(add-hook! draw-hook accumulate-fps!) diff --git a/2d/game.scm b/2d/game.scm deleted file mode 100644 index d6a0345..0000000 --- a/2d/game.scm +++ /dev/null @@ -1,109 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu> -;;; -;;; 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/>. - -;;; Commentary: -;; -;; The game loop. -;; -;;; Code: - -(define-module (2d game) - #:use-module (srfi srfi-9) - #:use-module ((sdl sdl) #:prefix SDL:) - #:use-module (gl) - #:use-module (2d agenda) - #:use-module (2d event) - #:use-module (2d math) - #:use-module (2d signal) - #:use-module (2d window) - #:export (tick-interval - max-ticks-per-frame - draw-hook - start-game-loop - stop-game-loop)) - -;;; -;;; Game Loop -;;; - -;; Update 60 times per second by default. -(define tick-interval (floor (/ 1000 60))) -;; The maximum number of times the game loop will update game state in -;; a single frame. When this upper bound is reached due to poor -;; performance, the game will start to slow down instead of becoming -;; completely unresponsive and possibly crashing. -(define max-ticks-per-frame 4) -(define draw-hook (make-hook 2)) - -(define (draw dt alpha) - "Render a frame." - (let ((width (signal-ref window-width)) - (height (signal-ref window-height))) - (gl-viewport 0 0 width height)) - (gl-clear (clear-buffer-mask color-buffer depth-buffer)) - (run-hook draw-hook dt alpha) - (SDL:gl-swap-buffers)) - -(define (update lag) - "Call the update callback. The update callback will be called as -many times as tick-interval can divide LAG. The return value -is the unused accumulator time." - (define (iter lag ticks) - (cond ((>= ticks max-ticks-per-frame) - lag) - ((>= lag tick-interval) - (tick-agenda!) - (iter (- lag tick-interval) (1+ ticks))) - (else - lag))) - (iter lag 0)) - -(define (alpha lag) - "Calculate interpolation factor in the range [0, 1] for the -leftover frame time LAG." - (clamp 0 1 (/ lag tick-interval))) - -(define (frame-sleep time) - "Sleep for the remainder of the frame that started at TIME." - (let ((t (- (+ time tick-interval) - (SDL:get-ticks)))) - (usleep (max 0 (* t 1000))))) - -(define (game-loop previous-time lag) - "Update game state, and render. PREVIOUS-TIME is the time in -milliseconds of the last iteration of the game loop." - (let* ((current-time (SDL:get-ticks)) - (dt (- current-time previous-time))) - (process-events) - (let ((lag (update (+ lag dt)))) - (draw dt (alpha lag)) - (frame-sleep current-time) - (game-loop current-time lag)))) - -(define (start-game-loop) - "Start the game loop." - (call-with-prompt - 'game-loop-prompt - (lambda () - (game-loop (SDL:get-ticks) 0)) - (lambda (cont callback) - (when (procedure? callback) - (callback cont))))) - -(define (stop-game-loop) - "Abort the game loop." - (abort-to-prompt 'game-loop-prompt #f)) diff --git a/2d/helpers.scm b/2d/helpers.scm deleted file mode 100644 index 4082377..0000000 --- a/2d/helpers.scm +++ /dev/null @@ -1,68 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu> -;;; Copyright (C) 2014 Ludovic Courtès <ludo@gnu.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/>. - -;;; Commentary: -;; -;; Miscellaneous helper procedures. -;; -;;; Code: - -(define-module (2d helpers) - #:use-module (srfi srfi-1) - #:use-module (rnrs arithmetic bitwise) - #:use-module (2d agenda) - #:use-module (2d game) - #:export (any-equal? - logand? - define-guardian - memoize)) - -(define (any-equal? elem . args) - "Return #t if ELEM equals any of the elements in the list ARGS." - (any (lambda (e) (equal? elem e)) args)) - -(define (logand? . args) - "Return #t if the result of a bitwise AND of the integers in list -ARGS is non-zero." - (not (zero? (apply logand args)))) - -(define-syntax-rule (define-guardian name reaper) - "Define a new guardian called NAME and call REAPER when an object -within the guardian is GC'd. Reaping is ensured to happen from the -same thread that is running the game loop." - (begin - (define name (make-guardian)) - (schedule-each - (lambda () - (let reap ((obj (name))) - (when obj - (reaper obj) - (reap (name)))))))) - -(define (memoize proc) - "Return a memoizing version of PROC." - (let ((cache (make-hash-table))) - (lambda args - (let ((results (hash-ref cache args))) - (if results - (apply values results) - (let ((results (call-with-values (lambda () - (apply proc args)) - list))) - (hash-set! cache args results) - (apply values results))))))) diff --git a/2d/keyboard.scm b/2d/keyboard.scm deleted file mode 100644 index 97bc20a..0000000 --- a/2d/keyboard.scm +++ /dev/null @@ -1,88 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu> -;;; -;;; 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/>. - -;;; Commentary: -;; -;; Keyboard signals. -;; -;;; Code: - -(define-module (2d keyboard) - #:use-module ((sdl sdl) #:prefix SDL:) - #:use-module (2d event) - #:use-module (2d signal) - #:use-module (2d vector) - #:export (key-press-hook - key-release-hook - key-last-down - key-last-up - key-down? - key-directions - key-arrows - key-wasd)) - -(define key-press-hook (make-hook 2)) - -(register-event-handler - 'key-down - (lambda (e) - (run-hook key-press-hook - (SDL:event:key:keysym:sym e) - (SDL:event:key:keysym:unicode e)))) - -(define-signal key-last-down - (hook->signal key-press-hook 'none - (lambda (key unicode) - key))) - -(define key-release-hook (make-hook 2)) - -(register-event-handler - 'key-up - (lambda (e) - (run-hook key-release-hook - (SDL:event:key:keysym:sym e) - (SDL:event:key:keysym:unicode e)))) - -(define-signal key-last-up - (hook->signal key-release-hook 'none - (lambda (key unicode) - key))) - -(define (key-down? key) - "Create a signal for the state of KEY. The signal value is #t when -KEY is pressed or #f otherwise." - (define (same-key? other-key) - (eq? key other-key)) - (define (key-filter value signal) - (signal-constant value (signal-filter same-key? #f signal))) - (signal-merge (key-filter #f key-last-up) - (key-filter #t key-last-down))) - -(define (key-directions up down left right) - (signal-map (lambda (up? down? left? right?) - (vector (+ (if left? -1 0) - (if right? 1 0)) - (+ (if up? -1 0) - (if down? 1 0)))) - (key-down? up) - (key-down? down) - (key-down? left) - (key-down? right))) - -(define-signal key-arrows (key-directions 'up 'down 'left 'right)) -(define-signal key-wasd (key-directions 'w 's 'a 'd)) diff --git a/2d/live-reload.scm b/2d/live-reload.scm deleted file mode 100644 index 265fa1f..0000000 --- a/2d/live-reload.scm +++ /dev/null @@ -1,54 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2014 David Thompson <dthompson2@worcester.edu> -;;; -;;; 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/>. - -;;; Commentary: -;; -;; Live asset reloading. -;; -;;; Code: - -(define-module (2d live-reload) - #:use-module (srfi srfi-1) - #:use-module (2d agenda) - #:use-module (2d coroutine) - #:use-module (2d signal) - #:export (live-reload-interval - live-reload)) - -(define live-reload-interval 120) - -(define (live-reload proc) - "Return a new procedure that re-applies PROC whenever the associated -file is modified. The new procedure returns a signal that contains -the return value of PROC. The first argument to PROC must be a -filename string." - (lambda (filename . args) - (define (load-asset) - (apply proc filename args)) - - (define (current-mtime) - (stat:mtime (stat filename))) - - (let ((asset (make-signal (load-asset)))) - (coroutine - (let loop ((last-mtime (current-mtime))) - (wait live-reload-interval) - (let ((mtime (current-mtime))) - (when (> mtime last-mtime) - (signal-set! asset (load-asset))) - (loop mtime)))) - asset))) diff --git a/2d/math.scm b/2d/math.scm deleted file mode 100644 index ba8d88e..0000000 --- a/2d/math.scm +++ /dev/null @@ -1,90 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu> -;;; -;;; 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/>. - -;;; Commentary: -;; -;; Miscellaneous math procedures. Currently just trigonometry. -;; -;;; Code: - -(define-module (2d math) - #:export (pi - degrees->radians - radians->degrees - sin-degrees - cos-degrees - tan-degrees - atan-degrees - clamp)) - -;; Dave was editing this module on Pi Approximation Day. -;; -;; 3.141592653589793238462643383279 -;; 5028841971693993751058209749445923 -;; 07816406286208998628034825342117067 -;; 9821 48086 5132 -;; 823 06647 09384 -;; 46 09550 58223 -;; 17 25359 4081 -;; 2848 1117 -;; 4502 8410 -;; 2701 9385 -;; 21105 55964 -;; 46229 48954 -;; 9303 81964 -;; 4288 10975 -;; 66593 34461 -;; 284756 48233 -;; 78678 31652 71 -;; 2019091 456485 66 -;; 9234603 48610454326648 -;; 2133936 0726024914127 -;; 3724587 00660631558 -;; 817488 152092096 -;; -(define pi 3.141592654) - -(define (degrees->radians angle) - "Convert ANGLE in degrees to radians." - (* angle (/ pi 180))) - -(define (radians->degrees angle) - "Convert ANGLE in radians to degrees." - (* angle (/ 180 pi))) - -(define (sin-degrees angle) - "Compute the sin of ANGLE expressed in degrees." - (sin (degrees->radians angle))) - -(define (cos-degrees angle) - "Compute the cosine of ANGLE expressed in degrees." - (cos (degrees->radians angle))) - -(define (tan-degrees angle) - "Compute the tangent of ANGLE expressed in degrees." - (tan (degrees->radians angle))) - -(define (atan-degrees y x) - "Compute the arctangent in degrees of the coordinates Y and X." - (radians->degrees (atan y x))) - -(define (clamp min max x) - "Restrict X to the range defined by MIN and MAX. Assumes that MIN is -actually less than MAX." - (cond ((< x min) min) - ((> x max) max) - (else x))) diff --git a/2d/mouse.scm b/2d/mouse.scm deleted file mode 100644 index 388b139..0000000 --- a/2d/mouse.scm +++ /dev/null @@ -1,99 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu> -;;; -;;; 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/>. - -;;; Commentary: -;; -;; Keyboard signals. -;; -;;; Code: - -(define-module (2d mouse) - #:use-module ((sdl sdl) #:prefix SDL:) - #:use-module (2d event) - #:use-module (2d signal) - #:use-module (2d vector) - #:export (mouse-move-hook - mouse-press-hook - mouse-click-hook - mouse-x - mouse-y - mouse-position - mouse-last-down - mouse-last-up - mouse-down?)) - -(define mouse-move-hook (make-hook 2)) - -(register-event-handler - 'mouse-motion - (lambda (e) - (run-hook mouse-move-hook - (SDL:event:motion:x e) - (SDL:event:motion:y e)))) - -(define-signal mouse-position - (hook->signal mouse-move-hook - #(0 0) - (lambda (x y) - (vector x y)))) - -(define-signal mouse-x (signal-map vx mouse-position)) -(define-signal mouse-y (signal-map vy mouse-position)) - -(define mouse-press-hook (make-hook 3)) - -(register-event-handler - 'mouse-button-down - (lambda (e) - (run-hook mouse-press-hook - (SDL:event:button:button e) - (SDL:event:button:x e) - (SDL:event:button:y e)))) - -(define-signal mouse-last-down - (hook->signal mouse-press-hook - 'none - (lambda (button x y) - button))) - -(define mouse-click-hook (make-hook 3)) - -(register-event-handler - 'mouse-button-up - (lambda (e) - (run-hook mouse-click-hook - (SDL:event:button:button e) - (SDL:event:button:x e) - (SDL:event:button:y e)))) - -(define-signal mouse-last-up - (hook->signal mouse-click-hook - 'none - (lambda (button x y) - button))) - -(define (mouse-down? button) - "Create a signal for the state of BUTTON. Value is #t when mouse -button is pressed or #f otherwise." - (define (same-button? other-button) - (eq? button other-button)) - - (define (button-filter value signal) - (signal-constant value (signal-filter #f same-button? signal))) - - (signal-merge (button-filter #f mouse-last-up) - (button-filter #t mouse-last-down))) diff --git a/2d/rect.scm b/2d/rect.scm deleted file mode 100644 index 3a74ae2..0000000 --- a/2d/rect.scm +++ /dev/null @@ -1,212 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu> -;;; -;;; 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/>. - -;;; Commentary: -;; -;; Rects are axis-aligned bounding boxes that can be used for -;; performing simple collision detection. -;; -;;; Code: - -(define-module (2d rect) - #:use-module (srfi srfi-9) - #:use-module (2d vector) - #:export (<rect> - make-rect - null-rect - rect? - rect-x - rect-y - rect-left - rect-right - rect-top - rect-bottom - rect-position - rect-top-left - rect-top-right - rect-bottom-left - rect-bottom-right - rect-center-x - rect-center-y - rect-center - rect-half-width - rect-half-height - rect-width - rect-height - rect-size - rect-move - rect-inflate - rect-union - rect-clip - rect-within? - rect-intersects? - rect-contains?)) - -;;; -;;; Rectangles -;;; - -;; The rect API is very similar to the Pygame rect API, but rects are -;; immutable. - -(define-record-type <rect> - (%make-rect x y width height) - rect? - (x rect-x) - (y rect-y) - (width rect-width) - (height rect-height)) - -(define make-rect - (case-lambda - ((x y width height) - (%make-rect x y width height)) - ((position size) - (%make-rect (vx position) (vy position) - (vx size) (vy size))))) - -(define null-rect (make-rect 0 0 0 0)) - -(define (rect-right rect) - (+ (rect-x rect) (rect-width rect))) - -(define rect-left rect-x) - -(define rect-top rect-y) - -(define (rect-bottom rect) - (+ (rect-y rect) (rect-height rect))) - -(define (rect-position rect) - "Return the top-left corner of RECT as a vector." - (vector (rect-x rect) - (rect-y rect))) - -(define rect-top-left rect-position) - -(define (rect-top-right rect) - (vector (rect-right rect) - (rect-top rect))) - -(define (rect-bottom-left rect) - (vector (rect-left rect) - (rect-bottom rect))) - -(define (rect-bottom-right rect) - (vector (rect-right rect) - (rect-bottom rect))) - -(define (rect-center-x rect) - (+ (rect-x rect) (rect-half-width rect))) - -(define (rect-center-y rect) - (+ (rect-y rect) (rect-half-height rect))) - -(define (rect-center rect) - (vector (rect-center-x rect) - (rect-center-y rect))) - -(define (rect-half-width rect) - (/ (rect-width rect) 2)) - -(define (rect-half-height rect) - (/ (rect-height rect) 2)) - -(define (rect-size rect) - "Return the size of RECT as a vector." - (vector (rect-width rect) - (rect-height rect))) - -(define (%rect-move rect x y) - "Move RECT by the offset X, Y." - (make-rect (+ (rect-x rect) x) - (+ (rect-y rect) y) - (rect-width rect) - (rect-height rect))) - -(define rect-move - (case-lambda - "Create a new rectangle by moving RECT by the given -offset. rect-move accepts a vector or x and y coordinates as separate -arguments." - ((rect v) - (%rect-move rect (vx v) (vy v))) - ((rect x y) - (%rect-move rect x y)))) - -(define (%rect-inflate rect width height) - "Grows the rect by the given amount. The rect stays centered around -its current center." - (make-rect (+ (rect-x rect) (/ width 2)) - (+ (rect-y rect) (/ height 2)) - (+ (rect-width rect) width) - (+ (rect-height rect) height))) - -(define rect-inflate - (case-lambda - "Create a new rectangle by growing RECT by the given amount -without changing the center point. rect-inflate accepts a vector or x -and y coordinates as separate arguments." - ((rect v) - (%rect-inflate rect (vx v) (vy v))) - ((rect x y) - (%rect-inflate rect x y)))) - -(define (rect-union rect1 rect2) - "Return a rect that covers the area of RECT1 and RECT2." - (let ((x1 (min (rect-left rect1) (rect-left rect2))) - (x2 (max (rect-right rect1) (rect-right rect2))) - (y1 (min (rect-top rect1) (rect-top rect2))) - (y2 (max (rect-bottom rect1) (rect-bottom rect2)))) - (make-rect x1 y1 (- x2 x1) (- y2 y1)))) - -(define (rect-clip rect1 rect2) - "Return the overlapping region of RECT1 and RECT2. If the rects do -not overlap, a rect of size 0 is returned." - (let ((x1 (max (rect-left rect1) (rect-left rect2))) - (x2 (min (rect-right rect1) (rect-right rect2))) - (y1 (max (rect-top rect1) (rect-top rect2))) - (y2 (min (rect-bottom rect1) (rect-bottom rect2)))) - (make-rect x1 y1 (max (- x2 x1) 0) (max (- y2 y1) 0)))) - -(define (rect-within? rect1 rect2) - "Return #t if RECT2 is completely within RECT1." - (and (>= (rect-left rect2) (rect-left rect1)) - (<= (rect-right rect2) (rect-right rect1)) - (>= (rect-top rect2) (rect-top rect1)) - (<= (rect-bottom rect2) (rect-bottom rect1)))) - -(define (rect-intersects? rect1 rect2) - "Return #t if RECT2 overlaps RECT1." - (and (< (rect-left rect1) (rect-right rect2)) - (> (rect-right rect1) (rect-left rect2)) - (< (rect-top rect1) (rect-bottom rect2)) - (> (rect-bottom rect1) (rect-top rect2)))) - -(define (%rect-contains? rect x y) - (and (>= x (rect-left rect)) - (<= x (rect-right rect)) - (>= y (rect-top rect)) - (<= y (rect-bottom rect)))) - -(define rect-contains? - (case-lambda - "Return #t if the given point is within RECT." - ((rect v) - (%rect-contains? rect (vx v) (vy v))) - ((rect x y) - (%rect-contains? rect x y)))) diff --git a/2d/repl.scm b/2d/repl.scm deleted file mode 100644 index f48b6d2..0000000 --- a/2d/repl.scm +++ /dev/null @@ -1,37 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2014 David Thompson <dthompson2@worcester.edu> -;;; -;;; 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/>. - -;;; Commentary: -;; -;; Cooperative REPL server extension. -;; -;;; Code: - -(define-module (2d repl) - #:use-module (system repl coop-server) - #:use-module (system repl server) - #:use-module (2d agenda) - #:export (start-2d-repl)) - -(define* (start-2d-repl #:optional (port (make-tcp-server-socket #:port 37146))) - "Start a cooperative REPL server that listens on the given PORT. By -default, this port is 37146. Additionally, a process is scheduled to -poll the REPL server upon every tick of the game loop." - (let ((server (spawn-coop-repl-server port))) - (schedule-each - (lambda () - (poll-coop-repl-server server))))) diff --git a/2d/shader.scm b/2d/shader.scm deleted file mode 100644 index 56a4e03..0000000 --- a/2d/shader.scm +++ /dev/null @@ -1,331 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2014 David Thompson <dthompson2@worcester.edu> -;;; -;;; 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 (2d shader) - #:use-module (system foreign) - #:use-module (rnrs bytevectors) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-4) - #:use-module (srfi srfi-9) - #:use-module (ice-9 rdelim) - #:use-module (gl) - #:use-module (gl low-level) - #:use-module (2d helpers) - #:use-module (2d transform) - #:use-module (2d vector) - #:use-module (2d color) - #:use-module (2d wrappers gl) - #:export (make-shader - make-vertex-shader - make-fragment-shader - load-shader - load-vertex-shader - load-fragment-shader - shader? - vertex-shader? - fragment-shader? - shader-compiled? - shader-type - shader-id - make-shader-program - load-shader-program - shader-program-id - shader-program? - shader-program-linked? - with-shader-program - %uniform-setters - register-uniform-setter! - uniforms)) - -(define-syntax-rule (define-logger name length-proc log-proc) - (define (name obj) - (let ((log-length (u32vector 0))) - (length-proc obj (version-2-0 info-log-length) - (bytevector->pointer log-length)) - (let ((log (make-u8vector (1+ (u32vector-ref log-length 0))))) - (log-proc obj (u32vector-ref log-length 0) %null-pointer - (bytevector->pointer log)) - (format #t "~a\n" (utf8->string log)))))) - -(define-syntax-rule (define-status name status-proc status-name) - (define (name obj) - (let ((status (u32vector 0))) - (status-proc obj (version-2-0 status-name) - (bytevector->pointer status)) - (= (u32vector-ref status 0) 1)))) - -;;; -;;; Shaders -;;; - -(define-record-type <shader> - (%make-shader type id) - shader? - (type shader-type) - (id shader-id)) - -(define (vertex-shader? shader) - "Return #t if SHADER is a vertex shader, #f otherwise." - (eq? (shader-type shader) 'vertex)) - -(define (fragment-shader? shader) - "Return #t if SHADER is a fragment shader, #f otherwise." - (eq? (shader-type shader) 'fragment)) - -(define-guardian shader-guardian - (lambda (shader) - (false-if-exception - (glDeleteShader (shader-id shader))))) - -;; Reap GL shaders when their wrapper objects are GC'd. -(define-guardian shader-guardian - (lambda (shader) - (false-if-exception (glDeleteShader (shader-id shader))))) - -(define-status %shader-compiled? glGetShaderiv compile-status) - -(define (shader-compiled? shader) - (%shader-compiled? (shader-id shader))) - -(define-logger %display-compilation-error glGetShaderiv glGetShaderInfoLog) - -(define (display-compilation-error shader) - (%display-compilation-error (shader-id shader))) - -(define (compile-shader shader) - "Attempt to compiler SHADER. Compilation errors are written to -stdout." - (glCompileShader (shader-id shader)) - (unless (shader-compiled? shader) - (display "Failed to compile shader:\n") - (display-compilation-error shader))) - -(define (set-shader-source shader source) - "Use the GLSL source code in the string SOURCE for SHADER." - (let ((length (u32vector (string-length source))) - (str (u64vector (pointer-address (string->pointer source))))) - (glShaderSource (shader-id shader) 1 (bytevector->pointer str) - (bytevector->pointer length)))) - -(define (gl-shader-type type) - "Convert the symbol TYPE to the appropriate OpenGL shader constant." - (cond ((eq? type 'vertex) - (version-2-0 vertex-shader)) - ((eq? type 'fragment) - (version-2-0 fragment-shader)) - (else - (error "Invalid shader type: " type)))) - -(define (make-shader type source) - "Create a new GLSL shader of the given TYPE (vertex or fragment) and -compile the GLSL program contained in the string SOURCE." - (let* ((id (glCreateShader (gl-shader-type type))) - (shader (%make-shader type id))) - (shader-guardian shader) - (set-shader-source shader source) - (compile-shader shader) - shader)) - -(define (make-vertex-shader source) - "Create a new GLSL vertex shader and compile the GLSL program -contained in the string SOURCE." - (make-shader 'vertex source)) - -(define (make-fragment-shader source) - "Create a new GLSL fragment shader and compile the GLSL program -contained in the string SOURCE." - (make-shader 'fragment source)) - -(define (load-shader type filename) - "Create a new GLSL shader of the given TYPE (vertex or fragment) and -compile the GLSL program stored in the file FILENAME." - (if (file-exists? filename) - (make-shader type (call-with-input-file filename read-string)) - (error "File not found!" filename))) - -(define (load-vertex-shader filename) - "Create a new GLSL vertex shader and compile the GLSL program stored -in the file FILENAME." - (load-shader 'vertex filename)) - -(define (load-fragment-shader filename) - "Create a new GLSL vertex shader and compile the GLSL program stored -in the file FILENAME." - (load-shader 'fragment filename)) - -;;; -;;; Programs -;;; - -(define-record-type <shader-program> - (%make-shader-program id) - shader-program? - (id shader-program-id)) - -(define-guardian shader-program-guardian - (lambda (shader-program) - (false-if-exception - (glDeleteProgram (shader-program-id shader-program))))) - -(define-status %shader-program-linked? glGetProgramiv link-status) - -(define (shader-program-linked? shader-program) - "Return #t if SHADER-PROGRAM has been successfully linked with -shaders or #f otherwise." - (%shader-program-linked? (shader-program-id shader-program))) - -(define-logger %display-linking-error glGetProgramiv glGetProgramInfoLog) - -(define (display-linking-error shader-program) - (%display-linking-error (shader-program-id shader-program))) - -(define (make-shader-program vertex-shader fragment-shader) - "Create a new shader program that has been linked with the given -VERTEX-SHADER and FRAGMENT-SHADER." - (unless (and (vertex-shader? vertex-shader) - (fragment-shader? fragment-shader)) - (error "Expected a vertex shader and fragment shader" - vertex-shader fragment-shader)) - (let* ((id (glCreateProgram)) - (shader-program (%make-shader-program id)) - (shaders (list vertex-shader fragment-shader))) - (shader-program-guardian shader-program) - (for-each (lambda (shader) - (glAttachShader id (shader-id shader))) - shaders) - (glLinkProgram id) - (unless (shader-program-linked? shader-program) - (display "Failed to link shader program:\n") - (display-linking-error shader-program)) - ;; Once the program has been linked, the shaders can be detached. - (for-each (lambda (shader) - (glDetachShader id (shader-id shader))) - shaders) - shader-program)) - -(define (load-shader-program vertex-shader-file-name fragment-shader-file-name) - (make-shader-program (load-vertex-shader vertex-shader-file-name) - (load-fragment-shader fragment-shader-file-name))) - -(define current-shader-program (make-parameter #f)) - -(define-syntax-rule (with-shader-program shader-program body ...) - "Evaluate BODY with SHADER-PROGRAM bound." - (parameterize ((current-shader-program shader-program)) - (begin - (glUseProgram (shader-program-id shader-program)) - (let ((return-value (begin body ...))) - (glUseProgram 0) - return-value)))) - -(define-record-type <uniform-setter> - (make-uniform-setter predicate proc) - uniform-setter? - (predicate uniform-setter-predicate) - (proc uniform-setter-proc)) - -(define %uniform-setters '()) - -(define (register-uniform-setter! predicate setter) - "Add a new type of uniform setter for shader programs where -PREDICATE tests the type of a given value and SETTER performs the -necessary OpenGL calls to set the uniform value in the proper -location." - (set! %uniform-setters - (cons (make-uniform-setter predicate setter) - %uniform-setters))) - -;; Built-in uniform setters for booleans, numbers, vectors, and -;; colors. -(register-uniform-setter! boolean? - (lambda (location b) - (glUniform1i location (if b 1 0)))) - -(register-uniform-setter! number? - (lambda (location n) - (glUniform1f location n))) - -(register-uniform-setter! vector2? - (lambda (location v) - (glUniform2f location (vx v) (vy v)))) - -(register-uniform-setter! vector3? - (lambda (location v) - (glUniform3f location (vx v) (vy v) (vz v)))) - -(register-uniform-setter! vector4? - (lambda (location v) - (glUniform4f location (vx v) (vy v) (vz v) (vw v)))) - -(register-uniform-setter! transform? - (lambda (location t) - (let ((pointer - (bytevector->pointer - (array-contents (transform-matrix t))))) - (glUniformMatrix4fv location 1 #f - pointer)))) - -(register-uniform-setter! color? - (lambda (location c) - (glUniform4f location - (color-r c) - (color-g c) - (color-b c) - (color-a c)))) - -(define uniform-location - (memoize - (lambda (shader-program name) - "Retrieve the location for the uniform NAME within SHADER-PROGRAM." - (glGetUniformLocation (shader-program-id shader-program) - (symbol->string name))))) - -(define attribute-location - (memoize - (lambda (shader-program name) - "Retrieve the location for the uniform NAME within SHADER-PROGRAM." - (glGetAttribLocation (shader-program-id shader-program) - (symbol->string name))))) - -(define (uniform-set! shader-program name value) - "Use the appropriate setter procedure to translate VALUE into OpenGL -compatible data and assign it to the location of the uniform NAME -within SHADER-PROGRAM." - (let ((setter (find (lambda (setter) - ((uniform-setter-predicate setter) value)) - %uniform-setters)) - (location (uniform-location shader-program name))) - (if setter - ((uniform-setter-proc setter) location value) - (error "Not a valid uniform data type" value)))) - -;; Bind values to uniform variables within the current shader program -;; via a let-style syntax. The types of the given values must be -;; accounted for in the %uniform-setters list. This macro simply sets -;; uniform values and does not restore the previous values after -;; evaluating the body of the form. -;; -;; emacs: (put 'uniforms 'scheme-indent-function 1) -(define-syntax uniforms - (syntax-rules () - ((_ () body ...) - (begin body ...)) - ((_ ((name value) ...) body ...) - (begin - (uniform-set! (current-shader-program) 'name value) - ... - body ...)))) diff --git a/2d/signal.scm b/2d/signal.scm deleted file mode 100644 index efbb103..0000000 --- a/2d/signal.scm +++ /dev/null @@ -1,292 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu> -;;; -;;; 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/>. - -;;; Commentary: -;; -;; Simple functional reactive programming API. -;; -;;; Code: - -(define-module (2d signal) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-26) - #:use-module (2d agenda) - #:export (signal? - make-signal - define-signal - hook->signal - signal-ref - signal-ref-maybe - signal-set! - signal-proc - signal-merge - signal-zip - signal-map - signal-fold - signal-filter - signal-reject - signal-constant - signal-count - signal-tap - signal-sample - signal-delay - signal-throttle)) - -;;; -;;; Signals -;;; - -;; Signals are time-varying values. For example, a signal could -;; represent the mouse position at the current point in time. The -;; signals API provides an abstraction over regular event-based -;; programming. State mutation is hidden away and a functional, -;; declarative interface is exposed. -(define-record-type <signal> - (%%make-signal value proc inputs outputs) - %signal? - (value %signal-ref %%signal-set!) - (proc signal-proc) - (inputs signal-inputs) - (outputs signal-outputs)) - -(define-record-type <signal-box> - (make-signal-box signal) - signal-box? - (signal signal-unbox signal-box-set!)) - -;; Alternate spelling of signal-box? for the public API. -(define signal? signal-box?) - -(define (%make-signal init proc inputs) - "Create a new signal with initial value INIT." - (let ((signal (%%make-signal init proc inputs (make-weak-key-hash-table)))) - (for-each (cut signal-connect! signal <>) inputs) - signal)) - -(define (make-signal init) - "Return a signal box with initial value INIT." - (make-signal-box (%make-signal init #f '()))) - -(define (make-boxed-signal init proc inputs) - "Return a signal box containing a signal with value INIT, updating -procedure PROC, and a list of INPUTS." - (make-signal-box (%make-signal init proc inputs))) - -(define (signal-connect! signal-out signal-box-in) - "Attach SIGNAL-OUT to SIGNAL-BOX-IN. When the signal within -SIGNAL-BOX-IN changes, the value will be propagated to SIGNAL-OUT." - (hashq-set! (signal-outputs (signal-unbox signal-box-in)) signal-out #f)) - -(define (signal-ref signal-box) - "Return the current value of the signal contained within -SIGNAL-BOX." - (%signal-ref (signal-unbox signal-box))) - -(define (signal-ref-maybe object) - "Retrieves the signal value from OBJECT if it is a signal and or -simply returns OBJECT otherwise." - (if (signal-box? object) - (signal-ref object) - object)) - -(define (signal-propagate! signal) - "Notify all output signals about the current value of SIGNAL." - (hash-for-each (lambda (output unused) - ((signal-proc output) output (%signal-ref signal))) - (signal-outputs signal))) - -(define (%signal-set! signal value) - "Change the current value of SIGNAL to VALUE and propagate VALUE to -all output signals." - (%%signal-set! signal value) - (signal-propagate! signal) - *unspecified*) - -(define (signal-set! signal-box value) - "Change the current value contained within SIGNAL-BOX to VALUE." - (%signal-set! (signal-unbox signal-box) value)) - -(define (splice-signals! to from) - "Replace the contents of the signal TO with the contents of the -signal FROM and transfer all output signals." - (let ((outputs (signal-outputs (signal-unbox to)))) - (hash-for-each (lambda (signal unused) - (signal-connect! signal from)) - outputs) - (signal-box-set! to (signal-unbox from)))) - -(define (make-signal-maybe value) - "Coerce VALUE into a signal. Return VALUE unmodified if it is -already a signal." - (if (signal? value) - value - (make-signal value))) - -(define-syntax define-signal - (lambda (x) - "Create a top-level signal variable. If the named variable -already exists and has a signal value then its outputs will be spliced -into the new signal. If the given value is not a signal then it will -be coerced into one." - (syntax-case x () - ((_ name (signal ...)) - (defined? (syntax->datum #'name)) - #'(let ((s (make-signal-maybe (signal ...)))) - (if (signal? name) - (begin - (splice-signals! name s) - (signal-propagate! (signal-unbox name))) - (set! name s)))) - ((_ name value) - (defined? (syntax->datum #'name)) - #'(let ((s (make-signal-maybe value))) - (if (signal? name) - (begin - (splice-signals! name s) - (signal-propagate! (signal-unbox name))) - (set! name s)))) - ((_ name (signal ...)) - #'(define name (make-signal-maybe (signal ...)))) - ((_ name value) - #'(define name (make-signal-maybe value)))))) - -;;; -;;; Higher Order Signals -;;; - -(define (hook->signal hook init proc) - "Return a new signal whose initial value is INIT and has future -values calculated by applying PROC to the arguments sent when HOOK is -run." - (let ((signal (make-signal init))) - (add-hook! hook - (lambda args - (signal-set! signal (apply proc args)))) - signal)) - -(define (signal-merge signal1 signal2 . rest) - "Create a new signal whose value is the that of the most recently -changed signal in SIGNALs. The initial value is that of the first -signal in SIGNALS." - (let ((inputs (append (list signal1 signal2) rest))) - (make-boxed-signal (signal-ref (car inputs)) - (lambda (self value) - (%signal-set! self value)) - inputs))) - -(define (signal-zip . signals) - "Create a new signal whose value is a list of the values stored in -the given signals." - (define (current-value) - (map signal-ref signals)) - (make-boxed-signal (current-value) - (lambda (self value) - (%signal-set! self (current-value))) - signals)) - -(define (signal-map proc signal . rest) - "Create a new signal that applies PROC to the values stored in one -or more SIGNALS." - (let ((inputs (cons signal rest))) - (define (current-value) - (apply proc (map signal-ref inputs))) - (make-boxed-signal (current-value) - (lambda (self value) - (%signal-set! self (current-value))) - inputs))) - -(define (signal-fold proc init signal . rest) - "Create a new signal that applies PROC to the values stored in -SIGNAL. PROC is applied with the current value of SIGNAL and the -previously computed value, or INIT for the first call." - (let ((inputs (cons signal rest))) - (make-boxed-signal init - (let ((previous init)) - (lambda (self value) - (let ((x (apply proc - (append (map signal-ref inputs) - (list previous))))) - (set! previous x) - (%signal-set! self x)))) - inputs))) - -(define (signal-filter predicate default signal) - "Create a new signal that keeps an incoming value from SIGNAL when -it satifies the procedure PREDICATE. The value of the signal is -DEFAULT when the predicate is never satisfied." - (make-boxed-signal (if (predicate (signal-ref signal)) - (signal-ref signal) - default) - (lambda (self value) - (when (predicate value) - (%signal-set! self value))) - (list signal))) - -(define (signal-reject predicate default signal) - "Create a new signal that does not keep an incoming value from -SIGNAL when it satisfies the procedure PREDICATE. The value of the -signal is DEFAULT when the predicate is never satisfied." - (signal-filter (lambda (x) (not (predicate x))) default signal)) - -(define (signal-constant constant signal) - "Create a new signal whose value is always CONSTANT regardless of -what the value received from SIGNAL." - (signal-map (lambda (value) constant) signal)) - -(define (signal-count signal) - "Create a new signal that increments a counter every time a new -value from SIGNAL is received." - (signal-fold + 0 (signal-constant 1 signal))) - -(define (signal-tap proc signal) - "Create a new signal that applies PROC when a new values is received -from SIGNAL. The value of the new signal will always be the value of -SIGNAL. This signal is a convenient way to sneak a procedure that has -a side-effect into a signal chain." - (signal-map (lambda (x) (proc x) x) signal)) - -(define (signal-sample delay signal) - "Create a new signal that emits the value contained within SIGNAL -every DELAY ticks of the current agenda." - (let ((sampler (%make-signal (signal-ref signal) #f '()))) - (define (tick) - (%signal-set! sampler (signal-ref signal))) - (schedule-interval tick delay) - (make-signal-box sampler))) - -(define (signal-delay delay signal) - "Create a new signal that delays propagation of SIGNAL by DELAY -ticks of the current agenda." - (make-boxed-signal (signal-ref signal) - (lambda (self value) - (schedule - (lambda () - (%signal-set! self value)) - delay)) - (list signal))) - -(define (signal-throttle delay signal) - "Return a new signal that propagates SIGNAL at most once every DELAY -ticks of the current agenda." - (make-boxed-signal (signal-ref signal) - (let ((last-time (agenda-time))) - (lambda (self value) - (when (>= (- (agenda-time) last-time) delay) - (%signal-set! self value) - (set! last-time (agenda-time))))) - (list signal))) diff --git a/2d/sprite.scm b/2d/sprite.scm deleted file mode 100644 index a672d58..0000000 --- a/2d/sprite.scm +++ /dev/null @@ -1,188 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu> -;;; -;;; 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/>. - -;;; Commentary: -;; -;; Sprites are typically the most important part of a 2D game. This -;; module provides sprites as an abstraction around OpenGL textures. -;; -;;; Code: - -(define-module (2d sprite) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-9 gnu) - #:use-module (gl) - #:use-module (gl contrib packed-struct) - #:use-module ((sdl sdl) #:prefix SDL:) - #:use-module (2d agenda) - #:use-module (2d animation) - #:use-module (2d color) - #:use-module (2d config) - #:use-module (2d helpers) - #:use-module (2d math) - #:use-module (2d shader) - #:use-module (2d signal) - #:use-module (2d texture) - #:use-module (2d vector) - #:use-module (2d window) - #:use-module (2d wrappers gl) - #:export (enable-sprites - make-sprite - sprite? - animated-sprite? - sprite-drawable - sprite-position - sprite-scale - sprite-rotation - sprite-color - sprite-anchor - set-sprite-drawable - set-sprite-position - set-sprite-scale - set-sprite-rotation - set-sprite-color - set-sprite-anchor - load-sprite - draw-sprite)) - -;;; -;;; Sprites -;;; - -(define sprite-shader #f) - -(define (enable-sprites) - (set! sprite-shader - (load-shader-program - (string-append %pkgdatadir - "/shaders/sprite-vertex.glsl") - (string-append %pkgdatadir - "/shaders/sprite-fragment.glsl")))) - -;; The <sprite> type represents a drawable object (texture, -;; texture-region, animation, etc.) with a given position, scale, -;; rotation, and color. -(define-immutable-record-type <sprite> - (%make-sprite drawable position scale rotation color anchor vertices animator) - sprite? - (drawable sprite-drawable set-sprite-drawable) - (position sprite-position set-sprite-position) - (scale sprite-scale set-sprite-scale) - (rotation sprite-rotation set-sprite-rotation) - (color sprite-color set-sprite-color) - (anchor sprite-anchor set-sprite-anchor) - (vertices sprite-vertices) - (animator sprite-animator)) - -(define (update-sprite-vertices! sprite) - (let ((texture (sprite-texture sprite))) - (pack-texture-vertices (sprite-vertices sprite) - 0 - (texture-width texture) - (texture-height texture) - (texture-s1 texture) - (texture-t1 texture) - (texture-s2 texture) - (texture-t2 texture)))) - -(define* (make-sprite drawable #:optional #:key - (position #(0 0)) (scale #(1 1)) - (rotation 0) (color white) (anchor 'center)) - "Create a new sprite object. DRAWABLE is either a texture or -animation object. All keyword arguments are optional. POSITION is a -vector with a default of (0, 0). SCALE is a vector that describes how -much DRAWABLE should be strected on the x and y axes, with a default -of 1x scale. ROTATION is an angle in degrees with a default of 0. -COLOR is a color object with a default of white. ANCHOR is either a -vector that represents the center point of the sprite, or 'center -which will place the anchor at the center of DRAWABLE. Sprites are -centered by default." - (let* ((vertices (make-packed-array texture-vertex 4)) - (animator (if (animation? drawable) - (make-animator drawable) - #f)) - (anchor (anchor-texture (drawable-texture drawable animator) anchor)) - (sprite (%make-sprite drawable position scale rotation color - anchor vertices animator))) - (update-sprite-vertices! sprite) - sprite)) - -(define* (load-sprite filename #:optional #:key - (position #(0 0)) (scale #(1 1)) - (rotation 0) (color white) (anchor 'center)) - "Load a sprite from the file at FILENAME. See make-sprite for -optional keyword arguments." - (make-sprite (load-texture filename) - #:position position - #:scale scale - #:rotation rotation - #:color color - #:anchor anchor)) - -(define (animated-sprite? sprite) - "Return #t if SPRITE has an animation as its drawable object." - (animation? (sprite-drawable sprite))) - -(define (drawable-texture drawable animator) - (cond ((texture? drawable) - drawable) - ((animation? drawable) - (animator-texture animator)))) - -(define (sprite-texture sprite) - "Return the texture for the SPRITE's drawable object." - (let ((drawable (sprite-drawable sprite))) - (drawable-texture (sprite-drawable sprite) - (sprite-animator sprite)))) - -(define (update-sprite-animator! sprite) - (animator-update! (sprite-animator sprite)) - (update-sprite-vertices! sprite)) - -(define (draw-sprite sprite) - "Render SPRITE to the screen. A sprite batch will be used if one is -currently bound." - (register-animated-sprite-maybe sprite) - (with-shader-program sprite-shader - (uniforms ((position (sprite-position sprite)) - (anchor (sprite-anchor sprite)) - (scale (sprite-scale sprite)) - (rotation (sprite-rotation sprite)) - (color (sprite-color sprite)) - (projection (signal-ref window-projection))) - (draw-texture-vertices (sprite-texture sprite) - (sprite-vertices sprite) - 1)))) - -;; A hash table for all of the animated sprites that have been drawn -;; since the last game update. It is cleared after every agenda tick. -(define animated-sprites (make-hash-table)) - -(define (register-animated-sprite-maybe sprite) - (when (animated-sprite? sprite) - (hash-set! animated-sprites sprite sprite))) - -(define (update-animated-sprites!) - "Update all animators for sprites that have been drawn this frame." - (hash-for-each (lambda (key val) - (update-sprite-animator! val)) - animated-sprites) - (hash-clear! animated-sprites)) - -;; Update animated sprites upon every update. -(schedule-each update-animated-sprites!) diff --git a/2d/texture.scm b/2d/texture.scm deleted file mode 100644 index bd7bea6..0000000 --- a/2d/texture.scm +++ /dev/null @@ -1,224 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu> -;;; -;;; 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/>. - -;;; Commentary: -;; -;; Textures and texture regions are high level wrappers over OpenGL -;; textures. -;; -;;; Code: - -(define-module (2d texture) - #:use-module (srfi srfi-9) - #:use-module (gl) - #:use-module (gl contrib packed-struct) - #:use-module (2d color) - #:use-module (2d helpers) - #:use-module (2d vector) - #:use-module (2d wrappers gl) - #:use-module (2d wrappers freeimage) - #:export (make-texture - make-texture-region - load-texture - texture? - texture-region? - texture-id - texture-width - texture-height - texture-s1 - texture-t1 - texture-s2 - texture-t2 - anchor-texture - texture-vertex - pack-texture-vertices - draw-texture-vertices)) - -;;; -;;; Textures -;;; - -;; The <texture> object is a simple wrapper around an OpenGL texture -;; id. -(define-record-type <texture> - (%make-texture id parent width height s1 t1 s2 t2) - texture? - (id texture-id) - (parent texture-parent) - (width texture-width) - (height texture-height) - (s1 texture-s1) - (t1 texture-t1) - (s2 texture-s2) - (t2 texture-t2)) - -(define (texture-region? texture) - "Return #t if TEXTURE has a parent texture." - (texture? (texture-parent texture))) - -(define (make-texture id parent width height s1 t1 s2 t2) - "Create a new texture object. ID is the OpenGL texture id. PARENT is -a texture object (if this texture only represents a region of another -texture) or #f. WIDTH and HEIGHT are the texture dimensions in -pixels. S1, T1, S2, and T2 are the OpenGL texture coordinates -representing the area of the texture that will be rendered." - (let ((texture (%make-texture id parent width height s1 t1 s2 t2))) - (texture-guardian texture) - texture)) - -(define (make-texture-region texture x y width height) - "Creates new texture region object. TEXTURE is the region's parent -texture. X, Y, WIDTH, and HEIGHT represent the region of the texture -that will be rendered, in pixels." - (let* ((w (texture-width texture)) - (h (texture-height texture))) - (make-texture (texture-id texture) - texture - width - height - (/ x w) - (/ y h) - (/ (+ x width) w) - (/ (+ y height) h)))) - -;; Use a guardian and an after GC hook that ensures that OpenGL -;; textures are deleted when texture objects are GC'd. -(define-guardian texture-guardian - (lambda (texture) - ;; Do not reap texture regions - (unless (texture-region? texture) - ;; When attempting to reap structures upon guile exit, the - ;; dynamic pointer to gl-delete-textures becomes invalid. So, we - ;; ignore the error and move on. - (false-if-exception (gl-delete-texture (texture-id texture)))))) - -(define (bitmap->texture bitmap) - "Translates a freeimage bitmap into an OpenGL texture." - (let ((texture-id (gl-generate-texture)) - (pixels (freeimage-get-bits bitmap))) - (with-gl-bind-texture (texture-target texture-2d) texture-id - ;; Use "nearest" scaling method so that pixel art doesn't become - ;; blurry when scaled. - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-min-filter) - (texture-min-filter nearest)) - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-mag-filter) - (texture-mag-filter nearest)) - (gl-texture-image-2d (texture-target texture-2d) - 0 - (pixel-format rgba) - (freeimage-get-width bitmap) - (freeimage-get-height bitmap) - 0 - (version-1-2 bgra) - (color-pointer-type unsigned-byte) - pixels)) - (make-texture texture-id - #f - (freeimage-get-width bitmap) - (freeimage-get-height bitmap) - 0 0 1 1))) - -(define (load-bitmap filename) - ;; Throw an error if image file does not exist or else we will - ;; segfault later. - (unless (file-exists? filename) - (throw 'image-not-found filename)) - ;; Load image and convert it to 32 bit color. - (let* ((image-type (freeimage-get-file-type filename)) - (bitmap (freeimage-load image-type filename)) - (32bit-bitmap (freeimage-convert-to-32-bits bitmap))) - (freeimage-unload bitmap) - ;; Need to flip because y-axis is reversed. - (freeimage-flip-vertical 32bit-bitmap) - 32bit-bitmap)) - -(define (load-texture filename) - "Load a texture from an image file at FILENAME." - (let* ((bitmap (load-bitmap filename)) - (texture (bitmap->texture bitmap))) - (freeimage-unload bitmap) - texture)) - -(define (anchor-texture texture anchor) - "Return a vector of the coordinates for the center point of a -texture." - (let ((w (texture-width texture)) - (h (texture-height texture))) - (cond - ((vector2? anchor) - anchor) - ((eq? anchor 'center) - (vector (/ w 2) - (/ h 2))) - ((eq? anchor 'top-left) - #(0 0)) - ((eq? anchor 'top-right) - (vector w 0)) - ((eq? anchor 'bottom-left) - (vector 0 h)) - ((eq? anchor 'bottom-right) - (vector w h)) - ((eq? anchor 'top-center) - (vector (/ w 2) 0)) - ((eq? anchor 'bottom-center) - (vector (/ w 2) h)) - (else - (error "Invalid anchor type!" anchor))))) - -;;; -;;; Texture Vertices -;;; - -(define-packed-struct texture-vertex - ;; Position - (x float) - (y float) - ;; Texture Coordinates - (s float) - (t float)) - -(define texture-vertex-size (packed-struct-size texture-vertex)) -(define x-offset (packed-struct-offset texture-vertex x)) -(define s-offset (packed-struct-offset texture-vertex s)) - -(define (pack-texture-vertices vertices offset width height s1 t1 s2 t2) - ;; Vertices go counter clockwise, starting from the top-left - ;; corner. - (pack vertices offset texture-vertex 0 0 s1 t1) - (pack vertices (+ offset 1) texture-vertex 0 height s1 t2) - (pack vertices (+ offset 2) texture-vertex width height s2 t2) - (pack vertices (+ offset 3) texture-vertex width 0 s2 t1)) - -(define (draw-texture-vertices texture vertices size) - (let ((pointer-type (tex-coord-pointer-type float))) - (gl-enable-client-state (enable-cap vertex-array)) - (gl-enable-client-state (enable-cap texture-coord-array)) - (with-gl-bind-texture (texture-target texture-2d) (texture-id texture) - (set-gl-vertex-array pointer-type - vertices - 2 - #:stride texture-vertex-size - #:offset x-offset) - (set-gl-texture-coordinates-array pointer-type - vertices - #:stride texture-vertex-size - #:offset s-offset) - (gl-draw-arrays (begin-mode quads) 0 (* size 4))) - (gl-disable-client-state (enable-cap texture-coord-array)) - (gl-disable-client-state (enable-cap vertex-array)))) diff --git a/2d/tileset.scm b/2d/tileset.scm deleted file mode 100644 index 669372b..0000000 --- a/2d/tileset.scm +++ /dev/null @@ -1,89 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu> -;;; -;;; 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/>. - -;;; Commentary: -;; -;; Tilesets encapsulate a group of uniformly sized texture regions -;; that come from a single texture. -;; -;;; Code: - -(define-module (2d tileset) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-42) - #:use-module (2d texture) - #:export (<tileset> - make-tileset - load-tileset - tileset? - tileset-tiles - tileset-width - tileset-height - tileset-margin - tileset-spacing - tileset-ref)) - -(define-record-type <tileset> - (%make-tileset tiles width height margin spacing) - tileset? - (tiles tileset-tiles) - (width tileset-width) - (height tileset-height) - (margin tileset-margin) - (spacing tileset-spacing)) - -(define (split-texture texture width height margin spacing) - "Split TEXTURE into a vector of texture regions of WIDTH x HEIGHT -size. SPACING refers to the number of pixels separating each -tile. MARGIN refers to the number of pixels on the top and left of -TEXTURE before the first tile begins." - (define (build-tile tx ty) - (let* ((x (+ (* tx (+ width spacing)) margin)) - (y (+ (* ty (+ height spacing)) margin))) - (make-texture-region texture x y width height))) - - (let* ((tw (texture-width texture)) - (th (texture-height texture)) - (rows (/ (- tw margin) (+ width spacing))) - (columns (/ (- tw margin) (+ height spacing)))) - (vector-ec (: y rows) (: x columns) (build-tile x y)))) - -(define* (make-tileset texture width height - #:optional #:key (margin 0) (spacing 0)) - "Return a new tileset that is built by splitting TEXTURE into -tiles." - (let ((tiles (split-texture texture - width - height - margin - spacing))) - (%make-tileset tiles width height margin spacing))) - -(define* (load-tileset filename width height - #:optional #:key (margin 0) (spacing 0)) - "Return a new tileset that is built by loading the texture at -FILENAME and splitting the texture into tiles." - (let* ((tiles (split-texture (load-texture filename) - width - height - margin - spacing))) - (%make-tileset tiles width height margin spacing))) - -(define (tileset-ref tileset i) - "Return the tile texture of TILESET at index I." - (vector-ref (tileset-tiles tileset) i)) diff --git a/2d/transform.scm b/2d/transform.scm deleted file mode 100644 index 21be955..0000000 --- a/2d/transform.scm +++ /dev/null @@ -1,233 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2014 David Thompson <dthompson2@worcester.edu> -;;; -;;; 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/>. - -;;; Commentary: -;; -;; 4x4 column-major transformation matrix. -;; -;;; Code: - -(define-module (2d transform) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-42) - #:use-module (2d math) - #:use-module (2d vector) - #:export (make-transform null-transform identity-transform - transform? transform-matrix - transpose transform-vector2 - transform+ transform* - scale translate rotate-x rotate-y rotate-z - orthographic-projection perspective-projection)) - -(define-record-type <transform> - (%make-transform matrix) - transform? - (matrix transform-matrix)) - -(define (make-4x4-matrix) - (make-typed-array 'f32 0 4 4)) - -(define (make-transform aa ab ac ad - ba bb bc bd - ca cb cc cd - da db dc dd) - "Return a new transform initialized with the given 16 values in -column-major format." - (let ((matrix (make-4x4-matrix))) - (array-set! matrix aa 0 0) - (array-set! matrix ab 0 1) - (array-set! matrix ac 0 2) - (array-set! matrix ad 0 3) - (array-set! matrix ba 1 0) - (array-set! matrix bb 1 1) - (array-set! matrix bc 1 2) - (array-set! matrix bd 1 3) - (array-set! matrix ca 2 0) - (array-set! matrix cb 2 1) - (array-set! matrix cc 2 2) - (array-set! matrix cd 2 3) - (array-set! matrix da 3 0) - (array-set! matrix db 3 1) - (array-set! matrix dc 3 2) - (array-set! matrix dd 3 3) - (%make-transform matrix))) - -(define null-transform - (%make-transform (make-4x4-matrix))) - -(define identity-transform - (make-transform 1 0 0 0 - 0 1 0 0 - 0 0 1 0 - 0 0 0 1)) - -(define (transpose transform) - "Return a transform that is the transpose of TRANSFORM." - (let ((m1 (transform-matrix transform)) - (m2 (make-4x4-matrix))) - (do-ec (: r 4) (: c 4) - (array-set! m2 (array-ref m1 r c) - c r)) - (%make-transform m2))) - -(define (transform-vector2 transform v) - "Apply TRANSFORM to the 2D vector V." - (let ((m (transform-matrix transform)) - (x (vx v)) - (y (vy v))) - (vector (+ (* x (array-ref m 0 0)) - (* y (array-ref m 0 1)) - (array-ref m 0 3)) - (+ (* x (array-ref m 1 0)) - (* y (array-ref m 1 1)) - (array-ref m 1 3))))) - -(define (transform+ . transforms) - "Return the sum of all given transformation matrices. Return -null-transform if called without any arguments." - (define (add a b) - (let ((m1 (transform-matrix a)) - (m2 (transform-matrix b)) - (m3 (make-4x4-matrix))) - (do-ec (: r 4) (: c 4) - (let ((x (+ (array-ref m1 r c) - (array-ref m2 r c)))) - (array-set! m3 x r c))) - (%make-transform m3))) - (reduce add null-transform transforms)) - -(define (transform* . transforms) - "Return the product of all given transformation matrices. Return -identity-transform if called without any arguments." - (define (mul a b) - (let ((m1 (transform-matrix a)) - (m2 (transform-matrix b)) - (m3 (make-4x4-matrix))) - (do-ec (: r 4) (: c 4) - (let ((x (sum-ec (: k 4) - (* (array-ref m1 r k) - (array-ref m2 k c))))) - (array-set! m3 x r c))) - (%make-transform m3))) - (reduce mul identity-transform transforms)) - -(define (translate v) - "Return a new transform that translates by the 2D or 3D vector V." - (cond - ((vector2? v) - (let ((x (vx v)) - (y (vy v))) - (make-transform 1 0 0 0 - 0 1 0 0 - 0 0 1 0 - x y 0 1))) - ((vector3? v) - (let ((x (vx v)) - (y (vy v)) - (z (vz v))) - (make-transform 1 0 0 0 - 0 1 0 0 - 0 0 1 0 - x y z 1))) - (else - (error "Invalid scaling vector: " v)))) - -(define (scale v) - "Return a new transform that scales by the 2D vector, 3D vector, or -scalar V." - (cond - ((number? v) - (make-transform v 0 0 0 - 0 v 0 0 - 0 0 v 0 - 0 0 0 1)) - ((vector2? v) - (let ((x (vx v)) - (y (vy v))) - (make-transform x 0 0 0 - 0 y 0 0 - 0 0 1 0 - 0 0 0 1))) - ((vector3? v) - (let ((x (vx v)) - (y (vy v)) - (z (vz v))) - (make-transform x 0 0 0 - 0 y 0 0 - 0 0 z 0 - 0 0 0 1))) - (else - (error "Invalid scaling vector: " v)))) - -(define (rotate-x angle) - "Return a new transform that rotates the X axis by ANGLE radians." - (make-transform 1 0 0 0 - 0 (cos angle) (- (sin angle)) 0 - 0 (sin angle) (cos angle) 0 - 0 0 0 1)) - -(define (rotate-y angle) - "Return a new transform that rotates the Y axis by ANGLE radians." - (make-transform (cos angle) 0 (sin angle) 0 - 0 1 0 0 - (- (sin angle)) 0 (cos angle) 0 - 0 0 0 1)) -(define (rotate-z angle) - "Return a new transform that rotates the Z axis by ANGLE radians." - (make-transform (cos angle) (- (sin angle)) 0 0 - (sin angle) (cos angle) 0 0 - 0 0 1 0 - 0 0 0 1)) - -(define (orthographic-projection left right top bottom near far) - "Return a new transform that represents an orthographic projection -for the vertical clipping plane LEFT and RIGHT, the horizontal -clipping plane TOP and BOTTOM, and the depth clipping plane NEAR and -FAR." - (make-transform (/ 2 (- right left)) 0 0 0 - 0 (/ 2 (- top bottom)) 0 0 - 0 0 (/ 2 (- far near)) 0 - (- (/ (+ right left) (- right left))) - (- (/ (+ top bottom) (- top bottom))) - (- (/ (+ far near) (- far near))) - 1)) - -(define (perspective-projection field-of-vision aspect-ratio near far) - "Return a new transform that represents a perspective projection -with a FIELD-OF-VISION in degrees, the desired ASPECT-RATIO, and the -depth clipping plane NEAR and FAR." - (let ((size (* near (tan (/ (degrees->radians field-of-vision) 2))))) - (let ((left (- size)) - (right size) - (top (/ size aspect-ratio)) - (bottom (/ (- size) aspect-ratio))) - (make-transform (/ (* 2 near) (- right left)) ;; First row - 0 - (/ (+ right left) (- right left)) - 0 - ;; Second row - 0 - (/ (* 2 near) (- top bottom)) - (/ (+ top bottom) (- top bottom)) - 0 - ;; Third row - 0 0 - (- (/ (+ far near) (- far near))) - (- (/ (* 2 far near) (- far near))) - ;; Fourth row - 0 0 -1 0)))) diff --git a/2d/vector.scm b/2d/vector.scm deleted file mode 100644 index 302f62b..0000000 --- a/2d/vector.scm +++ /dev/null @@ -1,157 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2014 David Thompson <davet@gnu.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/>. - -;;; Commentary: -;; -;; Vector math. -;; -;;; Code: - -(define-module (2d vector) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-43) - #:export (vector2? vector3? vector4? - vector-length= v= - vx vy vz vw - polar-vector - v+ v- v* vdot vcross - magnitude normalize)) - -(define (vector-dimensionality? v d) - (and (vector? v) (= (vector-length v) d))) - -(define (vector2? v) - "Return #t if V is a 2D vector, #f otherwise." - (vector-dimensionality? v 2)) - -(define (vector3? v) - "Return #t if V is a 3D vector, #f otherwise." - (vector-dimensionality? v 3)) - -(define (vector4? v) - "Return #t if V is a 4D vector, #f otherwise." - (vector-dimensionality? v 4)) - -(define (vector-length= v1 v2) - "Return #t if V1 and V2 are of the same dimensionality, #f -otherwise." - (= (vector-length v1) - (vector-length v2))) - -(define (v= . vectors) - "Return #t if all arguments are equivalent vectors, #f otherwise." - (apply vector= = vectors)) - -(define (vx v) - "Return the first component of the vector V." - (vector-ref v 0)) - -(define (vy v) - "Return the second component of the vector V." - (vector-ref v 1)) - -(define (vz v) - "Return the third component of the vector V." - (vector-ref v 2)) - -(define (vw v) - "Return the fourth component of the vector V." - (vector-ref v 3)) - -(define (polar-vector r theta) - "Create a 2D cartesian vector from the polar coordinates (R, -THETA)." - (vector (* r (cos theta)) - (* r (sin theta)))) - -(define (dimension-error v1 v2) - (error "Vector dimensionality mismatch: " v1 v2)) - -(define* (vreduce op vectors #:optional (reduce reduce)) - (reduce (lambda args - (match args - (((? number? k) (? number? l)) - (op k l)) - (((? number? k) (? vector? v)) - (vector-map (lambda (i n) (op k n)) v)) - (((? vector? v) (? number? k)) - (vector-map (lambda (i n) (op n k)) v)) - (((? vector? v1) (? vector? v2)) - (if (vector-length= v1 v2) - (vector-map (lambda (i a b) - (op a b)) - v1 v2) - (dimension-error v1 v2))))) - 0 vectors)) - -(define (v+ . vectors) - "Return the sum of all vectors. All vectors must be of the same -dimensionality. Scalar values can be used to add to all components of -the resulting vector." - (vreduce + vectors)) - -(define v- - (case-lambda - "Return the difference of all vectors. All vectors must be of the -same dimensionality. Scalar values can be used to subtract from all -components of the resulting vector." - ((v) (v- 0 v)) - ((v . rest) - (vreduce - (cons v rest) reduce-right)))) - -(define (v* . vectors) - "Return the product of all VECTORS. All vectors must be of the same -dimensionality. Scalar values can be used to multiply all components -of the resulting vector." - (vreduce * vectors)) - -(define (vdot v1 v2) - "Return the dot product of the vectors V1 and V2. V1 and V2 must be -of the same dimensionality." - (if (vector-length= v1 v2) - (vector-fold (lambda (i memo a b) - (+ memo (* a b))) - 0 v1 v2) - (dimension-error v1 v2))) - -(define (vcross v1 v2) - "Return the cross product of the vectors V1 and V2. V1 and V2 must -both be 3D vectors." - (match (list v1 v2) - ((#(x1 y1 z1) #(x2 y2 z2)) - (vector (- (* y1 z2) (* z1 y2)) - (- (* z1 x2) (* x1 z2)) - (- (* x1 y2) (* y1 x2)))) - (_ (error "Expected 3D vectors: " v1 v2)))) - -(define (magnitude v) - "Return the magnitude of the vector V." - (sqrt - (vector-fold (lambda (i memo n) - (+ memo (expt n 2))) - 0 v))) - -(define (normalize v) - "Normalize the vector V." - (let ((m (magnitude v))) - (if (zero? m) - 0 - (vector-map (lambda (i n) - (/ n m)) - v)))) diff --git a/2d/window.scm b/2d/window.scm deleted file mode 100644 index 126d1a2..0000000 --- a/2d/window.scm +++ /dev/null @@ -1,118 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu> -;;; -;;; 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/>. - -;;; Commentary: -;; -;; Window management. -;; -;;; Code: - -(define-module (2d window) - #:use-module (srfi srfi-9) - #:use-module (gl) - #:use-module ((sdl sdl) #:prefix SDL:) - #:use-module ((sdl mixer) #:prefix SDL:) - #:use-module (2d event) - #:use-module (2d signal) - #:use-module (2d transform) - #:use-module (2d vector) - #:export (make-window - window? - window-title - window-resolution - window-fullscreen? - window-width - window-height - window-size - window-projection - open-window - close-window - with-window - window-resize-hook - window-close-hook)) - -(define-record-type <window> - (%make-window title resolution fullscreen?) - window? - (title window-title) - (resolution window-resolution) - (fullscreen? window-fullscreen?)) - -(define* (make-window #:optional #:key - (title "Guile-2D Window") - (resolution #(640 480)) - (fullscreen? #f)) - (%make-window title resolution fullscreen?)) - -(define window-resize-hook (make-hook 2)) - -(register-event-handler - 'video-resize - (lambda (e) - (run-hook window-resize-hook - (SDL:event:resize:w e) - (SDL:event:resize:h e)))) - -(define-signal window-size - (hook->signal window-resize-hook - #(0 0) - (lambda (width height) - (vector width height)))) -(define-signal window-width (signal-map vx window-size)) -(define-signal window-height (signal-map vy window-size)) - -(define-signal window-projection - (signal-map (lambda (size) - (if (or (zero? (vx size)) (zero? (vy size))) - identity-transform - (orthographic-projection 0 (vx size) 0 (vy size) -1 1))) - window-size)) - -(define window-close-hook (make-hook)) - -(register-event-handler - 'quit - (lambda (e) - (run-hook window-close-hook))) - -(define* (open-window #:optional (window (make-window #:title ""))) - "Open the game window using the settings in WINDOW." - (let ((flags (if (window-fullscreen? window) '(opengl fullscreen) 'opengl)) - (width (vx (window-resolution window))) - (height (vy (window-resolution window)))) - (signal-set! window-size (vector width height)) - ;; Initialize everything - (SDL:enable-unicode #t) - (SDL:init 'everything) - ;; Open SDL window in OpenGL mode. - (SDL:set-video-mode width height 24 flags) - (SDL:set-caption (window-title window)) - ;; Enable texturing and alpha blending - (gl-enable (enable-cap texture-2d)) - (gl-enable (enable-cap blend)) - (set-gl-blend-function (blending-factor-src src-alpha) - (blending-factor-dest one-minus-src-alpha)))) - -(define (close-window) - "Close the currently open window and audio." - (SDL:quit)) - -(define-syntax-rule (with-window window body ...) - (dynamic-wind - (lambda () (open-window window)) - (lambda () body ...) - (lambda () (close-window)))) diff --git a/2d/wrappers/freeimage.scm b/2d/wrappers/freeimage.scm deleted file mode 100644 index 544bf51..0000000 --- a/2d/wrappers/freeimage.scm +++ /dev/null @@ -1,263 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu> -;;; -;;; 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/>. - -;;; Commentary: -;; -;; Quick and dirty wrapper for some freeimage functions. -;; -;;; Code: - -(define-module (2d wrappers freeimage) - #:use-module (system foreign) - #:use-module (2d wrappers util) - #:use-module (ice-9 format)) - -(define libfreeimage (dynamic-link "libfreeimage")) - -(define-syntax-rule (define-foreign name ret string-name args) - (define name - (pointer->procedure ret (dynamic-func string-name libfreeimage) args))) - -(define (number->boolean n) - (not (zero? n))) - -;;; -;;; FreeImage file formats -;;; - -(define-enumeration freeimage-format - (unknown -1) - (bmp 0) - (ico 1) - (jpeg 2) - (jng 3) - (koala 4) - (lbm 5) - (iff 5) - (mng 6) - (pbm 7) - (pbmraw 8) - (pcd 9) - (pcx 10) - (pgm 11) - (pgmraw 12) - (png 13) - (ppm 14) - (ppmraw 15) - (ras 16) - (targa 17) - (tiff 18) - (wbmp 19) - (psd 20) - (cut 21) - (xbm 22) - (xpm 23) - (dds 24) - (gif 25) - (hdr 26) - (faxg3 27) - (sgi 28) - (exr 29) - (j2k 30) - (jp2 31) - (pfm 32) - (pict 33) - (raw 34)) - -(export freeimage-format) - -;;; -;;; General functions -;;; - -(define-foreign %freeimage-get-version - '* "FreeImage_GetVersion" '()) -(define-foreign %freeimage-set-output-message - void "FreeImage_SetOutputMessage" '(*)) - -(define (freeimage-get-version) - (pointer->string (%freeimage-get-version))) - -(define (freeimage-set-output-message callback) - (%freeimage-set-output-message - (procedure->pointer void - (lambda (image-format message) - (callback image-format (pointer->string message))) - (list unsigned-int '*)))) - -;; Set a default output message callback to writes to stdout. -(freeimage-set-output-message - (lambda (image-format message) - (display "freeimage error: ") - (display message) - (newline))) - -(export freeimage-get-version - freeimage-set-output-message) - - -;;; -;;; Bitmap management functions -;;; - -(define-wrapped-pointer-type <freeimage-bitmap> - freeimage-bitmap? - wrap-freeimage-bitmap unwrap-freeimage-bitmap - (lambda (r port) - (let ((bitmap (unwrap-freeimage-bitmap r))) - (format port - "<freeimage-bitmap ~x width: ~d height: ~d bpp: ~d>" - (pointer-address bitmap) - (%freeimage-get-width bitmap) - (%freeimage-get-height bitmap) - (%freeimage-get-bpp bitmap))))) - -(define-foreign %freeimage-load - '* "FreeImage_Load" (list unsigned-int '* unsigned-int)) -(define-foreign %freeimage-unload - void "FreeImage_Unload" '(*)) - -(define (freeimage-load image-format filename) - (wrap-freeimage-bitmap - (%freeimage-load image-format (string->pointer filename) 0))) - -(define (freeimage-unload bitmap) - (%freeimage-unload (unwrap-freeimage-bitmap bitmap))) - -(export <freeimage-bitmap> - freeimage-bitmap? - freeimage-load - freeimage-unload) - -;;; -;;; Bitmap information functions -;;; - -(define-foreign %freeimage-get-image-type - unsigned-int "FreeImage_GetImageType" '(*)) -(define-foreign %freeimage-get-bpp - unsigned-int "FreeImage_GetBPP" '(*)) -(define-foreign %freeimage-get-width - unsigned-int "FreeImage_GetWidth" '(*)) -(define-foreign %freeimage-get-height - unsigned-int "FreeImage_GetHeight" '(*)) -(define-foreign %freeimage-get-pitch - unsigned-int "FreeImage_GetPitch" '(*)) -(define-foreign %freeimage-get-red-mask - unsigned-int "FreeImage_GetRedMask" '(*)) -(define-foreign %freeimage-get-green-mask - unsigned-int "FreeImage_GetGreenMask" '(*)) -(define-foreign %freeimage-get-blue-mask - unsigned-int "FreeImage_GetBlueMask" '(*)) -(define-foreign %freeimage-has-pixels - unsigned-int "FreeImage_HasPixels" '(*)) - -(define (freeimage-get-image-type bitmap) - (%freeimage-get-image-type (unwrap-freeimage-bitmap bitmap))) - -(define (freeimage-get-bpp bitmap) - (%freeimage-get-bpp (unwrap-freeimage-bitmap bitmap))) - -(define (freeimage-get-width bitmap) - (%freeimage-get-width (unwrap-freeimage-bitmap bitmap))) - -(define (freeimage-get-height bitmap) - (%freeimage-get-height (unwrap-freeimage-bitmap bitmap))) - -(define (freeimage-get-pitch bitmap) - (%freeimage-get-pitch (unwrap-freeimage-bitmap bitmap))) - -(define (freeimage-get-red-mask bitmap) - (%freeimage-get-red-mask (unwrap-freeimage-bitmap bitmap))) - -(define (freeimage-get-green-mask bitmap) - (%freeimage-get-green-mask (unwrap-freeimage-bitmap bitmap))) - -(define (freeimage-get-blue-mask bitmap) - (%freeimage-get-blue-mask (unwrap-freeimage-bitmap bitmap))) - -(define (freeimage-has-pixels? bitmap) - (number->boolean - (%freeimage-has-pixels (unwrap-freeimage-bitmap bitmap)))) - -(export freeimage-get-image-type - freeimage-get-bpp - freeimage-get-width - freeimage-get-height - freeimage-get-red-mask - freeimage-get-green-mask - freeimage-get-blue-mask - freeimage-has-pixels?) - -;;; -;;; Filetype functions -;;; - -(define-foreign %freeimage-get-file-type - unsigned-int "FreeImage_GetFileType" (list '* int)) - -(define (freeimage-get-file-type filename) - (%freeimage-get-file-type (string->pointer filename) 0)) - -(export freeimage-get-file-type) - -;;; -;;; Pixel access functions -;;; - -(define-foreign %freeimage-get-bits '* "FreeImage_GetBits" '(*)) - -(define (freeimage-get-bits bitmap) - (pointer->bytevector - (%freeimage-get-bits (unwrap-freeimage-bitmap bitmap)) - (* (freeimage-get-height bitmap) - (freeimage-get-pitch bitmap)))) - -(export freeimage-get-bits) - -;;; -;;; Conversion functions -;;; - -(define-foreign %freeimage-convert-to-24-bits - '* "FreeImage_ConvertTo24Bits" '(*)) -(define-foreign %freeimage-convert-to-32-bits - '* "FreeImage_ConvertTo32Bits" '(*)) - -(define (freeimage-convert-to-24-bits bitmap) - (wrap-freeimage-bitmap - (%freeimage-convert-to-24-bits (unwrap-freeimage-bitmap bitmap)))) - -(define (freeimage-convert-to-32-bits bitmap) - (wrap-freeimage-bitmap - (%freeimage-convert-to-32-bits (unwrap-freeimage-bitmap bitmap)))) - -(export freeimage-convert-to-24-bits - freeimage-convert-to-32-bits) - -;;; -;;; Rotation and flipping -;;; - -(define-foreign %freeimage-flip-vertical - uint8 "FreeImage_FlipVertical" '(*)) - -(define (freeimage-flip-vertical bitmap) - (number->boolean - (%freeimage-flip-vertical (unwrap-freeimage-bitmap bitmap)))) - -(export freeimage-flip-vertical) diff --git a/2d/wrappers/gl.scm b/2d/wrappers/gl.scm deleted file mode 100644 index 3ee84dd..0000000 --- a/2d/wrappers/gl.scm +++ /dev/null @@ -1,96 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu> -;;; -;;; 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/>. - -;;; Commentary: -;; -;; Custom wrappers over low level OpenGL commands that aren't part of -;; guile-opengl. -;; -;;; Code: - -(define-module (2d wrappers gl) - #:use-module ((gl low-level) #:renamer (symbol-prefix-proc '%)) - #:use-module (gl runtime) - #:use-module (gl types)) - -;;; -;;; 3.8.1 Texture Image Specification -;;; - -(re-export (%glTexImage3D . gl-texture-image-3d) - (%glTexImage2D . gl-texture-image-2d) - (%glTexImage1D . gl-texture-image-1d)) - -;;; -;;; 3.8.2 Alternate Texture Image Specification Commands -;;; - -(re-export (%glCopyTexImage2D . gl-copy-texture-image-2d) - (%glCopyTexImage1D . gl-copy-texture-image-1d) - (%glCopyTexSubImage3D . gl-copy-texture-sub-image-3d) - (%glCopyTexSubImage2D . gl-copy-texture-sub-image-2d) - (%glCopyTexSubImage1D . gl-copy-texture-sub-image-1d) - (%glTexSubImage3D . gl-texture-sub-image-3d) - (%glTexSubImage2D . gl-texture-sub-image-2d) - (%glTexSubImage1D . gl-texture-sub-image-1d)) - -;;; -;;; 3.8.3 Compressed Texture Images -;;; - -(re-export (%glCompressedTexImage1D . gl-compressed-texture-image-1d) - (%glCompressedTexImage2D . gl-compressed-texture-image-2d) - (%glCompressedTexImage3D . gl-compressed-texture-image-3d) - (%glCompressedTexSubImage1D . gl-compressed-texture-sub-image-1d) - (%glCompressedTexSubImage2D . gl-compressed-texture-sub-image-2d) - (%glCompressedTexSubImage3D . gl-compressed-texture-sub-image-3d)) - -;;; -;;; 3.8.4 Texture Parameters -;;; - -(re-export (%glTexParameteri . gl-texture-parameter)) - -;; emacs: (put 'with-gl-bind-texture 'scheme-indent-function 2) -(define-syntax-rule (with-gl-bind-texture target id body ...) - (begin - (%glBindTexture target id) - body - ... - (%glBindTexture target 0))) - -(export with-gl-bind-texture) - -;;; -;;; Instancing extension -;;; - -(define-gl-procedure (glDrawArraysInstanced (mode GLenum) - (first GLint) - (count GLsizei) - (primcount GLsizei) - -> GLboolean) - "Draw multiple instances of a set of arrays.") - -(define-gl-procedure (glVertexAttribDivisor (index GLuint) - (divisor GLuint) - -> void) - "Modify the rate at which generic vertex attributes advance during -instanced rendering.") - -(export glDrawArraysInstanced - glVertexAttribDivisor) diff --git a/2d/wrappers/util.scm b/2d/wrappers/util.scm deleted file mode 100644 index 254dc3a..0000000 --- a/2d/wrappers/util.scm +++ /dev/null @@ -1,40 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu> -;;; -;;; 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/>. - -;;; Commentary: -;; -;; Wrapper helper procedures. -;; -;;; Code: - -(define-module (2d wrappers util) - #:export (define-enumeration)) - -;; Borrowed from guile-opengl -(define-syntax-rule (define-enumeration enumerator (name value) ...) - (define-syntax enumerator - (lambda (x) - (syntax-case x () - ((_) - #''(name ...)) - ((_ enum) (number? (syntax->datum #'enum)) - #'enum) - ((_ enum) - (or (assq-ref '((name . value) ...) - (syntax->datum #'enum)) - (syntax-violation 'enumerator "invalid enumerated value" - #'enum))))))) |