├── .gitignore ├── 2d ├── actions.scm ├── agenda.scm ├── animation.scm ├── audio.scm ├── color.scm ├── coroutine.scm ├── font.scm ├── game.scm ├── helpers.scm ├── math.scm ├── mvars.scm ├── observer.scm ├── rect.scm ├── repl │ ├── repl.scm │ └── server.scm ├── scene.scm ├── sprite.scm ├── stage.scm ├── texture.scm ├── tileset.scm ├── vector2.scm ├── window.scm └── wrappers │ ├── freeimage.scm │ ├── ftgl.scm │ ├── gl.scm │ └── util.scm ├── COPYING ├── INSTALL.org ├── Makefile.am ├── README.org ├── TODO.org ├── autogen.sh ├── configure.ac ├── doc ├── Makefile.am ├── audio.texi ├── fdl.texi ├── game.texi ├── graphics.texi ├── graphics │ ├── animation.texi │ ├── color.texi │ ├── font.texi │ ├── sprite.texi │ ├── texture.texi │ └── tileset.texi ├── guile-2d.texi ├── introduction.texi ├── math.texi ├── math │ ├── math.texi │ ├── rect.texi │ └── vector2.texi ├── scripting.texi └── scripting │ ├── actions.texi │ ├── agenda.texi │ └── coroutine.texi ├── env.in ├── examples ├── action.scm ├── animation.scm ├── coroutine.scm ├── font.scm ├── fonts │ ├── AUTHORS │ └── Boxy-Bold.ttf ├── images │ ├── AUTHORS │ ├── bullet.png │ ├── ghost.png │ ├── princess.png │ ├── stars.png │ └── tiles.png ├── particles.scm ├── scenes.scm ├── simple.scm └── tilemap.scm └── guile.am /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | .#* 3 | *.go 4 | autom4te.cache/ 5 | build-aux/ 6 | Makefile 7 | Makefile.in 8 | /configure 9 | /env 10 | /config.status 11 | /config.log 12 | /aclocal.m4 13 | /doc/guile-2d.aux 14 | /doc/guile-2d.cp 15 | /doc/guile-2d.fn 16 | /doc/guile-2d.fns 17 | /doc/guile-2d.info 18 | /doc/guile-2d.ky 19 | /doc/guile-2d.log 20 | /doc/guile-2d.pdf 21 | /doc/guile-2d.pg 22 | /doc/guile-2d.toc 23 | /doc/guile-2d.tp 24 | /doc/guile-2d.vr 25 | /doc/guile-2d.vrs 26 | -------------------------------------------------------------------------------- /2d/actions.scm: -------------------------------------------------------------------------------- 1 | ;;; guile-2d 2 | ;;; Copyright (C) 2013 David Thompson 3 | ;;; 4 | ;;; Guile-2d is free software: you can redistribute it and/or modify it 5 | ;;; under the terms of the GNU Lesser General Public License as 6 | ;;; published by the Free Software Foundation, either version 3 of the 7 | ;;; License, or (at your option) any later version. 8 | ;;; 9 | ;;; Guile-2d is distributed in the hope that it will be useful, but 10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | ;;; Lesser General Public License for more details. 13 | ;;; 14 | ;;; You should have received a copy of the GNU Lesser General Public 15 | ;;; License along with this program. If not, see 16 | ;;; . 17 | 18 | ;;; Commentary: 19 | ;; 20 | ;; Actions are composable procedures that perform an operation over a 21 | ;; period of game time. 22 | ;; 23 | ;;; Code: 24 | 25 | (define-module (2d actions) 26 | #:use-module (srfi srfi-9) 27 | #:use-module (srfi srfi-1) 28 | #:use-module (2d agenda) 29 | #:use-module (2d coroutine) 30 | #:export ( 31 | make-action 32 | action? 33 | null-action 34 | null-action? 35 | action-duration 36 | action-proc 37 | perform-action 38 | schedule-action 39 | action-cons 40 | action-list 41 | action-parallel 42 | action-repeat 43 | idle 44 | lerp)) 45 | 46 | ;;; 47 | ;;; Action Procedures 48 | ;;; 49 | 50 | ;; Actions encapsulate a procedure that performs an action and the 51 | ;; duration of the action in game ticks. 52 | (define-record-type 53 | (%make-action proc duration) 54 | action? 55 | (duration action-duration) 56 | (proc action-proc)) 57 | 58 | (define (make-action proc duration) 59 | "Create a new action object that takes DURATION updates to 60 | complete. PROC is a procedure that takes a value in the range [0, 1] 61 | as its only argument. An error is thrown if DURATION is 0." 62 | (if (zero? duration) 63 | (throw 'action-duration-zero) 64 | (%make-action proc duration))) 65 | 66 | (define (step-action action t) 67 | "Apply ACTION procedure to the time delta, T." 68 | ((action-proc action) t)) 69 | 70 | (define (perform-action action) 71 | "Execute ACTION. `perform-action` must be called from within a 72 | coroutine, as it yields back to the agenda after each step." 73 | (let ((duration (action-duration action))) 74 | (define (step time) 75 | (if (= duration time) 76 | (step-action action 1) 77 | (begin 78 | (step-action action (/ time duration)) 79 | (wait) 80 | (step (1+ time))))) 81 | (step 1))) 82 | 83 | (define (schedule-action action) 84 | "Schedules a coroutine in the current agenda that will perform 85 | ACTION on the next update." 86 | (agenda-schedule (colambda () (perform-action action)))) 87 | 88 | (define (action-cons a1 a2) 89 | "Return an action that performs A1 first, followed by A2." 90 | (define (real-cons) 91 | (let* ((duration (+ (action-duration a1) (action-duration a2))) 92 | (t1 (/ (action-duration a1) duration)) 93 | (t2 (/ (action-duration a2) duration))) 94 | (make-action 95 | (lambda (t) 96 | (if (> t t1) 97 | (step-action a2 (/ (- t t1) t2)) 98 | (step-action a1 (/ t t1)))) 99 | duration))) 100 | ;; a2 can be #f, if this is the last action-cons of an action-list. 101 | (if a2 (real-cons) a1)) 102 | 103 | (define (action-list . actions) 104 | "Return an action that performs every action in the list ACTIONS." 105 | (if (null? actions) 106 | #f 107 | (action-cons (car actions) (apply action-list (cdr actions))))) 108 | 109 | (define (action-parallel . actions) 110 | "Perform every action in the list ACTIONS in parallel." 111 | (let ((max-duration (reduce max 0 (map action-duration actions)))) 112 | ;; Add idle action to each action to fill the time 113 | ;; difference between the action's duration and the 114 | ;; max action duration. 115 | (define (fill-action action) 116 | (if (= (action-duration action) max-duration) 117 | action 118 | (action-cons action (idle (- max-duration (action-duration action)))))) 119 | 120 | (let ((filled-actions (map fill-action actions))) 121 | (make-action 122 | (lambda (t) 123 | (for-each (lambda (a) (step-action a t)) filled-actions)) 124 | max-duration)))) 125 | 126 | (define (action-repeat n action) 127 | "Return an action that will perform ACTION N times." 128 | (apply action-list (make-list n action))) 129 | 130 | ;;; 131 | ;;; Simple Actions 132 | ;;; 133 | 134 | (define (idle duration) 135 | "Return an action that does nothing." 136 | (make-action (lambda (t) #t) duration)) 137 | 138 | (define (lerp proc start end duration) 139 | "Linearly interpolate a number from START to END that takes DURATION 140 | updates. Apply PROC to the linearly interpolated at each step." 141 | (let ((delta (- end start))) 142 | (make-action 143 | (lambda (t) 144 | (if (= t 1) 145 | (proc end) 146 | (proc (+ start (* delta t))))) 147 | duration))) 148 | -------------------------------------------------------------------------------- /2d/agenda.scm: -------------------------------------------------------------------------------- 1 | ;;; guile-2d 2 | ;;; Copyright (C) 2013 David Thompson 3 | ;;; 4 | ;;; Guile-2d is free software: you can redistribute it and/or modify it 5 | ;;; under the terms of the GNU Lesser General Public License as 6 | ;;; published by the Free Software Foundation, either version 3 of the 7 | ;;; License, or (at your option) any later version. 8 | ;;; 9 | ;;; Guile-2d is distributed in the hope that it will be useful, but 10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | ;;; Lesser General Public License for more details. 13 | ;;; 14 | ;;; You should have received a copy of the GNU Lesser General Public 15 | ;;; License along with this program. If not, see 16 | ;;; . 17 | 18 | ;;; Commentary: 19 | ;; 20 | ;; Deferred procedure scheduling. 21 | ;; 22 | ;;; Code: 23 | 24 | (define-module (2d agenda) 25 | #:use-module (ice-9 q) 26 | #:use-module (srfi srfi-1) 27 | #:use-module (srfi srfi-9) 28 | #:use-module (2d coroutine) 29 | #:export (make-agenda 30 | with-agenda 31 | agenda-schedule 32 | agenda-schedule-interval 33 | update-agenda 34 | clear-agenda 35 | wait)) 36 | 37 | ;; This code is a modified version of the agenda implementation in 38 | ;; SICP. Thank you, SICP! 39 | 40 | ;;; 41 | ;;; Time segment 42 | ;;; 43 | 44 | (define-record-type 45 | (%make-time-segment time queue) 46 | time-segment? 47 | (time segment-time) 48 | (queue segment-queue)) 49 | 50 | (define (make-time-segment time . callbacks) 51 | "Create a new time segment at TIME and enqueus everything in the 52 | list CALLBACKS." 53 | (let ((segment (%make-time-segment time (make-q)))) 54 | ;; Enqueue all callbacks 55 | (for-each (lambda (c) (segment-enq segment c)) callbacks) 56 | segment)) 57 | 58 | (define (segment-enq segment callback) 59 | "Add the CALLBACK procedure to SEGMENT's queue." 60 | (enq! (segment-queue segment) callback)) 61 | 62 | ;;; 63 | ;;; Agenda 64 | ;;; 65 | 66 | (define-record-type 67 | (%make-agenda time segments) 68 | agenda? 69 | (time agenda-time set-agenda-time!) 70 | (segments agenda-segments set-agenda-segments!)) 71 | 72 | (define (make-agenda) 73 | "Create a new, empty agenda." 74 | (%make-agenda 0 '())) 75 | 76 | ;; The global agenda that will be used when schedule is called outside 77 | ;; of a with-agenda form. 78 | (define global-agenda (make-agenda)) 79 | 80 | (define *current-agenda* global-agenda) 81 | 82 | ;; emacs: (put 'with-agenda 'scheme-indent-function 1) 83 | (define-syntax-rule (with-agenda agenda body ...) 84 | (begin 85 | (set! *current-agenda* agenda) 86 | body 87 | ... 88 | (set! *current-agenda* global-agenda))) 89 | 90 | (define (agenda-empty? agenda) 91 | "Return #t if AGENDA has no scheduled procedures." 92 | (null? (agenda-segments agenda))) 93 | 94 | (define (first-segment agenda) 95 | "Return the first time segment in AGENDA." 96 | (car (agenda-segments agenda))) 97 | 98 | (define (rest-segments agenda) 99 | "Return everything but the first segment in AGENDA." 100 | (cdr (agenda-segments agenda))) 101 | 102 | (define (agenda-add-segment agenda time callback) 103 | "Add a new time segment to the beginning of AGENDA at the given TIME 104 | and enqueue CALLBACK." 105 | (set-agenda-segments! agenda 106 | (cons (make-time-segment time callback) 107 | (agenda-segments agenda)))) 108 | 109 | (define (insert-segment segments time callback) 110 | "Insert a new time segment after the first segment in SEGMENTS." 111 | (set-cdr! segments 112 | (cons (make-time-segment time callback) 113 | (cdr segments)))) 114 | 115 | (define (first-agenda-item agenda) 116 | "Return the first time segment queue in AGENDA." 117 | (if (agenda-empty? agenda) 118 | (error "Agenda is empty") 119 | (segment-queue (first-segment agenda)))) 120 | 121 | (define (agenda-time-delay agenda dt) 122 | "Return the sum of the time delta, DT, and the current time of AGENDA." 123 | (+ (agenda-time agenda) (inexact->exact (round dt)))) 124 | 125 | (define (%agenda-schedule agenda callback dt) 126 | "Schedule the procedure CALLBACK in AGENDA to be run DT updates from now." 127 | (let ((time (agenda-time-delay agenda dt))) 128 | (define (belongs-before? segments) 129 | (or (null? segments) 130 | (< time (segment-time (car segments))))) 131 | 132 | (define (add-to-segments segments) 133 | ;; Add to existing time segment if the times match 134 | (if (= (segment-time (car segments)) time) 135 | (segment-enq (car segments) callback) 136 | ;; Continue searching 137 | (if (belongs-before? (cdr segments)) 138 | ;; Create new time segment and insert it where it belongs 139 | (insert-segment segments time callback) 140 | ;; Continue searching 141 | (add-to-segments (cdr segments))))) 142 | 143 | ;; Handle the case of inserting a new time segment at the 144 | ;; beginning of the segment list. 145 | (if (belongs-before? (agenda-segments agenda)) 146 | ;; Add segment if it belongs at the beginning of the list... 147 | (agenda-add-segment agenda time callback) 148 | ;; ... Otherwise, search for the right place 149 | (add-to-segments (agenda-segments agenda))))) 150 | 151 | (define (flush-queue! q) 152 | "Dequeue and execute every member of Q." 153 | (unless (q-empty? q) 154 | ((deq! q)) ;; Execute scheduled procedure 155 | (flush-queue! q))) 156 | 157 | (define (%update-agenda agenda) 158 | "Move AGENDA forward in time and run scheduled procedures." 159 | (set-agenda-time! agenda (1+ (agenda-time agenda))) 160 | (let next-segment () 161 | (unless (agenda-empty? agenda) 162 | (let ((segment (first-segment agenda))) 163 | ;; Process time segment if it is scheduled before or at the 164 | ;; current agenda time. 165 | (when (>= (agenda-time agenda) (segment-time segment)) 166 | (flush-queue! (segment-queue segment)) 167 | (set-agenda-segments! agenda (rest-segments agenda)) 168 | (next-segment)))))) 169 | 170 | (define (%clear-agenda agenda) 171 | "Remove all scheduled procedures from AGENDA." 172 | (set-agenda-segments! agenda '())) 173 | 174 | (define* (agenda-schedule thunk #:optional (delay 1)) 175 | "Schedule THUNK in the current agenda to run after DELAY updates (1 176 | by default)." 177 | (%agenda-schedule *current-agenda* thunk delay)) 178 | 179 | (define* (agenda-schedule-interval thunk #:optional (interval 1) (delay 1)) 180 | "Schedule THUNK in the current agenda to run after DELAY updates and 181 | run every INTERVAL updates thereafter. Both DELAY and INTERVAL default 182 | to 1. Simply pass THUNK and nothing else to schedule THUNK to be run 183 | upon every update." 184 | (%agenda-schedule *current-agenda* 185 | (lambda () 186 | (thunk) 187 | (agenda-schedule-interval thunk interval interval)) 188 | delay)) 189 | 190 | (define (update-agenda) 191 | "Update the current agenda." 192 | (%update-agenda *current-agenda*)) 193 | 194 | (define (clear-agenda) 195 | "Clear the current agenda." 196 | (%clear-agenda *current-agenda*)) 197 | 198 | (define* (wait #:optional (delay 1)) 199 | "Yield coroutine and schdule the continuation to be run after DELAY 200 | ticks." 201 | (yield (lambda (resume) (agenda-schedule resume delay)))) 202 | -------------------------------------------------------------------------------- /2d/animation.scm: -------------------------------------------------------------------------------- 1 | ;;; guile-2d 2 | ;;; Copyright (C) 2013 David Thompson 3 | ;;; 4 | ;;; Guile-2d is free software: you can redistribute it and/or modify it 5 | ;;; under the terms of the GNU Lesser General Public License as 6 | ;;; published by the Free Software Foundation, either version 3 of the 7 | ;;; License, or (at your option) any later version. 8 | ;;; 9 | ;;; Guile-2d is distributed in the hope that it will be useful, but 10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | ;;; Lesser General Public License for more details. 13 | ;;; 14 | ;;; You should have received a copy of the GNU Lesser General Public 15 | ;;; License along with this program. If not, see 16 | ;;; . 17 | 18 | ;;; Commentary: 19 | ;; 20 | ;; Animations represent a sequence of textures and/or texture regions. 21 | ;; 22 | ;;; Code: 23 | 24 | (define-module (2d animation) 25 | #:use-module (srfi srfi-9) 26 | #:use-module (2d texture)) 27 | 28 | ;;; 29 | ;;; Animations 30 | ;;; 31 | 32 | ;; The type represents a vector of textures or texture 33 | ;; regions that are to be played in sequence and possibly looped. 34 | (define-record-type 35 | (make-animation frames frame-duration loop) 36 | animation? 37 | (frames animation-frames) 38 | (frame-duration animation-frame-duration) 39 | (loop animation-loop?)) 40 | 41 | (define (animation-frame animation index) 42 | "Return the texture for the given frame INDEX of ANIMATION." 43 | (vector-ref (animation-frames animation) index)) 44 | 45 | (define (animation-length animation) 46 | "Return the number of frames in ANIMATION." 47 | (vector-length (animation-frames animation))) 48 | 49 | (define (animation-duration animation) 50 | "Return the total duration of ANIMATION in ticks." 51 | (* (animation-length animation) 52 | (animation-frame-duration animation))) 53 | 54 | (export make-animation 55 | animation? 56 | animation-frames 57 | animation-frame-duration 58 | animation-loop? 59 | animation-frame 60 | animation-length 61 | animation-duration) 62 | 63 | ;; The type encapsulates the state for playing an 64 | ;; animation. 65 | (define-record-type 66 | (%make-animator animation frame time playing) 67 | animator? 68 | (animation animator-animation) 69 | (frame animator-frame set-animator-frame!) 70 | (time animator-time set-animator-time!) 71 | (playing animator-playing? set-animator-playing!)) 72 | 73 | (define (make-animator animation) 74 | "Create a new animator for ANIMATION." 75 | (%make-animator animation 0 0 #t)) 76 | 77 | (define (animator-frame-complete? animator) 78 | "Return #t when ANIMATOR is done displaying the current frame." 79 | (>= (animator-time animator) 80 | (animation-frame-duration (animator-animation animator)))) 81 | 82 | (define (animator-next-frame animator) 83 | "Return the next frame index for ANIMATOR." 84 | (modulo (1+ (animator-frame animator)) 85 | (animation-length (animator-animation animator)))) 86 | 87 | (define (animator-texture animator) 88 | "Return a texture for the ANIMATOR's current frame." 89 | (animation-frame (animator-animation animator) 90 | (animator-frame animator))) 91 | 92 | (define (animator-next! animator) 93 | "Advance ANIMATOR to the next frame of its animation." 94 | (let ((next-frame (animator-next-frame animator)) 95 | (animation (animator-animation animator))) 96 | (set-animator-time! animator 0) 97 | (set-animator-frame! animator next-frame) 98 | (set-animator-playing! animator (or (not (zero? next-frame)) 99 | (animation-loop? animation))))) 100 | 101 | (define (animator-update! animator) 102 | "Increment the frame time for the ANIMATOR and advance to the next 103 | frame when necessary." 104 | (when (animator-playing? animator) 105 | (set-animator-time! animator (1+ (animator-time animator))) 106 | (when (animator-frame-complete? animator) 107 | (animator-next! animator)))) 108 | 109 | (export make-animator 110 | animator? 111 | animator-animation 112 | animator-frame 113 | animator-time 114 | animator-frame-complete? 115 | animator-playing? 116 | animator-next-frame 117 | animator-texture 118 | animator-next! 119 | animator-update!) 120 | -------------------------------------------------------------------------------- /2d/audio.scm: -------------------------------------------------------------------------------- 1 | ;;; guile-2d 2 | ;;; Copyright (C) 2013 David Thompson 3 | ;;; 4 | ;;; Guile-2d is free software: you can redistribute it and/or modify it 5 | ;;; under the terms of the GNU Lesser General Public License as 6 | ;;; published by the Free Software Foundation, either version 3 of the 7 | ;;; License, or (at your option) any later version. 8 | ;;; 9 | ;;; Guile-2d is distributed in the hope that it will be useful, but 10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | ;;; Lesser General Public License for more details. 13 | ;;; 14 | ;;; You should have received a copy of the GNU Lesser General Public 15 | ;;; License along with this program. If not, see 16 | ;;; . 17 | 18 | ;;; Commentary: 19 | ;; 20 | ;; Wrappers over SDL mixer. 21 | ;; 22 | ;;; Code: 23 | 24 | (define-module (2d audio) 25 | #:use-module (srfi srfi-9) 26 | #:use-module (srfi srfi-2) 27 | #:use-module ((sdl mixer) #:prefix SDL:)) 28 | 29 | ;; Wrapper over SDL audio objects. 30 | (define-record-type 31 | (make-sample audio) 32 | sample? 33 | (audio sample-audio)) 34 | 35 | (define (load-sample filename) 36 | "Load audio sample from FILENAME. Return #f on failure." 37 | (let ((audio (SDL:load-wave filename))) 38 | (if audio 39 | (make-sample audio) 40 | #f))) 41 | 42 | (define (sample-play sample) 43 | "Play audio SAMPLE." 44 | (SDL:play-channel (sample-audio sample))) 45 | 46 | (define (sample-volume) 47 | "Return volume that samples are played at." 48 | (SDL:volume)) 49 | 50 | (define (set-sample-volume volume) 51 | "Set the volume that samples are played at to VOLUME." 52 | (SDL:volume volume)) 53 | 54 | (export make-sample 55 | load-sample 56 | sample? 57 | sample-audio 58 | sample-play 59 | sample-volume 60 | set-sample-volume) 61 | 62 | ;; Wrapper over SDL music objects. 63 | (define-record-type 64 | (make-music audio) 65 | music? 66 | (audio music-audio)) 67 | 68 | (define (load-music filename) 69 | "Load music from FILENAME. Return #f on failure." 70 | (let ((audio (SDL:load-music filename))) 71 | (if audio 72 | (make-music audio) 73 | #f))) 74 | 75 | (define (music-play music) 76 | "Play MUSIC." 77 | (SDL:play-music (music-audio music))) 78 | 79 | (define (music-volume) 80 | "Return the volume that music is played at." 81 | (SDL:music-volume)) 82 | 83 | (define (set-music-volume volume) 84 | "Set the volume that music is played at." 85 | (SDL:volume volume)) 86 | 87 | (export make-music 88 | load-music 89 | music? 90 | music-audio 91 | music-play 92 | music-volume 93 | set-music-volume) 94 | 95 | (re-export (SDL:pause-music . music-pause) 96 | (SDL:resume-music . music-resume) 97 | (SDL:rewind-music . music-rewind) 98 | (SDL:halt-music . music-stop) 99 | (SDL:paused-music? . music-paused?) 100 | (SDL:playing-music? . music-playing?)) 101 | -------------------------------------------------------------------------------- /2d/color.scm: -------------------------------------------------------------------------------- 1 | ;;; guile-2d 2 | ;;; Copyright (C) 2013 David Thompson 3 | ;;; 4 | ;;; Guile-2d is free software: you can redistribute it and/or modify it 5 | ;;; under the terms of the GNU Lesser General Public License as 6 | ;;; published by the Free Software Foundation, either version 3 of the 7 | ;;; License, or (at your option) any later version. 8 | ;;; 9 | ;;; Guile-2d is distributed in the hope that it will be useful, but 10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | ;;; Lesser General Public License for more details. 13 | ;;; 14 | ;;; You should have received a copy of the GNU Lesser General Public 15 | ;;; License along with this program. If not, see 16 | ;;; . 17 | 18 | ;;; Commentary: 19 | ;; 20 | ;; Color. 21 | ;; 22 | ;;; Code: 23 | 24 | (define-module (2d color) 25 | #:use-module (figl gl) 26 | #:use-module (srfi srfi-9) 27 | #:use-module (srfi srfi-1) 28 | #:export ( 29 | make-color 30 | color? 31 | color-r 32 | color-g 33 | color-b 34 | color-a 35 | use-color 36 | rgba 37 | rgb 38 | white 39 | black 40 | red 41 | green 42 | blue 43 | magenta)) 44 | 45 | (define-record-type 46 | (make-color r g b a) 47 | color? 48 | (r color-r) 49 | (g color-g) 50 | (b color-b) 51 | (a color-a)) 52 | 53 | (define (use-color color) 54 | "Set the current OpenGL color state to the contents of COLOR." 55 | (gl-color (color-r color) 56 | (color-g color) 57 | (color-b color) 58 | (color-a color))) 59 | 60 | (define (color-component color-code offset) 61 | "Return the value of an 8-bit color channel in the range [0,1] for 62 | the integer COLOR-CODE, given an OFFSET in bits." 63 | (let ((mask (ash #xff offset))) 64 | (/ (ash (logand mask color-code) 65 | (- offset)) 66 | 255.0))) 67 | 68 | (define (rgba color-code) 69 | "Translate an RGBA format string COLOR-CODE into a color object. 70 | For example: #xffffffff will return a color with RGBA values 1, 1, 1, 71 | 1." 72 | (make-color (color-component color-code 24) 73 | (color-component color-code 16) 74 | (color-component color-code 8) 75 | (color-component color-code 0))) 76 | 77 | (define (rgb color-code) 78 | "Translate an RGB format string COLOR-CODE into a color object. 79 | For example: #xffffff will return a color with RGBA values 1, 1, 1, 80 | 1." 81 | (make-color (color-component color-code 16) 82 | (color-component color-code 8) 83 | (color-component color-code 0) 84 | 1)) 85 | 86 | ;; Pre-defined colors. 87 | (define white (rgb #xffffff)) 88 | (define black (rgb #x000000)) 89 | (define red (rgb #xff0000)) 90 | (define green (rgb #x00ff00)) 91 | (define blue (rgb #x0000ff)) 92 | (define magenta (rgb #xff00ff)) 93 | -------------------------------------------------------------------------------- /2d/coroutine.scm: -------------------------------------------------------------------------------- 1 | ;;; guile-2d 2 | ;;; Copyright (C) 2013 David Thompson 3 | ;;; 4 | ;;; Guile-2d is free software: you can redistribute it and/or modify it 5 | ;;; under the terms of the GNU Lesser General Public License as 6 | ;;; published by the Free Software Foundation, either version 3 of the 7 | ;;; License, or (at your option) any later version. 8 | ;;; 9 | ;;; Guile-2d is distributed in the hope that it will be useful, but 10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | ;;; Lesser General Public License for more details. 13 | ;;; 14 | ;;; You should have received a copy of the GNU Lesser General Public 15 | ;;; License along with this program. If not, see 16 | ;;; . 17 | 18 | ;;; Commentary: 19 | ;; 20 | ;; Cooperative multi-tasking. 21 | ;; 22 | ;;; Code: 23 | 24 | (define-module (2d coroutine) 25 | #:export (coroutine 26 | colambda 27 | codefine 28 | codefine*) 29 | #:replace (yield)) 30 | 31 | (define (coroutine thunk) 32 | "Calls a procedure that can yield a continuation." 33 | (define (handler cont callback . args) 34 | (define (resume . args) 35 | ;; Call continuation that resumes the procedure. 36 | (call-with-prompt 'coroutine-prompt 37 | (lambda () (apply cont args)) 38 | handler)) 39 | (when (procedure? callback) 40 | (apply callback resume args))) 41 | 42 | ;; Call procedure. 43 | (call-with-prompt 'coroutine-prompt thunk handler)) 44 | 45 | ;; emacs: (put 'colambda 'scheme-indent-function 1) 46 | (define-syntax-rule (colambda args body ...) 47 | "Syntacic sugar for a lambda that is run as a coroutine." 48 | (lambda args 49 | (coroutine 50 | (lambda () body ...)))) 51 | 52 | ;; emacs: (put 'codefine 'scheme-indent-function 1) 53 | (define-syntax-rule (codefine (name ...) . body) 54 | "Syntactic sugar for defining a procedure that is run as a 55 | coroutine." 56 | (define (name ...) 57 | ;; Create an inner procedure with the same signature so that a 58 | ;; recursive procedure call does not create a new prompt. 59 | (define (name ...) . body) 60 | (coroutine 61 | (lambda () (name ...))))) 62 | 63 | ;; emacs: (put 'codefine* 'scheme-indent-function 1) 64 | (define-syntax-rule (codefine* (name . formals) . body) 65 | "Syntactic sugar for defining a procedure that is run as a 66 | coroutine." 67 | (define (name . args) 68 | ;; Create an inner procedure with the same signature so that a 69 | ;; recursive procedure call does not create a new prompt. 70 | (define* (name . formals) . body) 71 | (coroutine 72 | (lambda () (apply name args))))) 73 | 74 | (define (yield callback) 75 | "Yield continuation to a CALLBACK procedure." 76 | (abort-to-prompt 'coroutine-prompt callback)) 77 | -------------------------------------------------------------------------------- /2d/font.scm: -------------------------------------------------------------------------------- 1 | ;;; guile-2d 2 | ;;; Copyright (C) 2013 David Thompson 3 | ;;; 4 | ;;; Guile-2d is free software: you can redistribute it and/or modify it 5 | ;;; under the terms of the GNU Lesser General Public License as 6 | ;;; published by the Free Software Foundation, either version 3 of the 7 | ;;; License, or (at your option) any later version. 8 | ;;; 9 | ;;; Guile-2d is distributed in the hope that it will be useful, but 10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | ;;; Lesser General Public License for more details. 13 | ;;; 14 | ;;; You should have received a copy of the GNU Lesser General Public 15 | ;;; License along with this program. If not, see 16 | ;;; . 17 | 18 | ;;; Commentary: 19 | ;; 20 | ;; Font rendering. 21 | ;; 22 | ;;; Code: 23 | 24 | (define-module (2d font) 25 | #:use-module (figl gl) 26 | #:use-module (srfi srfi-9) 27 | #:use-module (system foreign) 28 | #:use-module (2d wrappers ftgl) 29 | #:use-module (2d color) 30 | #:use-module (2d vector2)) 31 | 32 | ;;; 33 | ;;; Font 34 | ;;; 35 | 36 | ;; Font objects represent an FTGL texture font at a given size. 37 | (define-record-type 38 | (make-font ftgl-font size) 39 | font? 40 | (ftgl-font font-ftgl-font) 41 | (size font-size)) 42 | 43 | (define (load-font filename size) 44 | "Load a font from FILENAME with the given SIZE in points." 45 | (let ((ftgl-font (ftgl-create-texture-font filename))) 46 | ;; Hardcoded 72 dpi for now. 47 | (ftgl-set-font-face-size ftgl-font size 72) 48 | (make-font ftgl-font size))) 49 | 50 | (define (flip-text font) 51 | "Flip current GL matrix about the x-axis and translates by the 52 | negative font ascender value. This is necessary before rendering text 53 | because guile-2d flips the y-axis so that the origin is in the 54 | upper-left corner rather than the bottom-left." 55 | (gl-scale 1 -1 1) 56 | (gl-translate 0 (- (ftgl-get-font-ascender (font-ftgl-font font))) 0)) 57 | 58 | (define (draw-font font text) 59 | "Renders the string text using the given font." 60 | (with-gl-push-matrix 61 | (flip-text font) 62 | (ftgl-render-font (font-ftgl-font font) 63 | text 64 | (ftgl-render-mode all)))) 65 | 66 | (export 67 | make-font 68 | font? 69 | font-ftgl-font 70 | font-size 71 | load-font 72 | draw-font) 73 | 74 | ;;; 75 | ;;; Textbox 76 | ;;; 77 | 78 | ;; A textbox is a string of word-wrapped text 79 | (define-record-type 80 | (%make-textbox font text position color alignment line-length layout) 81 | textbox? 82 | (font textbox-font) 83 | (text textbox-text set-textbox-text!) 84 | (position textbox-position set-textbox-position!) 85 | (color textbox-color set-textbox-color!) 86 | (alignment textbox-alignment) 87 | (line-length textbox-line-length) 88 | (layout textbox-layout)) 89 | 90 | (define (make-textbox font text position color alignment line-length) 91 | "Create a textbox that will draw TEXT with the given FONT, at vector 92 | POSITION, with ALIGNMENT, and a maximum LINE-LENGTH." 93 | (let ((layout (ftgl-create-layout))) 94 | (ftgl-set-layout-font layout (font-ftgl-font font)) 95 | ;; (ftgl-set-layout-alignment layout (ftgl-text-alignment alignment)) 96 | (ftgl-set-layout-line-length layout line-length) 97 | (%make-textbox font text position color alignment line-length layout))) 98 | 99 | (define (draw-textbox textbox) 100 | "Draw TEXTBOX." 101 | (with-gl-push-matrix 102 | (vector2-translate (textbox-position textbox)) 103 | (flip-text (textbox-font textbox)) 104 | (use-color (textbox-color textbox)) 105 | (ftgl-render-layout (textbox-layout textbox) 106 | (textbox-text textbox) 107 | (ftgl-render-mode all)))) 108 | 109 | (export 110 | make-textbox 111 | textbox? 112 | textbox-font 113 | textbox-text 114 | set-textbox-text! 115 | textbox-position 116 | set-textbox-position! 117 | textbox-color 118 | set-textbox-color! 119 | textbox-alignment 120 | textbox-line-length 121 | textbox-layout 122 | draw-textbox) 123 | -------------------------------------------------------------------------------- /2d/game.scm: -------------------------------------------------------------------------------- 1 | ;;; guile-2d 2 | ;;; Copyright (C) 2013 David Thompson 3 | ;;; 4 | ;;; Guile-2d is free software: you can redistribute it and/or modify it 5 | ;;; under the terms of the GNU Lesser General Public License as 6 | ;;; published by the Free Software Foundation, either version 3 of the 7 | ;;; License, or (at your option) any later version. 8 | ;;; 9 | ;;; Guile-2d is distributed in the hope that it will be useful, but 10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | ;;; Lesser General Public License for more details. 13 | ;;; 14 | ;;; You should have received a copy of the GNU Lesser General Public 15 | ;;; License along with this program. If not, see 16 | ;;; . 17 | 18 | ;;; Commentary: 19 | ;; 20 | ;; Game data structure. 21 | ;; 22 | ;;; Code: 23 | 24 | (define-module (2d game) 25 | #:use-module (srfi srfi-2) 26 | #:use-module (srfi srfi-9) 27 | #:use-module ((sdl sdl) #:prefix SDL:) 28 | #:use-module (figl gl) 29 | #:use-module (2d agenda) 30 | #:use-module (2d coroutine) 31 | #:use-module (2d game) 32 | #:use-module (2d mvars) 33 | #:use-module (2d repl server) 34 | #:use-module (2d repl repl) 35 | #:use-module (2d scene) 36 | #:use-module (2d stage) 37 | #:use-module (2d vector2) 38 | #:use-module (2d window) 39 | #:export ( 40 | make-game 41 | game? 42 | game-title 43 | game-resolution 44 | game-fullscreen? 45 | game-first-scene 46 | current-fps 47 | run-game 48 | quit-game 49 | pause-game 50 | resume-game 51 | game-running? 52 | game-paused?)) 53 | 54 | ;;; 55 | ;;; Games 56 | ;;; 57 | 58 | (define-record-type 59 | (%make-game title resolution fullscreen? first-scene) 60 | game? 61 | (title game-title) 62 | (resolution game-resolution) 63 | (fullscreen? game-fullscreen?) 64 | (first-scene game-first-scene)) 65 | 66 | (define* (make-game #:optional #:key 67 | (title "A Guile-2D Game") 68 | (resolution (vector2 640 480)) 69 | (fullscreen? #f) 70 | (first-scene #f)) 71 | "Return a new game. All game properties have some reasonable default 72 | value." 73 | (%make-game title resolution fullscreen? first-scene)) 74 | 75 | (define (run-game game) 76 | "Open a window and start the game loop for GAME." 77 | (open-window (game-title game) 78 | (game-resolution game) 79 | (game-fullscreen? game)) 80 | (set! running? #t) 81 | (resume-game) 82 | (push-scene (game-first-scene game)) 83 | (spawn-server) 84 | (game-loop (SDL:get-ticks) 0) 85 | (close-window)) 86 | 87 | ;;; 88 | ;;; Game Loop 89 | ;;; 90 | 91 | (define running? #f) 92 | (define paused? #f) 93 | 94 | (define (update-and-render stage dt accumulator) 95 | (let ((remainder (update stage accumulator))) 96 | (run-repl) 97 | (render stage dt) 98 | remainder)) 99 | 100 | (define (tick dt accumulator) 101 | "Advance the game by one frame." 102 | (if paused? 103 | (begin 104 | (run-repl) 105 | (SDL:delay tick-interval) 106 | accumulator) 107 | (catch #t 108 | (lambda () 109 | (let ((stage (current-stage))) 110 | (if stage 111 | (update-and-render stage dt accumulator) 112 | (quit-game)))) 113 | (lambda (key . args) 114 | (pause-game) 115 | accumulator) 116 | (lambda (key . args) 117 | (display-backtrace (make-stack #t) 118 | (current-output-port)))))) 119 | 120 | (define (game-loop last-time accumulator) 121 | "Update game state, and render. LAST-TIME is the time in 122 | milliseconds of the last iteration of the loop. ACCUMULATOR is the 123 | time in milliseconds that has passed since the last game update." 124 | (when running? 125 | (let* ((current-time (SDL:get-ticks)) 126 | (dt (- current-time last-time)) 127 | (accumulator (+ accumulator dt))) 128 | (game-loop current-time (tick dt accumulator))))) 129 | 130 | (define (game-running?) 131 | (running?)) 132 | 133 | (define (game-paused?) 134 | (paused?)) 135 | 136 | (define (pause-game) 137 | "Pauses the game loop. Useful when developing." 138 | (set! paused? #t)) 139 | 140 | (define (resume-game) 141 | "Resumes the game loop." 142 | (set! paused? #f)) 143 | 144 | (define (quit-game) 145 | "Finish the current frame and terminate the game loop." 146 | (set! running? #f)) 147 | 148 | ;;; 149 | ;;; Constants 150 | ;;; 151 | 152 | (define target-fps 60) 153 | (define tick-interval (floor (/ 1000 target-fps))) 154 | 155 | ;;; 156 | ;;; Event Handling 157 | ;;; 158 | 159 | ;; By default, pressing the escape key will pop the current scene, and 160 | ;; closing the window will quit the game. 161 | (default-events `((key-down . ,(lambda (state key mod unicode) 162 | (when (eq? key 'escape) 163 | (pop-scene)))) 164 | (quit . ,(lambda (state) 165 | (quit-game))))) 166 | 167 | (define handle-events 168 | (let ((e (SDL:make-event))) 169 | (lambda (stage) 170 | "Handle all events in the SDL event queue." 171 | (while (SDL:poll-event e) 172 | (handle-event stage e))))) 173 | 174 | (define (handle-event stage e) 175 | "Call the relevant callbacks for the event, E." 176 | (case (SDL:event:type e) 177 | ((active) 178 | (stage-trigger stage 'active)) 179 | ((video-resize) 180 | (stage-trigger stage 181 | 'resize 182 | (SDL:event:resize:w e) 183 | (SDL:event:resize:h e))) 184 | ((quit) 185 | (stage-trigger stage 'quit)) 186 | ((key-down) 187 | (stage-trigger stage 188 | 'key-down 189 | (SDL:event:key:keysym:sym e) 190 | (SDL:event:key:keysym:mod e) 191 | (SDL:event:key:keysym:unicode e))) 192 | ((key-up) 193 | (stage-trigger stage 194 | 'key-up 195 | (SDL:event:key:keysym:sym e) 196 | (SDL:event:key:keysym:mod e) 197 | (SDL:event:key:keysym:unicode e))) 198 | ((mouse-motion) 199 | (stage-trigger stage 200 | 'mouse-motion 201 | (SDL:event:motion:state e) 202 | (SDL:event:motion:x e) 203 | (SDL:event:motion:y e) 204 | (SDL:event:motion:xrel e) 205 | (SDL:event:motion:yrel e))) 206 | ((mouse-button-down) 207 | (stage-trigger stage 208 | 'mouse-press 209 | (SDL:event:button:button e) 210 | (SDL:event:button:x e) 211 | (SDL:event:button:y e))) 212 | ((mouse-button-up) 213 | (stage-trigger stage 214 | 'mouse-click 215 | (SDL:event:button:button e) 216 | (SDL:event:button:x e) 217 | (SDL:event:button:y e))))) 218 | 219 | ;;; 220 | ;;; Frames Per Second 221 | ;;; 222 | 223 | (define game-fps 0) 224 | 225 | (define accumulate-fps! 226 | (let* ((elapsed-time 0) 227 | (fps 0)) 228 | (lambda (dt) 229 | "Increment the frames-per-second counter. Resets to 0 every 230 | second." 231 | (let ((new-time (+ elapsed-time dt)) 232 | (new-fps (1+ fps))) 233 | (if (>= new-time 1000) 234 | (begin 235 | (set! game-fps new-fps) 236 | (set! fps 0) 237 | (set! elapsed-time 0)) 238 | (begin 239 | (set! fps new-fps) 240 | (set! elapsed-time new-time))))))) 241 | 242 | (define (current-fps) 243 | "Return the current FPS value." 244 | game-fps) 245 | 246 | ;;; 247 | ;;; Update and Render 248 | ;;; 249 | 250 | (define (render stage dt) 251 | "Render a frame." 252 | (set-gl-matrix-mode (matrix-mode modelview)) 253 | (gl-load-identity) 254 | (gl-clear (clear-buffer-mask color-buffer depth-buffer)) 255 | (draw-stage stage) 256 | (SDL:gl-swap-buffers) 257 | (accumulate-fps! dt)) 258 | 259 | (define (update stage accumulator) 260 | "Call the update callback. The update callback will be called as 261 | many times as `tick-interval` can divide ACCUMULATOR. The return value 262 | is the unused accumulator time." 263 | (if (>= accumulator tick-interval) 264 | (begin 265 | (handle-events stage) 266 | (update-agenda) 267 | (update-stage stage) 268 | (update stage (- accumulator tick-interval))) 269 | accumulator)) 270 | 271 | ;;; 272 | ;;; REPL 273 | ;;; 274 | 275 | (define (run-repl-thunk thunk input output error stack) 276 | "Run THUNK with the given REPL STACK. I/O is redirected to the given 277 | INPUT, OUTPUT, and ERROR ports." 278 | (put-mvar 279 | repl-output-mvar 280 | (with-input-from-port input 281 | (lambda () 282 | (with-output-to-port output 283 | (lambda () 284 | (with-error-to-port error 285 | (lambda () 286 | (with-fluids ((*repl-stack* stack)) 287 | (thunk)))))))))) 288 | 289 | (define (run-repl) 290 | "Execute a thunk from the REPL is there is one." 291 | (unless (mvar-empty? repl-input-mvar) 292 | (and-let* ((vals (try-take-mvar repl-input-mvar))) 293 | (apply run-repl-thunk vals)))) 294 | -------------------------------------------------------------------------------- /2d/helpers.scm: -------------------------------------------------------------------------------- 1 | ;;; guile-2d 2 | ;;; Copyright (C) 2013 David Thompson 3 | ;;; 4 | ;;; Guile-2d is free software: you can redistribute it and/or modify it 5 | ;;; under the terms of the GNU Lesser General Public License as 6 | ;;; published by the Free Software Foundation, either version 3 of the 7 | ;;; License, or (at your option) any later version. 8 | ;;; 9 | ;;; Guile-2d is distributed in the hope that it will be useful, but 10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | ;;; Lesser General Public License for more details. 13 | ;;; 14 | ;;; You should have received a copy of the GNU Lesser General Public 15 | ;;; License along with this program. If not, see 16 | ;;; . 17 | 18 | ;;; Commentary: 19 | ;; 20 | ;; Miscellaneous helper procedures. 21 | ;; 22 | ;;; Code: 23 | 24 | (define-module (2d helpers) 25 | #:use-module (srfi srfi-1) 26 | #:use-module (rnrs arithmetic bitwise) 27 | #:export (any-equal? 28 | logand? 29 | rgba->gl-color)) 30 | 31 | (define (any-equal? elem . args) 32 | "Return #t if ELEM equals any of the elements in the list ARGS." 33 | (any (lambda (e) (equal? elem e)) args)) 34 | 35 | (define (logand? . args) 36 | "Return #t if the result of a bitwise AND of the integers in list 37 | ARGS is non-zero." 38 | (not (zero? (apply logand args)))) 39 | -------------------------------------------------------------------------------- /2d/math.scm: -------------------------------------------------------------------------------- 1 | ;;; guile-2d 2 | ;;; Copyright (C) 2013 David Thompson 3 | ;;; 4 | ;;; Guile-2d is free software: you can redistribute it and/or modify it 5 | ;;; under the terms of the GNU Lesser General Public License as 6 | ;;; published by the Free Software Foundation, either version 3 of the 7 | ;;; License, or (at your option) any later version. 8 | ;;; 9 | ;;; Guile-2d is distributed in the hope that it will be useful, but 10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | ;;; Lesser General Public License for more details. 13 | ;;; 14 | ;;; You should have received a copy of the GNU Lesser General Public 15 | ;;; License along with this program. If not, see 16 | ;;; . 17 | 18 | ;;; Commentary: 19 | ;; 20 | ;; Miscellaneous math procedures. Currently just trigonometry. 21 | ;; 22 | ;;; Code: 23 | 24 | (define-module (2d math) 25 | #:export (pi 26 | degrees->radians 27 | radians->degrees 28 | sin-degrees 29 | cos-degrees 30 | tan-degrees 31 | atan-degrees)) 32 | 33 | ;; Dave was editing this module on Pi Approximation Day. 34 | ;; 35 | ;; 3.141592653589793238462643383279 36 | ;; 5028841971693993751058209749445923 37 | ;; 07816406286208998628034825342117067 38 | ;; 9821 48086 5132 39 | ;; 823 06647 09384 40 | ;; 46 09550 58223 41 | ;; 17 25359 4081 42 | ;; 2848 1117 43 | ;; 4502 8410 44 | ;; 2701 9385 45 | ;; 21105 55964 46 | ;; 46229 48954 47 | ;; 9303 81964 48 | ;; 4288 10975 49 | ;; 66593 34461 50 | ;; 284756 48233 51 | ;; 78678 31652 71 52 | ;; 2019091 456485 66 53 | ;; 9234603 48610454326648 54 | ;; 2133936 0726024914127 55 | ;; 3724587 00660631558 56 | ;; 817488 152092096 57 | ;; 58 | (define pi 3.141592654) 59 | 60 | (define (degrees->radians angle) 61 | "Convert ANGLE in degrees to radians." 62 | (* angle (/ pi 180))) 63 | 64 | (define (radians->degrees angle) 65 | "Convert ANGLE in radians to degrees." 66 | (* angle (/ 180 pi))) 67 | 68 | (define (sin-degrees angle) 69 | "Compute the sin of ANGLE expressed in degrees." 70 | (sin (degrees->radians angle))) 71 | 72 | (define (cos-degrees angle) 73 | "Compute the cosine of ANGLE expressed in degrees." 74 | (cos (degrees->radians angle))) 75 | 76 | (define (tan-degrees angle) 77 | "Compute the tangent of ANGLE expressed in degrees." 78 | (tan (degrees->radians angle))) 79 | 80 | (define (atan-degrees y x) 81 | "Compute the arctangent in degrees of the coordinates Y and X." 82 | (radians->degrees (atan y x))) 83 | -------------------------------------------------------------------------------- /2d/mvars.scm: -------------------------------------------------------------------------------- 1 | ;;; Synchronized Mutable Variables 2 | 3 | ;; Copyright (C) 2013 Mark Weaver 4 | 5 | ;; This library is free software; you can redistribute it and/or 6 | ;; modify it under the terms of the GNU Lesser General Public 7 | ;; License as published by the Free Software Foundation; either 8 | ;; version 3 of the License, or (at your option) any later version. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | ;; Lesser General Public License for more details. 14 | ;; 15 | ;; You should have received a copy of the GNU Lesser General Public 16 | ;; License along with this library; if not, write to the Free Software 17 | ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 18 | ;; 02110-1301 USA 19 | 20 | ;;; Code: 21 | 22 | (define-module (2d mvars) 23 | #:use-module (ice-9 threads) 24 | #:use-module (srfi srfi-8) ; receive 25 | #:use-module (srfi srfi-9) ; records 26 | #:use-module (srfi srfi-9 gnu) 27 | #:export (mvar? 28 | mvar-empty? new-empty-mvar new-mvar 29 | take-mvar put-mvar read-mvar swap-mvar 30 | try-take-mvar try-put-mvar 31 | with-mvar modify-mvar modify-mvar*)) 32 | 33 | (define-record-type 34 | (make-mvar contents empty? mutex full-condition empty-condition) 35 | mvar? 36 | (contents %mvar-contents %set-mvar-contents!) 37 | (empty? %mvar-empty? %set-mvar-empty?!) 38 | (mutex mvar-mutex) 39 | (full-condition mvar-full-condition) 40 | (empty-condition mvar-empty-condition)) 41 | 42 | (define (mvar-empty? mvar) 43 | (with-mutex (mvar-mutex mvar) 44 | (%mvar-empty? mvar))) 45 | 46 | (define (new-empty-mvar) 47 | "Return a freshly allocated mvar that is initially empty." 48 | (make-mvar #f ; contents 49 | #t ; empty? 50 | (make-mutex) 51 | (make-condition-variable) 52 | (make-condition-variable))) 53 | 54 | (define (new-mvar x) 55 | "Return a freshly allocated mvar with initial contents X." 56 | (make-mvar x ; contents 57 | #f ; empty? 58 | (make-mutex) 59 | (make-condition-variable) 60 | (make-condition-variable))) 61 | 62 | (define (take-mvar mvar) 63 | "Block until MVAR is full, then atomically remove and return its contents." 64 | (with-mutex (mvar-mutex mvar) 65 | (when (%mvar-empty? mvar) 66 | (wait-condition-variable (mvar-full-condition mvar) (mvar-mutex mvar))) 67 | (let ((x (%mvar-contents mvar))) 68 | (%set-mvar-contents! mvar #f) 69 | (%set-mvar-empty?! mvar #t) 70 | (signal-condition-variable (mvar-empty-condition mvar)) 71 | x))) 72 | 73 | (define (put-mvar mvar x) 74 | "Block until MVAR is empty, then put X into it." 75 | (with-mutex (mvar-mutex mvar) 76 | (unless (%mvar-empty? mvar) 77 | (wait-condition-variable (mvar-empty-condition mvar) (mvar-mutex mvar))) 78 | (%set-mvar-contents! mvar x) 79 | (%set-mvar-empty?! mvar #f) 80 | (signal-condition-variable (mvar-full-condition mvar)) 81 | *unspecified*)) 82 | 83 | (define (read-mvar mvar) 84 | "Take a value x from MVAR, then put it back and return x. This 85 | procedure is atomic only if there are no other producers for MVAR." 86 | (let ((x (take-mvar mvar))) 87 | (put-mvar mvar x) 88 | x)) 89 | 90 | (define (swap-mvar mvar y) 91 | "Take a value x from MVAR, then put Y into MVAR and return x. This 92 | procedure is atomic only if there are no other producers for MVAR." 93 | (let ((x (take-mvar mvar))) 94 | (put-mvar mvar y) 95 | x)) 96 | 97 | (define (try-take-mvar mvar) 98 | "If MVAR is full, return its contents and #t, else return #f and #f." 99 | (with-mutex (mvar-mutex mvar) 100 | (if (%mvar-empty? mvar) 101 | (values #f #f) 102 | (let ((x (%mvar-contents mvar))) 103 | (%set-mvar-contents! mvar #f) 104 | (%set-mvar-empty?! mvar #t) 105 | (signal-condition-variable (mvar-empty-condition mvar)) 106 | (values x #t))))) 107 | 108 | (define (try-put-mvar mvar x) 109 | "If MVAR is empty, put X into it and return #t, else return #f." 110 | (with-mutex (mvar-mutex mvar) 111 | (and (%mvar-empty? mvar) 112 | (begin 113 | (%set-mvar-contents! mvar x) 114 | (%set-mvar-empty?! mvar #f) 115 | (signal-condition-variable (mvar-full-condition mvar)) 116 | #t)))) 117 | 118 | (define (with-mvar mvar proc) 119 | "Take a value from MVAR and apply PROC to it. If an exception is raised, 120 | the original value is put back into MVAR. This procedure is atomic only if 121 | there are no other producers for MVAR." 122 | (let ((x (take-mvar mvar))) 123 | (catch #t 124 | (lambda () (proc x)) 125 | (lambda (key . args) 126 | (put-mvar mvar x) 127 | (apply throw key args))))) 128 | 129 | (define (modify-mvar mvar f) 130 | "Take a value x from MVAR, and then put back (F x). If an exception is 131 | raised, the original value is put back into MVAR. This procedure is 132 | atomic only if there are no other producers for MVAR." 133 | (let ((old (take-mvar mvar))) 134 | (catch #t 135 | (lambda () (put-mvar mvar (f old))) 136 | (lambda (key . args) 137 | (put-mvar mvar old) 138 | (apply throw key args))))) 139 | 140 | (define (modify-mvar* mvar f) 141 | "Take a value x from MVAR, and apply F to it. (F x) should return one 142 | or more values: the new value to be put back into MVAR, and zero or more 143 | additional values to be returned from MODIFY-MVAR*. If an exception is 144 | raised, the original value is put back into MVAR. This procedure is 145 | atomic only if there are no other producers for MVAR." 146 | (let ((old (take-mvar mvar))) 147 | (catch #t 148 | (lambda () 149 | (receive (new . results) (f old) 150 | (put-mvar mvar new) 151 | (apply values results))) 152 | (lambda (key . args) 153 | (put-mvar mvar old) 154 | (apply throw key args))))) 155 | 156 | (set-record-type-printer! 157 | 158 | (lambda (mvar port) 159 | (display "#string (object-address mvar) 16) port) 161 | (display " " port) 162 | (write (with-mutex (mvar-mutex mvar) 163 | (if (%mvar-empty? mvar) 164 | '() 165 | (list (%mvar-contents mvar)))) 166 | port) 167 | (display ">" port))) 168 | -------------------------------------------------------------------------------- /2d/observer.scm: -------------------------------------------------------------------------------- 1 | ;;; guile-2d 2 | ;;; Copyright (C) 2013 David Thompson 3 | ;;; 4 | ;;; Guile-2d is free software: you can redistribute it and/or modify it 5 | ;;; under the terms of the GNU Lesser General Public License as 6 | ;;; published by the Free Software Foundation, either version 3 of the 7 | ;;; License, or (at your option) any later version. 8 | ;;; 9 | ;;; Guile-2d is distributed in the hope that it will be useful, but 10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | ;;; Lesser General Public License for more details. 13 | ;;; 14 | ;;; You should have received a copy of the GNU Lesser General Public 15 | ;;; License along with this program. If not, see 16 | ;;; . 17 | 18 | ;;; Commentary: 19 | ;; 20 | ;; Event listener. 21 | ;; 22 | ;;; Code: 23 | 24 | (define-module (2d observer) 25 | #:use-module (srfi srfi-1) 26 | #:use-module (srfi srfi-9) 27 | #:use-module (srfi srfi-26) 28 | #:export ( 29 | make-observer 30 | alist->observer 31 | observer? 32 | observer-events 33 | observer-callbacks 34 | observer-on 35 | observer-off 36 | observer-clear 37 | observer-trigger)) 38 | 39 | (define-record-type 40 | (%make-observer events) 41 | observer? 42 | (events observer-events)) 43 | 44 | (define (make-observer) 45 | "Create a new observer." 46 | (%make-observer (make-hash-table))) 47 | 48 | (define (alist->observer alst) 49 | "Return a new observer that registers the callbacks for events in 50 | the alist ALST. Each pair in ALST should map one event type to one 51 | callback procedure. For multiple event handlers of the same type, use 52 | multiple pairs." 53 | (let ((observer (make-observer))) 54 | (for-each (lambda (e) (observer-on observer (car e) (cdr e))) alst) 55 | observer)) 56 | 57 | (define (observer-callbacks observer event-type) 58 | "Return a list of callback procedures for the given EVENT-TYPE. The 59 | null list is returned if there are no callbacks for EVENT-TYPE." 60 | (or (hash-ref (observer-events observer) event-type) 61 | '())) 62 | 63 | (define (observer-on observer event-type proc) 64 | "Register PROC as a callback for the given EVENT-TYPE." 65 | (hash-set! (observer-events observer) 66 | event-type 67 | (cons proc (observer-callbacks observer event-type)))) 68 | 69 | (define (observer-off observer event-type proc) 70 | "Unregister PROC as a callabck for the given EVENT-TYPE." 71 | (hash-set! (observer-events observer) 72 | event-type 73 | (delete proc (observer-callbacks observer event-type)))) 74 | 75 | (define (observer-clear observer event-type) 76 | "Unregister all callbacks for EVENT-TYPE." 77 | (hash-remove! (observer-events observer) event-type)) 78 | 79 | (define (observer-trigger observer event-type . args) 80 | "Call all callbacks for EVENT-TYPE with the given ARGS." 81 | (for-each (cut apply <> args) 82 | (observer-callbacks observer event-type))) 83 | -------------------------------------------------------------------------------- /2d/rect.scm: -------------------------------------------------------------------------------- 1 | ;;; guile-2d 2 | ;;; Copyright (C) 2013 David Thompson 3 | ;;; 4 | ;;; Guile-2d is free software: you can redistribute it and/or modify it 5 | ;;; under the terms of the GNU Lesser General Public License as 6 | ;;; published by the Free Software Foundation, either version 3 of the 7 | ;;; License, or (at your option) any later version. 8 | ;;; 9 | ;;; Guile-2d is distributed in the hope that it will be useful, but 10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | ;;; Lesser General Public License for more details. 13 | ;;; 14 | ;;; You should have received a copy of the GNU Lesser General Public 15 | ;;; License along with this program. If not, see 16 | ;;; . 17 | 18 | ;;; Commentary: 19 | ;; 20 | ;; Rects are axis-aligned bounding boxes that can be used for 21 | ;; performing simple collision detection. 22 | ;; 23 | ;;; Code: 24 | 25 | (define-module (2d rect) 26 | #:use-module (srfi srfi-9) 27 | #:use-module (2d vector2) 28 | #:export ( 29 | make-rect 30 | rect? 31 | rect-x 32 | rect-y 33 | rect-left 34 | rect-right 35 | rect-top 36 | rect-bottom 37 | rect-position 38 | rect-top-left 39 | rect-top-right 40 | rect-bottom-left 41 | rect-bottom-right 42 | rect-center-x 43 | rect-center-y 44 | rect-center 45 | rect-half-width 46 | rect-half-height 47 | rect-width 48 | rect-height 49 | rect-size 50 | rect-move 51 | rect-inflate 52 | rect-union 53 | rect-clip 54 | rect-within? 55 | rect-intersects? 56 | rect-contains?)) 57 | 58 | ;;; 59 | ;;; Rectangles 60 | ;;; 61 | 62 | ;; The rect API is very similar to the Pygame rect API, but rects are 63 | ;; immutable. 64 | 65 | (define-record-type 66 | (make-rect x y width height) 67 | rect? 68 | (x rect-x) 69 | (y rect-y) 70 | (width rect-width) 71 | (height rect-height)) 72 | 73 | (define (rect-right rect) 74 | (+ (rect-x rect) (rect-width rect))) 75 | 76 | (define rect-left rect-x) 77 | 78 | (define rect-top rect-y) 79 | 80 | (define (rect-bottom rect) 81 | (+ (rect-y rect) (rect-height rect))) 82 | 83 | (define (rect-position rect) 84 | "Return the top-left corner of RECT as a vector2." 85 | (vector2 (rect-x rect) 86 | (rect-y rect))) 87 | 88 | (define rect-top-left rect-position) 89 | 90 | (define (rect-top-right rect) 91 | (vector2 (rect-right rect) 92 | (rect-top rect))) 93 | 94 | (define (rect-bottom-left rect) 95 | (vector2 (rect-left rect) 96 | (rect-bottom rect))) 97 | 98 | (define (rect-bottom-right rect) 99 | (vector2 (rect-right rect) 100 | (rect-bottom rect))) 101 | 102 | (define (rect-center-x rect) 103 | (+ (rect-x rect) (rect-half-width rect))) 104 | 105 | (define (rect-center-y rect) 106 | (+ (rect-y rect) (rect-half-height rect))) 107 | 108 | (define (rect-center rect) 109 | (vector2 (rect-center-x rect) 110 | (rect-center-y rect))) 111 | 112 | (define (rect-half-width rect) 113 | (/ (rect-width rect) 2)) 114 | 115 | (define (rect-half-height rect) 116 | (/ (rect-height rect) 2)) 117 | 118 | (define (rect-size rect) 119 | "Return the size of RECT as a vector2." 120 | (vector2 (rect-width rect) 121 | (rect-height rect))) 122 | 123 | (define (%rect-move rect x y) 124 | "Move RECT by the offset X, Y." 125 | (make-rect (+ (rect-x rect) x) 126 | (+ (rect-y rect) y) 127 | (rect-width rect) 128 | (rect-height rect))) 129 | 130 | (define rect-move 131 | (case-lambda 132 | "Create a new rectangle by moving RECT by the given 133 | offset. rect-move accepts a vector2 or x and y coordinates as separate 134 | arguments." 135 | ((rect v) 136 | (%rect-move rect (vx v) (vy v))) 137 | ((rect x y) 138 | (%rect-move rect x y)))) 139 | 140 | (define (%rect-inflate rect width height) 141 | "Grows the rect by the given amount. The rect stays centered around 142 | its current center." 143 | (make-rect (+ (rect-x rect) (/ width 2)) 144 | (+ (rect-y rect) (/ height 2)) 145 | (+ (rect-width rect) width) 146 | (+ (rect-height rect) height))) 147 | 148 | (define rect-inflate 149 | (case-lambda 150 | "Create a new rectangle by growing RECT by the given amount 151 | without changing the center point. rect-inflate accepts a vector2 or x 152 | and y coordinates as separate arguments." 153 | ((rect v) 154 | (%rect-inflate rect (vx v) (vy v))) 155 | ((rect x y) 156 | (%rect-inflate rect x y)))) 157 | 158 | (define (rect-union rect1 rect2) 159 | "Return a rect that covers the area of RECT1 and RECT2." 160 | (let ((x1 (min (rect-left rect1) (rect-left rect2))) 161 | (x2 (max (rect-right rect1) (rect-right rect2))) 162 | (y1 (min (rect-top rect1) (rect-top rect2))) 163 | (y2 (max (rect-bottom rect1) (rect-bottom rect2)))) 164 | (make-rect x1 y1 (- x2 x1) (- y2 y1)))) 165 | 166 | (define (rect-clip rect1 rect2) 167 | "Return the overlapping region of RECT1 and RECT2. If the rects do 168 | not overlap, a rect of size 0 is returned." 169 | (let ((x1 (max (rect-left rect1) (rect-left rect2))) 170 | (x2 (min (rect-right rect1) (rect-right rect2))) 171 | (y1 (max (rect-top rect1) (rect-top rect2))) 172 | (y2 (min (rect-bottom rect1) (rect-bottom rect2)))) 173 | (make-rect x1 y1 (max (- x2 x1) 0) (max (- y2 y1) 0)))) 174 | 175 | (define (rect-within? rect1 rect2) 176 | "Return #t if RECT2 is completely within RECT1." 177 | (and (>= (rect-left rect2) (rect-left rect1)) 178 | (<= (rect-right rect2) (rect-right rect1)) 179 | (>= (rect-top rect2) (rect-top rect1)) 180 | (<= (rect-bottom rect2) (rect-bottom rect1)))) 181 | 182 | (define (rect-intersects? rect1 rect2) 183 | "Return #t if RECT2 overlaps RECT1." 184 | (and (< (rect-left rect1) (rect-right rect2)) 185 | (> (rect-right rect1) (rect-left rect2)) 186 | (< (rect-top rect1) (rect-bottom rect2)) 187 | (> (rect-bottom rect1) (rect-top rect2)))) 188 | 189 | (define (%rect-contains? rect x y) 190 | (and (>= x (rect-left rect)) 191 | (<= x (rect-right rect)) 192 | (>= y (rect-top rect)) 193 | (<= y (rect-bottom rect)))) 194 | 195 | (define rect-contains? 196 | (case-lambda 197 | "Return #t if the given point is within RECT." 198 | ((rect v) 199 | (%rect-contains? rect (vx v) (vy v))) 200 | ((rect x y) 201 | (%rect-contains? rect x y)))) 202 | -------------------------------------------------------------------------------- /2d/repl/repl.scm: -------------------------------------------------------------------------------- 1 | ;;; Read-Eval-Print Loop 2 | 3 | ;; Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software Foundation, Inc. 4 | 5 | ;; This library is free software; you can redistribute it and/or 6 | ;; modify it under the terms of the GNU Lesser General Public 7 | ;; License as published by the Free Software Foundation; either 8 | ;; version 3 of the License, or (at your option) any later version. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | ;; Lesser General Public License for more details. 14 | ;; 15 | ;; You should have received a copy of the GNU Lesser General Public 16 | ;; License along with this library; if not, write to the Free Software 17 | ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 18 | ;; 02110-1301 USA 19 | 20 | ;;; Code: 21 | 22 | (define-module (2d repl repl) 23 | #:use-module (system base syntax) 24 | #:use-module (system base pmatch) 25 | #:use-module (system base compile) 26 | #:use-module (system base language) 27 | #:use-module (system vm vm) 28 | #:use-module (system repl error-handling) 29 | #:use-module (system repl common) 30 | #:use-module (system repl command) 31 | #:use-module (ice-9 control) 32 | #:use-module (2d mvars) 33 | #:use-module (2d game) 34 | #:export (repl-input-mvar repl-output-mvar start-repl run-repl)) 35 | 36 | 37 | ;;; 38 | ;;; Comments 39 | ;;; 40 | ;;; (You don't want a comment to force a continuation line.) 41 | ;;; 42 | 43 | (define (read-scheme-line-comment port) 44 | (let lp () 45 | (let ((ch (read-char port))) 46 | (or (eof-object? ch) 47 | (eqv? ch #\newline) 48 | (lp))))) 49 | 50 | (define (read-scheme-datum-comment port) 51 | (read port)) 52 | 53 | ;; ch is a peeked char 54 | (define (read-comment lang port ch) 55 | (and (eq? (language-name lang) 'scheme) 56 | (case ch 57 | ((#\;) 58 | (read-char port) 59 | (read-scheme-line-comment port) 60 | #t) 61 | ((#\#) 62 | (read-char port) 63 | (case (peek-char port) 64 | ((#\;) 65 | (read-char port) 66 | (read-scheme-datum-comment port) 67 | #t) 68 | ;; Not doing R6RS block comments because of the possibility 69 | ;; of read-hash extensions. Lame excuse. Not doing scsh 70 | ;; block comments either, because I don't feel like handling 71 | ;; #!r6rs. 72 | (else 73 | (unread-char #\# port) 74 | #f))) 75 | (else 76 | #f)))) 77 | 78 | 79 | 80 | ;;; 81 | ;;; Meta commands 82 | ;;; 83 | 84 | (define meta-command-token (cons 'meta 'command)) 85 | 86 | (define (meta-reader lang env) 87 | (lambda* (#:optional (port (current-input-port))) 88 | (with-input-from-port port 89 | (lambda () 90 | (let ((ch (flush-leading-whitespace))) 91 | (cond ((eof-object? ch) 92 | (read-char)) ; consume the EOF and return it 93 | ((eqv? ch #\,) 94 | (read-char) 95 | meta-command-token) 96 | ((read-comment lang port ch) 97 | *unspecified*) 98 | (else ((language-reader lang) port env)))))))) 99 | 100 | (define (flush-all-input) 101 | (if (and (char-ready?) 102 | (not (eof-object? (peek-char)))) 103 | (begin 104 | (read-char) 105 | (flush-all-input)))) 106 | 107 | ;; repl-reader is a function defined in boot-9.scm, and is replaced by 108 | ;; something else if readline has been activated. much of this hoopla is 109 | ;; to be able to re-use the existing readline machinery. 110 | ;; 111 | ;; Catches read errors, returning *unspecified* in that case. 112 | (define (prompting-meta-read repl) 113 | (catch #t 114 | (lambda () 115 | (repl-reader (lambda () (repl-prompt repl)) 116 | (meta-reader (repl-language repl) (current-module)))) 117 | (lambda (key . args) 118 | (case key 119 | ((quit) 120 | (apply throw key args)) 121 | (else 122 | (format (current-output-port) "While reading expression:\n") 123 | (print-exception (current-output-port) #f key args) 124 | (flush-all-input) 125 | *unspecified*))))) 126 | 127 | 128 | 129 | ;;; 130 | ;;; The repl 131 | ;;; 132 | 133 | (define repl-input-mvar (new-empty-mvar)) 134 | (define repl-output-mvar (new-empty-mvar)) 135 | 136 | (define* (start-repl #:optional (lang (current-language)) #:key debug) 137 | ;; ,language at the REPL will update the current-language. Make 138 | ;; sure that it does so in a new dynamic scope. 139 | (parameterize ((current-language lang)) 140 | (run-repl (make-repl lang debug)))) 141 | 142 | ;; (put 'abort-on-error 'scheme-indent-function 1) 143 | (define-syntax-rule (abort-on-error string exp) 144 | (catch #t 145 | (lambda () exp) 146 | (lambda (key . args) 147 | (format #t "While ~A:~%" string) 148 | (print-exception (current-output-port) #f key args) 149 | (abort)))) 150 | 151 | (define (run-repl repl) 152 | (define (with-stack-and-prompt thunk) 153 | (call-with-prompt (default-prompt-tag) 154 | (lambda () (start-stack #t (thunk))) 155 | (lambda (k proc) 156 | (with-stack-and-prompt (lambda () (proc k)))))) 157 | 158 | (% (with-fluids ((*repl-stack* 159 | (cons repl (or (fluid-ref *repl-stack*) '())))) 160 | (if (null? (cdr (fluid-ref *repl-stack*))) 161 | (repl-welcome repl)) 162 | (let prompt-loop () 163 | (let ((exp (prompting-meta-read repl))) 164 | (cond 165 | ((eqv? exp *unspecified*)) ; read error or comment, pass 166 | ((eq? exp meta-command-token) 167 | (catch #t 168 | (lambda () 169 | (meta-command repl)) 170 | (lambda (k . args) 171 | (if (eq? k 'quit) 172 | (abort args) 173 | (begin 174 | (format #t "While executing meta-command:~%") 175 | (print-exception (current-output-port) #f k args)))))) 176 | ((eof-object? exp) 177 | (newline) 178 | (abort '())) 179 | (else 180 | ;; since the input port is line-buffered, consume up to the 181 | ;; newline 182 | (flush-to-newline) 183 | (call-with-error-handling 184 | (lambda () 185 | (catch 'quit 186 | (lambda () 187 | (call-with-values 188 | (lambda () 189 | (% (let ((thunk 190 | (abort-on-error "compiling expression" 191 | (repl-prepare-eval-thunk 192 | repl 193 | (abort-on-error "parsing expression" 194 | (repl-parse repl exp)))))) 195 | (run-hook before-eval-hook exp) 196 | ;; Insert thunk into repl-mvar. The 197 | ;; game loop will schedule it and run 198 | ;; it on the next tick. We also pass 199 | ;; along the input/output/error ports 200 | ;; and the REPL stack. 201 | (put-mvar 202 | repl-input-mvar 203 | (list 204 | (lambda () 205 | (call-with-error-handling 206 | (lambda () 207 | (with-stack-and-prompt thunk)) 208 | #:on-error (repl-option-ref repl 'on-error))) 209 | (current-input-port) 210 | (current-output-port) 211 | (current-error-port) 212 | (fluid-ref *repl-stack*))) 213 | ;; Read the results back from 214 | ;; game-mvar. Will block until results 215 | ;; are available. 216 | (take-mvar repl-output-mvar)) 217 | (lambda (k) (values)))) 218 | (lambda l 219 | (for-each (lambda (v) 220 | (repl-print repl v)) 221 | l)))) 222 | (lambda (k . args) 223 | (run-hook after-eval-hook exp) 224 | (abort args)))) 225 | #:on-error (repl-option-ref repl 'on-error) 226 | #:trap-handler 'disabled))) 227 | (flush-to-newline) ;; consume trailing whitespace 228 | (run-hook after-eval-hook exp) 229 | (prompt-loop)))) 230 | (lambda (k status) 231 | status))) 232 | 233 | ;; Returns first non-whitespace char. 234 | (define (flush-leading-whitespace) 235 | (let ((ch (peek-char))) 236 | (cond ((eof-object? ch) ch) 237 | ((char-whitespace? ch) (read-char) (flush-leading-whitespace)) 238 | (else ch)))) 239 | 240 | (define (flush-to-newline) 241 | (if (char-ready?) 242 | (let ((ch (peek-char))) 243 | (if (and (not (eof-object? ch)) (char-whitespace? ch)) 244 | (begin 245 | (read-char) 246 | (if (not (char=? ch #\newline)) 247 | (flush-to-newline))))))) 248 | -------------------------------------------------------------------------------- /2d/repl/server.scm: -------------------------------------------------------------------------------- 1 | ;;; Repl server 2 | 3 | ;; Copyright (C) 2003, 2010, 2011 Free Software Foundation, Inc. 4 | 5 | ;; This library is free software; you can redistribute it and/or 6 | ;; modify it under the terms of the GNU Lesser General Public 7 | ;; License as published by the Free Software Foundation; either 8 | ;; version 3 of the License, or (at your option) any later version. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | ;; Lesser General Public License for more details. 14 | ;; 15 | ;; You should have received a copy of the GNU Lesser General Public 16 | ;; License along with this library; if not, write to the Free Software 17 | ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 18 | ;; 02110-1301 USA 19 | 20 | ;;; Code: 21 | 22 | (define-module (2d repl server) 23 | #:use-module (2d repl repl) 24 | #:use-module (ice-9 threads) 25 | #:export (make-tcp-server-socket 26 | make-unix-domain-server-socket 27 | run-server 28 | spawn-server 29 | stop-server-and-clients!)) 30 | 31 | (define *open-sockets* '()) 32 | 33 | (define sockets-lock (make-mutex)) 34 | 35 | (define (close-socket! s) 36 | (with-mutex sockets-lock 37 | (set! *open-sockets* (delq! s *open-sockets*))) 38 | ;; Close-port could block or raise an exception flushing buffered 39 | ;; output. Hmm. 40 | (close-port s)) 41 | 42 | (define (add-open-socket! s) 43 | (with-mutex sockets-lock 44 | (set! *open-sockets* (cons s *open-sockets*)))) 45 | 46 | (define (stop-server-and-clients!) 47 | (cond 48 | ((with-mutex sockets-lock 49 | (and (pair? *open-sockets*) 50 | (car *open-sockets*))) 51 | => (lambda (s) 52 | (close-socket! s) 53 | (stop-server-and-clients!))))) 54 | 55 | (define* (make-tcp-server-socket #:key 56 | (host #f) 57 | (addr (if host (inet-aton host) INADDR_LOOPBACK)) 58 | (port 37146)) 59 | (let ((sock (socket PF_INET SOCK_STREAM 0))) 60 | (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) 61 | (bind sock AF_INET addr port) 62 | sock)) 63 | 64 | (define* (make-unix-domain-server-socket #:key (path "/tmp/guile-socket")) 65 | (let ((sock (socket PF_UNIX SOCK_STREAM 0))) 66 | (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) 67 | (bind sock AF_UNIX path) 68 | sock)) 69 | 70 | (define call-with-sigint 71 | (if (not (provided? 'posix)) 72 | (lambda (thunk) (thunk)) 73 | (lambda (thunk) 74 | (let ((handler #f)) 75 | (dynamic-wind 76 | (lambda () 77 | (set! handler 78 | (sigaction SIGINT (lambda (sig) (throw 'interrupt))))) 79 | thunk 80 | (lambda () 81 | (if handler 82 | ;; restore Scheme handler, SIG_IGN or SIG_DFL. 83 | (sigaction SIGINT (car handler) (cdr handler)) 84 | ;; restore original C handler. 85 | (sigaction SIGINT #f)))))))) 86 | 87 | (define* (run-server #:optional (server-socket (make-tcp-server-socket))) 88 | (define (accept-new-client) 89 | (catch #t 90 | (lambda () (call-with-sigint (lambda () (accept server-socket)))) 91 | (lambda (k . args) 92 | (cond 93 | ((port-closed? server-socket) 94 | ;; Shutting down. 95 | #f) 96 | ((eq? k 'interrupt) 97 | ;; Interrupt. 98 | (close-socket! server-socket) 99 | #f) 100 | (else 101 | (warn "Error accepting client" k args) 102 | ;; Retry after a timeout. 103 | (sleep 1) 104 | (accept-new-client)))))) 105 | 106 | (sigaction SIGPIPE SIG_IGN) 107 | (add-open-socket! server-socket) 108 | (listen server-socket 5) 109 | (let lp ((client (accept-new-client))) 110 | ;; If client is false, we are shutting down. 111 | (if client 112 | (let ((client-socket (car client)) 113 | (client-addr (cdr client))) 114 | (add-open-socket! client-socket) 115 | (make-thread serve-client client-socket client-addr) 116 | (lp (accept-new-client)))))) 117 | 118 | (define* (spawn-server #:optional (server-socket (make-tcp-server-socket))) 119 | (make-thread run-server server-socket)) 120 | 121 | (define (serve-client client addr) 122 | (with-continuation-barrier 123 | (lambda () 124 | (with-input-from-port client 125 | (lambda () 126 | (with-output-to-port client 127 | (lambda () 128 | (with-error-to-port client 129 | (lambda () 130 | (with-fluids ((*repl-stack* '())) 131 | (start-repl)))))))))) 132 | (close-socket! client)) 133 | -------------------------------------------------------------------------------- /2d/scene.scm: -------------------------------------------------------------------------------- 1 | ;;; guile-2d 2 | ;;; Copyright (C) 2013 David Thompson 3 | ;;; 4 | ;;; Guile-2d is free software: you can redistribute it and/or modify it 5 | ;;; under the terms of the GNU Lesser General Public License as 6 | ;;; published by the Free Software Foundation, either version 3 of the 7 | ;;; License, or (at your option) any later version. 8 | ;;; 9 | ;;; Guile-2d is distributed in the hope that it will be useful, but 10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | ;;; Lesser General Public License for more details. 13 | ;;; 14 | ;;; You should have received a copy of the GNU Lesser General Public 15 | ;;; License along with this program. If not, see 16 | ;;; . 17 | 18 | ;;; Commentary: 19 | ;; 20 | ;; Scenes describe the behavioral aspects of a game. 21 | ;; 22 | ;;; Code: 23 | 24 | (define-module (2d scene) 25 | #:use-module (srfi srfi-9) 26 | #:use-module (2d observer) 27 | #:export ( 28 | make-scene 29 | scene? 30 | scene-name 31 | scene-init 32 | scene-enter 33 | scene-exit 34 | scene-draw 35 | scene-update 36 | scene-observer 37 | init-scene 38 | enter-scene 39 | exit-scene 40 | draw-scene 41 | update-scene 42 | scene-trigger 43 | default-events)) 44 | 45 | (define-record-type 46 | (%make-scene name init enter exit draw update observer) 47 | scene? 48 | (name scene-name) 49 | (init scene-init) 50 | (enter scene-enter) 51 | (exit scene-exit) 52 | (draw scene-draw) 53 | (update scene-update) 54 | (observer scene-observer)) 55 | 56 | (define no-op (lambda args #f)) 57 | (define default-events (make-parameter '())) 58 | 59 | (define* (make-scene name 60 | #:optional #:key 61 | (init no-op) 62 | (enter no-op) 63 | (exit no-op) 64 | (draw no-op) 65 | (update no-op) 66 | (events (default-events))) 67 | "Create a new scene object. All callbacks default to a no-op." 68 | (%make-scene name init enter exit draw update 69 | (alist->observer events))) 70 | 71 | (define (init-scene scene) 72 | "Return the value returned by the state constructor thunk for 73 | SCENE." 74 | ((scene-init scene))) 75 | 76 | (define (enter-scene scene state) 77 | "Call enter callback for SCENE with STATE." 78 | ((scene-enter scene) state)) 79 | 80 | (define (exit-scene scene state) 81 | "Call the exit callback for SCENE with STATE." 82 | ((scene-exit scene) state)) 83 | 84 | (define (draw-scene scene state) 85 | "Call the draw callback for SCENE with STATE." 86 | ((scene-draw scene) state)) 87 | 88 | (define (update-scene scene state) 89 | "Call the update callback for SCENE with STATE." 90 | ((scene-update scene) state)) 91 | 92 | (define (scene-trigger scene state event . args) 93 | (apply observer-trigger (scene-observer scene) event state args)) 94 | -------------------------------------------------------------------------------- /2d/sprite.scm: -------------------------------------------------------------------------------- 1 | ;;; guile-2d 2 | ;;; Copyright (C) 2013 David Thompson 3 | ;;; 4 | ;;; Guile-2d is free software: you can redistribute it and/or modify it 5 | ;;; under the terms of the GNU Lesser General Public License as 6 | ;;; published by the Free Software Foundation, either version 3 of the 7 | ;;; License, or (at your option) any later version. 8 | ;;; 9 | ;;; Guile-2d is distributed in the hope that it will be useful, but 10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | ;;; Lesser General Public License for more details. 13 | ;;; 14 | ;;; You should have received a copy of the GNU Lesser General Public 15 | ;;; License along with this program. If not, see 16 | ;;; . 17 | 18 | ;;; Commentary: 19 | ;; 20 | ;; Sprites are typically the most important part of a 2D game. This 21 | ;; module provides sprites as an abstraction around OpenGL textures. 22 | ;; 23 | ;;; Code: 24 | 25 | (define-module (2d sprite) 26 | #:use-module (srfi srfi-1) 27 | #:use-module (srfi srfi-9) 28 | #:use-module (figl gl) 29 | #:use-module (figl contrib packed-struct) 30 | #:use-module ((sdl sdl) #:prefix SDL:) 31 | #:use-module (2d agenda) 32 | #:use-module (2d animation) 33 | #:use-module (2d color) 34 | #:use-module (2d helpers) 35 | #:use-module (2d math) 36 | #:use-module (2d texture) 37 | #:use-module (2d vector2) 38 | #:use-module (2d wrappers gl)) 39 | 40 | ;;; 41 | ;;; Sprite Vertices 42 | ;;; 43 | 44 | ;; Used to build OpenGL vertex array for a sprite. 45 | (define-packed-struct sprite-vertex 46 | ;; Position 47 | (x float) 48 | (y float) 49 | ;; Color 50 | (r float) 51 | (g float) 52 | (b float) 53 | (a float) 54 | ;; Texture Coordinates 55 | (s float) 56 | (t float)) 57 | 58 | (define sprite-vertex-size (packed-struct-size sprite-vertex)) 59 | (define x-offset (packed-struct-offset sprite-vertex x)) 60 | (define r-offset (packed-struct-offset sprite-vertex r)) 61 | (define s-offset (packed-struct-offset sprite-vertex s)) 62 | 63 | (define (pack-sprite-vertices vertices offset x y width height origin-x origin-y 64 | scale-x scale-y rotation s1 t1 s2 t2 color) 65 | (define (pack-sprite x1 y1 x2 y2 x3 y3 x4 y4) 66 | (let ((r (color-r color)) 67 | (g (color-g color)) 68 | (b (color-b color)) 69 | (a (color-a color))) 70 | ;; Vertices go counter clockwise, starting from the top-left 71 | ;; corner. 72 | (pack vertices offset sprite-vertex 73 | x1 y1 74 | r g b a 75 | s1 t1) 76 | (pack vertices (+ offset 1) sprite-vertex 77 | x2 y2 78 | r g b a 79 | s1 t2) 80 | (pack vertices (+ offset 2) sprite-vertex 81 | x3 y3 82 | r g b a 83 | s2 t2) 84 | (pack vertices (+ offset 3) sprite-vertex 85 | x4 y4 86 | r g b a 87 | s2 t1))) 88 | 89 | (let ((local-x1 (* (- origin-x) scale-x)) 90 | (local-y1 (* (- origin-y) scale-y)) 91 | (local-x2 (* (- width origin-x) scale-x)) 92 | (local-y2 (* (- height origin-y) scale-y))) 93 | (if (= rotation 0) 94 | (begin 95 | (let ((x1 (+ x local-x1)) 96 | (y1 (+ y local-y1)) 97 | (x2 (+ x local-x2)) 98 | (y2 (+ y local-y2))) 99 | (pack-sprite x1 y1 x1 y2 x2 y2 x2 y1))) 100 | (begin 101 | (let* ((sin (sin-degrees rotation)) 102 | (cos (cos-degrees rotation)) 103 | (x1 (+ x (- (* cos local-x1) (* sin local-y1)))) 104 | (y1 (+ y (* sin local-x1) (* cos local-y1))) 105 | (x2 (+ x (- (* cos local-x1) (* sin local-y2)))) 106 | (y2 (+ y (* sin local-x1) (* cos local-y2))) 107 | (x3 (+ x (- (* cos local-x2) (* sin local-y2)))) 108 | (y3 (+ y (* sin local-x2) (* cos local-y2))) 109 | (x4 (+ x1 (- x3 x2))) 110 | (y4 (- y3 (- y2 y1)))) 111 | (pack-sprite x1 y1 x2 y2 x3 y3 x4 y4)))))) 112 | 113 | (define (draw-sprite-vertices texture vertices size) 114 | (let ((pointer-type (tex-coord-pointer-type float))) 115 | (gl-enable-client-state (enable-cap vertex-array)) 116 | (gl-enable-client-state (enable-cap color-array)) 117 | (gl-enable-client-state (enable-cap texture-coord-array)) 118 | (with-gl-bind-texture (texture-target texture-2d) (texture-id texture) 119 | (set-gl-vertex-array pointer-type 120 | vertices 121 | 2 122 | #:stride sprite-vertex-size 123 | #:offset x-offset) 124 | (set-gl-color-array pointer-type 125 | vertices 126 | 4 127 | #:stride sprite-vertex-size 128 | #:offset r-offset) 129 | (set-gl-texture-coordinates-array pointer-type 130 | vertices 131 | #:stride sprite-vertex-size 132 | #:offset s-offset) 133 | (gl-draw-arrays (begin-mode quads) 0 (* size 4))) 134 | (gl-disable-client-state (enable-cap texture-coord-array)) 135 | (gl-disable-client-state (enable-cap color-array)) 136 | (gl-disable-client-state (enable-cap vertex-array)))) 137 | 138 | ;;; 139 | ;;; Sprites 140 | ;;; 141 | 142 | ;; The type represents a drawable object (texture, 143 | ;; texture-region, animation, etc.) with a given position, scale, 144 | ;; rotation, and color. 145 | (define-record-type 146 | (%make-sprite drawable position scale rotation color anchor 147 | vertices dirty animator) 148 | sprite? 149 | (drawable sprite-drawable set-sprite-drawable!) 150 | (position sprite-position %set-sprite-position!) 151 | (scale sprite-scale %set-sprite-scale!) 152 | (rotation sprite-rotation %set-sprite-rotation!) 153 | (color sprite-color %set-sprite-color!) 154 | (anchor sprite-anchor %set-sprite-anchor!) 155 | (vertices sprite-vertices set-sprite-vertices!) 156 | (dirty sprite-dirty? set-sprite-dirty!) 157 | (animator sprite-animator)) 158 | 159 | (define* (make-sprite drawable #:optional #:key 160 | (position (vector2 0 0)) (scale (vector2 1 1)) 161 | (rotation 0) (color white) (anchor 'center)) 162 | "Create a new sprite object. DRAWABLE is either a texture or 163 | animation object. All keyword arguments are optional. POSITION is a 164 | vector2 object with a default of (0, 0). SCALE is a vector2 object 165 | that describes how much DRAWABLE should be strected on the x and y 166 | axes, with a default of 1x scale. ROTATION is an angle in degrees with 167 | a default of 0. COLOR is a color object with a default of 168 | white. ANCHOR is either a vector2 that represents the center point of 169 | the sprite, or 'center which will place the anchor at the center of 170 | DRAWABLE. Sprites are centered by default." 171 | (let ((vertices (make-packed-array sprite-vertex 4)) 172 | (animator (if (animation? drawable) 173 | (make-animator drawable) 174 | #f))) 175 | (%make-sprite drawable position scale rotation color anchor vertices 176 | #t animator))) 177 | 178 | (define-syntax-rule (dirty-sprite-setter setter private-setter) 179 | "Defines a setter that calls the private version of the given 180 | procedure name (prefix with %) and marks the sprite as dirty. Any 181 | operation that requires a refresh of the vertex array should use this macro." 182 | (define (setter sprite value) 183 | (private-setter sprite value) 184 | (set-sprite-dirty! sprite #t))) 185 | 186 | (dirty-sprite-setter set-sprite-position! %set-sprite-position!) 187 | (dirty-sprite-setter set-sprite-scale! %set-sprite-scale!) 188 | (dirty-sprite-setter set-sprite-rotation! %set-sprite-rotation!) 189 | (dirty-sprite-setter set-sprite-color! %set-sprite-color!) 190 | (dirty-sprite-setter set-sprite-anchor! %set-sprite-anchor!) 191 | 192 | (define* (load-sprite filename #:optional #:key 193 | (position (vector2 0 0)) (scale (vector2 1 1)) 194 | (rotation 0) (color white) (anchor 'center)) 195 | "Load a sprite from the file at FILENAME. See make-sprite for 196 | optional keyword arguments." 197 | (make-sprite (load-texture filename) #:position position #:scale scale 198 | #:rotation rotation #:color color #:anchor anchor)) 199 | 200 | (define (animated-sprite? sprite) 201 | "Return #t if SPRITE has an animation as its drawable object." 202 | (animation? (sprite-drawable sprite))) 203 | 204 | (define (sprite-animation-texture sprite) 205 | (animator-texture (sprite-animator sprite))) 206 | 207 | (define (sprite-texture sprite) 208 | "Return the texture for the SPRITE's drawable object." 209 | (let ((drawable (sprite-drawable sprite))) 210 | (cond ((texture? drawable) 211 | drawable) 212 | ((animation? drawable) 213 | (sprite-animation-texture sprite))))) 214 | 215 | (define (sprite-anchor-vector sprite) 216 | "Return a vector2 of the coordinates for the center point of a 217 | sprite." 218 | (let ((anchor (sprite-anchor sprite)) 219 | (texture (sprite-texture sprite))) 220 | (cond 221 | ((eq? anchor 'center) 222 | (vector2 (/ (texture-width texture) 2) 223 | (/ (texture-height texture) 2))) 224 | (else anchor)))) 225 | 226 | (define (update-sprite-vertices! sprite) 227 | "Rebuild the internal vertex array." 228 | (let ((pos (sprite-position sprite)) 229 | (scale (sprite-scale sprite)) 230 | (anchor (sprite-anchor-vector sprite)) 231 | (texture (sprite-texture sprite))) 232 | (pack-sprite-vertices (sprite-vertices sprite) 233 | 0 234 | (vx pos) 235 | (vy pos) 236 | (texture-width texture) 237 | (texture-height texture) 238 | (vx anchor) 239 | (vy anchor) 240 | (vx scale) 241 | (vy scale) 242 | (sprite-rotation sprite) 243 | (texture-s1 texture) 244 | (texture-t1 texture) 245 | (texture-s2 texture) 246 | (texture-t2 texture) 247 | (sprite-color sprite)))) 248 | 249 | (define (update-sprite-animator! sprite) 250 | (animator-update! (sprite-animator sprite))) 251 | 252 | (define (draw-sprite sprite) 253 | "Render SPRITE to the screen. A sprite batch will be used if one is 254 | currently bound." 255 | (when (sprite-dirty? sprite) 256 | (update-sprite-vertices! sprite)) 257 | (register-animated-sprite-maybe sprite) 258 | (if *sprite-batch* 259 | (draw-sprite-batched sprite) 260 | (draw-sprite-vertices (sprite-texture sprite) 261 | (sprite-vertices sprite) 262 | 1))) 263 | 264 | (define (draw-sprite-batched sprite) 265 | "Add SPRITE to the current sprite batch batch." 266 | (let ((texture (sprite-texture sprite)) 267 | (pos (sprite-position sprite)) 268 | (scale (sprite-scale sprite)) 269 | (anchor (sprite-anchor-vector sprite))) 270 | (register-animated-sprite-maybe sprite) 271 | (%sprite-batch-draw *sprite-batch* 272 | texture 273 | (vx pos) 274 | (vy pos) 275 | (texture-width texture) 276 | (texture-height texture) 277 | (vx anchor) 278 | (vy anchor) 279 | (vx scale) 280 | (vy scale) 281 | (sprite-rotation sprite) 282 | (texture-s1 texture) 283 | (texture-t1 texture) 284 | (texture-s2 texture) 285 | (texture-t2 texture) 286 | (sprite-color sprite)))) 287 | 288 | ;; A hash table for all of the animated sprites that have been drawn 289 | ;; since the last game update. It is cleared after every game update. 290 | (define animated-sprites (make-hash-table)) 291 | 292 | (define (register-animated-sprite-maybe sprite) 293 | (when (animated-sprite? sprite) 294 | (hash-set! animated-sprites sprite sprite))) 295 | 296 | (define (update-animated-sprites!) 297 | "Update all animators for sprites that have been drawn this frame." 298 | (hash-for-each (lambda (key val) 299 | (update-sprite-animator! val)) 300 | animated-sprites) 301 | (hash-clear! animated-sprites)) 302 | 303 | ;; Update animated sprites upon every update. 304 | (agenda-schedule-interval update-animated-sprites!) 305 | 306 | (export make-sprite 307 | sprite? 308 | sprite-drawable 309 | set-sprite-drawable! 310 | sprite-position 311 | set-sprite-position! 312 | sprite-scale 313 | set-sprite-scale! 314 | sprite-rotation 315 | set-sprite-rotation! 316 | sprite-color 317 | set-sprite-color! 318 | sprite-anchor 319 | set-sprite-anchor! 320 | sprite-vertices 321 | set-sprite-vertices! 322 | animated-sprite? 323 | load-sprite 324 | draw-sprite) 325 | 326 | ;;; 327 | ;;; Sprite batches 328 | ;;; 329 | 330 | ;; Sprite batches allow for efficient texture rendering. Sprites drawn 331 | ;; with the same texture are drawn in the same draw call using a 332 | ;; vertex array, rather than re-binding the texture for each 333 | ;; individual draw call. 334 | (define-record-type 335 | (%make-sprite-batch max-size size texture vertices) 336 | sprite-batch? 337 | (max-size sprite-batch-max-size) 338 | (size sprite-batch-size set-sprite-batch-size!) 339 | (texture sprite-batch-texture set-sprite-batch-texture!) 340 | (vertices sprite-batch-vertices)) 341 | 342 | ;; Dynamic state for the current sprite batch. 343 | (define *sprite-batch* #f) 344 | 345 | (define* (make-sprite-batch #:optional (max-size 1000)) 346 | "Creates a new sprite batch. The default max-size is 1000." 347 | (let ((vertex-array (make-packed-array sprite-vertex (* 4 max-size)))) 348 | (%make-sprite-batch max-size 0 #f vertex-array))) 349 | 350 | (define (sprite-batch-draw . args) 351 | "Add a textured quad to the current sprite batch. X, Y, WIDTH, and 352 | HEIGHT represent the quad in pixels. ORIGIN-X and ORIGIN-Y represent 353 | the center point of the quad which is used for rotation. SCALE-X and 354 | SCALE-Y are the scaling factors for the x and y axis, 355 | respectively. ROTATION is the angle in degrees to rotate the quad. U, 356 | V, U2, and V2 represent the texture coordinate region to texture the 357 | quad with. COLOR is a color object." 358 | (apply %sprite-batch-draw *sprite-batch* args)) 359 | 360 | (define* (%sprite-batch-draw batch texture x y width height origin-x origin-y 361 | scale-x scale-y rotation u v u2 v2 color) 362 | "Add a textured quad to the sprite batch." 363 | ;; Render the batch when it's full or the texture changes. 364 | (cond ((= (sprite-batch-size batch) (sprite-batch-max-size batch)) 365 | (sprite-batch-render batch)) 366 | ((not (equal? texture (sprite-batch-texture batch))) 367 | (sprite-batch-switch-texture batch texture))) 368 | 369 | ;; Add 4 new vertices, taking into account scaling and rotation. 370 | (pack-sprite-vertices (sprite-batch-vertices batch) 371 | (* 4 (sprite-batch-size batch)) 372 | x y width height origin-x origin-y 373 | scale-x scale-y rotation u v u2 v2 color) 374 | 375 | ;; Increment batch size 376 | (set-sprite-batch-size! batch (1+ (sprite-batch-size batch)))) 377 | 378 | (define (sprite-batch-switch-texture batch texture) 379 | "Change the currently bound texture for BATCH to TEXTURE. This 380 | requires flushing the batched texture vertices first." 381 | (sprite-batch-render batch) 382 | (set-sprite-batch-texture! batch texture)) 383 | 384 | (define (sprite-batch-render batch) 385 | "Render and flushes the currently batched texture vertices within 386 | BATCH." 387 | (unless (= (sprite-batch-size batch) 0) 388 | (draw-sprite-vertices (sprite-batch-texture batch) 389 | (sprite-batch-vertices batch) 390 | (sprite-batch-size batch)) 391 | ;; Reset batch size to 0. 392 | (set-sprite-batch-size! batch 0))) 393 | 394 | ;; emacs: (put 'with-sprite-batch 'scheme-indent-function 1) 395 | (define-syntax-rule (with-sprite-batch batch body ...) 396 | (begin 397 | (set! *sprite-batch* batch) 398 | (set-sprite-batch-size! batch 0) 399 | (set-sprite-batch-texture! batch #f) 400 | body 401 | ... 402 | (sprite-batch-render batch) 403 | (set! *sprite-batch* #f))) 404 | 405 | (export make-sprite-batch 406 | sprite-batch? 407 | sprite-batch-max-size 408 | sprite-batch-size 409 | set-sprite-batch-size! 410 | sprite-batch-texture 411 | set-sprite-batch-texture! 412 | sprite-batch-vertices 413 | sprite-batch-draw 414 | with-sprite-batch) 415 | -------------------------------------------------------------------------------- /2d/stage.scm: -------------------------------------------------------------------------------- 1 | ;;; guile-2d 2 | ;;; Copyright (C) 2013 David Thompson 3 | ;;; 4 | ;;; Guile-2d is free software: you can redistribute it and/or modify it 5 | ;;; under the terms of the GNU Lesser General Public License as 6 | ;;; published by the Free Software Foundation, either version 3 of the 7 | ;;; License, or (at your option) any later version. 8 | ;;; 9 | ;;; Guile-2d is distributed in the hope that it will be useful, but 10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | ;;; Lesser General Public License for more details. 13 | ;;; 14 | ;;; You should have received a copy of the GNU Lesser General Public 15 | ;;; License along with this program. If not, see 16 | ;;; . 17 | 18 | ;;; Commentary: 19 | ;; 20 | ;; Stages represent the game state at the present time. 21 | ;; 22 | ;;; Code: 23 | 24 | (define-module (2d stage) 25 | #:use-module (srfi srfi-9) 26 | #:use-module (2d agenda) 27 | #:use-module (2d scene) 28 | #:export (make-stage 29 | stage? 30 | stage-agenda 31 | stage-state 32 | stage-scene 33 | set-stage-scene! 34 | enter-stage 35 | exit-stage 36 | draw-stage 37 | update-stage 38 | stage-trigger 39 | make-stage-variable 40 | define-stage-variable 41 | stage-on 42 | stage-off 43 | current-stage 44 | push-scene 45 | pop-scene 46 | replace-scene)) 47 | 48 | (define-record-type 49 | (%make-stage agenda scene state) 50 | stage? 51 | (agenda stage-agenda) 52 | (scene stage-scene set-stage-scene!) 53 | (state stage-state)) 54 | 55 | (define (make-stage scene) 56 | "Create a new stage object for SCENE." 57 | (%make-stage (make-agenda) scene (init-scene scene))) 58 | 59 | ;;; 60 | ;;; Scene callbacks 61 | ;;; 62 | 63 | (define (enter-stage stage) 64 | "Call the scene enter callback for STAGE." 65 | (with-agenda (stage-agenda stage) 66 | (enter-scene (stage-scene stage) 67 | (stage-state stage)))) 68 | 69 | (define (exit-stage stage) 70 | "Call the scene exit callback for STAGE." 71 | (with-agenda (stage-agenda stage) 72 | (exit-scene (stage-scene stage) 73 | (stage-state stage)))) 74 | 75 | (define (update-stage stage) 76 | "Call the scene update callback for STAGE." 77 | (with-agenda (stage-agenda stage) 78 | (update-agenda) 79 | (update-scene (stage-scene stage) 80 | (stage-state stage)))) 81 | 82 | (define (draw-stage stage) 83 | "Call the scene draw callback for STAGE." 84 | (with-agenda (stage-agenda stage) 85 | (draw-scene (stage-scene stage) 86 | (stage-state stage)))) 87 | 88 | (define (stage-trigger stage event . args) 89 | (with-agenda (stage-agenda stage) 90 | (apply scene-trigger 91 | (stage-scene stage) 92 | (stage-state stage) 93 | event 94 | args))) 95 | 96 | ;;; 97 | ;;; Stage management 98 | ;;; 99 | 100 | (define stack '()) 101 | 102 | (define (current-stage) 103 | "Return the top of the stage stack or #f if the stack is empty." 104 | (if (null? stack) #f (car stack))) 105 | 106 | (define (push-scene scene) 107 | "Make STAGE active and push it to the top of the stack." 108 | (let ((prev-stage (current-stage)) 109 | (stage (make-stage scene))) 110 | (when prev-stage 111 | (exit-stage prev-stage)) 112 | (set! stack (cons stage stack)) 113 | (enter-stage stage))) 114 | 115 | (define (pop-scene) 116 | "Replace the current stage with the next one on the stack, if 117 | present." 118 | (let ((prev-stage (current-stage))) 119 | (when prev-stage 120 | (exit-stage prev-stage)) 121 | (set! stack (cdr stack)) 122 | (when (current-stage) 123 | (enter-stage (current-stage))))) 124 | 125 | (define (replace-scene scene) 126 | "Replace the current stage with STAGE." 127 | (let ((prev-stage (current-stage)) 128 | (stage (make-stage scene))) 129 | (when prev-stage 130 | (exit-stage prev-stage)) 131 | (set! stack (cons stage (cdr stack))) 132 | (enter-stage stage))) 133 | -------------------------------------------------------------------------------- /2d/texture.scm: -------------------------------------------------------------------------------- 1 | ;;; guile-2d 2 | ;;; Copyright (C) 2013 David Thompson 3 | ;;; 4 | ;;; Guile-2d is free software: you can redistribute it and/or modify it 5 | ;;; under the terms of the GNU Lesser General Public License as 6 | ;;; published by the Free Software Foundation, either version 3 of the 7 | ;;; License, or (at your option) any later version. 8 | ;;; 9 | ;;; Guile-2d is distributed in the hope that it will be useful, but 10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | ;;; Lesser General Public License for more details. 13 | ;;; 14 | ;;; You should have received a copy of the GNU Lesser General Public 15 | ;;; License along with this program. If not, see 16 | ;;; . 17 | 18 | ;;; Commentary: 19 | ;; 20 | ;; Textures and texture regions are high level wrappers over OpenGL 21 | ;; textures. 22 | ;; 23 | ;;; Code: 24 | 25 | (define-module (2d texture) 26 | #:use-module (srfi srfi-9) 27 | #:use-module (figl gl) 28 | #:use-module (2d wrappers gl) 29 | #:use-module (2d wrappers freeimage) 30 | #:use-module (2d helpers) 31 | #:export (make-texture 32 | make-texture-region 33 | load-texture 34 | texture? 35 | texture-region? 36 | texture-id 37 | texture-width 38 | texture-height 39 | texture-s1 40 | texture-t1 41 | texture-s2 42 | texture-t2 43 | surface->texture 44 | draw-texture)) 45 | 46 | ;;; 47 | ;;; Textures 48 | ;;; 49 | 50 | ;; The object is a simple wrapper around an OpenGL texture 51 | ;; id. 52 | (define-record-type 53 | (%make-texture id parent width height s1 t1 s2 t2) 54 | texture? 55 | (id texture-id) 56 | (parent texture-parent) 57 | (width texture-width) 58 | (height texture-height) 59 | (s1 texture-s1) 60 | (t1 texture-t1) 61 | (s2 texture-s2) 62 | (t2 texture-t2)) 63 | 64 | (define (texture-region? texture) 65 | "Return #t if TEXTURE has a parent texture." 66 | (texture? (texture-parent texture))) 67 | 68 | (define (make-texture id parent width height s1 t1 s2 t2) 69 | "Create a new texture object. ID is the OpenGL texture id. PARENT is 70 | a texture object (if this texture only represents a region of another 71 | texture) or #f. WIDTH and HEIGHT are the texture dimensions in 72 | pixels. S1, T1, S2, and T2 are the OpenGL texture coordinates 73 | representing the area of the texture that will be rendered." 74 | (let ((texture (%make-texture id parent width height s1 t1 s2 t2))) 75 | (texture-guardian texture) 76 | texture)) 77 | 78 | (define (make-texture-region texture x y width height) 79 | "Creates new texture region object. TEXTURE is the region's parent 80 | texture. X, Y, WIDTH, and HEIGHT represent the region of the texture 81 | that will be rendered, in pixels." 82 | (let* ((w (texture-width texture)) 83 | (h (texture-height texture))) 84 | (make-texture (texture-id texture) 85 | texture 86 | width 87 | height 88 | (/ x w) 89 | (/ y h) 90 | (/ (+ x width) w) 91 | (/ (+ y height) h)))) 92 | 93 | ;; Use a guardian and an after GC hook that ensures that OpenGL 94 | ;; textures are deleted when texture objects are GC'd. 95 | (define texture-guardian (make-guardian)) 96 | 97 | (define (reap-textures) 98 | (let loop ((texture (texture-guardian))) 99 | (when texture 100 | ;; Do not reap texture regions 101 | (unless (texture-region? texture) 102 | ;; When attempting to reap structures upon guile exit, the 103 | ;; dynamic pointer to gl-delete-textures becomes invalid. So, we 104 | ;; ignore the error and move on. 105 | (catch 'misc-error 106 | (lambda () (gl-delete-texture (texture-id texture))) 107 | (lambda (key . args) #f))) 108 | (loop (texture-guardian))))) 109 | 110 | (add-hook! after-gc-hook reap-textures) 111 | 112 | (define (bitmap->texture bitmap) 113 | "Translates a freeimage bitmap into an OpenGL texture." 114 | (let ((texture-id (gl-generate-texture)) 115 | (pixels (freeimage-get-bits bitmap))) 116 | (with-gl-bind-texture (texture-target texture-2d) texture-id 117 | ;; Use "nearest" scaling method so that pixel art doesn't become 118 | ;; blurry when scaled. 119 | (gl-texture-parameter (texture-target texture-2d) 120 | (texture-parameter-name texture-min-filter) 121 | (texture-min-filter nearest)) 122 | (gl-texture-parameter (texture-target texture-2d) 123 | (texture-parameter-name texture-mag-filter) 124 | (texture-mag-filter nearest)) 125 | (gl-texture-image-2d (texture-target texture-2d) 126 | 0 127 | (pixel-format rgba) 128 | (freeimage-get-width bitmap) 129 | (freeimage-get-height bitmap) 130 | 0 131 | (version-1-2 bgra) 132 | (color-pointer-type unsigned-byte) 133 | pixels)) 134 | (make-texture texture-id 135 | #f 136 | (freeimage-get-width bitmap) 137 | (freeimage-get-height bitmap) 138 | 0 0 1 1))) 139 | 140 | (define (load-bitmap filename) 141 | ;; Throw an error if image file does not exist or else we will 142 | ;; segfault later. 143 | (unless (file-exists? filename) 144 | (throw 'image-not-found filename)) 145 | ;; Load image and convert it to 32 bit color. 146 | (let* ((image-type (freeimage-get-file-type filename)) 147 | (bitmap (freeimage-load image-type filename)) 148 | (32bit-bitmap (freeimage-convert-to-32-bits bitmap))) 149 | (freeimage-unload bitmap) 150 | ;; Need to flip because y-axis is reversed. 151 | (freeimage-flip-vertical 32bit-bitmap) 152 | 32bit-bitmap)) 153 | 154 | (define (load-texture filename) 155 | "Load a texture from an image file at FILENAME." 156 | (let* ((bitmap (load-bitmap filename)) 157 | (texture (bitmap->texture bitmap))) 158 | (freeimage-unload bitmap) 159 | texture)) 160 | 161 | (define* (draw-texture texture x y #:optional (color #xffffffff)) 162 | "Render a textured quad in GL immediate mode." 163 | (let* ((x2 (+ x (texture-width texture))) 164 | (y2 (+ y (texture-height texture))) 165 | (color (rgba->gl-color color)) 166 | (r (vector-ref color 0)) 167 | (g (vector-ref color 1)) 168 | (b (vector-ref color 2)) 169 | (a (vector-ref color 3)) 170 | (s1 (texture-s1 texture)) 171 | (t1 (texture-t1 texture)) 172 | (s2 (texture-s2 texture)) 173 | (t2 (texture-t2 texture))) 174 | (with-gl-bind-texture (texture-target texture-2d) (texture-id texture) 175 | (gl-begin (begin-mode quads) 176 | (gl-color r g b a) 177 | (gl-texture-coordinates s1 t1) 178 | (gl-vertex x y) 179 | (gl-texture-coordinates s1 t2) 180 | (gl-vertex x y2) 181 | (gl-texture-coordinates s2 t2) 182 | (gl-vertex x2 y2) 183 | (gl-texture-coordinates s2 t1) 184 | (gl-vertex x2 y))))) 185 | -------------------------------------------------------------------------------- /2d/tileset.scm: -------------------------------------------------------------------------------- 1 | ;;; guile-2d 2 | ;;; Copyright (C) 2013 David Thompson 3 | ;;; 4 | ;;; Guile-2d is free software: you can redistribute it and/or modify it 5 | ;;; under the terms of the GNU Lesser General Public License as 6 | ;;; published by the Free Software Foundation, either version 3 of the 7 | ;;; License, or (at your option) any later version. 8 | ;;; 9 | ;;; Guile-2d is distributed in the hope that it will be useful, but 10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | ;;; Lesser General Public License for more details. 13 | ;;; 14 | ;;; You should have received a copy of the GNU Lesser General Public 15 | ;;; License along with this program. If not, see 16 | ;;; . 17 | 18 | ;;; Commentary: 19 | ;; 20 | ;; Tilesets encapsulate a group of uniformly sized texture regions 21 | ;; that come from a single texture. 22 | ;; 23 | ;;; Code: 24 | 25 | (define-module (2d tileset) 26 | #:use-module (srfi srfi-9) 27 | #:use-module (srfi srfi-42) 28 | #:use-module (2d texture) 29 | #:export ( 30 | make-tileset 31 | load-tileset 32 | tileset? 33 | tileset-tiles 34 | tileset-width 35 | tileset-height 36 | tileset-margin 37 | tileset-spacing 38 | tileset-ref)) 39 | 40 | (define-record-type 41 | (%make-tileset tiles width height margin spacing) 42 | tileset? 43 | (tiles tileset-tiles) 44 | (width tileset-width) 45 | (height tileset-height) 46 | (margin tileset-margin) 47 | (spacing tileset-spacing)) 48 | 49 | (define (split-texture texture width height margin spacing) 50 | "Split TEXTURE into a vector of texture regions of WIDTH x HEIGHT 51 | size. SPACING refers to the number of pixels separating each 52 | tile. MARGIN refers to the number of pixels on the top and left of 53 | TEXTURE before the first tile begins." 54 | (define (build-tile tx ty) 55 | (let* ((x (+ (* tx (+ width spacing)) margin)) 56 | (y (+ (* ty (+ height spacing)) margin))) 57 | (make-texture-region texture x y width height))) 58 | 59 | (let* ((tw (texture-width texture)) 60 | (th (texture-height texture)) 61 | (rows (/ (- tw margin) (+ width spacing))) 62 | (columns (/ (- tw margin) (+ height spacing)))) 63 | (vector-ec (: y rows) (: x columns) (build-tile x y)))) 64 | 65 | (define* (make-tileset texture width height 66 | #:optional #:key (margin 0) (spacing 0)) 67 | "Return a new tileset that is built by splitting TEXTURE into 68 | tiles." 69 | (let ((tiles (split-texture texture 70 | width 71 | height 72 | margin 73 | spacing))) 74 | (%make-tileset tiles width height margin spacing))) 75 | 76 | (define* (load-tileset filename width height 77 | #:optional #:key (margin 0) (spacing 0)) 78 | "Return a new tileset that is built by loading the texture at 79 | FILENAME and splitting the texture into tiles." 80 | (let* ((tiles (split-texture (load-texture filename) 81 | width 82 | height 83 | margin 84 | spacing))) 85 | (%make-tileset tiles width height margin spacing))) 86 | 87 | (define (tileset-ref tileset i) 88 | "Return the tile texture of TILESET at index I." 89 | (vector-ref (tileset-tiles tileset) i)) 90 | -------------------------------------------------------------------------------- /2d/vector2.scm: -------------------------------------------------------------------------------- 1 | ;;; guile-2d 2 | ;;; Copyright (C) 2013 David Thompson 3 | ;;; 4 | ;;; Guile-2d is free software: you can redistribute it and/or modify it 5 | ;;; under the terms of the GNU Lesser General Public License as 6 | ;;; published by the Free Software Foundation, either version 3 of the 7 | ;;; License, or (at your option) any later version. 8 | ;;; 9 | ;;; Guile-2d is distributed in the hope that it will be useful, but 10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | ;;; Lesser General Public License for more details. 13 | ;;; 14 | ;;; You should have received a copy of the GNU Lesser General Public 15 | ;;; License along with this program. If not, see 16 | ;;; . 17 | 18 | ;;; Commentary: 19 | ;; 20 | ;; 2D vector math operations. 21 | ;; 22 | ;;; Code: 23 | 24 | (define-module (2d vector2) 25 | #:use-module (figl gl) 26 | #:use-module (srfi srfi-1) 27 | #:use-module (srfi srfi-9) 28 | #:export ( 29 | vector2 30 | vector2? 31 | vx 32 | vy 33 | null-vector2 34 | identity-vector2 35 | vector2-polar 36 | v+ 37 | v* 38 | vscale 39 | vmag 40 | vnorm 41 | vdot 42 | vcross 43 | vector2-translate 44 | vector2-scale)) 45 | 46 | (define-record-type 47 | (vector2 x y) 48 | vector2? 49 | (x vx) 50 | (y vy)) 51 | 52 | (define null-vector2 (vector2 0 0)) 53 | (define identity-vector2 (vector2 1 1)) 54 | 55 | (define (vector2-polar r theta) 56 | "Convert the polar coordinates (R, THETA) into a cartesian vector." 57 | (vector2 (* r (cos theta)) 58 | (* r (sin theta)))) 59 | 60 | (define (v+ . vectors) 61 | "Return the sum of all VECTORS." 62 | (define (add-vectors x y vectors) 63 | (cond ((null? vectors) 64 | (vector2 x y)) 65 | (else 66 | (add-vectors (+ x (vx (car vectors))) 67 | (+ y (vy (car vectors))) 68 | (cdr vectors))))) 69 | (add-vectors 0 0 vectors)) 70 | 71 | (define (v* . vectors) 72 | "Return the product of all VECTORS." 73 | (define (multiply-vectors x y vectors) 74 | (cond ((null? vectors) 75 | (vector2 x y)) 76 | (else 77 | (multiply-vectors (* x (vx (car vectors))) 78 | (* y (vy (car vectors))) 79 | (cdr vectors))))) 80 | (multiply-vectors 1 1 vectors)) 81 | 82 | (define (vscale v scalar) 83 | "Multiply the vector V by a scalar value." 84 | (vector2 (* (vx v) scalar) 85 | (* (vy v) scalar))) 86 | 87 | (define (vmag v) 88 | "Return the magnitude of the vector V." 89 | (sqrt (+ (expt (vx v) 2) 90 | (expt (vy v) 2)))) 91 | 92 | (define (vnorm v) 93 | "Normalize the vector V." 94 | (let ((m (vmag v))) 95 | (if (zero? m) 96 | null-vector2 97 | (vector2 (/ (vx v) m) 98 | (/ (vy v) m))))) 99 | 100 | (define (vdot v1 v2) 101 | "Return the dot product of the vectors V1 and V2." 102 | (+ (* (vx v1) (vx v2)) 103 | (* (vy v1) (vy v2)))) 104 | 105 | (define (vcross v1 v2) 106 | "Return the cross product of the vectors V1 and V2. Technically, the 107 | cross product of a 2D vector is not defined. This function instead 108 | returns the Z coordinate of the cross product as if the vectors were 109 | in 3D space." 110 | (- (* (vx v1) (vy v2)) 111 | (* (vy v1) (vx v2)))) 112 | 113 | (define (vector2-translate v) 114 | "Perform an OpenGL translate operation with the vector V." 115 | (gl-translate (vx v) (vy v) 0)) 116 | 117 | (define (vector2-scale v) 118 | "Perform an OpenGL scale operation with the vector V." 119 | (gl-scale (vx v) (vy v) 1)) 120 | -------------------------------------------------------------------------------- /2d/window.scm: -------------------------------------------------------------------------------- 1 | ;;; guile-2d 2 | ;;; Copyright (C) 2013 David Thompson 3 | ;;; 4 | ;;; Guile-2d is free software: you can redistribute it and/or modify it 5 | ;;; under the terms of the GNU Lesser General Public License as 6 | ;;; published by the Free Software Foundation, either version 3 of the 7 | ;;; License, or (at your option) any later version. 8 | ;;; 9 | ;;; Guile-2d is distributed in the hope that it will be useful, but 10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | ;;; Lesser General Public License for more details. 13 | ;;; 14 | ;;; You should have received a copy of the GNU Lesser General Public 15 | ;;; License along with this program. If not, see 16 | ;;; . 17 | 18 | ;;; Commentary: 19 | ;; 20 | ;; Window management. 21 | ;; 22 | ;;; Code: 23 | 24 | (define-module (2d window) 25 | #:use-module (figl gl) 26 | #:use-module ((sdl sdl) #:prefix SDL:) 27 | #:use-module ((sdl mixer) #:prefix SDL:) 28 | #:use-module (2d vector2) 29 | #:export (open-window 30 | close-window)) 31 | 32 | (define* (open-window title resolution fullscreen) 33 | "Open the game window with the given TITLE and RESOLUTION. If 34 | FULLSCREEN is #t, open a fullscreen window." 35 | (let ((flags (if fullscreen '(opengl fullscreen) 'opengl)) 36 | (width (vx resolution)) 37 | (height (vy resolution))) 38 | ;; Initialize everything 39 | (SDL:enable-unicode #t) 40 | (SDL:init 'everything) 41 | (SDL:open-audio) 42 | ;; Open SDL window in OpenGL mode. 43 | (SDL:set-video-mode width height 24 flags) 44 | (SDL:set-caption title) 45 | ;; Initialize OpenGL orthographic view 46 | (gl-viewport 0 0 width height) 47 | (set-gl-matrix-mode (matrix-mode projection)) 48 | (gl-load-identity) 49 | (gl-ortho 0 width height 0 -1 1) 50 | (set-gl-matrix-mode (matrix-mode modelview)) 51 | (gl-load-identity) 52 | ;; Enable texturing and alpha blending 53 | (gl-enable (enable-cap texture-2d)) 54 | (gl-enable (enable-cap blend)) 55 | (set-gl-blend-function (blending-factor-src src-alpha) 56 | (blending-factor-dest one-minus-src-alpha)))) 57 | 58 | (define (close-window) 59 | "Close the game window and audio." 60 | (SDL:close-audio) 61 | (SDL:quit)) 62 | -------------------------------------------------------------------------------- /2d/wrappers/freeimage.scm: -------------------------------------------------------------------------------- 1 | ;;; guile-2d 2 | ;;; Copyright (C) 2013 David Thompson 3 | ;;; 4 | ;;; Guile-2d is free software: you can redistribute it and/or modify it 5 | ;;; under the terms of the GNU Lesser General Public License as 6 | ;;; published by the Free Software Foundation, either version 3 of the 7 | ;;; License, or (at your option) any later version. 8 | ;;; 9 | ;;; Guile-2d is distributed in the hope that it will be useful, but 10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | ;;; Lesser General Public License for more details. 13 | ;;; 14 | ;;; You should have received a copy of the GNU Lesser General Public 15 | ;;; License along with this program. If not, see 16 | ;;; . 17 | 18 | ;;; Commentary: 19 | ;; 20 | ;; Quick and dirty wrapper for some freeimage functions. 21 | ;; 22 | ;;; Code: 23 | 24 | (define-module (2d wrappers freeimage) 25 | #:use-module (system foreign) 26 | #:use-module (2d wrappers util) 27 | #:use-module (ice-9 format)) 28 | 29 | (define libfreeimage (dynamic-link "libfreeimage")) 30 | 31 | (define-syntax-rule (define-foreign name ret string-name args) 32 | (define name 33 | (pointer->procedure ret (dynamic-func string-name libfreeimage) args))) 34 | 35 | (define (number->boolean n) 36 | (not (zero? n))) 37 | 38 | ;;; 39 | ;;; FreeImage file formats 40 | ;;; 41 | 42 | (define-enumeration freeimage-format 43 | (unknown -1) 44 | (bmp 0) 45 | (ico 1) 46 | (jpeg 2) 47 | (jng 3) 48 | (koala 4) 49 | (lbm 5) 50 | (iff 5) 51 | (mng 6) 52 | (pbm 7) 53 | (pbmraw 8) 54 | (pcd 9) 55 | (pcx 10) 56 | (pgm 11) 57 | (pgmraw 12) 58 | (png 13) 59 | (ppm 14) 60 | (ppmraw 15) 61 | (ras 16) 62 | (targa 17) 63 | (tiff 18) 64 | (wbmp 19) 65 | (psd 20) 66 | (cut 21) 67 | (xbm 22) 68 | (xpm 23) 69 | (dds 24) 70 | (gif 25) 71 | (hdr 26) 72 | (faxg3 27) 73 | (sgi 28) 74 | (exr 29) 75 | (j2k 30) 76 | (jp2 31) 77 | (pfm 32) 78 | (pict 33) 79 | (raw 34)) 80 | 81 | (export freeimage-format) 82 | 83 | ;;; 84 | ;;; General functions 85 | ;;; 86 | 87 | (define-foreign %freeimage-get-version 88 | '* "FreeImage_GetVersion" '()) 89 | (define-foreign %freeimage-set-output-message 90 | void "FreeImage_SetOutputMessage" '(*)) 91 | 92 | (define (freeimage-get-version) 93 | (pointer->string (%freeimage-get-version))) 94 | 95 | (define (freeimage-set-output-message callback) 96 | (%freeimage-set-output-message 97 | (procedure->pointer void 98 | (lambda (image-format message) 99 | (callback image-format (pointer->string message))) 100 | (list unsigned-int '*)))) 101 | 102 | ;; Set a default output message callback to writes to stdout. 103 | (freeimage-set-output-message 104 | (lambda (image-format message) 105 | (display "freeimage error: ") 106 | (display message) 107 | (newline))) 108 | 109 | (export freeimage-get-version 110 | freeimage-set-output-message) 111 | 112 | 113 | ;;; 114 | ;;; Bitmap management functions 115 | ;;; 116 | 117 | (define-wrapped-pointer-type 118 | freeimage-bitmap? 119 | wrap-freeimage-bitmap unwrap-freeimage-bitmap 120 | (lambda (r port) 121 | (let ((bitmap (unwrap-freeimage-bitmap r))) 122 | (format port 123 | "" 124 | (pointer-address bitmap) 125 | (%freeimage-get-width bitmap) 126 | (%freeimage-get-height bitmap) 127 | (%freeimage-get-bpp bitmap))))) 128 | 129 | (define-foreign %freeimage-load 130 | '* "FreeImage_Load" (list unsigned-int '* unsigned-int)) 131 | (define-foreign %freeimage-unload 132 | void "FreeImage_Unload" '(*)) 133 | 134 | (define (freeimage-load image-format filename) 135 | (wrap-freeimage-bitmap 136 | (%freeimage-load image-format (string->pointer filename) 0))) 137 | 138 | (define (freeimage-unload bitmap) 139 | (%freeimage-unload (unwrap-freeimage-bitmap bitmap))) 140 | 141 | (export 142 | freeimage-bitmap? 143 | freeimage-load 144 | freeimage-unload) 145 | 146 | ;;; 147 | ;;; Bitmap information functions 148 | ;;; 149 | 150 | (define-foreign %freeimage-get-image-type 151 | unsigned-int "FreeImage_GetImageType" '(*)) 152 | (define-foreign %freeimage-get-bpp 153 | unsigned-int "FreeImage_GetBPP" '(*)) 154 | (define-foreign %freeimage-get-width 155 | unsigned-int "FreeImage_GetWidth" '(*)) 156 | (define-foreign %freeimage-get-height 157 | unsigned-int "FreeImage_GetHeight" '(*)) 158 | (define-foreign %freeimage-get-pitch 159 | unsigned-int "FreeImage_GetPitch" '(*)) 160 | (define-foreign %freeimage-get-red-mask 161 | unsigned-int "FreeImage_GetRedMask" '(*)) 162 | (define-foreign %freeimage-get-green-mask 163 | unsigned-int "FreeImage_GetGreenMask" '(*)) 164 | (define-foreign %freeimage-get-blue-mask 165 | unsigned-int "FreeImage_GetBlueMask" '(*)) 166 | (define-foreign %freeimage-has-pixels 167 | unsigned-int "FreeImage_HasPixels" '(*)) 168 | 169 | (define (freeimage-get-image-type bitmap) 170 | (%freeimage-get-image-type (unwrap-freeimage-bitmap bitmap))) 171 | 172 | (define (freeimage-get-bpp bitmap) 173 | (%freeimage-get-bpp (unwrap-freeimage-bitmap bitmap))) 174 | 175 | (define (freeimage-get-width bitmap) 176 | (%freeimage-get-width (unwrap-freeimage-bitmap bitmap))) 177 | 178 | (define (freeimage-get-height bitmap) 179 | (%freeimage-get-height (unwrap-freeimage-bitmap bitmap))) 180 | 181 | (define (freeimage-get-pitch bitmap) 182 | (%freeimage-get-pitch (unwrap-freeimage-bitmap bitmap))) 183 | 184 | (define (freeimage-get-red-mask bitmap) 185 | (%freeimage-get-red-mask (unwrap-freeimage-bitmap bitmap))) 186 | 187 | (define (freeimage-get-green-mask bitmap) 188 | (%freeimage-get-green-mask (unwrap-freeimage-bitmap bitmap))) 189 | 190 | (define (freeimage-get-blue-mask bitmap) 191 | (%freeimage-get-blue-mask (unwrap-freeimage-bitmap bitmap))) 192 | 193 | (define (freeimage-has-pixels? bitmap) 194 | (number->boolean 195 | (%freeimage-has-pixels (unwrap-freeimage-bitmap bitmap)))) 196 | 197 | (export freeimage-get-image-type 198 | freeimage-get-bpp 199 | freeimage-get-width 200 | freeimage-get-height 201 | freeimage-get-red-mask 202 | freeimage-get-green-mask 203 | freeimage-get-blue-mask 204 | freeimage-has-pixels?) 205 | 206 | ;;; 207 | ;;; Filetype functions 208 | ;;; 209 | 210 | (define-foreign %freeimage-get-file-type 211 | unsigned-int "FreeImage_GetFileType" (list '* int)) 212 | 213 | (define (freeimage-get-file-type filename) 214 | (%freeimage-get-file-type (string->pointer filename) 0)) 215 | 216 | (export freeimage-get-file-type) 217 | 218 | ;;; 219 | ;;; Pixel access functions 220 | ;;; 221 | 222 | (define-foreign %freeimage-get-bits '* "FreeImage_GetBits" '(*)) 223 | 224 | (define (freeimage-get-bits bitmap) 225 | (pointer->bytevector 226 | (%freeimage-get-bits (unwrap-freeimage-bitmap bitmap)) 227 | (* (freeimage-get-height bitmap) 228 | (freeimage-get-pitch bitmap)))) 229 | 230 | (export freeimage-get-bits) 231 | 232 | ;;; 233 | ;;; Conversion functions 234 | ;;; 235 | 236 | (define-foreign %freeimage-convert-to-24-bits 237 | '* "FreeImage_ConvertTo24Bits" '(*)) 238 | (define-foreign %freeimage-convert-to-32-bits 239 | '* "FreeImage_ConvertTo32Bits" '(*)) 240 | 241 | (define (freeimage-convert-to-24-bits bitmap) 242 | (wrap-freeimage-bitmap 243 | (%freeimage-convert-to-24-bits (unwrap-freeimage-bitmap bitmap)))) 244 | 245 | (define (freeimage-convert-to-32-bits bitmap) 246 | (wrap-freeimage-bitmap 247 | (%freeimage-convert-to-32-bits (unwrap-freeimage-bitmap bitmap)))) 248 | 249 | (export freeimage-convert-to-24-bits 250 | freeimage-convert-to-32-bits) 251 | 252 | ;;; 253 | ;;; Rotation and flipping 254 | ;;; 255 | 256 | (define-foreign %freeimage-flip-vertical 257 | uint8 "FreeImage_FlipVertical" '(*)) 258 | 259 | (define (freeimage-flip-vertical bitmap) 260 | (number->boolean 261 | (%freeimage-flip-vertical (unwrap-freeimage-bitmap bitmap)))) 262 | 263 | (export freeimage-flip-vertical) 264 | -------------------------------------------------------------------------------- /2d/wrappers/ftgl.scm: -------------------------------------------------------------------------------- 1 | ;;; guile-2d 2 | ;;; Copyright (C) 2013 David Thompson 3 | ;;; 4 | ;;; Guile-2d is free software: you can redistribute it and/or modify it 5 | ;;; under the terms of the GNU Lesser General Public License as 6 | ;;; published by the Free Software Foundation, either version 3 of the 7 | ;;; License, or (at your option) any later version. 8 | ;;; 9 | ;;; Guile-2d is distributed in the hope that it will be useful, but 10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | ;;; Lesser General Public License for more details. 13 | ;;; 14 | ;;; You should have received a copy of the GNU Lesser General Public 15 | ;;; License along with this program. If not, see 16 | ;;; . 17 | 18 | ;;; Commentary: 19 | ;; 20 | ;; Quick and dirty wrapper for the FTGL library. 21 | ;; 22 | ;;; Code: 23 | 24 | (define-module (2d wrappers ftgl) 25 | #:use-module (system foreign) 26 | #:use-module (2d wrappers util) 27 | #:use-module (ice-9 format)) 28 | 29 | (define libftgl (dynamic-link "libftgl")) 30 | 31 | (define-syntax-rule (define-foreign name ret string-name args) 32 | (define name 33 | (pointer->procedure ret (dynamic-func string-name libftgl) args))) 34 | 35 | ;;; 36 | ;;; Enums 37 | ;;; 38 | 39 | (define-enumeration ftgl-render-mode 40 | (front #x0001) 41 | (back #x0002) 42 | (side #x0004) 43 | (all #xffff)) 44 | 45 | (define-enumeration ftgl-text-alignment 46 | (left 0) 47 | (center 1) 48 | (right 2) 49 | (justify 3)) 50 | 51 | (export ftgl-render-mode 52 | ftgl-text-alignment) 53 | 54 | ;;; 55 | ;;; Fonts 56 | ;;; 57 | 58 | (define-wrapped-pointer-type 59 | ftgl-font? 60 | wrap-ftgl-font unwrap-ftgl-font 61 | (lambda (r port) 62 | (let ((font (unwrap-ftgl-font r))) 63 | (format port 64 | "" 65 | (pointer-address font))))) 66 | 67 | (define-foreign %ftgl-create-texture-font 68 | '* "ftglCreateTextureFont" '(*)) 69 | 70 | (define-foreign %ftgl-set-font-face-size 71 | void "ftglSetFontFaceSize" (list '* unsigned-int unsigned-int)) 72 | 73 | (define-foreign %ftgl-render-font 74 | void "ftglRenderFont" (list '* '* unsigned-int)) 75 | 76 | (define-foreign %ftgl-get-font-descender 77 | float "ftglGetFontDescender" '(*)) 78 | 79 | (define-foreign %ftgl-get-font-ascender 80 | float "ftglGetFontAscender" '(*)) 81 | 82 | (define (ftgl-create-texture-font filename) 83 | (unless (file-exists? filename) 84 | (throw 'font-not-found filename)) 85 | (let ((font (%ftgl-create-texture-font (string->pointer filename)))) 86 | (when (null-pointer? font) 87 | (throw 'font-load-failure filename)) 88 | (wrap-ftgl-font font))) 89 | 90 | (define (ftgl-set-font-face-size font size res) 91 | (%ftgl-set-font-face-size (unwrap-ftgl-font font) size res)) 92 | 93 | (define (ftgl-render-font font text render-mode) 94 | (%ftgl-render-font (unwrap-ftgl-font font) 95 | (string->pointer text) 96 | render-mode)) 97 | 98 | (define (ftgl-get-font-descender font) 99 | (%ftgl-get-font-descender (unwrap-ftgl-font font))) 100 | 101 | (define (ftgl-get-font-ascender font) 102 | (%ftgl-get-font-ascender (unwrap-ftgl-font font))) 103 | 104 | (export ftgl-create-texture-font 105 | ftgl-set-font-face-size 106 | ftgl-render-font 107 | ftgl-get-font-descender 108 | ftgl-get-font-ascender) 109 | 110 | ;;; 111 | ;;; SimpleLayout 112 | ;;; 113 | 114 | (define-wrapped-pointer-type 115 | ftgl-simple-layout? 116 | wrap-ftgl-simple-layout unwrap-ftgl-simple-layout 117 | (lambda (r port) 118 | (let ((simple-layout (unwrap-ftgl-simple-layout r))) 119 | (format port 120 | "" 121 | (pointer-address simple-layout))))) 122 | 123 | (define-foreign %ftgl-create-simple-layout 124 | '* "ftglCreateSimpleLayout" '()) 125 | 126 | (define-foreign %ftgl-destroy-layout 127 | void "ftglDestroyLayout" '(*)) 128 | 129 | (define-foreign %ftgl-set-layout-font 130 | void "ftglSetLayoutFont" '(* *)) 131 | 132 | (define-foreign %ftgl-get-layout-font 133 | '* "ftglGetLayoutFont" '(*)) 134 | 135 | (define-foreign %ftgl-set-layout-line-length 136 | void "ftglSetLayoutLineLength" (list '* float)) 137 | 138 | (define-foreign %ftgl-get-layout-line-length 139 | float "ftglGetLayoutLineLength" '(*)) 140 | 141 | (define-foreign %ftgl-set-layout-alignment 142 | void "ftglSetLayoutAlignment" (list '* int)) 143 | 144 | (define-foreign %ftgl-get-layout-alignment 145 | int "ftglGetLayoutAlignement" '(*)) 146 | 147 | (define-foreign %ftgl-set-layout-line-spacing 148 | void "ftglSetLayoutLineSpacing" (list '* float)) 149 | 150 | ;; For some reason this symbol is not found. 151 | ;; (define-foreign %ftgl-get-layout-line-spacing 152 | ;; float "ftglGetLayoutLineSpacing" '(*)) 153 | 154 | (define-foreign %ftgl-render-layout 155 | void "ftglRenderLayout" (list '* '* int)) 156 | 157 | (define (ftgl-create-layout) 158 | (wrap-ftgl-simple-layout 159 | (%ftgl-create-simple-layout))) 160 | 161 | (define (ftgl-destroy-layout layout) 162 | (%ftgl-destroy-layout (unwrap-ftgl-simple-layout layout))) 163 | 164 | (define (ftgl-set-layout-font layout font) 165 | (%ftgl-set-layout-font (unwrap-ftgl-simple-layout layout) 166 | (unwrap-ftgl-font font))) 167 | 168 | (define (ftgl-get-layout-font layout) 169 | (wrap-ftgl-font 170 | (%ftgl-get-layout-font (unwrap-ftgl-simple-layout layout)))) 171 | 172 | (define (ftgl-set-layout-line-length layout line-length) 173 | (%ftgl-set-layout-line-length (unwrap-ftgl-simple-layout layout) 174 | line-length)) 175 | 176 | (define (ftgl-get-layout-line-length layout) 177 | (%ftgl-get-layout-line-length (unwrap-ftgl-simple-layout layout))) 178 | 179 | (define (ftgl-set-layout-alignment layout alignment) 180 | (%ftgl-set-layout-alignment (unwrap-ftgl-simple-layout layout) 181 | alignment)) 182 | 183 | (define (ftgl-get-layout-alignment layout) 184 | (%ftgl-get-layout-alignment (unwrap-ftgl-simple-layout layout))) 185 | 186 | (define (ftgl-set-layout-line-spacing layout spacing) 187 | (%ftgl-set-layout-line-spacing (unwrap-ftgl-simple-layout layout) 188 | spacing)) 189 | 190 | (define (ftgl-render-layout layout text mode) 191 | (%ftgl-render-layout (unwrap-ftgl-simple-layout layout) 192 | (string->pointer text) 193 | mode)) 194 | 195 | (export ftgl-create-layout 196 | ftgl-destroy-layout 197 | ftgl-set-layout-font 198 | ftgl-get-layout-font 199 | ftgl-set-layout-line-length 200 | ftgl-get-layout-line-length 201 | ftgl-set-layout-alignment 202 | ftgl-get-layout-alignment 203 | ftgl-set-layout-line-spacing 204 | ftgl-render-layout) 205 | -------------------------------------------------------------------------------- /2d/wrappers/gl.scm: -------------------------------------------------------------------------------- 1 | ;;; guile-2d 2 | ;;; Copyright (C) 2013 David Thompson 3 | ;;; 4 | ;;; Guile-2d is free software: you can redistribute it and/or modify it 5 | ;;; under the terms of the GNU Lesser General Public License as 6 | ;;; published by the Free Software Foundation, either version 3 of the 7 | ;;; License, or (at your option) any later version. 8 | ;;; 9 | ;;; Guile-2d is distributed in the hope that it will be useful, but 10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | ;;; Lesser General Public License for more details. 13 | ;;; 14 | ;;; You should have received a copy of the GNU Lesser General Public 15 | ;;; License along with this program. If not, see 16 | ;;; . 17 | 18 | ;;; Commentary: 19 | ;; 20 | ;; Custom wrappers over low level OpenGL commands that aren't part of 21 | ;; FIGL. 22 | ;; 23 | ;;; Code: 24 | 25 | (define-module (2d wrappers gl) 26 | #:use-module (figl runtime) 27 | #:use-module ((figl gl low-level) #:renamer (symbol-prefix-proc '%)) 28 | #:export (pixel-format*)) 29 | 30 | ;;; 31 | ;;; 3.8.1 Texture Image Specification 32 | ;;; 33 | 34 | (re-export (%glTexImage3D . gl-texture-image-3d) 35 | (%glTexImage2D . gl-texture-image-2d) 36 | (%glTexImage1D . gl-texture-image-1d)) 37 | 38 | ;;; 39 | ;;; 3.8.2 Alternate Texture Image Specification Commands 40 | ;;; 41 | 42 | (re-export (%glCopyTexImage2D . gl-copy-texture-image-2d) 43 | (%glCopyTexImage1D . gl-copy-texture-image-1d) 44 | (%glCopyTexSubImage3D . gl-copy-texture-sub-image-3d) 45 | (%glCopyTexSubImage2D . gl-copy-texture-sub-image-2d) 46 | (%glCopyTexSubImage1D . gl-copy-texture-sub-image-1d) 47 | (%glTexSubImage3D . gl-texture-sub-image-3d) 48 | (%glTexSubImage2D . gl-texture-sub-image-2d) 49 | (%glTexSubImage1D . gl-texture-sub-image-1d)) 50 | 51 | ;;; 52 | ;;; 3.8.3 Compressed Texture Images 53 | ;;; 54 | 55 | (re-export (%glCompressedTexImage1D . gl-compressed-texture-image-1d) 56 | (%glCompressedTexImage2D . gl-compressed-texture-image-2d) 57 | (%glCompressedTexImage3D . gl-compressed-texture-image-3d) 58 | (%glCompressedTexSubImage1D . gl-compressed-texture-sub-image-1d) 59 | (%glCompressedTexSubImage2D . gl-compressed-texture-sub-image-2d) 60 | (%glCompressedTexSubImage3D . gl-compressed-texture-sub-image-3d)) 61 | 62 | ;;; 63 | ;;; 3.8.4 Texture Parameters 64 | ;;; 65 | 66 | (re-export (%glTexParameteri . gl-texture-parameter)) 67 | 68 | ;; emacs: (put 'with-gl-bind-texture 'scheme-indent-function 2) 69 | (define-syntax-rule (with-gl-bind-texture target id body ...) 70 | (begin 71 | (%glBindTexture target id) 72 | body 73 | ... 74 | (%glBindTexture target 0))) 75 | 76 | (export with-gl-bind-texture) 77 | -------------------------------------------------------------------------------- /2d/wrappers/util.scm: -------------------------------------------------------------------------------- 1 | ;;; guile-2d 2 | ;;; Copyright (C) 2013 David Thompson 3 | ;;; 4 | ;;; Guile-2d is free software: you can redistribute it and/or modify it 5 | ;;; under the terms of the GNU Lesser General Public License as 6 | ;;; published by the Free Software Foundation, either version 3 of the 7 | ;;; License, or (at your option) any later version. 8 | ;;; 9 | ;;; Guile-2d is distributed in the hope that it will be useful, but 10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of 11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | ;;; Lesser General Public License for more details. 13 | ;;; 14 | ;;; You should have received a copy of the GNU Lesser General Public 15 | ;;; License along with this program. If not, see 16 | ;;; . 17 | 18 | ;;; Commentary: 19 | ;; 20 | ;; Wrapper helper procedures. 21 | ;; 22 | ;;; Code: 23 | 24 | (define-module (2d wrappers util) 25 | #:export (define-enumeration)) 26 | 27 | ;; Borrowed from guile-figl 28 | (define-syntax-rule (define-enumeration enumerator (name value) ...) 29 | (define-syntax enumerator 30 | (lambda (x) 31 | (syntax-case x () 32 | ((_) 33 | #''(name ...)) 34 | ((_ enum) (number? (syntax->datum #'enum)) 35 | #'enum) 36 | ((_ enum) 37 | (or (assq-ref '((name . value) ...) 38 | (syntax->datum #'enum)) 39 | (syntax-violation 'enumerator "invalid enumerated value" 40 | #'enum))))))) 41 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | 9 | This version of the GNU Lesser General Public License incorporates 10 | the terms and conditions of version 3 of the GNU General Public 11 | License, supplemented by the additional permissions listed below. 12 | 13 | 0. Additional Definitions. 14 | 15 | As used herein, "this License" refers to version 3 of the GNU Lesser 16 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 17 | General Public License. 18 | 19 | "The Library" refers to a covered work governed by this License, 20 | other than an Application or a Combined Work as defined below. 21 | 22 | An "Application" is any work that makes use of an interface provided 23 | by the Library, but which is not otherwise based on the Library. 24 | Defining a subclass of a class defined by the Library is deemed a mode 25 | of using an interface provided by the Library. 26 | 27 | A "Combined Work" is a work produced by combining or linking an 28 | Application with the Library. The particular version of the Library 29 | with which the Combined Work was made is also called the "Linked 30 | Version". 31 | 32 | The "Minimal Corresponding Source" for a Combined Work means the 33 | Corresponding Source for the Combined Work, excluding any source code 34 | for portions of the Combined Work that, considered in isolation, are 35 | based on the Application, and not on the Linked Version. 36 | 37 | The "Corresponding Application Code" for a Combined Work means the 38 | object code and/or source code for the Application, including any data 39 | and utility programs needed for reproducing the Combined Work from the 40 | Application, but excluding the System Libraries of the Combined Work. 41 | 42 | 1. Exception to Section 3 of the GNU GPL. 43 | 44 | You may convey a covered work under sections 3 and 4 of this License 45 | without being bound by section 3 of the GNU GPL. 46 | 47 | 2. Conveying Modified Versions. 48 | 49 | If you modify a copy of the Library, and, in your modifications, a 50 | facility refers to a function or data to be supplied by an Application 51 | that uses the facility (other than as an argument passed when the 52 | facility is invoked), then you may convey a copy of the modified 53 | version: 54 | 55 | a) under this License, provided that you make a good faith effort to 56 | ensure that, in the event an Application does not supply the 57 | function or data, the facility still operates, and performs 58 | whatever part of its purpose remains meaningful, or 59 | 60 | b) under the GNU GPL, with none of the additional permissions of 61 | this License applicable to that copy. 62 | 63 | 3. Object Code Incorporating Material from Library Header Files. 64 | 65 | The object code form of an Application may incorporate material from 66 | a header file that is part of the Library. You may convey such object 67 | code under terms of your choice, provided that, if the incorporated 68 | material is not limited to numerical parameters, data structure 69 | layouts and accessors, or small macros, inline functions and templates 70 | (ten or fewer lines in length), you do both of the following: 71 | 72 | a) Give prominent notice with each copy of the object code that the 73 | Library is used in it and that the Library and its use are 74 | covered by this License. 75 | 76 | b) Accompany the object code with a copy of the GNU GPL and this license 77 | document. 78 | 79 | 4. Combined Works. 80 | 81 | You may convey a Combined Work under terms of your choice that, 82 | taken together, effectively do not restrict modification of the 83 | portions of the Library contained in the Combined Work and reverse 84 | engineering for debugging such modifications, if you also do each of 85 | the following: 86 | 87 | a) Give prominent notice with each copy of the Combined Work that 88 | the Library is used in it and that the Library and its use are 89 | covered by this License. 90 | 91 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 92 | document. 93 | 94 | c) For a Combined Work that displays copyright notices during 95 | execution, include the copyright notice for the Library among 96 | these notices, as well as a reference directing the user to the 97 | copies of the GNU GPL and this license document. 98 | 99 | d) Do one of the following: 100 | 101 | 0) Convey the Minimal Corresponding Source under the terms of this 102 | License, and the Corresponding Application Code in a form 103 | suitable for, and under terms that permit, the user to 104 | recombine or relink the Application with a modified version of 105 | the Linked Version to produce a modified Combined Work, in the 106 | manner specified by section 6 of the GNU GPL for conveying 107 | Corresponding Source. 108 | 109 | 1) Use a suitable shared library mechanism for linking with the 110 | Library. A suitable mechanism is one that (a) uses at run time 111 | a copy of the Library already present on the user's computer 112 | system, and (b) will operate properly with a modified version 113 | of the Library that is interface-compatible with the Linked 114 | Version. 115 | 116 | e) Provide Installation Information, but only if you would otherwise 117 | be required to provide such information under section 6 of the 118 | GNU GPL, and only to the extent that such information is 119 | necessary to install and execute a modified version of the 120 | Combined Work produced by recombining or relinking the 121 | Application with a modified version of the Linked Version. (If 122 | you use option 4d0, the Installation Information must accompany 123 | the Minimal Corresponding Source and Corresponding Application 124 | Code. If you use option 4d1, you must provide the Installation 125 | Information in the manner specified by section 6 of the GNU GPL 126 | for conveying Corresponding Source.) 127 | 128 | 5. Combined Libraries. 129 | 130 | You may place library facilities that are a work based on the 131 | Library side by side in a single library together with other library 132 | facilities that are not Applications and are not covered by this 133 | License, and convey such a combined library under terms of your 134 | choice, if you do both of the following: 135 | 136 | a) Accompany the combined library with a copy of the same work based 137 | on the Library, uncombined with any other library facilities, 138 | conveyed under the terms of this License. 139 | 140 | b) Give prominent notice with the combined library that part of it 141 | is a work based on the Library, and explaining where to find the 142 | accompanying uncombined form of the same work. 143 | 144 | 6. Revised Versions of the GNU Lesser General Public License. 145 | 146 | The Free Software Foundation may publish revised and/or new versions 147 | of the GNU Lesser General Public License from time to time. Such new 148 | versions will be similar in spirit to the present version, but may 149 | differ in detail to address new problems or concerns. 150 | 151 | Each version is given a distinguishing version number. If the 152 | Library as you received it specifies that a certain numbered version 153 | of the GNU Lesser General Public License "or any later version" 154 | applies to it, you have the option of following the terms and 155 | conditions either of that published version or of any later version 156 | published by the Free Software Foundation. If the Library as you 157 | received it does not specify a version number of the GNU Lesser 158 | General Public License, you may choose any version of the GNU Lesser 159 | General Public License ever published by the Free Software Foundation. 160 | 161 | If the Library as you received it specifies that a proxy can decide 162 | whether future versions of the GNU Lesser General Public License shall 163 | apply, that proxy's public statement of acceptance of any version is 164 | permanent authorization for you to choose that version for the 165 | Library. 166 | -------------------------------------------------------------------------------- /INSTALL.org: -------------------------------------------------------------------------------- 1 | * Installation Instructions 2 | 3 | Installing guile-2d is rather easy (but not easy enough) if you are 4 | on a GNU/Linux system. Currently, only installation instructions for 5 | Debian are provided, but the non-apt commands should work without 6 | any modifications on any GNU/Linux distro. 7 | 8 | This installation guide assumes that you have the GNU build system 9 | (automake, autoconf, texinfo, pkg-config) and git installed. 10 | 11 | ** Install dependencies 12 | 13 | *** Guile 14 | 15 | *Debian* 16 | 17 | #+BEGIN_SRC sh 18 | sudo apt-get install guile-2.0-dev 19 | #+END_SRC 20 | 21 | This assumes that the version of Debian you are running has Guile 22 | 2.0.9. 23 | 24 | Check the versions available to you with =sudo apt-cache show guile-2.0-dev=. 25 | 26 | *** SDL 27 | SDL is a very popular, cross-platform game library. 28 | 29 | *Debian* 30 | 31 | #+BEGIN_SRC sh 32 | sudo apt-get install libsdl1.2-dev libsdl-image1.2-dev libsdl-mixer1.2-dev 33 | #+END_SRC 34 | 35 | *** Freeimage 36 | 37 | Freeimage is to used to load textures. Make sure that your distro 38 | provides at least version 3.14. 39 | 40 | *Debian* 41 | 42 | #+BEGIN_SRC sh 43 | sudo apt-get install libfreeimage-dev 44 | #+END_SRC 45 | 46 | *** FTGL 47 | 48 | FTGL renders fonts in OpenGL using the Freetype2 library. 49 | 50 | *Debian* 51 | 52 | #+BEGIN_SRC sh 53 | sudo apt-get install libftgl-dev 54 | #+END_SRC 55 | 56 | *** guile-sdl 57 | 58 | guile-sdl is the GNU Guile wrapper for SDL. 59 | 60 | Grab the latest release tarball from http://www.gnu.org/software/guile-sdl/. 61 | 62 | *Source* 63 | 64 | #+BEGIN_SRC sh 65 | tar xf guile-sdl-.tar.xz 66 | cd guile-sdl-/ 67 | ./configure --prefix=/usr 68 | make 69 | sudo make install 70 | #+END_SRC 71 | 72 | Note: guile-sdl is currently broken on OS X. Please see this issue 73 | for more information: 74 | https://github.com/davexunit/guile-2d/issues/2 75 | 76 | *** guile-figl 77 | 78 | *Source* 79 | 80 | FIGL is an unreleased library. You can find an unofficial 81 | source tarball that is compatible with guile-2d here: 82 | http://dthompson.us/static/src/guile-figl.tar.gz 83 | 84 | #+BEGIN_SRC sh 85 | tar -xvf guile-figl.tar.gz 86 | cd guile-figl/ 87 | ./configure --prefix=/usr 88 | make 89 | sudo make install 90 | #+END_SRC 91 | 92 | *Git* 93 | 94 | #+BEGIN_SRC sh 95 | git clone https://gitorious.org/guile-figl/guile-figl.git 96 | cd guile-figl 97 | autoreconf -vif 98 | ./configure --prefix=/usr 99 | make 100 | sudo make install 101 | #+END_SRC 102 | 103 | You will probably encounter a syntax error in the 104 | /low-level-gl.texi/ file. To fix it, you will need to join the 105 | lines 19152 and 19153 together. There are a lot of warnings that 106 | get output, but only one fatal error. The documentation is 107 | auto-generated from the OpenGL docs and it seems that there are 108 | still a few bugs in the generator. 109 | 110 | ** Install guile-2d 111 | 112 | Once the dependencies have been installed, installing guile-2d is 113 | pretty straightforward. 114 | 115 | *Debian* 116 | 117 | #+BEGIN_SRC sh 118 | git clone https://github.com/davexunit/guile-2d.git 119 | cd guile-2d/ 120 | ./autogen.sh 121 | ./configure --prefix=/usr 122 | make 123 | sudo make install 124 | #+END_SRC 125 | -------------------------------------------------------------------------------- /Makefile.am: -------------------------------------------------------------------------------- 1 | include guile.am 2 | 3 | moddir=$(prefix)/share/guile/site/2.0 4 | godir=$(libdir)/guile/2.0/ccache 5 | 6 | SOURCES = $(wildcard 2d/*.scm 2d/*/*.scm) 7 | 8 | EXTRA_DIST += env.in 9 | 10 | SUBDIRS = doc 11 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | * guile-2d 2 | 3 | *ATTENTION: Guile-2d has a new home at [[http://dthompson.us/pages/software/sly.html][my own web server]] under a new 4 | name: Sly* 5 | 6 | Guile-2d is a 2D game programming library for GNU Guile. It is a 7 | layer above SDL and OpenGL that provides abstractions for common 2D 8 | game programming requirements such as: 9 | 10 | - Sprites 11 | - Animation 12 | - Tilesets 13 | - Tile maps 14 | - Scene graph 15 | - Input handling 16 | - Scripting 17 | 18 | ** Inspiration 19 | Every programming language should have a fun, easy to use 2D game 20 | library. Guile-2d draws its inspiration from great 21 | libraries/frameworks such as [[http://love2d.org/][LÖVE]], [[http://pygame.org/][Pygame]], and [[http://pyglet.org/][Pyglet]]. 22 | 23 | ** Example 24 | Here is the simplest Guile-2d application (so far). 25 | 26 | #+BEGIN_SRC scheme 27 | (use-modules (2d game) 28 | (2d scene) 29 | (2d sprite) 30 | (2d vector2)) 31 | 32 | (define (make-demo-sprite) 33 | (load-sprite "images/ghost.png" 34 | #:position (vector2 320 240))) 35 | 36 | (define simple-scene 37 | (make-scene 38 | "Simple" 39 | #:init make-demo-sprite 40 | #:draw draw-sprite)) 41 | 42 | (define simple-demo 43 | (make-game 44 | #:title "Simple Demo" 45 | #:first-scene simple-scene)) 46 | 47 | (run-game simple-demo) 48 | #+END_SRC 49 | 50 | ** Features 51 | 52 | *** Scenes 53 | Game objects are used to define the basic aspects of a Guile-2D 54 | game such as the window title, resolution, whether or not it 55 | is fullscreen, and what the first scene is. 56 | 57 | #+BEGIN_SRC scheme 58 | (define my-game 59 | (make-game 60 | #:title "Simple Demo" 61 | #:resolution (vector2 640 480) 62 | #:fullscreen? #f 63 | #:first-scene main-menu)) 64 | #+END_SRC 65 | 66 | Games can be divided into several smaller pieces, called scenes. A 67 | scene describes how a particular part of a game is initialized, 68 | drawn, updated, etc. 69 | 70 | #+BEGIN_SRC scheme 71 | (define main-menu 72 | (make-scene 73 | "Main Menu" 74 | #:init create-menu 75 | #:enter menu-enter 76 | #:exit menu-exit 77 | #:draw draw-menu 78 | #:update update-menu 79 | #:events `((key-down . ,menu-key-down)))) 80 | #+END_SRC 81 | 82 | In addition to the essential callbacks (draw, update, enter, 83 | exit), scenes can specify an alist of additional arbitrary event 84 | handlers. Some events such as =key-down= are emitted by the game 85 | loop when input events are received. 86 | 87 | Scenes live in a place called the stage. There can be many stages, 88 | but only one is active at any given time. When a stage enters 89 | focus, the scene's enter procedure is applied. When a stage loses 90 | focus, the exit procedure is applied. Stages are stored in a 91 | stack, and they can pushed and popped as needed. To change the 92 | current scene, and thus the current stage, use =push-scene=, 93 | =pop-scene=, or =replace-scene=. 94 | 95 | #+BEGIN_SRC scheme 96 | (push-scene tetris-clone) 97 | (pop-scene) 98 | (replace-scene high-scores) 99 | #+END_SRC 100 | 101 | *** Sprites 102 | Sprites encapsulate the presentation of an image or a region of an 103 | image. 104 | 105 | The simplest way to get started with sprites is to use the 106 | =load-sprite= procedure. All arguments except the filename are 107 | optional keyword arguments. 108 | 109 | Guile-2d uses the FreeImage library and can load many different 110 | image formats. See the FreeImage [[http://freeimage.sourceforge.net/features.html][features page]] for a full list of 111 | supported formats. 112 | 113 | #+BEGIN_SRC scheme 114 | (define sprite 115 | (load-sprite "cirno.png" 116 | #:position #(0 0) 117 | #:scale (1 1) 118 | #:rotation (0) 119 | #:color white 120 | #:anchor 'center)) 121 | #+END_SRC 122 | 123 | Alternatively, you can make a sprite from an existing texture. The 124 | same keyword arguments in =load-sprite= are also available here. 125 | 126 | #+BEGIN_SRC scheme 127 | (define sprite (make-sprite (load-texture "cirno.png"))) 128 | #+END_SRC 129 | 130 | Position, scale, rotation, color, and anchor are mutable. 131 | 132 | #+BEGIN_SRC scheme 133 | (set-sprite-position! sprite #(100 100)) 134 | #+END_SRC 135 | 136 | Drawing a sprite is simple. 137 | 138 | #+BEGIN_SRC scheme 139 | (draw-sprite sprite) 140 | #+END_SRC 141 | 142 | *** Sprite Batches 143 | When drawing many sprites, it is inefficient to send them to the 144 | GPU individually. Sprite batches resolve this issue by sending 145 | sprites to the GPU in large chunks. 146 | 147 | To take advantage of this, create a sprite batch and use 148 | =with-sprite-batch=. All calls to =draw-sprite= will use the 149 | sprite batch within this form. 150 | 151 | #+BEGIN_SRC scheme 152 | (define sprites (make-a-ton-of-sprites)) 153 | 154 | (define batch (make-sprite-batch)) 155 | 156 | (with-sprite-batch batch 157 | (for-each draw-sprite sprites)) 158 | #+END_SRC 159 | 160 | *** Coroutines and Agendas 161 | The ability to write scripts is very important for most games. A 162 | script for an RPG NPC could look like this: 163 | 164 | #+BEGIN_SRC scheme 165 | ;; Walk up one tile and then down one tile, forever. 166 | (while #t 167 | (walk 'up) 168 | (walk 'down)) 169 | #+END_SRC 170 | 171 | Unfortunately, running this script as it is means completely 172 | locking up the program in an unbounded loop. However, coroutines 173 | (and a scheduler known as the "agenda") are here to save the day! 174 | Coroutines are procedures that can be exited at any point and 175 | resumed later. 176 | 177 | It would be nice if after every call to =walk=, the NPC would wait 178 | for one second before taking its next step. This is where the 179 | agenda comes in. The agenda is used to schedule procedures to be 180 | run after an arbitrary number of game updates (1 by 181 | default). Since coroutines and the agenda go hand in hand, there 182 | exists a =wait= procedure to pause a coroutine and schedule it to 183 | be resumed later. 184 | 185 | Using a coroutine and the agenda, the NPC script can be rewritten 186 | such that it does not halt further program execution. 187 | 188 | #+BEGIN_SRC scheme 189 | (agenda-schedule 190 | (colambda () 191 | (while #t 192 | (walk 'up) 193 | (wait 60) 194 | (walk 'down) 195 | (wait 60)))) 196 | 197 | #+END_SRC 198 | 199 | =colambda= is a useful macro that is syntactic sugar for a lambda 200 | expression executed as a coroutine. =agenda-schedule= accepts a 201 | thunk (a procedure that takes 0 arguments) and schedules it to be 202 | executed later. In this example we do not provide a second 203 | argument to =agenda-schedule=, which means that the thunk will be 204 | executed upon the next game update. 205 | 206 | Since guile-2d enforces a fixed timestep and updates 60 times per 207 | second, waiting for 60 updates means that the NPC will wait one 208 | second in between each step. 209 | 210 | *** Actions 211 | Actions encapsulate a procedure that operates over a certain 212 | period of time. Action objects have two properties: an arbitrary 213 | procedure and a duration in game ticks. Action procedures accept 214 | one argument: a time delta in the range [0, 1]. Use actions in 215 | combination with coroutines for things that are a function of 216 | time, such as moving a sprite across the screen. 217 | 218 | #+BEGIN_SRC scheme 219 | (schedule-action 220 | ;; Move horizontally across the screen, starting at x=0 and moving to 221 | ;; x=800, in 60 ticks. 222 | (lerp (lambda (x) 223 | (set-sprite-position! sprite (vector2 x (/ window-height 2)))) 224 | 0 800 60)) 225 | #+END_SRC 226 | 227 | =schedule-action= is used to schedule a coroutine that will 228 | perform the given action in the current agenda. =lerp= is a type 229 | of action, short for linear interpolation. =lerp= takes an 230 | arbitrary procedure to apply at each tick, a start value, an end 231 | value, and like all other actions, a duration. The code above 232 | interpolates from 0 to 800 over 60 ticks. The result of this 233 | action is a sprite moving across the screen from left to right. 234 | 235 | Actions can be combined to run in a sequence or in parallel. 236 | 237 | #+BEGIN_SRC scheme 238 | (schedule-action 239 | (action-parallel 240 | (lerp (lambda (x) 241 | (set-sprite-position! sprite (vector2 x (/ window-height 2)))) 242 | 0 800 60) 243 | ;; Rotate sprite 1080 degrees in 120 ticks. 244 | (lerp (lambda (angle) 245 | (set-sprite-rotation! sprite angle)) 246 | 0 1080 120))) 247 | #+END_SRC 248 | 249 | =action-parallel= will combine many actions into one action that 250 | does everything at the same time. In the example above, the sprite 251 | will still move across the screen from left to right, but while 252 | it's doing so (and for 60 ticks after), it will be rotating from 0 253 | to 1080 degrees. 254 | 255 | ** REPL Driven Development 256 | 257 | The read-eval-print-loop present in Guile allows you to develop 258 | your game while it is running! This allows you to see in real time 259 | what your changes do to the game without having to restart the 260 | program every time. 261 | 262 | Guile-2d uses a modified REPL server that is integrated with the 263 | game loop. A REPL server is started when the game loop starts. To 264 | connect to it, use the [[http://www.nongnu.org/geiser/][Geiser]] extension for GNU Emacs or telnet. 265 | 266 | *Geiser* 267 | 268 | #+BEGIN_SRC fundamental 269 | M-x connect-to-guile 270 | #+END_SRC 271 | 272 | Use the default host and port settings. 273 | 274 | *Telnet* 275 | 276 | #+BEGIN_SRC sh 277 | telnet localhost 37146 278 | #+END_SRC 279 | 280 | ** Building 281 | guile-2d uses the typical GNU build system. First run `autogen.sh` 282 | and then do the usual incantations. 283 | 284 | #+BEGIN_SRC sh 285 | ./autogen.sh 286 | ./configure 287 | make 288 | sudo make install 289 | #+END_SRC 290 | 291 | See =INSTALL.org= for more detailed installation instructions. 292 | 293 | ** Running Examples 294 | To run an example when guile-2d has been installed: 295 | 296 | #+BEGIN_SRC sh 297 | cd examples 298 | guile simple.scm 299 | #+END_SRC 300 | 301 | To run an example using the not-yet-installed files (useful when 302 | developing): 303 | 304 | #+BEGIN_SRC sh 305 | cd examples 306 | guile -L .. simple.scm 307 | #+END_SRC 308 | 309 | To quit an example: 310 | - Close the window 311 | - Press the =ESCAPE= or =Q= key 312 | 313 | ** Platforms 314 | 315 | Guile-2d supports GNU/Linux currently. OS X support is in the 316 | works, but there are problems with guile-sdl. See 317 | https://github.com/davexunit/guile-2d/issues/2 for more details. 318 | 319 | ** Dependencies 320 | 321 | - GNU Guile >= 2.0.9 322 | - [[https://gitorious.org/guile-figl/guile-figl][guile-figl]] (git master branch) 323 | - [[https://www.gnu.org/software/guile-sdl/index.html][guile-sdl]] >= 0.5.0 324 | - SDL 1.2 325 | - FreeImage >= 3.0 326 | - FTGL >= 2.1 327 | 328 | ** License 329 | 330 | GNU LGPL v3+ 331 | -------------------------------------------------------------------------------- /TODO.org: -------------------------------------------------------------------------------- 1 | * Things To Do 2 | 3 | ** DONE Game loop 4 | Provide a game loop structure that responds to input events, 5 | updates the game state, renders the scene. Use a fixed update 6 | timestep and cap the maximum FPS. 7 | 8 | ** DONE Game scenes 9 | Games can be broken up into many chunks, called scenes. Examples 10 | would be a main menu, a world map, a battle screen, etc. 11 | 12 | - [X] Create a type that encapsulates input/render/update 13 | callbacks 14 | - [X] Macro for declaratively defining a scene 15 | - [X] Scene switching 16 | 17 | ** TODO Input 18 | Provide hooks to respond to keyboard, mouse, and joystick events. 19 | Wrap SDL keycode, mouse button, etc. constants in our own 20 | enumeration. 21 | 22 | - [X] Keyboard 23 | - [X] Mouse 24 | - [X] Window (active, resize, quit) 25 | - [ ] Joystick 26 | 27 | ** DONE Sprites 28 | Encapsulates an image and all of its transformations: position, 29 | rotation, scale, color, etc. 30 | 31 | - [X] Use FreeImage 32 | - [X] Add support for texture regions 33 | - [X] Add support for animations 34 | - [X] Use a sprite batch when drawing if one is currently bound 35 | 36 | ** TODO Sprite batches 37 | Efficiently render a large number of sprites. Only change OpenGL 38 | context when necessary. For example, don't change texture when 39 | rendering several sprites in a row that use the same one. 40 | 41 | - [X] Add basic batching for non-scaled, non-rotated sprites 42 | - [X] Add transformation logic for scaling and rotating 43 | - [X] Add support for colors 44 | - [ ] Add support for different blending modes 45 | 46 | ** DONE Tilesets 47 | Break an image up into many small pieces. Useful for creating maps. 48 | 49 | - [X] Algorithm to split texture into tiles 50 | - [X] type 51 | 52 | ** DONE Animations 53 | Create a data type to represent an animated sequence of textures 54 | and/or texture regions. 55 | 56 | ** TODO Tile maps 57 | - [ ] Create a generic tilemap module 58 | - [ ] Create a loader for Tiled .tmx map files. 59 | 60 | ** TODO Scene graph 61 | A tree structure that is traversed when rendering a game scene. 62 | The graph is composed of groups and nodes. Transformations are 63 | accumulated as the tree is walked. 64 | 65 | ** DONE Scripting 66 | Provide a way for users to easily script 2D games using coroutines 67 | and a scheduler. 68 | 69 | - [X] Coroutines 70 | - [X] Agenda 71 | 72 | ** TODO Vectors and matrices 73 | Vectors and matrices are needed constantly for games. Provide an 74 | easy-to-use module that provides procedures for common 75 | vector/matrix math operations 76 | 77 | - [X] Vectors 78 | - [ ] Matrices 79 | 80 | ** DONE Fonts 81 | - [X] Write wrappers for needed FTGL functions 82 | - [X] Write font rendering procedures 83 | 84 | ** DONE Sound 85 | Provide helpful wrappers around SDL sound procedures? 86 | 87 | ** TODO A* pathfinding 88 | A* is a commonly used pathfinding algorithm for games. Pathfinding 89 | is such a common task that it would be nice to provide users with 90 | a generic implementation. 91 | 92 | ** TODO Bounding box collision detection 93 | Most games need simple bounding box collision detection. Provide an 94 | efficient implementation that uses quad trees. 95 | 96 | - [X] Rect module 97 | - [ ] Quadtree module 98 | 99 | ** TODO Particle systems 100 | Provide a highly configurible particle simulation system. 101 | 102 | - [ ] Investigate ways to make it fast. Might have to resort to a C 103 | shared library to avoid GC overhead. 104 | 105 | ** TODO Asset Management 106 | Provide a generic system for loading assets (images, sounds, fonts, 107 | etc.) and storing them in a cache. Explore using weak keys so that 108 | assets are removed from the cache when they are no longer 109 | referenced. 110 | 111 | - [ ] Create asset cache 112 | - [ ] Investigate automatic asset reloading. 113 | 114 | ** TODO Actions 115 | Provide a library of coroutines that perform commonly used 116 | time-based actions such as linear interpolation. It would be nice 117 | to have a way to make these easily composable as well. 118 | 119 | - [X] Make actions composable 120 | - [X] Linear interpolation (lerp) 121 | - [ ] Move to/move by 122 | 123 | ** TODO Keymaps 124 | Provide an Emacs-like way of defining key combinations so that 125 | multi-button input is easy for users. 126 | 127 | The more I think about what I want, the more I realize that I am 128 | describing a system that uses functional reactive programming. 129 | 130 | - [ ] Abstract away input methods 131 | Controls can be bound to keys, mouse, whatever 132 | - [ ] Basic sequences 133 | Press A then B 134 | - [ ] Simultaneous key presses 135 | Press A and B at the same time 136 | - [ ] Composing sequences 137 | Press A then B + C 138 | - [ ] Timeouts 139 | Press A then B then C within 15 frames time 140 | - [ ] Sequences with actions along the way 141 | Press A to kick, then forward + B to uppercut, within 30 frames 142 | time. 143 | 144 | ** TODO GUI widgets 145 | Provide a set of common graphical widgets such as buttons, scroll 146 | bars, and sliders. 147 | 148 | ** TODO REPL 149 | Provide a REPL that plays nice with the game loop. Easier said than 150 | done. 151 | 152 | - [X] Modify Guile's REPL to work with the game loop 153 | - Short-term solution that *mostly* works 154 | - [ ] Write a new REPL that runs in the current thread 155 | - Use coroutines 156 | - Read user input from a separate thread so as to not block the 157 | main thread 158 | 159 | ** DONE 0.1 Release 160 | An official 0.1 alpha release with basic, minimal functionality 161 | will provide a good place for people other than me to try out 162 | guile-2d and perhaps even start to hack on it. 163 | 164 | - [X] Font rendering with FTGL 165 | - [X] Resolve issues with FIGL 166 | - [X] Texinfo documentation 167 | - [X] Clean up docstrings 168 | - [X] Autotools build files 169 | - [X] Fix animation bug 170 | 171 | ** TODO 0.2 Release 172 | - [ ] New REPL server 173 | - [ ] Screencast 174 | - [ ] Keymaps 175 | - [X] Better scene management 176 | - [ ] More documentation 177 | -------------------------------------------------------------------------------- /autogen.sh: -------------------------------------------------------------------------------- 1 | #! /bin/sh 2 | 3 | autoreconf -vif 4 | -------------------------------------------------------------------------------- /configure.ac: -------------------------------------------------------------------------------- 1 | dnl -*- Autoconf -*- 2 | 3 | AC_INIT(guile-2d, 0.1.0) 4 | AC_CONFIG_SRCDIR(2d) 5 | AC_CONFIG_AUX_DIR([build-aux]) 6 | AM_INIT_AUTOMAKE([color-tests -Wall -Wno-portability foreign]) 7 | AM_SILENT_RULES([yes]) 8 | 9 | GUILE_PROGS 10 | 11 | if $GUILE_TOOLS | grep -q compile; then 12 | # everything cool 13 | true 14 | else 15 | AC_MSG_ERROR([Guile 2.0 required.]) 16 | fi 17 | 18 | AC_CONFIG_FILES([Makefile doc/Makefile]) 19 | AC_CONFIG_FILES([env], [chmod +x env]) 20 | 21 | PKG_CHECK_MODULES([SDL], [sdl <= 1.3 sdl >= 1.2]) 22 | PKG_CHECK_MODULES([FTGL], [ftgl >= 2.1]) 23 | # Why doesn't freeimage have a pkg-config file? 24 | #PKG_CHECK_MODULES([freeimage], [freeimage >= 3.0]) 25 | 26 | AC_OUTPUT 27 | -------------------------------------------------------------------------------- /doc/Makefile.am: -------------------------------------------------------------------------------- 1 | AUTOMAKE_OPTIONS = gnu 2 | 3 | info_TEXINFOS = guile-2d.texi 4 | 5 | guile_TEXINFOS = audio.texi \ 6 | fdl.texi \ 7 | game.texi \ 8 | graphics.texi \ 9 | graphics/animation.texi \ 10 | graphics/color.texi \ 11 | graphics/font.texi \ 12 | graphics/sprite.texi \ 13 | graphics/texture.texi \ 14 | graphics/tileset.texi \ 15 | guile-2d.texi \ 16 | introduction.texi \ 17 | math.texi \ 18 | math/math.texi \ 19 | math/rect.texi \ 20 | math/vector2.texi \ 21 | scripting.texi \ 22 | scripting/actions.texi \ 23 | scripting/agenda.texi \ 24 | scripting/coroutine.texi 25 | -------------------------------------------------------------------------------- /doc/audio.texi: -------------------------------------------------------------------------------- 1 | @node Audio 2 | @chapter Audio 3 | 4 | Guile-2D provides a simple wrapper over SDL's mixer API for working 5 | with music and sound effects. 6 | 7 | @menu 8 | * Music:: 9 | * Samples:: 10 | @end menu 11 | 12 | @node Music 13 | @section Music 14 | 15 | Music objects are used for a game's background music. Only one music 16 | object is playing at any given time. 17 | 18 | @anchor{2d audio make-music}@defspec make-music 19 | @end defspec 20 | 21 | @anchor{2d audio load-music}@defun load-music filename 22 | Load music from FILENAME. Return #f on failure. 23 | 24 | @end defun 25 | 26 | @anchor{2d audio music?}@defspec music? 27 | @end defspec 28 | 29 | @anchor{2d audio music-audio}@defspec music-audio 30 | @end defspec 31 | 32 | @anchor{2d audio music-pause}@defun music-pause 33 | @end defun 34 | 35 | @anchor{2d audio music-paused?}@defun music-paused? 36 | @end defun 37 | 38 | @anchor{2d audio music-play}@defun music-play music 39 | Play MUSIC. 40 | 41 | @end defun 42 | 43 | @anchor{2d audio music-playing?}@defun music-playing? 44 | @end defun 45 | 46 | @anchor{2d audio music-resume}@defun music-resume 47 | @end defun 48 | 49 | @anchor{2d audio music-rewind}@defun music-rewind 50 | @end defun 51 | 52 | @anchor{2d audio music-stop}@defun music-stop 53 | @end defun 54 | 55 | @anchor{2d audio music-volume}@defun music-volume 56 | Return the volume that music is played at. 57 | 58 | @end defun 59 | 60 | @node Samples 61 | @section Samples 62 | 63 | Samples are short audio clips, typically sound effects. Many samples 64 | can be played at the same time. 65 | 66 | @anchor{2d audio make-sample}@defspec make-sample 67 | @end defspec 68 | 69 | @anchor{2d audio load-sample}@defun load-sample filename 70 | Load audio sample from FILENAME. Return #f on failure. 71 | 72 | @end defun 73 | 74 | @anchor{2d audio sample?}@defspec sample? 75 | @end defspec 76 | 77 | @anchor{2d audio sample-audio}@defspec sample-audio 78 | @end defspec 79 | 80 | @anchor{2d audio sample-play}@defun sample-play sample 81 | Play audio SAMPLE. 82 | 83 | @end defun 84 | 85 | @anchor{2d audio sample-volume}@defun sample-volume 86 | Return volume that samples are played at. 87 | 88 | @end defun 89 | 90 | @anchor{2d audio set-music-volume}@defun set-music-volume volume 91 | Set the volume that music is played at. 92 | 93 | @end defun 94 | 95 | @anchor{2d audio set-sample-volume}@defun set-sample-volume volume 96 | Set the volume that samples are played at to VOLUME. 97 | 98 | @end defun 99 | -------------------------------------------------------------------------------- /doc/game.texi: -------------------------------------------------------------------------------- 1 | @node Games and Scenes 2 | @chapter Games and Scenes 3 | 4 | In Guile-2D, games are defined declaratively. Game objects define 5 | things such as the title and screen resolution. Games are composed of 6 | many scenes, which encapsulate a particular aspect of the 7 | game. Examples would be a main menu, a world map, or a battle screen. 8 | 9 | @menu 10 | * Games:: 11 | * Scenes:: 12 | @end menu 13 | 14 | @node Games 15 | @section Games 16 | 17 | @anchor{2d game make-game}@defun make-game [#:title] [#:resolution] [#:fullscreen] [#:first-scene] 18 | Return a new game. All game properties have some reasonable default 19 | value. 20 | 21 | @end defun 22 | 23 | @anchor{2d game define-game}@defspec define-game name kwargs ... 24 | Syntactic sugar over define and make-game. 25 | 26 | @end defspec 27 | 28 | @anchor{2d game game?}@defspec game? 29 | @end defspec 30 | 31 | @anchor{2d game game-first-scene}@defspec game-first-scene 32 | @end defspec 33 | 34 | @anchor{2d game game-fullscreen?}@defspec game-fullscreen? 35 | @end defspec 36 | 37 | @anchor{2d game game-resolution}@defspec game-resolution 38 | @end defspec 39 | 40 | @anchor{2d game game-title}@defspec game-title 41 | @end defspec 42 | 43 | @anchor{2d game run-game}@defun run-game game 44 | Open a window and start the game loop for GAME. 45 | 46 | @end defun 47 | 48 | @node Scenes 49 | @section Scenes 50 | 51 | @anchor{2d game make-scene}@defun make-scene [#:title] [#:events] [#:update] [#:draw] [#:state] 52 | Return a new scene. TITLE is a human readable name for the scene. 53 | EVENTS is an alist of event handlers. UPDATE is a procedure that 54 | updates the scene. DRAW is a procedure that renders the scene. STATE 55 | is an object that encapsulates the scene state. 56 | 57 | @end defun 58 | 59 | @anchor{2d game define-scene}@defspec define-scene name kwargs ... 60 | Syntactic sugar over define and make-scene. Return a procedure that 61 | creates a new scene. 62 | 63 | @end defspec 64 | 65 | @anchor{2d game scene?}@defspec scene? 66 | @end defspec 67 | 68 | @anchor{2d game scene-draw-proc}@defspec scene-draw-proc 69 | @end defspec 70 | 71 | @anchor{2d game scene-observer}@defspec scene-observer 72 | @end defspec 73 | 74 | @anchor{2d game scene-state}@defspec scene-state 75 | @end defspec 76 | 77 | @anchor{2d game scene-title}@defspec scene-title 78 | @end defspec 79 | 80 | @anchor{2d game scene-update-proc}@defspec scene-update-proc 81 | @end defspec 82 | 83 | @anchor{2d game current-fps}@defun current-fps 84 | Return the current FPS value. 85 | 86 | @end defun 87 | 88 | @anchor{2d game default-scene-events}@defun default-scene-events 89 | @end defun 90 | 91 | @anchor{2d game draw-scene}@defun draw-scene scene 92 | Draw SCENE. 93 | 94 | @end defun 95 | 96 | @anchor{2d game pop-scene}@defun pop-scene 97 | Exit the current scene and resume the previous scene. If there is no 98 | previous scene, the game loop will terminate. 99 | 100 | @end defun 101 | 102 | @anchor{2d game push-scene}@defun push-scene scene 103 | Pause the current scene and start SCENE upon next game tick. 104 | 105 | @end defun 106 | 107 | @anchor{2d game replace-scene}@defun replace-scene scene 108 | @end defun 109 | 110 | @anchor{2d game scene-trigger}@defun scene-trigger scene event-type . args 111 | Trigger an event on the scene observer. 112 | 113 | @end defun 114 | 115 | @anchor{2d game update-scene}@defun update-scene scene 116 | Update SCENE. 117 | 118 | @end defun 119 | -------------------------------------------------------------------------------- /doc/graphics.texi: -------------------------------------------------------------------------------- 1 | @node Graphics 2 | @chapter Graphics 3 | 4 | Graphics are a fundamental part of most computer games. Guile-2D makes 5 | it easy to make sprite-based games by providing all of the necessary 6 | primitives. Graphics are rendered via OpenGL to take advantage of 7 | hardware acceleration. 8 | 9 | @menu 10 | * Sprites:: 11 | * Textures:: 12 | * Animations:: 13 | * Colors:: 14 | * Tilesets:: 15 | * Fonts:: 16 | @end menu 17 | 18 | @include graphics/sprite.texi 19 | @include graphics/texture.texi 20 | @include graphics/animation.texi 21 | @include graphics/color.texi 22 | @include graphics/tileset.texi 23 | @include graphics/font.texi 24 | -------------------------------------------------------------------------------- /doc/graphics/animation.texi: -------------------------------------------------------------------------------- 1 | @node Animations 2 | @section Animations 3 | 4 | Animations are sequences of textures and/or texture regions. Common 5 | uses for animations are to give the illusion that a character is 6 | walking across the screen or swinging their sword at a 7 | monster. Animator objects are used to control the playback of an 8 | animation. 9 | 10 | @anchor{2d animation animation-frame-duration}@defspec animation-frame-duration 11 | @end defspec 12 | 13 | @anchor{2d animation animation-frames}@defspec animation-frames 14 | @end defspec 15 | 16 | @anchor{2d animation animation-loop?}@defspec animation-loop? 17 | @end defspec 18 | 19 | @anchor{2d animation animation?}@defspec animation? 20 | @end defspec 21 | 22 | @anchor{2d animation animator-animation}@defspec animator-animation 23 | @end defspec 24 | 25 | @anchor{2d animation animator-frame}@defspec animator-frame 26 | @end defspec 27 | 28 | @anchor{2d animation animator-playing?}@defspec animator-playing? 29 | @end defspec 30 | 31 | @anchor{2d animation animator-time}@defspec animator-time 32 | @end defspec 33 | 34 | @anchor{2d animation animator?}@defspec animator? 35 | @end defspec 36 | 37 | @anchor{2d animation make-animation}@defspec make-animation 38 | @end defspec 39 | 40 | @anchor{2d animation animation-duration}@defun animation-duration animation 41 | Return the total duration of ANIMATION in ticks. 42 | 43 | @end defun 44 | 45 | @anchor{2d animation animation-frame}@defun animation-frame animation index 46 | Return the texture for the given frame INDEX of ANIMATION. 47 | 48 | @end defun 49 | 50 | @anchor{2d animation animation-length}@defun animation-length animation 51 | Return the number of frames in ANIMATION. 52 | 53 | @end defun 54 | 55 | @anchor{2d animation animator-frame-complete?}@defun animator-frame-complete? animator 56 | Return #t when ANIMATOR is done displaying the current frame. 57 | 58 | @end defun 59 | 60 | @anchor{2d animation animator-next!}@defun animator-next! animator 61 | Advance ANIMATOR to the next frame of its animation. 62 | 63 | @end defun 64 | 65 | @anchor{2d animation animator-next-frame}@defun animator-next-frame animator 66 | Return the next frame index for ANIMATOR. 67 | 68 | @end defun 69 | 70 | @anchor{2d animation animator-texture}@defun animator-texture animator 71 | Return a texture for the ANIMATOR's current frame. 72 | 73 | @end defun 74 | 75 | @anchor{2d animation animator-update!}@defun animator-update! animator 76 | Increment the frame time for the ANIMATOR and advance to the next frame 77 | when necessary. 78 | 79 | @end defun 80 | 81 | @anchor{2d animation make-animator}@defun make-animator animation 82 | Create a new animator for ANIMATION. 83 | 84 | @end defun 85 | -------------------------------------------------------------------------------- /doc/graphics/color.texi: -------------------------------------------------------------------------------- 1 | @node Colors 2 | @section Colors 3 | 4 | Colors store RGBA data in OpenGL format. Each color channel has a 5 | value in the range [0, 1]. 6 | 7 | @anchor{2d color make-color}@defspec make-color 8 | @end defspec 9 | 10 | @anchor{2d color color?}@defspec color? 11 | @end defspec 12 | 13 | @anchor{2d color color-r}@defspec color-r 14 | @end defspec 15 | 16 | @anchor{2d color color-g}@defspec color-g 17 | @end defspec 18 | 19 | @anchor{2d color color-b}@defspec color-b 20 | @end defspec 21 | 22 | @anchor{2d color color-a}@defspec color-a 23 | @end defspec 24 | 25 | @anchor{2d color use-color}@defun use-color color 26 | Set the current OpenGL color state to the contents of COLOR. 27 | 28 | @end defun 29 | 30 | A lot of people are used to working with colors as hexadecimal values, 31 | so the following procedures are provided to convert hexadecimal color 32 | codes into color objects. 33 | 34 | @anchor{2d color rgba}@defun rgba color-code 35 | Translate an RGBA format string COLOR-CODE into a color object. For 36 | example: #xffffffff will return a color with RGBA values 1, 1, 1, 1. 37 | 38 | @end defun 39 | 40 | @anchor{2d color rgb}@defun rgb color-code 41 | Translate an RGB format string COLOR-CODE into a color object. For 42 | example: #xffffff will return a color with RGBA values 1, 1, 1, 1. 43 | 44 | @end defun 45 | 46 | Commonly used colors are predefined for convenience. 47 | 48 | @anchor{2d color white}@defvar white 49 | @end defvar 50 | 51 | @anchor{2d color black}@defvar black 52 | @end defvar 53 | 54 | @anchor{2d color red}@defvar red 55 | @end defvar 56 | 57 | @anchor{2d color green}@defvar green 58 | @end defvar 59 | 60 | @anchor{2d color blue}@defvar blue 61 | @end defvar 62 | 63 | @anchor{2d color magenta}@defvar magenta 64 | @end defvar 65 | -------------------------------------------------------------------------------- /doc/graphics/font.texi: -------------------------------------------------------------------------------- 1 | @node Fonts 2 | @section Fonts 3 | 4 | Guile-2D can render TTF fonts via the FTGL library. 5 | 6 | @anchor{2d font font-ftgl-font}@defspec font-ftgl-font 7 | @end defspec 8 | 9 | @anchor{2d font font-size}@defspec font-size 10 | @end defspec 11 | 12 | @anchor{2d font font?}@defspec font? 13 | @end defspec 14 | 15 | @anchor{2d font make-font}@defspec make-font 16 | @end defspec 17 | 18 | @anchor{2d font set-textbox-color!}@defspec set-textbox-color! 19 | @end defspec 20 | 21 | @anchor{2d font set-textbox-position!}@defspec set-textbox-position! 22 | @end defspec 23 | 24 | @anchor{2d font set-textbox-text!}@defspec set-textbox-text! 25 | @end defspec 26 | 27 | @anchor{2d font textbox-alignment}@defspec textbox-alignment 28 | @end defspec 29 | 30 | @anchor{2d font textbox-color}@defspec textbox-color 31 | @end defspec 32 | 33 | @anchor{2d font textbox-font}@defspec textbox-font 34 | @end defspec 35 | 36 | @anchor{2d font textbox-layout}@defspec textbox-layout 37 | @end defspec 38 | 39 | @anchor{2d font textbox-line-length}@defspec textbox-line-length 40 | @end defspec 41 | 42 | @anchor{2d font textbox-position}@defspec textbox-position 43 | @end defspec 44 | 45 | @anchor{2d font textbox-text}@defspec textbox-text 46 | @end defspec 47 | 48 | @anchor{2d font textbox?}@defspec textbox? 49 | @end defspec 50 | 51 | @anchor{2d font draw-font}@defun draw-font font text 52 | Renders the string text using the given font. 53 | 54 | @end defun 55 | 56 | @anchor{2d font draw-textbox}@defun draw-textbox textbox 57 | Draw TEXTBOX. 58 | 59 | @end defun 60 | 61 | @anchor{2d font load-font}@defun load-font filename size 62 | Load a font from FILENAME with the given SIZE in points. 63 | 64 | @end defun 65 | 66 | @anchor{2d font make-textbox}@defun make-textbox font text position color alignment line-length 67 | Create a textbox that will draw TEXT with the given FONT, at vector 68 | POSITION, with ALIGNMENT, and a maximum LINE-LENGTH. 69 | 70 | @end defun 71 | -------------------------------------------------------------------------------- /doc/graphics/sprite.texi: -------------------------------------------------------------------------------- 1 | @node Sprites 2 | @section Sprites 3 | 4 | Sprites are typically the most important part of a 2D game. Sprites 5 | represent a texture with a specific color, position, rotation and 6 | scale. Sprites can render texture objects or animations. 7 | 8 | @anchor{2d sprite set-sprite-batch-size!}@defspec set-sprite-batch-size! 9 | @end defspec 10 | 11 | @anchor{2d sprite set-sprite-batch-texture!}@defspec set-sprite-batch-texture! 12 | @end defspec 13 | 14 | @anchor{2d sprite set-sprite-drawable!}@defspec set-sprite-drawable! 15 | @end defspec 16 | 17 | @anchor{2d sprite set-sprite-vertices!}@defspec set-sprite-vertices! 18 | @end defspec 19 | 20 | @anchor{2d sprite sprite-anchor}@defspec sprite-anchor 21 | @end defspec 22 | 23 | @anchor{2d sprite sprite-batch-max-size}@defspec sprite-batch-max-size 24 | @end defspec 25 | 26 | @anchor{2d sprite sprite-batch-size}@defspec sprite-batch-size 27 | @end defspec 28 | 29 | @anchor{2d sprite sprite-batch-texture}@defspec sprite-batch-texture 30 | @end defspec 31 | 32 | @anchor{2d sprite sprite-batch-vertices}@defspec sprite-batch-vertices 33 | @end defspec 34 | 35 | @anchor{2d sprite sprite-batch?}@defspec sprite-batch? 36 | @end defspec 37 | 38 | @anchor{2d sprite sprite-color}@defspec sprite-color 39 | @end defspec 40 | 41 | @anchor{2d sprite sprite-drawable}@defspec sprite-drawable 42 | @end defspec 43 | 44 | @anchor{2d sprite sprite-position}@defspec sprite-position 45 | @end defspec 46 | 47 | @anchor{2d sprite sprite-rotation}@defspec sprite-rotation 48 | @end defspec 49 | 50 | @anchor{2d sprite sprite-scale}@defspec sprite-scale 51 | @end defspec 52 | 53 | @anchor{2d sprite sprite-vertices}@defspec sprite-vertices 54 | @end defspec 55 | 56 | @anchor{2d sprite sprite?}@defspec sprite? 57 | @end defspec 58 | 59 | @anchor{2d sprite with-sprite-batch}@defspec with-sprite-batch batch body ... 60 | @end defspec 61 | 62 | @anchor{2d sprite animated-sprite?}@defun animated-sprite? sprite 63 | Return #t if SPRITE has an animation as its drawable object. 64 | 65 | @end defun 66 | 67 | @anchor{2d sprite draw-sprite}@defun draw-sprite sprite 68 | Render SPRITE to the screen. A sprite batch will be used if one is 69 | currently bound. 70 | 71 | @end defun 72 | 73 | @anchor{2d sprite load-sprite}@defun load-sprite filename [#:position] [#:scale] [#:rotation] [#:color] [#:anchor] 74 | Load a sprite from the file at FILENAME. See make-sprite for optional 75 | keyword arguments. 76 | 77 | @end defun 78 | 79 | @anchor{2d sprite make-sprite}@defun make-sprite drawable [#:position] [#:scale] [#:rotation] [#:color] [#:anchor] 80 | Create a new sprite object. DRAWABLE is either a texture or animation 81 | object. All keyword arguments are optional. POSITION is a vector2 82 | object with a default of (0, 0). SCALE is a vector2 object that 83 | describes how much DRAWABLE should be strected on the x and y axes, with 84 | a default of 1x scale. ROTATION is an angle in degrees with a default 85 | of 0. COLOR is a color object with a default of white. ANCHOR is 86 | either a vector2 that represents the center point of the sprite, or 87 | 'center which will place the anchor at the center of DRAWABLE. Sprites 88 | are centered by default. 89 | 90 | @end defun 91 | 92 | @anchor{2d sprite make-sprite-batch}@defun make-sprite-batch [max-size] 93 | Creates a new sprite batch. The default max-size is 1000. 94 | 95 | @end defun 96 | 97 | @anchor{2d sprite set-sprite-anchor!}@defun set-sprite-anchor! sprite value 98 | @end defun 99 | 100 | @anchor{2d sprite set-sprite-color!}@defun set-sprite-color! sprite value 101 | @end defun 102 | 103 | @anchor{2d sprite set-sprite-position!}@defun set-sprite-position! sprite value 104 | @end defun 105 | 106 | @anchor{2d sprite set-sprite-rotation!}@defun set-sprite-rotation! sprite value 107 | @end defun 108 | 109 | @anchor{2d sprite set-sprite-scale!}@defun set-sprite-scale! sprite value 110 | @end defun 111 | 112 | @anchor{2d sprite sprite-batch-draw}@defun sprite-batch-draw . args 113 | Add a textured quad to the current sprite batch. X, Y, WIDTH, and 114 | HEIGHT represent the quad in pixels. ORIGIN-X and ORIGIN-Y represent 115 | the center point of the quad which is used for rotation. SCALE-X and 116 | SCALE-Y are the scaling factors for the x and y axis, respectively. 117 | ROTATION is the angle in degrees to rotate the quad. U, V, U2, and V2 118 | represent the texture coordinate region to texture the quad with. COLOR 119 | is a color object. 120 | 121 | @end defun 122 | -------------------------------------------------------------------------------- /doc/graphics/texture.texi: -------------------------------------------------------------------------------- 1 | @node Textures 2 | @section Textures 3 | 4 | Textures are images loaded in graphics memory. Guile-2D supports many 5 | texture formats via the FreeImage library. A texture object can 6 | describe a full image or a rectangular section of an image. 7 | 8 | @anchor{2d texture make-texture}@defun make-texture id parent width height s1 t1 s2 t2 9 | Create a new texture object. ID is the OpenGL texture id. PARENT is a 10 | texture object (if this texture only represents a region of another 11 | texture) or #f. WIDTH and HEIGHT are the texture dimensions in pixels. 12 | S1, T1, S2, and T2 are the OpenGL texture coordinates representing the 13 | area of the texture that will be rendered. 14 | 15 | @end defun 16 | 17 | @anchor{2d texture make-texture-region}@defun make-texture-region texture x y width height 18 | Creates new texture region object. TEXTURE is the region's parent 19 | texture. X, Y, WIDTH, and HEIGHT represent the region of the texture 20 | that will be rendered, in pixels. 21 | 22 | @end defun 23 | 24 | @anchor{2d texture load-texture}@defun load-texture filename 25 | Load a texture from an image file at FILENAME. 26 | 27 | @end defun 28 | 29 | @anchor{2d texture texture?}@defspec texture? 30 | @end defspec 31 | 32 | @anchor{2d texture texture-region?}@defun texture-region? texture 33 | Return #t if TEXTURE has a parent texture. 34 | 35 | @end defun 36 | 37 | @anchor{2d texture texture-id}@defspec texture-id 38 | @end defspec 39 | 40 | @anchor{2d texture texture-width}@defspec texture-width 41 | @end defspec 42 | 43 | @anchor{2d texture texture-height}@defspec texture-height 44 | @end defspec 45 | 46 | @anchor{2d texture texture-s1}@defspec texture-s1 47 | @end defspec 48 | 49 | @anchor{2d texture texture-t1}@defspec texture-t1 50 | @end defspec 51 | 52 | @anchor{2d texture texture-s2}@defspec texture-s2 53 | @end defspec 54 | 55 | @anchor{2d texture texture-t2}@defspec texture-t2 56 | @end defspec 57 | 58 | @anchor{2d texture surface->texture}@defvar surface->texture 59 | [unbound!] 60 | @end defvar 61 | 62 | @anchor{2d texture draw-texture}@defun draw-texture texture x y [color] 63 | Render a textured quad in GL immediate mode. 64 | 65 | @end defun 66 | -------------------------------------------------------------------------------- /doc/graphics/tileset.texi: -------------------------------------------------------------------------------- 1 | @node Tilesets 2 | @section Tilesets 3 | 4 | In most 2D games, the game world is composed of many small, 5 | rectangular pieces called tiles. In Guile-2D, tilesets are used to 6 | encapsulate a group of uniformly sized texture regions that come from 7 | a single parent texture. 8 | 9 | @anchor{2d tileset make-tileset}@defun make-tileset texture width height [#:margin] [#:spacing] 10 | Return a new tileset that is built by splitting TEXTURE into tiles. 11 | 12 | @end defun 13 | 14 | @anchor{2d tileset load-tileset}@defun load-tileset filename width height [#:margin] [#:spacing] 15 | Return a new tileset that is built by loading the texture at FILENAME 16 | and splitting the texture into tiles. 17 | 18 | @end defun 19 | 20 | @anchor{2d tileset tileset?}@defspec tileset? 21 | @end defspec 22 | 23 | @anchor{2d tileset tileset-tiles}@defspec tileset-tiles 24 | @end defspec 25 | 26 | @anchor{2d tileset tileset-width}@defspec tileset-width 27 | @end defspec 28 | 29 | @anchor{2d tileset tileset-height}@defspec tileset-height 30 | @end defspec 31 | 32 | @anchor{2d tileset tileset-margin}@defspec tileset-margin 33 | @end defspec 34 | 35 | @anchor{2d tileset tileset-spacing}@defspec tileset-spacing 36 | @end defspec 37 | 38 | @anchor{2d tileset tileset-ref}@defun tileset-ref tileset i 39 | Return the tile texture of TILESET at index I. 40 | 41 | @end defun 42 | -------------------------------------------------------------------------------- /doc/guile-2d.texi: -------------------------------------------------------------------------------- 1 | \input texinfo @c -*-texinfo-*- 2 | @c %**start of header 3 | @setfilename guile-2d.info 4 | @settitle Guile-2D 5 | @c %**end of header 6 | @copying 7 | Guile-2D is a 2D game development framework for GNU Guile. 8 | 9 | Copyright @copyright{} 2013 David Thompson 10 | 11 | @quotation 12 | Permission is granted to copy, distribute and/or modify this document 13 | under the terms of the GNU Free Documentation License, Version 1.3 14 | or any later version published by the Free Software Foundation; 15 | with no Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. 16 | A copy of the license is included in the section entitled ``GNU 17 | Free Documentation License''. 18 | 19 | A copy of the license is also available from the Free Software 20 | Foundation Web site at @url{http://www.gnu.org/licenses/fdl.html}. 21 | 22 | @end quotation 23 | 24 | The document was typeset with 25 | @uref{http://www.texinfo.org/, GNU Texinfo}. 26 | 27 | @end copying 28 | 29 | @titlepage 30 | @title Guile-2D 0.1 31 | @subtitle Guile-2D is a 2D game development framework for GNU Guile 32 | @author David Thompson 33 | @page 34 | @vskip 0pt plus 1filll 35 | @insertcopying 36 | @end titlepage 37 | 38 | @c Output the table of the contents at the beginning. 39 | @contents 40 | 41 | @ifnottex 42 | @node Top 43 | @top Guile-2D 44 | 45 | @insertcopying 46 | @end ifnottex 47 | 48 | @c Generate the nodes for this menu with `C-c C-u C-m'. 49 | @menu 50 | * Introduction:: 51 | * Games and Scenes:: 52 | * Graphics:: 53 | * Audio:: 54 | * Scripting:: 55 | * Math:: 56 | * Copying This Manual:: 57 | * Index:: 58 | @end menu 59 | 60 | @c Update all node entries with `C-c C-u C-n'. 61 | @c Insert new nodes with `C-c C-c n'. 62 | @include introduction.texi 63 | @include game.texi 64 | @include graphics.texi 65 | @include audio.texi 66 | @include scripting.texi 67 | @include math.texi 68 | 69 | @node Copying This Manual 70 | @appendix Copying This Manual 71 | 72 | @menu 73 | * GNU Free Documentation License:: License for copying this manual. 74 | @end menu 75 | 76 | @c Get fdl.texi from http://www.gnu.org/licenses/fdl.html 77 | @node GNU Free Documentation License 78 | @section GNU Free Documentation License 79 | @include fdl.texi 80 | 81 | @node Index 82 | @unnumbered Index 83 | 84 | @printindex cp 85 | 86 | @bye 87 | 88 | @c guile-2d.texi ends here 89 | -------------------------------------------------------------------------------- /doc/introduction.texi: -------------------------------------------------------------------------------- 1 | @node Introduction 2 | @chapter Introduction 3 | 4 | Guile-2D is a 2D game development framework for GNU Guile. Guile-2D 5 | aims to be simple for beginners to learn and to provide users with all 6 | of the necessary tools for making 2D computer games, such as sprites, 7 | tilesets, audio, scripting, and collision detection. 8 | 9 | This manual is a work in progress. You will find that it is lacking in 10 | many areas. If Guile-2D interests you, please consider helping to 11 | improve the documentation. 12 | 13 | @menu 14 | * Purpose:: 15 | * The Game Loop:: 16 | @end menu 17 | 18 | @node Purpose 19 | @section Purpose 20 | 21 | There are many existing game libraries and engines already, so why 22 | make another one? Well, I, the author, believe that GNU Guile is a 23 | fantastic Scheme implementation with a great purpose: to bring 24 | practical user freedom to the GNU system via Emacs-like 25 | extensibility. There are many libraries available to make games with 26 | languages such as Python, Java, and Lua, but there isn't much out 27 | there for Scheme. Guile-2D aims to change that. 28 | 29 | I originally set out on the journey to write a game in C with a Scheme 30 | scripting layer. A year later, I've decided that it would be best to 31 | create an generic game framework in order to give back to the Guile 32 | community and help promote Guile to game developers. 33 | 34 | Guile-2D draws much inspiration from existing game libraries for 35 | other, more popular programming languages. Pygame, pyglet, and love2d 36 | are very beginner friendly, and Guile-2D hopes to translate their good 37 | ideas into the Scheme world. 38 | 39 | @node The Game Loop 40 | @section The Game Loop 41 | 42 | The game loop is so fundamental that it has to be discussed 43 | immediately, so as to avoid any confusion about how it 44 | operates. Guile-2D's game loop operates on a fixed-timestep of 1/60th 45 | of a second. Time is measured in frames rather than in seconds to 46 | avoid the pitfalls of a variable time-based approach. Though the 47 | update rate is fixed, the frame-rate is not. Guile-2D will render at 48 | as high of a framerate as it can. Keyboard and mouse input is polled 49 | during every update and events are emitted to the relevant callbacks. 50 | -------------------------------------------------------------------------------- /doc/math.texi: -------------------------------------------------------------------------------- 1 | @node Math 2 | @chapter Math 3 | 4 | Games typically require a lot of linear algebra and trigonometry in 5 | order to function. Guile-2D provides modules to perform 2D vector 6 | math, degree to/from radian conversions, and axis-aligned bounding box 7 | collision tests. 8 | 9 | @menu 10 | * Vectors:: 11 | * Rectangles:: 12 | * Miscellaneous:: 13 | @end menu 14 | 15 | @include math/vector2.texi 16 | @include math/rect.texi 17 | @include math/math.texi 18 | -------------------------------------------------------------------------------- /doc/math/math.texi: -------------------------------------------------------------------------------- 1 | @node Miscellaneous 2 | @section Miscellaneous 3 | 4 | Miscellaneous math procedures. 5 | 6 | @anchor{2d math pi}@defvar pi 7 | @end defvar 8 | 9 | @anchor{2d math degrees->radians}@defun degrees->radians angle 10 | Convert ANGLE in degrees to radians. 11 | 12 | @end defun 13 | 14 | @anchor{2d math radians->degrees}@defun radians->degrees angle 15 | Convert ANGLE in radians to degrees. 16 | 17 | @end defun 18 | 19 | @anchor{2d math sin-degrees}@defun sin-degrees angle 20 | Compute the sin of ANGLE expressed in degrees. 21 | 22 | @end defun 23 | 24 | @anchor{2d math cos-degrees}@defun cos-degrees angle 25 | Compute the cosine of ANGLE expressed in degrees. 26 | 27 | @end defun 28 | 29 | @anchor{2d math tan-degrees}@defun tan-degrees angle 30 | Compute the tangent of ANGLE expressed in degrees. 31 | 32 | @end defun 33 | 34 | @anchor{2d math atan-degrees}@defun atan-degrees y x 35 | Compute the arctangent in degrees of the coordinates Y and X. 36 | 37 | @end defun 38 | -------------------------------------------------------------------------------- /doc/math/rect.texi: -------------------------------------------------------------------------------- 1 | @node Rectangles 2 | @section Rectangles 3 | 4 | Rects are axis-aligned bounding boxes that can be used for performing 5 | simple collision detection. 6 | 7 | @anchor{2d rect make-rect}@defspec make-rect 8 | @end defspec 9 | 10 | @anchor{2d rect rect?}@defspec rect? 11 | @end defspec 12 | 13 | @anchor{2d rect rect-x}@defspec rect-x 14 | @end defspec 15 | 16 | @anchor{2d rect rect-y}@defspec rect-y 17 | @end defspec 18 | 19 | @anchor{2d rect rect-x2}@defun rect-x2 rect 20 | @end defun 21 | 22 | @anchor{2d rect rect-y2}@defun rect-y2 rect 23 | @end defun 24 | 25 | @anchor{2d rect rect-center-x}@defun rect-center-x rect 26 | @end defun 27 | 28 | @anchor{2d rect rect-center-y}@defun rect-center-y rect 29 | @end defun 30 | 31 | @anchor{2d rect rect-half-width}@defun rect-half-width rect 32 | @end defun 33 | 34 | @anchor{2d rect rect-half-height}@defun rect-half-height rect 35 | @end defun 36 | 37 | @anchor{2d rect rect-width}@defspec rect-width 38 | @end defspec 39 | 40 | @anchor{2d rect rect-height}@defspec rect-height 41 | @end defspec 42 | 43 | @anchor{2d rect rect-position}@defun rect-position rect 44 | Return the top-left corner of RECT as a vector2. 45 | 46 | @end defun 47 | 48 | @anchor{2d rect rect-size}@defun rect-size rect 49 | Return the size of RECT as a vector2. 50 | 51 | @end defun 52 | 53 | @anchor{2d rect rect-move}@defun rect-move rect v 54 | Create a new rectangle by moving RECT by the given offset. rect-move 55 | accepts a vector2 or x and y coordinates as separate arguments. 56 | 57 | @end defun 58 | 59 | @anchor{2d rect rect-inflate}@defun rect-inflate rect v 60 | Create a new rectangle by growing RECT by the given amount without 61 | changing the center point. rect-inflate accepts a vector2 or x and y 62 | coordinates as separate arguments. 63 | 64 | @end defun 65 | 66 | @anchor{2d rect rect-union}@defun rect-union rect1 rect2 67 | Return a rect that covers the area of RECT1 and RECT2. 68 | 69 | @end defun 70 | 71 | @anchor{2d rect rect-clip}@defun rect-clip rect1 rect2 72 | Return the overlapping region of RECT1 and RECT2. If the rects do not 73 | overlap, a rect of size 0 is returned. 74 | 75 | @end defun 76 | 77 | @anchor{2d rect rect-within?}@defun rect-within? rect1 rect2 78 | Return #t if RECT2 is completely within RECT1. 79 | 80 | @end defun 81 | 82 | @anchor{2d rect rect-intersects?}@defun rect-intersects? rect1 rect2 83 | Return #t if RECT2 overlaps RECT1. 84 | 85 | @end defun 86 | 87 | @anchor{2d rect rect-contains?}@defun rect-contains? rect v 88 | Return #t if the given point is within RECT. 89 | 90 | @end defun 91 | -------------------------------------------------------------------------------- /doc/math/vector2.texi: -------------------------------------------------------------------------------- 1 | @node Vectors 2 | @section Vectors 3 | 4 | 2D vector math operations. Vector objects are of type vector2 to avoid 5 | confusion with regular Scheme vectors. 6 | 7 | @anchor{2d vector2 vector2}@defspec vector2 8 | @end defspec 9 | 10 | @anchor{2d vector2 vector2?}@defspec vector2? 11 | @end defspec 12 | 13 | @anchor{2d vector2 vx}@defspec vx 14 | @end defspec 15 | 16 | @anchor{2d vector2 vy}@defspec vy 17 | @end defspec 18 | 19 | @anchor{2d vector2 null-vector2}@defvar null-vector2 20 | @end defvar 21 | 22 | @anchor{2d vector2 identity-vector2}@defvar identity-vector2 23 | @end defvar 24 | 25 | @anchor{2d vector2 vector2-polar}@defun vector2-polar r theta 26 | Convert the polar coordinates (R, THETA) into a cartesian vector. 27 | 28 | @end defun 29 | 30 | @anchor{2d vector2 v+}@defun v+ . vectors 31 | Return the sum of all VECTORS. 32 | 33 | @end defun 34 | 35 | @anchor{2d vector2 v*}@defun v* . vectors 36 | Return the product of all VECTORS. 37 | 38 | @end defun 39 | 40 | @anchor{2d vector2 vscale}@defun vscale v scalar 41 | Multiply the vector V by a scalar value. 42 | 43 | @end defun 44 | 45 | @anchor{2d vector2 vmag}@defun vmag v 46 | Return the magnitude of the vector V. 47 | 48 | @end defun 49 | 50 | @anchor{2d vector2 vnorm}@defun vnorm v 51 | Normalize the vector V. 52 | 53 | @end defun 54 | 55 | @anchor{2d vector2 vdot}@defun vdot v1 v2 56 | Return the dot product of the vectors V1 and V2. 57 | 58 | @end defun 59 | 60 | @anchor{2d vector2 vcross}@defun vcross v1 v2 61 | Return the cross product of the vectors V1 and V2. Technically, the 62 | cross product of a 2D vector is not defined. This function instead 63 | returns the Z coordinate of the cross product as if the vectors were in 64 | 3D space. 65 | 66 | @end defun 67 | 68 | @anchor{2d vector2 vector2-translate}@defun vector2-translate v 69 | Perform an OpenGL translate operation with the vector V. 70 | 71 | @end defun 72 | 73 | @anchor{2d vector2 vector2-scale}@defun vector2-scale v 74 | Perform an OpenGL scale operation with the vector V. 75 | 76 | @end defun 77 | -------------------------------------------------------------------------------- /doc/scripting.texi: -------------------------------------------------------------------------------- 1 | @node Scripting 2 | @chapter Scripting 3 | 4 | The ability to write scripts is very important for most games. Scripts 5 | are short programs that modify game state. In an RPG, one might want 6 | to write a script that causes an NPC to walk up to the player and 7 | begin a conversation with them. Guile-2D allows for easy, linear 8 | script writing by using cooperative multitasking, also known as 9 | coroutines. Agendas are used to schedule scripts to be run at distinct 10 | points in game time, and actions provide an API to describe 11 | transformations that happen over a period of game time. 12 | 13 | @menu 14 | * Coroutines:: 15 | * Agendas:: 16 | * Actions:: 17 | @end menu 18 | 19 | @include scripting/coroutine.texi 20 | @include scripting/agenda.texi 21 | @include scripting/actions.texi 22 | -------------------------------------------------------------------------------- /doc/scripting/actions.texi: -------------------------------------------------------------------------------- 1 | @node Actions 2 | @section Actions 3 | 4 | Actions are composable procedures that perform an operation over a 5 | period of game time. Action objects have two properties: an arbitrary 6 | procedure and a duration in game ticks. Action procedures accept one 7 | argument: a time delta in the range [0, 1]. Use actions in combination 8 | with coroutines for things that are a function of time, such as moving 9 | a sprite across the screen. 10 | 11 | @anchor{2d actions make-action}@defun make-action proc duration 12 | Create a new action object that takes DURATION updates to complete. PROC 13 | is a procedure that takes a value in the range [0, 1] as its only 14 | argument. An error is thrown if DURATION is 0. 15 | 16 | @end defun 17 | 18 | @anchor{2d actions action?}@defspec action? 19 | @end defspec 20 | 21 | @anchor{2d actions null-action}@defvar null-action 22 | [unbound!] 23 | @end defvar 24 | 25 | @anchor{2d actions null-action?}@defvar null-action? 26 | [unbound!] 27 | @end defvar 28 | 29 | @anchor{2d actions action-duration}@defspec action-duration 30 | @end defspec 31 | 32 | @anchor{2d actions action-proc}@defspec action-proc 33 | @end defspec 34 | 35 | @anchor{2d actions perform-action}@defun perform-action action 36 | Execute ACTION. `perform-action` must be called from within a 37 | coroutine, as it yields back to the agenda after each step. 38 | 39 | @end defun 40 | 41 | @anchor{2d actions schedule-action}@defun schedule-action action 42 | Schedules a coroutine in the current agenda that will perform ACTION on 43 | the next update. 44 | 45 | @end defun 46 | 47 | @anchor{2d actions action-cons}@defun action-cons a1 a2 48 | Return an action that performs A1 first, followed by A2. 49 | 50 | @end defun 51 | 52 | @anchor{2d actions action-list}@defun action-list . actions 53 | Return an action that performs every action in the list ACTIONS. 54 | 55 | @end defun 56 | 57 | @anchor{2d actions action-parallel}@defun action-parallel . actions 58 | Perform every action in the list ACTIONS in parallel. 59 | 60 | @end defun 61 | 62 | @anchor{2d actions action-repeat}@defun action-repeat n action 63 | Return an action that will perform ACTION N times. 64 | 65 | @end defun 66 | 67 | @anchor{2d actions idle}@defun idle duration 68 | Return an action that does nothing. 69 | 70 | @end defun 71 | 72 | @anchor{2d actions lerp}@defun lerp proc start end duration 73 | Linearly interpolate a number from START to END that takes DURATION 74 | updates. Apply PROC to the linearly interpolated at each step. 75 | 76 | @end defun 77 | -------------------------------------------------------------------------------- /doc/scripting/agenda.texi: -------------------------------------------------------------------------------- 1 | @node Agendas 2 | @section Agendas 3 | 4 | Agendas are used to schedule procedures to be called at distinct 5 | points in game time. 6 | 7 | @anchor{2d agenda make-agenda}@defun make-agenda 8 | Create a new, empty agenda. 9 | 10 | @end defun 11 | 12 | @anchor{2d agenda with-agenda}@defspec with-agenda agenda body ... 13 | @end defspec 14 | 15 | @anchor{2d agenda agenda-schedule}@defun agenda-schedule thunk [delay] 16 | Schedule THUNK in the current agenda to run after DELAY updates (1 by 17 | default). 18 | 19 | @end defun 20 | 21 | @anchor{2d agenda agenda-schedule-interval}@defun agenda-schedule-interval thunk [interval] [delay] 22 | Schedule THUNK in the current agenda to run after DELAY updates and run 23 | every INTERVAL updates thereafter. Both DELAY and INTERVAL default to 24 | 1. Simply pass THUNK and nothing else to schedule THUNK to be run upon 25 | every update. 26 | 27 | @end defun 28 | 29 | @anchor{2d agenda update-agenda}@defun update-agenda 30 | Update the current agenda. 31 | 32 | @end defun 33 | 34 | @anchor{2d agenda clear-agenda}@defun clear-agenda 35 | Clear the current agenda. 36 | 37 | @end defun 38 | -------------------------------------------------------------------------------- /doc/scripting/coroutine.texi: -------------------------------------------------------------------------------- 1 | @node Coroutines 2 | @section Coroutines 3 | 4 | Coroutines are the building block for cooperative multitasking. When 5 | used with agendas, they are a powerful mechanism for writing game 6 | scripts. 7 | 8 | @anchor{2d coroutine coroutine}@defun coroutine thunk 9 | Calls a procedure that can yield a continuation. 10 | 11 | @end defun 12 | 13 | @anchor{2d coroutine colambda}@defspec colambda args body ... 14 | Syntacic sugar for a lambda that is run as a coroutine. 15 | 16 | @end defspec 17 | 18 | @anchor{2d coroutine codefine}@defspec codefine (name ...) . body 19 | Syntactic sugar for defining a procedure that is run as a coroutine. 20 | 21 | @end defspec 22 | 23 | @anchor{2d coroutine codefine*}@defspec codefine* (name ...) . body 24 | Syntactic sugar for defining a procedure with optional and keyword 25 | arguments that is run as a coroutine. 26 | 27 | @end defspec 28 | 29 | @anchor{2d coroutine wait}@defun wait [delay] 30 | Yield coroutine and schdule the continuation to be run after DELAY 31 | ticks. 32 | 33 | @end defun 34 | 35 | @anchor{2d coroutine yield}@defun yield callback 36 | Yield continuation to a CALLBACK procedure. 37 | 38 | @end defun 39 | -------------------------------------------------------------------------------- /env.in: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | GUILE_LOAD_PATH=@abs_top_srcdir@:$GUILE_LOAD_PATH 4 | if test "@abs_top_srcdir@" != "@abs_top_builddir@"; then 5 | GUILE_LOAD_PATH=@abs_top_builddir@:$GUILE_LOAD_PATH 6 | fi 7 | GUILE_LOAD_COMPILED_PATH=@abs_top_builddir@:$GUILE_LOAD_PATH 8 | PATH=@abs_top_builddir@/bin:$PATH 9 | 10 | export GUILE_LOAD_PATH 11 | export GUILE_LOAD_COMPILED_PATH 12 | export PATH 13 | 14 | exec "$@" 15 | -------------------------------------------------------------------------------- /examples/action.scm: -------------------------------------------------------------------------------- 1 | (use-modules (2d actions) 2 | (2d agenda) 3 | (2d coroutine) 4 | (2d game) 5 | (2d scene) 6 | (2d sprite) 7 | (2d stage) 8 | (2d vector2)) 9 | 10 | (define (enter sprite) 11 | (let ((size (game-resolution actions-demo))) 12 | (schedule-action 13 | (action-parallel 14 | ;; Move horizontally across the screen in 60 frames. 15 | (lerp (lambda (x) 16 | (set-sprite-position! 17 | sprite 18 | (vector2 x (/ (vy size) 2)))) 19 | 0 (vx size) 60) 20 | ;; Rotate 1080 degrees in 120 frames. 21 | (lerp (lambda (angle) 22 | (set-sprite-rotation! sprite angle)) 23 | 0 360 120))))) 24 | 25 | (define actions-scene 26 | (make-scene 27 | "Actions" 28 | #:init (lambda () 29 | (load-sprite "images/ghost.png" 30 | #:position (vector2 320 240))) 31 | #:enter enter 32 | #:draw draw-sprite)) 33 | 34 | (define actions-demo 35 | (make-game 36 | #:title "Actions" 37 | #:first-scene actions-scene)) 38 | 39 | (run-game actions-demo) 40 | -------------------------------------------------------------------------------- /examples/animation.scm: -------------------------------------------------------------------------------- 1 | (use-modules (2d animation) 2 | (2d game) 3 | (2d scene) 4 | (2d sprite) 5 | (2d stage) 6 | (2d tileset) 7 | (2d vector2) 8 | (2d window)) 9 | 10 | (define (make-demo-animation) 11 | "Load a texture, split it into 64x64 tiles, and build an animated 12 | sprite out of it." 13 | (let* ((tiles (load-tileset "images/princess.png" 64 64)) 14 | (frames (vector (tileset-ref tiles 19) 15 | (tileset-ref tiles 20) 16 | (tileset-ref tiles 21) 17 | (tileset-ref tiles 22) 18 | (tileset-ref tiles 23) 19 | (tileset-ref tiles 24) 20 | (tileset-ref tiles 25) 21 | (tileset-ref tiles 26)))) 22 | (make-animation frames 6 #t))) 23 | 24 | (define animation-scene 25 | (make-scene 26 | "Animation" 27 | #:init (lambda () 28 | (make-sprite (make-demo-animation) 29 | #:position (vector2 320 240))) 30 | #:draw draw-sprite)) 31 | 32 | (define animation-demo 33 | (make-game 34 | #:title "Animation" 35 | #:first-scene animation-scene)) 36 | 37 | (run-game animation-demo) 38 | -------------------------------------------------------------------------------- /examples/coroutine.scm: -------------------------------------------------------------------------------- 1 | (use-modules (2d agenda) 2 | (2d coroutine) 3 | (2d game) 4 | (2d scene) 5 | (2d sprite) 6 | (2d stage) 7 | (2d vector2)) 8 | 9 | (define (enter sprite) 10 | ;; Simple script that moves the sprite to a random location every 11 | ;; second. 12 | (agenda-schedule 13 | (colambda () 14 | (while #t 15 | (set-sprite-position! 16 | sprite 17 | (vector2 (random (vx (game-resolution coroutine-demo))) 18 | (random (vy (game-resolution coroutine-demo))))) 19 | (wait 60))))) 20 | 21 | (define coroutine-scene 22 | (make-scene 23 | "Coroutine" 24 | #:init (lambda () 25 | (load-sprite "images/ghost.png" 26 | #:position (vector2 320 240))) 27 | #:enter enter 28 | #:draw draw-sprite)) 29 | 30 | (define coroutine-demo 31 | (make-game 32 | #:title "Coroutines" 33 | #:first-scene coroutine-scene)) 34 | 35 | (run-game coroutine-demo) 36 | -------------------------------------------------------------------------------- /examples/font.scm: -------------------------------------------------------------------------------- 1 | (use-modules (srfi srfi-9) 2 | (figl gl) 3 | (2d color) 4 | (2d font) 5 | (2d game) 6 | (2d scene) 7 | (2d stage) 8 | (2d vector2)) 9 | 10 | (define (make-demo-textbox) 11 | (make-textbox (load-font "fonts/Boxy-Bold.ttf" 48) 12 | "The quick brown fox jumped over the lazy dog." 13 | (vector2 240 160) 14 | white 15 | 'left 16 | 200)) 17 | 18 | (define fonts-scene 19 | (make-scene 20 | "Fonts" 21 | #:init make-demo-textbox 22 | #:draw draw-textbox)) 23 | 24 | (define fonts-demo 25 | (make-game 26 | #:title "Fonts" 27 | #:first-scene fonts-scene)) 28 | 29 | (run-game fonts-demo) 30 | -------------------------------------------------------------------------------- /examples/fonts/AUTHORS: -------------------------------------------------------------------------------- 1 | Clint Bellanger and William Thompson 2 | http://opengameart.org/content/boxy-bold-truetype-font -------------------------------------------------------------------------------- /examples/fonts/Boxy-Bold.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/davexunit/guile-2d/83d9dfab5b04a337565cb2798847b15e4fbd7786/examples/fonts/Boxy-Bold.ttf -------------------------------------------------------------------------------- /examples/images/AUTHORS: -------------------------------------------------------------------------------- 1 | Zabin, Daneeklu, Jetrel, Hyptosis, Redshrike, Bertram 2 | http://opengameart.org/content/rpg-tiles-cobble-stone-paths-town-objects 3 | 4 | Chris Gabriel 5 | http://opengameart.org/content/lpc-in-battle-rpg-sprites 6 | 7 | Lanea Zimmerman (AKA Sharm) 8 | http://opengameart.org/content/liberated-pixel-cup-base-assets-sprites-map-tiles 9 | -------------------------------------------------------------------------------- /examples/images/bullet.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/davexunit/guile-2d/83d9dfab5b04a337565cb2798847b15e4fbd7786/examples/images/bullet.png -------------------------------------------------------------------------------- /examples/images/ghost.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/davexunit/guile-2d/83d9dfab5b04a337565cb2798847b15e4fbd7786/examples/images/ghost.png -------------------------------------------------------------------------------- /examples/images/princess.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/davexunit/guile-2d/83d9dfab5b04a337565cb2798847b15e4fbd7786/examples/images/princess.png -------------------------------------------------------------------------------- /examples/images/stars.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/davexunit/guile-2d/83d9dfab5b04a337565cb2798847b15e4fbd7786/examples/images/stars.png -------------------------------------------------------------------------------- /examples/images/tiles.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/davexunit/guile-2d/83d9dfab5b04a337565cb2798847b15e4fbd7786/examples/images/tiles.png -------------------------------------------------------------------------------- /examples/particles.scm: -------------------------------------------------------------------------------- 1 | ;; load the SDL module and some useful srfi's 2 | (use-modules (srfi srfi-1) 3 | (srfi srfi-9) 4 | (2d game) 5 | (2d scene) 6 | (2d sprite) 7 | (2d texture) 8 | (2d vector2)) 9 | 10 | (set! *random-state* (random-state-from-platform)) 11 | 12 | ;;; 13 | ;;; Particles 14 | ;;; 15 | 16 | (define-record-type 17 | (make-particle sprite position velocity) 18 | particle? 19 | (sprite particle-sprite) 20 | (position particle-position set-particle-position!) 21 | (velocity particle-velocity set-particle-velocity!)) 22 | 23 | (define (update-particle! particle) 24 | (set-particle-position! particle 25 | (v+ (particle-position particle) 26 | (particle-velocity particle)))) 27 | 28 | ;;; 29 | ;;; Demo 30 | ;;; 31 | 32 | (define-record-type 33 | (make-demo-state stars particles) 34 | demo-state? 35 | (stars demo-stars) 36 | (particles demo-particles)) 37 | 38 | (define (generate-particles n) 39 | (let ((particle-image (load-texture "images/bullet.png")) 40 | (game-size (game-resolution particles))) 41 | (list-tabulate n (lambda (n) 42 | (make-particle (make-sprite particle-image) 43 | (vector2 (random (vx game-size)) 44 | (random (vy game-size))) 45 | (vector2 (* (random:normal) 1) 46 | (* (random:normal) 1))))))) 47 | 48 | (define particle-count 500) 49 | (define batch (make-sprite-batch (* particle-count 4))) 50 | 51 | (define (draw-particles particles) 52 | (with-sprite-batch batch 53 | (for-each 54 | (lambda (p) 55 | (let* ((sprite (particle-sprite p))) 56 | (set-sprite-position! sprite (particle-position p)) 57 | (draw-sprite sprite))) 58 | particles))) 59 | 60 | (define (draw state) 61 | (draw-sprite (demo-stars state)) 62 | (draw-particles (demo-particles state))) 63 | 64 | (define (update state) 65 | (for-each update-particle! (demo-particles state))) 66 | 67 | (define (init) 68 | (make-demo-state (load-sprite "images/stars.png" 69 | #:anchor null-vector2) 70 | (generate-particles particle-count))) 71 | 72 | (define particles-scene 73 | (make-scene 74 | "Particles" 75 | #:draw draw 76 | #:update update 77 | #:init init)) 78 | 79 | (define particles 80 | (make-game 81 | #:title "Particles" 82 | #:first-scene particles-scene)) 83 | 84 | (run-game particles) 85 | -------------------------------------------------------------------------------- /examples/scenes.scm: -------------------------------------------------------------------------------- 1 | (use-modules (2d game) 2 | (2d scene) 3 | (2d stage) 4 | (2d sprite) 5 | (2d vector2)) 6 | 7 | ;; Press the RETURN key to toggle between the 2 scenes. 8 | 9 | ;;; 10 | ;;; Scene 1 11 | ;;; 12 | 13 | (define (make-sprite-1) 14 | (load-sprite "images/ghost.png" 15 | #:position (vector2 320 240))) 16 | 17 | (define (scene-1-key-down sprite key mod unicode) 18 | (when (eq? key 'return) 19 | (replace-scene scene-2))) 20 | 21 | (define scene-1 22 | (make-scene 23 | "Scene 1" 24 | #:init make-sprite-1 25 | #:enter (lambda (sprite) (display "Enter Scene 1\n")) 26 | #:exit (lambda (sprite) (display "Exit Scene 1\n")) 27 | #:draw draw-sprite 28 | #:events (append 29 | (default-events) 30 | `((key-down . ,scene-1-key-down))))) 31 | 32 | ;;; 33 | ;;; Scene 2 34 | ;;; 35 | 36 | (define (make-sprite-2) 37 | (load-sprite "images/stars.png" 38 | #:position (vector2 320 240))) 39 | 40 | (define (scene-2-key-down sprite key mod unicode) 41 | (when (eq? key 'return) 42 | (replace-scene scene-1))) 43 | 44 | (define scene-2 45 | (make-scene 46 | "Scene 2" 47 | #:init make-sprite-2 48 | #:enter (lambda (sprite) (display "Enter Scene 2\n")) 49 | #:exit (lambda (sprite) (display "Exit Scene 2\n")) 50 | #:draw draw-sprite 51 | #:events (append 52 | (default-events) 53 | `((key-down . ,scene-2-key-down))))) 54 | 55 | (define scenes-demo 56 | (make-game 57 | #:title "Scenes" 58 | #:first-scene scene-1)) 59 | 60 | (run-game scenes-demo) 61 | -------------------------------------------------------------------------------- /examples/simple.scm: -------------------------------------------------------------------------------- 1 | (use-modules (2d game) 2 | (2d scene) 3 | (2d sprite) 4 | (2d vector2)) 5 | 6 | (define (make-demo-sprite) 7 | (load-sprite "images/ghost.png" 8 | #:position (vector2 320 240))) 9 | 10 | (define simple-scene 11 | (make-scene 12 | "Simple" 13 | #:init make-demo-sprite 14 | #:draw draw-sprite)) 15 | 16 | (define simple-demo 17 | (make-game 18 | #:title "Simple Demo" 19 | #:first-scene simple-scene)) 20 | 21 | (run-game simple-demo) 22 | -------------------------------------------------------------------------------- /examples/tilemap.scm: -------------------------------------------------------------------------------- 1 | (use-modules (srfi srfi-1) 2 | (srfi srfi-9) 3 | (srfi srfi-42) 4 | (2d game) 5 | (2d scene) 6 | (2d sprite) 7 | (2d texture) 8 | (2d tileset) 9 | (2d vector2)) 10 | 11 | ;;; 12 | ;;; Orthogonal tile map example 13 | ;;; 14 | 15 | ;; This is a quick and dirty tile map implementation. No fancy map 16 | ;; loading. Just a hardcoded tile map that demonstrates the 17 | ;; split-texture procedure. 18 | 19 | ;; tiles is a 2d array of texture regions. 20 | (define-record-type 21 | (make-map-layer width height tile-width tile-height tiles) 22 | map-layer? 23 | (width map-layer-width) 24 | (height map-layer-height) 25 | (tile-width map-layer-tile-width) 26 | (tile-height map-layer-tile-height) 27 | (tiles map-layer-tiles)) 28 | 29 | (define draw-map-layer 30 | (let ((batch (make-sprite-batch 2000))) 31 | (lambda (layer) 32 | (with-sprite-batch batch 33 | (do-ec (: y (map-layer-height layer)) 34 | (: x (map-layer-width layer)) 35 | (let ((tile (array-ref (map-layer-tiles layer) y x))) 36 | (draw-sprite tile))))))) 37 | 38 | ;; A small 8x8 array of tile indices. 39 | (define map-width 8) 40 | (define map-height 8) 41 | (define map-tiles 42 | #2u32((00 01 01 01 01 01 01 02) 43 | (16 17 17 17 17 17 17 18) 44 | (16 17 17 17 17 17 17 18) 45 | (16 17 17 48 49 17 17 18) 46 | (16 17 17 64 65 17 17 18) 47 | (16 17 17 17 17 17 17 18) 48 | (16 17 17 17 17 17 17 18) 49 | (32 33 33 33 33 33 33 34))) 50 | 51 | (define tile-width 32) 52 | (define tile-height 32) 53 | 54 | (define (random-map width height tileset) 55 | (let ((tiles (make-array 0 height width)) 56 | (n (vector-length tileset))) 57 | (do-ec (: y height) (: x width) 58 | (array-set! tiles (random n) y x)) 59 | tiles)) 60 | 61 | (define (tiles->sprites width height tile-width tile-height tileset tiles) 62 | (define (build-sprite x y) 63 | (let ((region (tileset-ref tileset (array-ref tiles y x)))) 64 | (make-sprite region 65 | #:position (vector2 (* x tile-width) 66 | (* y tile-height)) 67 | #:anchor null-vector2))) 68 | 69 | (let ((sprites (list-ec (: y height) 70 | (list-ec (: x width) 71 | (build-sprite x y))))) 72 | (list->array 2 sprites))) 73 | 74 | (define (build-map) 75 | ;; Load tileset and build map layer 76 | (let ((tileset (load-tileset "images/tiles.png" 32 32))) 77 | (make-map-layer map-width map-height tile-width tile-height 78 | (tiles->sprites map-width 79 | map-height 80 | tile-width 81 | tile-height 82 | tileset 83 | map-tiles)))) 84 | 85 | (define tilemap-scene 86 | (make-scene 87 | "Tilemap" 88 | #:init build-map 89 | #:draw draw-map-layer)) 90 | 91 | (define tilemap 92 | (make-game 93 | #:title "Tilemap" 94 | #:first-scene tilemap-scene)) 95 | 96 | (run-game tilemap) 97 | -------------------------------------------------------------------------------- /guile.am: -------------------------------------------------------------------------------- 1 | GOBJECTS = $(SOURCES:%.scm=%.go) 2 | 3 | nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES) 4 | nobase_go_DATA = $(GOBJECTS) 5 | 6 | # Make sure source files are installed first, so that the mtime of 7 | # installed compiled files is greater than that of installed source 8 | # files. See 9 | # 10 | # for details. 11 | guile_install_go_files = install-nobase_goDATA 12 | $(guile_install_go_files): install-nobase_modDATA 13 | 14 | CLEANFILES = $(GOBJECTS) 15 | EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES) 16 | GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat 17 | SUFFIXES = .scm .go 18 | .scm.go: 19 | $(AM_V_GEN)$(top_builddir)/env $(GUILE_TOOLS) compile $(GUILE_WARNINGS) -o "$@" "$<" 20 | --------------------------------------------------------------------------------