{ ============================================================================
FreeImage 3.8 DLL Testbed
Changes:
Created 12/19/2005 by Mike Ghan, Logix
The FreeImage DLL is available at http://freeimage.sourceforge.net/
To Test: copy the FreeImage DLL to the Windows System directory (most proper)
or to the same directory as where this file resides (simple for testing). Any
application would, of course, need to install the DLL into the Windows System
directory - a capability of most installation packages.
=========================================================================== }
LIBRARY FreeImage.DLL
{ The FreeImage function names vary from the documentation as follows: Prefixed
with an underscore, suffixed with @## where ## is the number of function
parameters * cell size.
The AS clause allows us to name the function to whatever we wish - ie per the
FreeImage documentation. }
AS FreeImage_GetVersion 0 IMPORT: _FreeImage_GetVersion@0 ( -- zString )
\ Function: FreeImage_Allocate ( width height bits/pixel red_mask green_mask blue_mask -- DIB )
AS FreeImage_Allocate 6 IMPORT: _FreeImage_Allocate@24 ( width height bits/pixel red_mask green_mask blue_mask -- DIB )
\ Function: FreeImage_GetInfo ( DIB -- pBitmapInfo )
AS FreeImage_GetInfo 1 IMPORT: _FreeImage_GetInfo@4 ( DIB -- pBitmapInfo )
\ Function: FreeImage_GetHeight ( DIB -- pBitmapInfo )
AS FreeImage_GetHeight 1 IMPORT: _FreeImage_GetHeight@4 ( DIB -- Height )
\ Function: FreeImage_GetWidth ( DIB -- pBitmapInfo )
AS FreeImage_GetWidth 1 IMPORT: _FreeImage_GetWidth@4 ( DIB -- Width )
\ Function: FreeImage_GetBits ( DIB -- pBits )
AS FreeImage_GetBits 1 IMPORT: _FreeImage_GetBits@4 ( DIB -- pBits )
\ Function: FreeImage_Load ( type zFilename flags -- DIB )
AS FreeImage_Load 3 IMPORT: _FreeImage_Load@12 ( type zFilename flags -- DIB )
\ Function: FreeImage_Unload ( DIB -- ? )
AS FreeImage_Unload 1 IMPORT: _FreeImage_Unload@4 ( DIB -- ? )
\ Function: FreeImage_Save ( type DIB zFilename flags -- res )
AS FreeImage_Save 4 IMPORT: _FreeImage_Save@16 ( type pDIB zFilename flags -- res )
AS FreeImage_ConvertTo8Bits 1 IMPORT: _FreeImage_ConvertTo8Bits@4 ( DIB -- DIB )
AS FreeImage_ColorQuantize 2 IMPORT: _FreeImage_ColorQuantize@8 ( DIB type -- DIB )
AS FreeImage_ConvertTo24Bits 1 IMPORT: _FreeImage_ConvertTo24Bits@4 ( DIB -- DIB )
0 CONSTANT PNG_DEFAULT
0 CONSTANT BMP_DEFAULT
1 CONSTANT BMP_SAVE_RLE
0 CONSTANT GIF_DEFAULT
0 CONSTANT JPEG_DEFAULT
0 CONSTANT FIF_BMP
2 CONSTANT FIF_JPEG
13 CONSTANT FIF_PNG
25 CONSTANT FIF_GIF
0 CONSTANT FIQ_WUQUANT \ Xiaolin Wu color quantization algorithm
1 CONSTANT FIQ_NNQUANT \ NeuQuant neural-net quantization algorithm by Anthony Dekker
\ **** Convert a .BMP to a .PNG **********************************************
: CONVERT-TEST ( -- )
\ FreeImage_GetVersion ZCOUNT TYPE
FIF_BMP Z" LOGIX.BMP" BMP_DEFAULT FreeImage_Load
\ CR DUP ." DIB: " H. SPACE
FIF_PNG OVER ( DIB ) Z" LOGIX.PNG" PNG_DEFAULT FreeImage_Save
IF ." Success" ELSE ." Error!" THEN
( DIB ) FreeImage_Unload DROP ;
: CONVERT-TEST2 ( -- )
FreeImage_GetVersion ZCOUNT TYPE
FIF_BMP Z" LOGIX.BMP" BMP_DEFAULT FreeImage_Load ( DIB )
CR DUP ." DIB: " H. SPACE
\ Convert the DIB into 256 Palette Image
DUP >R ( DIB ) FreeImage_ConvertTo24Bits R> FreeImage_Unload DROP
CR DUP ." DIB: " H. SPACE
DUP >R ( DIB ) FIQ_WUQUANT FreeImage_ColorQuantize R> FreeImage_Unload DROP
CR DUP ." DIB: " H. SPACE
\ Save the DIB
FIF_PNG OVER ( DIB ) Z" LOGIX.PNG" PNG_DEFAULT FreeImage_Save
IF ." Success" ELSE ." Error!" THEN
( DIB ) FreeImage_Unload DROP ;
\ **** Show Various File Types ***********************************************
Function: SetDIBitsToDevice ( hdc XDest YDest Width Height XSrc YSrc StartScan #ScanLines pDIB-Bits pBITMAPINFO ColorUse -- res )
: SHOW-DIB ( FreeImageDIB -- )
?DUP -EXIT
HWND GetDC ( hDC )
LOCALS| hDC DIB |
hDC 100 50 ( x y ) DIB FreeImage_GetWidth
DIB FreeImage_GetHeight 0 0 0
DIB FreeImage_GetHeight DIB FreeImage_GetBits
DIB FreeImage_GetInfo DIB_RGB_COLORS SetDIBitsToDevice DROP
DIB FreeImage_Unload DROP
HWND hDC ReleaseDC DROP ;
: SHOW-LOGO ( -- ) \ Test PNG
FIF_PNG Z" LOGIX.PNG" PNG_DEFAULT FreeImage_Load ( DIB ) SHOW-DIB ;
: SHOW-JPEG ( -- ) \ Test JPEG
FIF_JPEG Z" TEST.JPG" JPEG_DEFAULT FreeImage_Load ( DIB ) SHOW-DIB ;
: SHOW-BMP ( -- ) \ Test JPEG
FIF_BMP Z" TEST.BMP" BMP_DEFAULT FreeImage_Load ( DIB ) SHOW-DIB ;
\ **** Save Client Snapshot as PNG *******************************************
Function: GetDIBits ( hDC hBmp uStartScan cScanLines lpvBits lpbi uUsage -- res )
Function: CreateCompatibleBitmap ( hDC width height -- hBmp )
CLASS tagBITMAP \ BITMAP Object Class
VARIABLE Type
VARIABLE Width
VARIABLE Height
VARIABLE WidthBytes
HVARIABLE Planes
HVARIABLE BitsPixel
VARIABLE Bits
END-CLASS
0 VALUE DIB
0 VALUE hBM
0 VALUE hDCMem
0 VALUE hDC
0 VALUE hClientWND
0 VALUE ImgWidth
0 VALUE ImgHeight
\ Here we save the Client Window as a PNG
: CLIENT-SAVE ( hwnd -- )
[OBJECTS tagBITMAP MAKES BMP OBJECTS]
TO hClientWND
hClientWND GetDC TO hDC ( The client's DC )
hClientWND PAD GetClientRect DROP
PAD 2 CELLS + 2@ ( Client's height & width ) TO ImgWidth TO ImgHeight
\ Next, create a compatible DC and bitmap
hDC CreateCompatibleDC TO hDCMem
hDC ImgWidth ImgHeight CreateCompatibleBitmap TO hBM
hDCMem hBM SelectObject DROP
\ Next, copy the client's bitmap to the compatible bitmap
hDCMem ( DestDC ) 0 0 ImgWidth ImgHeight
hDC ( SourceDC ) 0 0 ( Source x y ) SRCCOPY ( ROP ) BitBlt DROP
\ Next, get the Bitmap Object and allocate a FreeImage DIB for it
hBM tagBITMAP SIZEOF BMP ADDR GetObject DROP
BMP Width @ BMP Height @ BMP BitsPixel H@ 0 0 0 FreeImage_Allocate TO DIB
\ Copy the bitmap to the DIB
hDC hBM 0 BMP Height @ DIB FreeImage_GetBits
DIB FreeImage_GetInfo DIB_RGB_COLORS GetDIBits DROP
\ Save the DIB
FIF_PNG DIB Z" SnapShot.PNG" PNG_DEFAULT FreeImage_Save ( True = OK )
IF ." Success" ELSE ." Error!" THEN
\ Finally, cleanup
DIB FreeImage_Unload DROP
hDCMem DeleteDC DROP
hBM DeleteObject DROP
hClientWND hDC ReleaseDC DROP ;
: SAVE-ME ( -- ) HWND CLIENT-SAVE ;
\ **** Save a Bitmap as a GIF *************************************
S" LOGIX.BMP" BMP LOGO \ See BMP.F
: BMP-SAVE ( -- )
HWND GetDC 0 0 LOCALS| DIB hBM hDC |
[OBJECTS BITMAP MAKES BM tagBITMAP MAKES BMP OBJECTS]
LOGO HWND BM CENTERED \ Show Image, Not Required
hDC LOGO BM GET-HANDLE TO hBM
\ Next, get the Bitmap Object and allocate a FreeImage DIB for it
hBM tagBITMAP SIZEOF BMP ADDR GetObject DROP
BMP Width @ BMP Height @ BMP BitsPixel H@ 0 0 0 FreeImage_Allocate TO DIB
\ Copy the bitmap to the DIB
hDC hBM 0 BMP Height @ DIB FreeImage_GetBits
DIB FreeImage_GetInfo DIB_RGB_COLORS GetDIBits DROP
\ Save the DIB
FIF_GIF DIB Z" LOGIX.GIF" GIF_DEFAULT FreeImage_Save ( True = OK )
IF ." Success" ELSE ." Error!" THEN
\ Finally, cleanup
DIB FreeImage_Unload DROP
HWND hDC ReleaseDC DROP ;
\ ****************************************************************************