summaryrefslogtreecommitdiff
path: root/2d
diff options
context:
space:
mode:
authorDavid Thompson <dthompson2@worcester.edu>2014-06-28 18:46:16 -0400
committerDavid Thompson <dthompson2@worcester.edu>2014-06-28 18:46:16 -0400
commitf47eb69a354188154731846dde8b384c2c2f39f6 (patch)
tree6aa1ccb9212836b7c941e771475eb995fa6df9f9 /2d
parentdf0f2a5f3f09394f1953abbc7e33e9a98204680e (diff)
Rename guile-2d to Sly!
Massive find/replace job.
Diffstat (limited to '2d')
-rw-r--r--2d/agenda.scm206
-rw-r--r--2d/animation.scm119
-rw-r--r--2d/audio.scm128
-rw-r--r--2d/color.scm203
-rw-r--r--2d/config.scm.in28
-rw-r--r--2d/coroutine.scm82
-rw-r--r--2d/event.scm45
-rw-r--r--2d/font.scm156
-rw-r--r--2d/fps.scm47
-rw-r--r--2d/game.scm109
-rw-r--r--2d/helpers.scm68
-rw-r--r--2d/keyboard.scm88
-rw-r--r--2d/live-reload.scm54
-rw-r--r--2d/math.scm90
-rw-r--r--2d/mouse.scm99
-rw-r--r--2d/rect.scm212
-rw-r--r--2d/repl.scm37
-rw-r--r--2d/shader.scm331
-rw-r--r--2d/signal.scm292
-rw-r--r--2d/sprite.scm188
-rw-r--r--2d/texture.scm224
-rw-r--r--2d/tileset.scm89
-rw-r--r--2d/transform.scm233
-rw-r--r--2d/vector.scm157
-rw-r--r--2d/window.scm118
-rw-r--r--2d/wrappers/freeimage.scm263
-rw-r--r--2d/wrappers/gl.scm96
-rw-r--r--2d/wrappers/util.scm40
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)))))))