summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Thompson <dthompson@member.fsf.org>2013-08-25 14:48:51 -0400
committerDavid Thompson <dthompson@member.fsf.org>2013-08-25 14:48:51 -0400
commitc8f8ad1319d3946e58626df3afee6205e084b76b (patch)
tree68a61c0fffd97e88ef7cad19ad6443e78de0c41f
parentb740960d681e6c0985dbdb734d6486784c9a370b (diff)
parentfd326a63b6ef49257c165289e8244bff92ef0994 (diff)
Merge branch 'master' of github.com:davexunit/guile-2d
-rw-r--r--2d/texture.scm8
-rw-r--r--2d/wrappers/freeimage.scm60
-rw-r--r--2d/wrappers/ftgl.scm3
-rw-r--r--Makefile.am13
-rw-r--r--README.org22
5 files changed, 60 insertions, 46 deletions
diff --git a/2d/texture.scm b/2d/texture.scm
index b7808b3..19c26c8 100644
--- a/2d/texture.scm
+++ b/2d/texture.scm
@@ -132,7 +132,13 @@
0 0 1 1)))
(define (load-bitmap filename)
- (let* ((bitmap (freeimage-load (freeimage-get-file-type filename) filename))
+ ;; Throw an error if image file does not exist or else we will
+ ;; segfault later.
+ (unless (file-exists? filename)
+ (throw 'image-not-found filename))
+ ;; Load image and convert it to 32 bit color.
+ (let* ((image-type (freeimage-get-file-type filename))
+ (bitmap (freeimage-load image-type filename))
(32bit-bitmap (freeimage-convert-to-32-bits bitmap)))
(freeimage-unload bitmap)
32bit-bitmap))
diff --git a/2d/wrappers/freeimage.scm b/2d/wrappers/freeimage.scm
index 3192dbb..964eff7 100644
--- a/2d/wrappers/freeimage.scm
+++ b/2d/wrappers/freeimage.scm
@@ -23,7 +23,8 @@
(define-module (2d wrappers freeimage)
#:use-module (system foreign)
- #:use-module (2d wrappers util))
+ #:use-module (2d wrappers util)
+ #:use-module (ice-9 format))
(define libfreeimage (dynamic-link "libfreeimage"))
@@ -83,7 +84,8 @@
;;; General functions
;;;
-(define-foreign %freeimage-get-version '* "FreeImage_GetVersion" '())
+(define-foreign %freeimage-get-version
+ '* "FreeImage_GetVersion" '())
(define-foreign %freeimage-set-output-message
void "FreeImage_SetOutputMessage" '(*))
@@ -124,8 +126,10 @@
(%freeimage-get-height bitmap)
(%freeimage-get-bpp bitmap)))))
-(define-foreign %freeimage-load '* "FreeImage_Load" (list unsigned-int '* unsigned-int))
-(define-foreign %freeimage-unload void "FreeImage_Unload" '(*))
+(define-foreign %freeimage-load
+ '* "FreeImage_Load" (list unsigned-int '* unsigned-int))
+(define-foreign %freeimage-unload
+ void "FreeImage_Unload" '(*))
(define (freeimage-load image-format filename)
(wrap-freeimage-bitmap
@@ -134,22 +138,33 @@
(define (freeimage-unload bitmap)
(%freeimage-unload (unwrap-freeimage-bitmap bitmap)))
-(export freeimage-load
+(export <freeimage-bitmap>
+ freeimage-bitmap?
+ freeimage-load
freeimage-unload)
;;;
;;; Bitmap information functions
;;;
-(define-foreign %freeimage-get-image-type unsigned-int "FreeImage_GetImageType" '(*))
-(define-foreign %freeimage-get-bpp unsigned-int "FreeImage_GetBPP" '(*))
-(define-foreign %freeimage-get-width unsigned-int "FreeImage_GetWidth" '(*))
-(define-foreign %freeimage-get-height unsigned-int "FreeImage_GetHeight" '(*))
-(define-foreign %freeimage-get-pitch unsigned-int "FreeImage_GetPitch" '(*))
-(define-foreign %freeimage-get-red-mask unsigned-int "FreeImage_GetRedMask" '(*))
-(define-foreign %freeimage-get-green-mask unsigned-int "FreeImage_GetGreenMask" '(*))
-(define-foreign %freeimage-get-blue-mask unsigned-int "FreeImage_GetBlueMask" '(*))
-(define-foreign %freeimage-has-pixels unsigned-int "FreeImage_HasPixels" '(*))
+(define-foreign %freeimage-get-image-type
+ unsigned-int "FreeImage_GetImageType" '(*))
+(define-foreign %freeimage-get-bpp
+ unsigned-int "FreeImage_GetBPP" '(*))
+(define-foreign %freeimage-get-width
+ unsigned-int "FreeImage_GetWidth" '(*))
+(define-foreign %freeimage-get-height
+ unsigned-int "FreeImage_GetHeight" '(*))
+(define-foreign %freeimage-get-pitch
+ unsigned-int "FreeImage_GetPitch" '(*))
+(define-foreign %freeimage-get-red-mask
+ unsigned-int "FreeImage_GetRedMask" '(*))
+(define-foreign %freeimage-get-green-mask
+ unsigned-int "FreeImage_GetGreenMask" '(*))
+(define-foreign %freeimage-get-blue-mask
+ unsigned-int "FreeImage_GetBlueMask" '(*))
+(define-foreign %freeimage-has-pixels
+ unsigned-int "FreeImage_HasPixels" '(*))
(define (freeimage-get-image-type bitmap)
(%freeimage-get-image-type (unwrap-freeimage-bitmap bitmap)))
@@ -192,10 +207,11 @@
;;; Filetype functions
;;;
-(define-foreign %freeimage-get-file-type unsigned-int "FreeImage_GetFileType" '(*))
+(define-foreign %freeimage-get-file-type
+ unsigned-int "FreeImage_GetFileType" (list '* int))
(define (freeimage-get-file-type filename)
- (%freeimage-get-file-type (string->pointer filename)))
+ (%freeimage-get-file-type (string->pointer filename) 0))
(export freeimage-get-file-type)
@@ -217,11 +233,10 @@
;;; Conversion functions
;;;
-(define-foreign %freeimage-convert-to-24-bits '* "FreeImage_ConvertTo24Bits" '(*))
-(define-foreign %freeimage-convert-to-32-bits '* "FreeImage_ConvertTo32Bits" '(*))
-(define-foreign %freeimage-convert-to-raw-bits
- void "FreeImage_ConvertToRawBits"
- (list '* '* int unsigned-int unsigned-int unsigned-int unsigned-int uint8))
+(define-foreign %freeimage-convert-to-24-bits
+ '* "FreeImage_ConvertTo24Bits" '(*))
+(define-foreign %freeimage-convert-to-32-bits
+ '* "FreeImage_ConvertTo32Bits" '(*))
(define (freeimage-convert-to-24-bits bitmap)
(wrap-freeimage-bitmap
@@ -238,7 +253,8 @@
;;; Rotation and flipping
;;;
-(define-foreign %freeimage-flip-vertical uint8 "FreeImage_FlipVertical" '(*))
+(define-foreign %freeimage-flip-vertical
+ uint8 "FreeImage_FlipVertical" '(*))
(define (freeimage-flip-vertical bitmap)
(number->boolean
diff --git a/2d/wrappers/ftgl.scm b/2d/wrappers/ftgl.scm
index f44443b..1d18fad 100644
--- a/2d/wrappers/ftgl.scm
+++ b/2d/wrappers/ftgl.scm
@@ -23,7 +23,8 @@
(define-module (2d wrappers ftgl)
#:use-module (system foreign)
- #:use-module (2d wrappers util))
+ #:use-module (2d wrappers util)
+ #:use-module (ice-9 format))
(define libftgl (dynamic-link "libftgl"))
diff --git a/Makefile.am b/Makefile.am
index 19f9992..031ffd6 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -3,17 +3,6 @@ include guile.am
moddir=$(prefix)/share/guile/site/2.0
godir=$(libdir)/guile/2.0/ccache
-SOURCES = \
- 2d/agenda.scm\
- 2d/animation.scm\
- 2d/coroutine.scm\
- 2d/game-loop.scm\
- 2d/gl.scm\
- 2d/helpers.scm\
- 2d/math.scm\
- 2d/sprite.scm\
- 2d/texture.scm\
- 2d/vector.scm\
- 2d/window.scm
+SOURCES = $(wildcard 2d/*.scm 2d/*/*.scm)
EXTRA_DIST += env.in
diff --git a/README.org b/README.org
index bea0dc4..5f1a376 100644
--- a/README.org
+++ b/README.org
@@ -23,7 +23,8 @@
#+BEGIN_SRC scheme
(use-modules (2d sprite)
(2d game-loop)
- (2d window))
+ (2d window)
+ (2d helpers))
(define window-width 800)
(define window-height 600)
@@ -37,13 +38,13 @@
#:position (vector (/ window-width 2)
(/ window-height 2))))
- (define (key-down key)
- (display key) (newline)
- (case key
- ;; Quit program when ESCAPE or Q is pressed.
- ((any-equal? key 'escape 'q)
- (close-window)
- (quit))))
+ (define (quit-demo)
+ (close-window)
+ (quit))
+
+ (define (key-down key mod unicode)
+ (cond ((any-equal? key 'escape 'q)
+ (quit-demo))))
;; Draw our sprite
(define (render)
@@ -52,8 +53,9 @@
;; Register hooks. Lambdas are used as "trampolines" so that render
;; and key-down can be redefined later and the hooks will call the
;; updated procedures.
+ (add-hook! on-quit-hook (lambda () (quit-demo)))
(add-hook! on-render-hook (lambda () (render)))
- (add-hook! on-key-down-hook (lambda (key) (key-down key)))
+ (add-hook! on-key-down-hook (lambda (key mod unicode) (key-down key mod unicode)))
;; Start the game loop.
;; The render callback will be called through this procedure.
@@ -72,7 +74,7 @@
Guile-2d uses the FreeImage library and can load many different
image formats. See the FreeImage [[http://freeimage.sourceforge.net/features.html][features page]] for a full list of
- support formats.
+ supported formats.
#+BEGIN_SRC scheme
(define sprite