diff options
| -rw-r--r-- | 2d/texture.scm | 8 | ||||
| -rw-r--r-- | 2d/wrappers/freeimage.scm | 60 | ||||
| -rw-r--r-- | 2d/wrappers/ftgl.scm | 3 | ||||
| -rw-r--r-- | Makefile.am | 13 | ||||
| -rw-r--r-- | README.org | 22 |
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 @@ -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 |