summaryrefslogtreecommitdiff
path: root/2d/wrappers/freeimage.scm
diff options
context:
space:
mode:
authorDavid Thompson <dthompson2@worcester.edu>2014-06-28 18:46:16 -0400
committerDavid Thompson <dthompson2@worcester.edu>2014-06-28 18:46:16 -0400
commitf47eb69a354188154731846dde8b384c2c2f39f6 (patch)
tree6aa1ccb9212836b7c941e771475eb995fa6df9f9 /2d/wrappers/freeimage.scm
parentdf0f2a5f3f09394f1953abbc7e33e9a98204680e (diff)
Rename guile-2d to Sly!
Massive find/replace job.
Diffstat (limited to '2d/wrappers/freeimage.scm')
-rw-r--r--2d/wrappers/freeimage.scm263
1 files changed, 0 insertions, 263 deletions
diff --git a/2d/wrappers/freeimage.scm b/2d/wrappers/freeimage.scm
deleted file mode 100644
index 544bf51..0000000
--- a/2d/wrappers/freeimage.scm
+++ /dev/null
@@ -1,263 +0,0 @@
-;;; guile-2d
-;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu>
-;;;
-;;; This program is free software: you can redistribute it and/or
-;;; modify it under the terms of the GNU General Public License as
-;;; published by the Free Software Foundation, either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; This program is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with this program. If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Quick and dirty wrapper for some freeimage functions.
-;;
-;;; Code:
-
-(define-module (2d wrappers freeimage)
- #:use-module (system foreign)
- #:use-module (2d wrappers util)
- #:use-module (ice-9 format))
-
-(define libfreeimage (dynamic-link "libfreeimage"))
-
-(define-syntax-rule (define-foreign name ret string-name args)
- (define name
- (pointer->procedure ret (dynamic-func string-name libfreeimage) args)))
-
-(define (number->boolean n)
- (not (zero? n)))
-
-;;;
-;;; FreeImage file formats
-;;;
-
-(define-enumeration freeimage-format
- (unknown -1)
- (bmp 0)
- (ico 1)
- (jpeg 2)
- (jng 3)
- (koala 4)
- (lbm 5)
- (iff 5)
- (mng 6)
- (pbm 7)
- (pbmraw 8)
- (pcd 9)
- (pcx 10)
- (pgm 11)
- (pgmraw 12)
- (png 13)
- (ppm 14)
- (ppmraw 15)
- (ras 16)
- (targa 17)
- (tiff 18)
- (wbmp 19)
- (psd 20)
- (cut 21)
- (xbm 22)
- (xpm 23)
- (dds 24)
- (gif 25)
- (hdr 26)
- (faxg3 27)
- (sgi 28)
- (exr 29)
- (j2k 30)
- (jp2 31)
- (pfm 32)
- (pict 33)
- (raw 34))
-
-(export freeimage-format)
-
-;;;
-;;; General functions
-;;;
-
-(define-foreign %freeimage-get-version
- '* "FreeImage_GetVersion" '())
-(define-foreign %freeimage-set-output-message
- void "FreeImage_SetOutputMessage" '(*))
-
-(define (freeimage-get-version)
- (pointer->string (%freeimage-get-version)))
-
-(define (freeimage-set-output-message callback)
- (%freeimage-set-output-message
- (procedure->pointer void
- (lambda (image-format message)
- (callback image-format (pointer->string message)))
- (list unsigned-int '*))))
-
-;; Set a default output message callback to writes to stdout.
-(freeimage-set-output-message
- (lambda (image-format message)
- (display "freeimage error: ")
- (display message)
- (newline)))
-
-(export freeimage-get-version
- freeimage-set-output-message)
-
-
-;;;
-;;; Bitmap management functions
-;;;
-
-(define-wrapped-pointer-type <freeimage-bitmap>
- freeimage-bitmap?
- wrap-freeimage-bitmap unwrap-freeimage-bitmap
- (lambda (r port)
- (let ((bitmap (unwrap-freeimage-bitmap r)))
- (format port
- "<freeimage-bitmap ~x width: ~d height: ~d bpp: ~d>"
- (pointer-address bitmap)
- (%freeimage-get-width bitmap)
- (%freeimage-get-height bitmap)
- (%freeimage-get-bpp bitmap)))))
-
-(define-foreign %freeimage-load
- '* "FreeImage_Load" (list unsigned-int '* unsigned-int))
-(define-foreign %freeimage-unload
- void "FreeImage_Unload" '(*))
-
-(define (freeimage-load image-format filename)
- (wrap-freeimage-bitmap
- (%freeimage-load image-format (string->pointer filename) 0)))
-
-(define (freeimage-unload bitmap)
- (%freeimage-unload (unwrap-freeimage-bitmap bitmap)))
-
-(export <freeimage-bitmap>
- freeimage-bitmap?
- freeimage-load
- freeimage-unload)
-
-;;;
-;;; Bitmap information functions
-;;;
-
-(define-foreign %freeimage-get-image-type
- unsigned-int "FreeImage_GetImageType" '(*))
-(define-foreign %freeimage-get-bpp
- unsigned-int "FreeImage_GetBPP" '(*))
-(define-foreign %freeimage-get-width
- unsigned-int "FreeImage_GetWidth" '(*))
-(define-foreign %freeimage-get-height
- unsigned-int "FreeImage_GetHeight" '(*))
-(define-foreign %freeimage-get-pitch
- unsigned-int "FreeImage_GetPitch" '(*))
-(define-foreign %freeimage-get-red-mask
- unsigned-int "FreeImage_GetRedMask" '(*))
-(define-foreign %freeimage-get-green-mask
- unsigned-int "FreeImage_GetGreenMask" '(*))
-(define-foreign %freeimage-get-blue-mask
- unsigned-int "FreeImage_GetBlueMask" '(*))
-(define-foreign %freeimage-has-pixels
- unsigned-int "FreeImage_HasPixels" '(*))
-
-(define (freeimage-get-image-type bitmap)
- (%freeimage-get-image-type (unwrap-freeimage-bitmap bitmap)))
-
-(define (freeimage-get-bpp bitmap)
- (%freeimage-get-bpp (unwrap-freeimage-bitmap bitmap)))
-
-(define (freeimage-get-width bitmap)
- (%freeimage-get-width (unwrap-freeimage-bitmap bitmap)))
-
-(define (freeimage-get-height bitmap)
- (%freeimage-get-height (unwrap-freeimage-bitmap bitmap)))
-
-(define (freeimage-get-pitch bitmap)
- (%freeimage-get-pitch (unwrap-freeimage-bitmap bitmap)))
-
-(define (freeimage-get-red-mask bitmap)
- (%freeimage-get-red-mask (unwrap-freeimage-bitmap bitmap)))
-
-(define (freeimage-get-green-mask bitmap)
- (%freeimage-get-green-mask (unwrap-freeimage-bitmap bitmap)))
-
-(define (freeimage-get-blue-mask bitmap)
- (%freeimage-get-blue-mask (unwrap-freeimage-bitmap bitmap)))
-
-(define (freeimage-has-pixels? bitmap)
- (number->boolean
- (%freeimage-has-pixels (unwrap-freeimage-bitmap bitmap))))
-
-(export freeimage-get-image-type
- freeimage-get-bpp
- freeimage-get-width
- freeimage-get-height
- freeimage-get-red-mask
- freeimage-get-green-mask
- freeimage-get-blue-mask
- freeimage-has-pixels?)
-
-;;;
-;;; Filetype functions
-;;;
-
-(define-foreign %freeimage-get-file-type
- unsigned-int "FreeImage_GetFileType" (list '* int))
-
-(define (freeimage-get-file-type filename)
- (%freeimage-get-file-type (string->pointer filename) 0))
-
-(export freeimage-get-file-type)
-
-;;;
-;;; Pixel access functions
-;;;
-
-(define-foreign %freeimage-get-bits '* "FreeImage_GetBits" '(*))
-
-(define (freeimage-get-bits bitmap)
- (pointer->bytevector
- (%freeimage-get-bits (unwrap-freeimage-bitmap bitmap))
- (* (freeimage-get-height bitmap)
- (freeimage-get-pitch bitmap))))
-
-(export freeimage-get-bits)
-
-;;;
-;;; Conversion functions
-;;;
-
-(define-foreign %freeimage-convert-to-24-bits
- '* "FreeImage_ConvertTo24Bits" '(*))
-(define-foreign %freeimage-convert-to-32-bits
- '* "FreeImage_ConvertTo32Bits" '(*))
-
-(define (freeimage-convert-to-24-bits bitmap)
- (wrap-freeimage-bitmap
- (%freeimage-convert-to-24-bits (unwrap-freeimage-bitmap bitmap))))
-
-(define (freeimage-convert-to-32-bits bitmap)
- (wrap-freeimage-bitmap
- (%freeimage-convert-to-32-bits (unwrap-freeimage-bitmap bitmap))))
-
-(export freeimage-convert-to-24-bits
- freeimage-convert-to-32-bits)
-
-;;;
-;;; Rotation and flipping
-;;;
-
-(define-foreign %freeimage-flip-vertical
- uint8 "FreeImage_FlipVertical" '(*))
-
-(define (freeimage-flip-vertical bitmap)
- (number->boolean
- (%freeimage-flip-vertical (unwrap-freeimage-bitmap bitmap))))
-
-(export freeimage-flip-vertical)