From f47eb69a354188154731846dde8b384c2c2f39f6 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Sat, 28 Jun 2014 18:46:16 -0400 Subject: Rename guile-2d to Sly! Massive find/replace job. --- 2d/agenda.scm | 206 ----------------------------- 2d/animation.scm | 119 ----------------- 2d/audio.scm | 128 ------------------ 2d/color.scm | 203 ---------------------------- 2d/config.scm.in | 28 ---- 2d/coroutine.scm | 82 ------------ 2d/event.scm | 45 ------- 2d/font.scm | 156 ---------------------- 2d/fps.scm | 47 ------- 2d/game.scm | 109 --------------- 2d/helpers.scm | 68 ---------- 2d/keyboard.scm | 88 ------------ 2d/live-reload.scm | 54 -------- 2d/math.scm | 90 ------------- 2d/mouse.scm | 99 -------------- 2d/rect.scm | 212 ----------------------------- 2d/repl.scm | 37 ------ 2d/shader.scm | 331 ---------------------------------------------- 2d/signal.scm | 292 ---------------------------------------- 2d/sprite.scm | 188 -------------------------- 2d/texture.scm | 224 ------------------------------- 2d/tileset.scm | 89 ------------- 2d/transform.scm | 233 -------------------------------- 2d/vector.scm | 157 ---------------------- 2d/window.scm | 118 ----------------- 2d/wrappers/freeimage.scm | 263 ------------------------------------ 2d/wrappers/gl.scm | 96 -------------- 2d/wrappers/util.scm | 40 ------ 28 files changed, 3802 deletions(-) delete mode 100644 2d/agenda.scm delete mode 100644 2d/animation.scm delete mode 100644 2d/audio.scm delete mode 100644 2d/color.scm delete mode 100644 2d/config.scm.in delete mode 100644 2d/coroutine.scm delete mode 100644 2d/event.scm delete mode 100644 2d/font.scm delete mode 100644 2d/fps.scm delete mode 100644 2d/game.scm delete mode 100644 2d/helpers.scm delete mode 100644 2d/keyboard.scm delete mode 100644 2d/live-reload.scm delete mode 100644 2d/math.scm delete mode 100644 2d/mouse.scm delete mode 100644 2d/rect.scm delete mode 100644 2d/repl.scm delete mode 100644 2d/shader.scm delete mode 100644 2d/signal.scm delete mode 100644 2d/sprite.scm delete mode 100644 2d/texture.scm delete mode 100644 2d/tileset.scm delete mode 100644 2d/transform.scm delete mode 100644 2d/vector.scm delete mode 100644 2d/window.scm delete mode 100644 2d/wrappers/freeimage.scm delete mode 100644 2d/wrappers/gl.scm delete mode 100644 2d/wrappers/util.scm (limited to '2d') diff --git a/2d/agenda.scm b/2d/agenda.scm deleted file mode 100644 index ab36f23..0000000 --- a/2d/agenda.scm +++ /dev/null @@ -1,206 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson -;;; -;;; This program is free software: you can redistribute it and/or -;;; modify it under the terms of the GNU General Public License as -;;; published by the Free Software Foundation, either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; . - -;;; Commentary: -;; -;; Deferred procedure scheduling. -;; -;;; Code: - -(define-module (2d agenda) - #:use-module (ice-9 q) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-26) - #:use-module (2d coroutine) - #:export (make-agenda - agenda? - agenda-time - current-agenda - with-agenda - tick-agenda! - clear-agenda! - schedule - schedule-interval - schedule-each - wait)) - -;; This code is a modified version of the agenda implementation in -;; SICP. Thank you, SICP! - -;;; -;;; Time segment -;;; - -(define-record-type - (%make-time-segment time queue) - time-segment? - (time segment-time) - (queue segment-queue)) - -(define (make-time-segment time . callbacks) - "Create a new time segment at TIME and enqueues everything in the -list CALLBACKS." - (let ((segment (%make-time-segment time (make-q)))) - ;; Enqueue all callbacks - (for-each (cut segment-enq segment <>) callbacks) - segment)) - -(define (segment-enq segment callback) - "Add the CALLBACK procedure to SEGMENT's queue." - (enq! (segment-queue segment) callback)) - -;;; -;;; Agenda -;;; - -(define-record-type - (%make-agenda time segments) - agenda? - (time %agenda-time set-agenda-time!) - (segments agenda-segments set-agenda-segments!)) - -(define (make-agenda) - "Create a new, empty agenda." - (%make-agenda 0 '())) - -(define (agenda-empty? agenda) - "Return #t if AGENDA has no scheduled procedures." - (null? (agenda-segments agenda))) - -(define (first-segment agenda) - "Return the first time segment in AGENDA." - (car (agenda-segments agenda))) - -(define (rest-segments agenda) - "Return everything but the first segment in AGENDA." - (cdr (agenda-segments agenda))) - -(define (agenda-add-segment agenda time callback) - "Add a new time segment to the beginning of AGENDA at the given TIME -and enqueue CALLBACK." - (set-agenda-segments! agenda - (cons (make-time-segment time callback) - (agenda-segments agenda)))) - -(define (insert-segment segments time callback) - "Insert a new time segment after the first segment in SEGMENTS." - (set-cdr! segments - (cons (make-time-segment time callback) - (cdr segments)))) - -(define (first-agenda-item agenda) - "Return the first time segment queue in AGENDA." - (if (agenda-empty? agenda) - (error "Agenda is empty") - (segment-queue (first-segment agenda)))) - -(define (agenda-time-delay agenda dt) - "Return the sum of the time delta, DT, and the current time of AGENDA." - (+ (%agenda-time agenda) (inexact->exact (round dt)))) - -(define (flush-queue! q) - "Dequeue and execute every member of Q." - (unless (q-empty? q) - ((deq! q)) ;; Execute scheduled procedure - (flush-queue! q))) - -(define (%tick-agenda! agenda) - "Move AGENDA forward in time and run scheduled procedures." - (set-agenda-time! agenda (1+ (%agenda-time agenda))) - (let next-segment () - (unless (agenda-empty? agenda) - (let ((segment (first-segment agenda))) - ;; Process time segment if it is scheduled before or at the - ;; current agenda time. - (when (>= (%agenda-time agenda) (segment-time segment)) - (flush-queue! (segment-queue segment)) - (set-agenda-segments! agenda (rest-segments agenda)) - (next-segment)))))) - -(define (%clear-agenda! agenda) - "Remove all scheduled procedures from AGENDA." - (set-agenda-segments! agenda '())) - -(define (%schedule agenda thunk delay) - "Schedule THUNK to be run after DELAY ticks of AGENDA." - (let ((time (agenda-time-delay agenda delay))) - (define (belongs-before? segments) - (or (null? segments) - (< time (segment-time (car segments))))) - - (define (add-to-segments segments) - ;; Add to existing time segment if the times match - (if (= (segment-time (car segments)) time) - (segment-enq (car segments) thunk) - ;; Continue searching - (if (belongs-before? (cdr segments)) - ;; Create new time segment and insert it where it belongs - (insert-segment segments time thunk) - ;; Continue searching - (add-to-segments (cdr segments))))) - - (if (belongs-before? (agenda-segments agenda)) - (agenda-add-segment agenda time thunk) - (add-to-segments (agenda-segments agenda))))) - -(define current-agenda - (make-parameter (make-agenda) - (lambda (val) - (if (agenda? val) - val - (error "Must be an agenda"))))) - -(define-syntax-rule (with-agenda agenda body ...) - (parameterize ((current-agenda agenda)) - body ...)) - -(define (agenda-time) - "Return the time of the current agenda." - (%agenda-time (current-agenda))) - -(define (tick-agenda!) - "Increment time for the current agenda and run scheduled -procedures." - (%tick-agenda! (current-agenda))) - -(define (clear-agenda!) - "Remove all scheduled procedures from the current agenda." - (%clear-agenda! (current-agenda))) - -(define* (schedule thunk #:optional (delay 1)) - "Schedule THUNK to be applied after DELAY ticks of the current -agenda, or 1 tick if DELAY is not specified." - (%schedule (current-agenda) thunk delay)) - -(define (schedule-interval thunk interval) - "Schedule THUNK to be applied every INTERVAL ticks of the current -agenda." - (coroutine - (while #t - (wait interval) - (thunk)))) - -(define (schedule-each thunk) - "Schedule THUNK to be applied upon every tick of the current -agenda." - (schedule-interval thunk 1)) - -(define (wait delay) - "Abort coroutine and schedule the continuation to be run after DELAY -ticks of the current agenda." - (yield (cut schedule <> delay))) diff --git a/2d/animation.scm b/2d/animation.scm deleted file mode 100644 index 4998036..0000000 --- a/2d/animation.scm +++ /dev/null @@ -1,119 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson -;;; -;;; This program is free software: you can redistribute it and/or -;;; modify it under the terms of the GNU General Public License as -;;; published by the Free Software Foundation, either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; . - -;;; Commentary: -;; -;; Animations represent a sequence of textures and/or texture regions. -;; -;;; Code: - -(define-module (2d animation) - #:use-module (srfi srfi-9) - #:use-module (2d texture)) - -;;; -;;; Animations -;;; - -;; The type represents a vector of textures or texture -;; regions that are to be played in sequence and possibly looped. -(define-record-type - (make-animation frames frame-duration loop) - animation? - (frames animation-frames) - (frame-duration animation-frame-duration) - (loop animation-loop?)) - -(define (animation-frame animation index) - "Return the texture for the given frame INDEX of ANIMATION." - (vector-ref (animation-frames animation) index)) - -(define (animation-length animation) - "Return the number of frames in ANIMATION." - (vector-length (animation-frames animation))) - -(define (animation-duration animation) - "Return the total duration of ANIMATION in ticks." - (* (animation-length animation) - (animation-frame-duration animation))) - -(export make-animation - animation? - animation-frames - animation-frame-duration - animation-loop? - animation-frame - animation-length - animation-duration) - -;; The type encapsulates the state for playing an -;; animation. -(define-record-type - (%make-animator animation frame time playing) - animator? - (animation animator-animation) - (frame animator-frame set-animator-frame!) - (time animator-time set-animator-time!) - (playing animator-playing? set-animator-playing!)) - -(define (make-animator animation) - "Create a new animator for ANIMATION." - (%make-animator animation 0 0 #t)) - -(define (animator-frame-complete? animator) - "Return #t when ANIMATOR is done displaying the current frame." - (>= (animator-time animator) - (animation-frame-duration (animator-animation animator)))) - -(define (animator-next-frame animator) - "Return the next frame index for ANIMATOR." - (modulo (1+ (animator-frame animator)) - (animation-length (animator-animation animator)))) - -(define (animator-texture animator) - "Return a texture for the ANIMATOR's current frame." - (animation-frame (animator-animation animator) - (animator-frame animator))) - -(define (animator-next! animator) - "Advance ANIMATOR to the next frame of its animation." - (let ((next-frame (animator-next-frame animator)) - (animation (animator-animation animator))) - (set-animator-time! animator 0) - (set-animator-frame! animator next-frame) - (set-animator-playing! animator (or (not (zero? next-frame)) - (animation-loop? animation))))) - -(define (animator-update! animator) - "Increment the frame time for the ANIMATOR and advance to the next -frame when necessary." - (when (animator-playing? animator) - (set-animator-time! animator (1+ (animator-time animator))) - (when (animator-frame-complete? animator) - (animator-next! animator)))) - -(export make-animator - animator? - animator-animation - animator-frame - animator-time - animator-frame-complete? - animator-playing? - animator-next-frame - animator-texture - animator-next! - animator-update!) diff --git a/2d/audio.scm b/2d/audio.scm deleted file mode 100644 index 3accb8b..0000000 --- a/2d/audio.scm +++ /dev/null @@ -1,128 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson -;;; -;;; This program is free software: you can redistribute it and/or -;;; modify it under the terms of the GNU General Public License as -;;; published by the Free Software Foundation, either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; . - -;;; Commentary: -;; -;; Wrappers over SDL mixer. -;; -;;; Code: - -(define-module (2d audio) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-2) - #:use-module ((sdl mixer) #:prefix SDL:) - #:export (enable-audio - load-sample - sample? - sample-audio - sample-volume - set-sample-volume - play-sample - load-music - music? - music-audio - music-volume - play-music - set-music-volume - pause-music - resume-music - rewind-music - stop-music - music-paused? - music-playing?)) - -(define (enable-audio) - (SDL:open-audio)) - -;; Used to wrap SDL audio functions whose return values should be -;; ignored. -(define-syntax-rule (ignore-value body ...) - (begin - body ... - *unspecified*)) - -;; Wrapper over SDL audio objects. -(define-record-type - (make-sample audio) - sample? - (audio sample-audio)) - -(define (load-sample filename) - "Load audio sample from FILENAME or return #f if the file cannot be -loaded" - (let ((audio (SDL:load-wave filename))) - (if audio (make-sample audio) #f))) - -(define (sample-volume) - "Return the volume that all samples are played at." - (SDL:volume)) - -(define (set-sample-volume volume) - "Set the volume that all samples are played at to VOLUME." - (ignore-value (SDL:volume volume))) - -(define (play-sample sample) - "Play the given audio SAMPLE." - (ignore-value (SDL:play-channel (sample-audio sample)))) - -;; Wrapper over SDL music objects. -(define-record-type - (make-music audio) - music? - (audio music-audio)) - -(define (load-music filename) - "Load music from FILENAME or return #f if the file cannot be -loaded." - (let ((audio (SDL:load-music filename))) - (if audio (make-music audio) #f))) - -(define (music-volume) - "Return the volume that music is played at." - (SDL:music-volume)) - -(define (set-music-volume volume) - "Set the volume that music is played at to VOLUME." - (ignore-value (SDL:volume volume))) - -(define (play-music music) - "Play the given MUSIC." - (ignore-value (SDL:play-music (music-audio music)))) - -(define (pause-music) - "Pause the current music track." - (ignore-value (SDL:pause-music))) - -(define (resume-music) - "Resume the current music track." - (ignore-value (SDL:resume-music))) - -(define (rewind-music) - "Restart the current music track." - (ignore-value (SDL:rewind-music))) - -(define (stop-music) - "Stop playing the current music track." - (ignore-value (SDL:halt-music))) - -(define (music-playing?) - "Return #t if music is currently playing, otherwise return #f." - (SDL:playing-music?)) - -(define (music-paused?) - "Return #t if music is currently paused, otherwise return #f." - (SDL:paused-music?)) diff --git a/2d/color.scm b/2d/color.scm deleted file mode 100644 index d3aba00..0000000 --- a/2d/color.scm +++ /dev/null @@ -1,203 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson -;;; -;;; This program is free software: you can redistribute it and/or -;;; modify it under the terms of the GNU General Public License as -;;; published by the Free Software Foundation, either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; . - -;;; Commentary: -;; -;; Color. -;; -;;; Code: - -(define-module (2d color) - #:use-module (gl) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-1) - #:use-module (2d math) - #:export ( - make-color - color? - color-r - color-g - color-b - color-a - rgba - rgb - color* - color+ - color- - color-inverse - white - black - red - green - blue - yellow - magenta - cyan - tango-light-butter - tango-butter - tango-dark-butter - tango-light-orange - tango-orange - tango-dark-orange - tango-light-chocolate - tango-chocolate - tango-dark-chocolate - tango-light-chameleon - tango-chameleon - tango-dark-chameleon - tango-light-sky-blue - tango-sky-blue - tango-dark-sky-blue - tango-light-plum - tango-plum - tango-dark-plum - tango-light-scarlet-red - tango-scarlet-red - tango-dark-scarlet-red - tango-aluminium-1 - tango-aluminium-2 - tango-aluminium-3 - tango-aluminium-4 - tango-aluminium-5 - tango-aluminium-6)) - -(define-record-type - (%make-color r g b a) - color? - (r color-r) - (g color-g) - (b color-b) - (a color-a)) - -(define (make-color r g b a) - "Return a newly allocated color with the given RGBA channel values. -Each channel is clamped to the range [0, 1]." - (%make-color (clamp 0 1 r) - (clamp 0 1 g) - (clamp 0 1 b) - (clamp 0 1 a))) - -(define (color-component color-code offset) - "Return the value of an 8-bit color channel in the range [0,1] for -the integer COLOR-CODE, given an OFFSET in bits." - (let ((mask (ash #xff offset))) - (/ (ash (logand mask color-code) - (- offset)) - 255.0))) - -(define (rgba color-code) - "Translate an RGBA format string COLOR-CODE into a color object. -For example: #xffffffff will return a color with RGBA values 1, 1, 1, -1." - (%make-color (color-component color-code 24) - (color-component color-code 16) - (color-component color-code 8) - (color-component color-code 0))) - -(define (rgb color-code) - "Translate an RGB format string COLOR-CODE into a color object. -For example: #xffffff will return a color with RGBA values 1, 1, 1, -1." - (%make-color (color-component color-code 16) - (color-component color-code 8) - (color-component color-code 0) - 1)) - -(define (color* a b) - "Multiply the RGBA channels of colors A and B." - (make-color (* (color-r a) - (color-r b)) - (* (color-g a) - (color-g b)) - (* (color-b a) - (color-b b)) - (* (color-a a) - (color-a b)))) - -(define (color+ a b) - "Add the RGBA channels of colors A and B." - (make-color (+ (color-r a) - (color-r b)) - (+ (color-g a) - (color-g b)) - (+ (color-b a) - (color-b b)) - (+ (color-a a) - (color-a b)))) - -(define (color- a b) - "Subtract the RGBA channels of colors A and B." - (make-color (- (color-r a) - (color-r b)) - (- (color-g a) - (color-g b)) - (- (color-b a) - (color-b b)) - (- (color-a a) - (color-a b)))) - -(define (color-inverse color) - "Create a new color that is the inverse of COLOR. The alpha channel -is left unchanged." - (make-color (- 1 (color-r color)) - (- 1 (color-g color)) - (- 1 (color-b color)) - (color-a color))) - -;;; -;;; Pre-defined Colors -;;; - -;; Basic -(define white (rgb #xffffff)) -(define black (rgb #x000000)) -(define red (rgb #xff0000)) -(define green (rgb #x00ff00)) -(define blue (rgb #x0000ff)) -(define yellow (rgb #xffff00)) -(define magenta (rgb #xff00ff)) -(define cyan (rgb #x00ffff)) - -;; Tango color pallete -;; http://tango.freedesktop.org -(define tango-light-butter (rgb #xfce94f)) -(define tango-butter (rgb #xedd400)) -(define tango-dark-butter (rgb #xc4a000)) -(define tango-light-orange (rgb #xfcaf3e)) -(define tango-orange (rgb #xf57900)) -(define tango-dark-orange (rgb #xce5c00)) -(define tango-light-chocolate (rgb #xe9b96e)) -(define tango-chocolate (rgb #xc17d11)) -(define tango-dark-chocolate (rgb #x8f5902)) -(define tango-light-chameleon (rgb #x8ae234)) -(define tango-chameleon (rgb #x73d216)) -(define tango-dark-chameleon (rgb #x4e9a06)) -(define tango-light-sky-blue (rgb #x729fcf)) -(define tango-sky-blue (rgb #x3465a4)) -(define tango-dark-sky-blue (rgb #x204a87)) -(define tango-light-plum (rgb #xad7fa8)) -(define tango-plum (rgb #x75507b)) -(define tango-dark-plum (rgb #x5c3566)) -(define tango-light-scarlet-red (rgb #xef2929)) -(define tango-scarlet-red (rgb #xcc0000)) -(define tango-dark-scarlet-red (rgb #xa40000)) -(define tango-aluminium-1 (rgb #xeeeeec)) -(define tango-aluminium-2 (rgb #xd3d7cf)) -(define tango-aluminium-3 (rgb #xbabdb6)) -(define tango-aluminium-4 (rgb #x888a85)) -(define tango-aluminium-5 (rgb #x555753)) -(define tango-aluminium-6 (rgb #x2e3436)) diff --git a/2d/config.scm.in b/2d/config.scm.in deleted file mode 100644 index e62a2b1..0000000 --- a/2d/config.scm.in +++ /dev/null @@ -1,28 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2014 David Thompson -;;; -;;; Guile-2d is free software: you can redistribute it and/or modify it -;;; under the terms of the GNU Lesser General Public License as -;;; published by the Free Software Foundation, either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; Guile-2d is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with this program. If not, see -;;; . - -;;; Commentary: -;; -;; Build time configuration. -;; -;;; Code: - -(define-module (2d config) - #:export (%pkgdatadir)) - -(define %pkgdatadir - (or (getenv "GUILE_2D_PKGDATADIR") "@pkgdatadir@")) diff --git a/2d/coroutine.scm b/2d/coroutine.scm deleted file mode 100644 index b8e1df9..0000000 --- a/2d/coroutine.scm +++ /dev/null @@ -1,82 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson -;;; -;;; This program is free software: you can redistribute it and/or -;;; modify it under the terms of the GNU General Public License as -;;; published by the Free Software Foundation, either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; . - -;;; Commentary: -;; -;; Cooperative multi-tasking. -;; -;;; Code: - -(define-module (2d coroutine) - #:export (call-with-coroutine - coroutine - colambda - codefine - codefine*) - #:replace (yield)) - -(define (call-with-coroutine thunk) - "Apply THUNK with a coroutine prompt." - (define (handler cont callback . args) - (define (resume . args) - ;; Call continuation that resumes the procedure. - (call-with-prompt 'coroutine-prompt - (lambda () (apply cont args)) - handler)) - (when (procedure? callback) - (apply callback resume args))) - - ;; Call procedure. - (call-with-prompt 'coroutine-prompt thunk handler)) - -;; emacs: (put 'coroutine 'scheme-indent-function 0) -(define-syntax-rule (coroutine body ...) - "Evaluate BODY as a coroutine." - (call-with-coroutine (lambda () body ...))) - -;; emacs: (put 'colambda 'scheme-indent-function 1) -(define-syntax-rule (colambda args body ...) - "Syntacic sugar for a lambda that is run as a coroutine." - (lambda args - (call-with-coroutine - (lambda () body ...)))) - -;; emacs: (put 'codefine 'scheme-indent-function 1) -(define-syntax-rule (codefine (name ...) . body) - "Syntactic sugar for defining a procedure that is run as a -coroutine." - (define (name ...) - ;; Create an inner procedure with the same signature so that a - ;; recursive procedure call does not create a new prompt. - (define (name ...) . body) - (call-with-coroutine - (lambda () (name ...))))) - -;; emacs: (put 'codefine* 'scheme-indent-function 1) -(define-syntax-rule (codefine* (name . formals) . body) - "Syntactic sugar for defining a procedure that is run as a -coroutine." - (define (name . args) - ;; Create an inner procedure with the same signature so that a - ;; recursive procedure call does not create a new prompt. - (define* (name . formals) . body) - (call-with-coroutine - (lambda () (apply name args))))) - -(define (yield callback) - "Yield continuation to a CALLBACK procedure." - (abort-to-prompt 'coroutine-prompt callback)) diff --git a/2d/event.scm b/2d/event.scm deleted file mode 100644 index 7badf72..0000000 --- a/2d/event.scm +++ /dev/null @@ -1,45 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson -;;; -;;; This program is free software: you can redistribute it and/or -;;; modify it under the terms of the GNU General Public License as -;;; published by the Free Software Foundation, either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; . - -;;; Commentary: -;; -;; SDL event handlers. -;; -;;; Code: - -(define-module (2d event) - #:use-module ((sdl sdl) #:prefix SDL:) - #:export (process-events - register-event-handler)) - -(define process-events - (let ((e (SDL:make-event))) - (lambda () - "Process all events in the input event queue." - (while (SDL:poll-event e) - (handle-event e))))) - -(define event-handlers (make-hash-table)) - -(define (register-event-handler event-type proc) - (hashq-set! event-handlers event-type proc)) - -(define (handle-event e) - "Run the relevant hook for the event E." - (let ((handle (hashq-get-handle event-handlers (SDL:event:type e)))) - (when handle - ((cdr handle) e)))) diff --git a/2d/font.scm b/2d/font.scm deleted file mode 100644 index 909f351..0000000 --- a/2d/font.scm +++ /dev/null @@ -1,156 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson -;;; -;;; This program is free software: you can redistribute it and/or -;;; modify it under the terms of the GNU General Public License as -;;; published by the Free Software Foundation, either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; . - -;;; Commentary: -;; -;; Font rendering. -;; -;;; Code: - -(define-module (2d font) - #:use-module (srfi srfi-2) - #:use-module (srfi srfi-9) - #:use-module (system foreign) - #:use-module ((sdl sdl) #:prefix SDL:) - #:use-module ((sdl ttf) #:prefix SDL:) - #:use-module (gl) - #:use-module (gl contrib packed-struct) - #:use-module (2d color) - #:use-module (2d config) - #:use-module (2d shader) - #:use-module (2d signal) - #:use-module (2d texture) - #:use-module (2d vector) - #:use-module (2d window) - #:use-module (2d wrappers gl) - #:export (enable-fonts - load-font - load-default-font - font? - font-point-size - make-label - label? - label-font - label-text - label-position - label-color - draw-label)) - -;;; -;;; Font -;;; - -(define font-shader #f) - -(define (enable-fonts) - (SDL:ttf-init) - (set! font-shader - (load-shader-program - (string-append %pkgdatadir - "/shaders/font-vertex.glsl") - (string-append %pkgdatadir - "/shaders/font-fragment.glsl")))) - -(define-record-type - (make-font ttf point-size) - font? - (ttf font-ttf) - (point-size font-point-size)) - -(define (load-font filename point-size) - "Load the TTF font in FILENAME with the given POINT-SIZE." - (if (file-exists? filename) - (make-font (SDL:load-font filename point-size) point-size) - (error "File not found!" filename))) - -(define* (load-default-font #:optional (point-size 12)) - "Load the guile-2d default TTF font. POINT-SIZE is an optional -argument with a default value of 12." - (load-font (string-append %pkgdatadir "/fonts/DejaVuSans.ttf") point-size)) - -(define (render-text font text) - "Return a new texture with TEXT rendered using FONT." - ;; An empty string will result in a surface value of #f, in which we - ;; want to abort the texture creation process. - (and-let* ((surface (SDL:render-utf8 (font-ttf font) text - (SDL:make-color 255 255 255) #t)) - (pixels (SDL:surface-pixels surface)) - (texture-id (gl-generate-texture))) - (with-gl-bind-texture (texture-target texture-2d) texture-id - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-min-filter) - (texture-min-filter nearest)) - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-mag-filter) - (texture-mag-filter nearest)) - (gl-texture-image-2d (texture-target texture-2d) - 0 - (pixel-format rgba) - (SDL:surface:w surface) - (SDL:surface:h surface) - 0 - (version-1-2 bgra) - (color-pointer-type unsigned-byte) - pixels)) - (make-texture texture-id #f - (SDL:surface:w surface) - (SDL:surface:h surface) - 0 0 1 1))) - -(define-record-type