From 16a6e6801fde495b2782e2e04a0cf055ce1e1516 Mon Sep 17 00:00:00 2001 From: k-m_schindler Date: Wed, 27 Aug 2008 14:59:38 +0000 Subject: rename Classes part1 git-svn-id: svn://svn.code.sf.net/p/ultrastardx/svn/trunk@1307 b956fd51-792f-4845-bead-9b4dfca2ff2c --- src/classes0/UImage.pas | 993 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 993 insertions(+) create mode 100644 src/classes0/UImage.pas (limited to 'src/classes0/UImage.pas') diff --git a/src/classes0/UImage.pas b/src/classes0/UImage.pas new file mode 100644 index 00000000..d33c0d38 --- /dev/null +++ b/src/classes0/UImage.pas @@ -0,0 +1,993 @@ +unit UImage; + +interface + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$I switches.inc} + +uses + SDL; + +{$DEFINE HavePNG} +{$DEFINE HaveBMP} +{$DEFINE HaveJPG} + +const + PixelFmt_RGBA: TSDL_Pixelformat = ( + palette: nil; + BitsPerPixel: 32; + BytesPerPixel: 4; + Rloss: 0; + Gloss: 0; + Bloss: 0; + Aloss: 0; + Rshift: 0; + Gshift: 8; + Bshift: 16; + Ashift: 24; + Rmask: $000000ff; + Gmask: $0000ff00; + Bmask: $00ff0000; + Amask: $ff000000; + ColorKey: 0; + Alpha: 255 + ); + + PixelFmt_RGB: TSDL_Pixelformat = ( + palette: nil; + BitsPerPixel: 24; + BytesPerPixel: 3; + Rloss: 0; + Gloss: 0; + Bloss: 0; + Aloss: 0; + Rshift: 0; + Gshift: 8; + Bshift: 16; + Ashift: 0; + Rmask: $000000ff; + Gmask: $0000ff00; + Bmask: $00ff0000; + Amask: $00000000; + ColorKey: 0; + Alpha: 255 + ); + + PixelFmt_BGRA: TSDL_Pixelformat = ( + palette: nil; + BitsPerPixel: 32; + BytesPerPixel: 4; + Rloss: 0; + Gloss: 0; + Bloss: 0; + Aloss: 0; + Rshift: 16; + Gshift: 8; + Bshift: 0; + Ashift: 24; + Rmask: $00ff0000; + Gmask: $0000ff00; + Bmask: $000000ff; + Amask: $ff000000; + ColorKey: 0; + Alpha: 255 + ); + + PixelFmt_BGR: TSDL_Pixelformat = ( + palette: nil; + BitsPerPixel: 24; + BytesPerPixel: 3; + Rloss: 0; + Gloss: 0; + Bloss: 0; + Aloss: 0; + Rshift: 16; + Gshift: 8; + Bshift: 0; + Ashift: 0; + Rmask: $00ff0000; + Gmask: $0000ff00; + Bmask: $000000ff; + Amask: $00000000; + ColorKey: 0; + Alpha: 255 + ); + +type + TImagePixelFmt = ( + ipfRGBA, ipfRGB, ipfBGRA, ipfBGR + ); + +(******************************************************* + * Image saving + *******************************************************) + +{$IFDEF HavePNG} +function WritePNGImage(const FileName: string; Surface: PSDL_Surface): boolean; +{$ENDIF} +{$IFDEF HaveBMP} +function WriteBMPImage(const FileName: string; Surface: PSDL_Surface): boolean; +{$ENDIF} +{$IFDEF HaveJPG} +function WriteJPGImage(const FileName: string; Surface: PSDL_Surface; Quality: integer): boolean; +{$ENDIF} + +(******************************************************* + * Image loading + *******************************************************) + +function LoadImage(const Identifier: string): PSDL_Surface; + +(******************************************************* + * Image manipulation + *******************************************************) + +function PixelFormatEquals(fmt1, fmt2: PSDL_PixelFormat): boolean; +procedure ScaleImage(var ImgSurface: PSDL_Surface; Width, Height: Cardinal); +procedure FitImage(var ImgSurface: PSDL_Surface; Width, Height: Cardinal); +procedure ColorizeImage(ImgSurface: PSDL_Surface; NewColor: Cardinal); + + +implementation + +uses + SysUtils, + Classes, + Math, + {$IFDEF MSWINDOWS} + Windows, + {$ENDIF} + {$IFDEF HaveJPG} + {$IFDEF Delphi} + Graphics, + jpeg, + {$ELSE} + jpeglib, + jerror, + jcparam, + jdatadst, jcapimin, jcapistd, + {$ENDIF} + {$ENDIF} + {$IFDEF HavePNG} + png, + {$ENDIF} + zlib, + sdl_image, + sdlutils, + UCommon, + ULog; + + +function IsRGBSurface(pixelFmt: PSDL_PixelFormat): boolean; +begin + Result := (pixelFmt.BitsPerPixel = 24) and + (pixelFmt.RMask = $0000FF) and + (pixelFmt.GMask = $00FF00) and + (pixelFmt.BMask = $FF0000); +end; + +function IsRGBASurface(pixelFmt: PSDL_PixelFormat): boolean; +begin + Result := (pixelFmt.BitsPerPixel = 32) and + (pixelFmt.RMask = $000000FF) and + (pixelFmt.GMask = $0000FF00) and + (pixelFmt.BMask = $00FF0000) and + (pixelFmt.AMask = $FF000000); +end; + +function IsBGRSurface(pixelFmt: PSDL_PixelFormat): boolean; +begin + Result := (pixelFmt.BitsPerPixel = 24) and + (pixelFmt.BMask = $0000FF) and + (pixelFmt.GMask = $00FF00) and + (pixelFmt.RMask = $FF0000); +end; + +function IsBGRASurface(pixelFmt: PSDL_PixelFormat): boolean; +begin + Result := (pixelFmt.BitsPerPixel = 32) and + (pixelFmt.BMask = $000000FF) and + (pixelFmt.GMask = $0000FF00) and + (pixelFmt.RMask = $00FF0000) and + (pixelFmt.AMask = $FF000000); +end; + +// Converts alpha-formats to BGRA, non-alpha to BGR, and leaves BGR(A) as is +// sets converted to true if the surface needed to be converted +function ConvertToBGR_BGRASurface(Surface: PSDL_Surface; out Converted: boolean): PSDL_Surface; +var + pixelFmt: PSDL_PixelFormat; +begin + pixelFmt := Surface.format; + if (IsBGRSurface(pixelFmt) or IsBGRASurface(pixelFmt)) then + begin + Converted := false; + Result := Surface; + end + else + begin + // invalid format -> needs conversion + if (pixelFmt.AMask <> 0) then + Result := SDL_ConvertSurface(Surface, @PixelFmt_BGRA, SDL_SWSURFACE) + else + Result := SDL_ConvertSurface(Surface, @PixelFmt_BGR, SDL_SWSURFACE); + Converted := true; + end; +end; + +// Converts alpha-formats to RGBA, non-alpha to RGB, and leaves RGB(A) as is +// sets converted to true if the surface needed to be converted +function ConvertToRGB_RGBASurface(Surface: PSDL_Surface; out Converted: boolean): PSDL_Surface; +var + pixelFmt: PSDL_PixelFormat; +begin + pixelFmt := Surface.format; + if (IsRGBSurface(pixelFmt) or IsRGBASurface(pixelFmt)) then + begin + Converted := false; + Result := Surface; + end + else + begin + // invalid format -> needs conversion + if (pixelFmt.AMask <> 0) then + Result := SDL_ConvertSurface(Surface, @PixelFmt_RGBA, SDL_SWSURFACE) + else + Result := SDL_ConvertSurface(Surface, @PixelFmt_RGB, SDL_SWSURFACE); + Converted := true; + end; +end; + + +(******************************************************* + * Image saving + *******************************************************) + +(*************************** + * PNG section + *****************************) + +{$IFDEF HavePNG} + +// delphi does not support setjmp()/longjmp() -> define our own error-handler +procedure user_error_fn(png_ptr: png_structp; error_msg: png_const_charp); cdecl; +begin + raise Exception.Create(error_msg); +end; + +procedure user_read_data(png_ptr: png_structp; data: png_bytep; length: png_size_t); cdecl; +var + inFile: TFileStream; +begin + inFile := TFileStream(png_get_io_ptr(png_ptr)); + inFile.Read(data^, length); +end; + +procedure user_write_data(png_ptr: png_structp; data: png_bytep; length: png_size_t); cdecl; +var + outFile: TFileStream; +begin + outFile := TFileStream(png_get_io_ptr(png_ptr)); + outFile.Write(data^, length); +end; + +procedure user_flush_data(png_ptr: png_structp); cdecl; +//var +// outFile: TFileStream; +begin + // binary files are flushed automatically, Flush() works with Text-files only + //outFile := TFileStream(png_get_io_ptr(png_ptr)); + //outFile.Flush(); +end; + +procedure DateTimeToPngTime(time: TDateTime; var pngTime: png_time); +var + year, month, day: word; + hour, minute, second, msecond: word; +begin + DecodeDate(time, year, month, day); + pngTime.year := year; + pngTime.month := month; + pngTime.day := day; + DecodeTime(time, hour, minute, second, msecond); + pngTime.hour := hour; + pngTime.minute := minute; + pngTime.second := second; +end; + +(* + * ImageData must be in RGB-format + *) +function WritePNGImage(const FileName: string; Surface: PSDL_Surface): boolean; +var + png_ptr: png_structp; + info_ptr: png_infop; + pngFile: TFileStream; + row: integer; + rowData: array of png_bytep; +// rowStride: integer; + converted: boolean; + colorType: integer; +// time: png_time; +begin + Result := false; + + // open file for writing + try + pngFile := TFileStream.Create(FileName, fmCreate); + except + Log.LogError('Could not open file: "' + FileName + '"', 'WritePngImage'); + Exit; + end; + + // only 24bit (RGB) or 32bit (RGBA) data is supported, so convert to it + Surface := ConvertToRGB_RGBASurface(Surface, converted); + + png_ptr := nil; + + try + // initialize png (and enable a user-defined error-handler that throws an exception on error) + png_ptr := png_create_write_struct(PNG_LIBPNG_VER_STRING, nil, @user_error_fn, nil); + // the error-handler is called if png_create_write_struct() fails, so png_ptr should always be <> nil + if (png_ptr = nil) then + begin + Log.LogError('png_create_write_struct() failed', 'WritePngImage'); + if (converted) then + SDL_FreeSurface(Surface); + Exit; + end; + + info_ptr := png_create_info_struct(png_ptr); + + if (Surface^.format^.BitsPerPixel = 24) then + colorType := PNG_COLOR_TYPE_RGB + else + colorType := PNG_COLOR_TYPE_RGBA; + + // define write IO-functions (POSIX-style FILE-pointers are not available in Delphi) + png_set_write_fn(png_ptr, pngFile, @user_write_data, @user_flush_data); + png_set_IHDR( + png_ptr, info_ptr, + Surface.w, Surface.h, + 8, + colorType, + PNG_INTERLACE_NONE, + PNG_COMPRESSION_TYPE_DEFAULT, + PNG_FILTER_TYPE_DEFAULT + ); + + // TODO: do we need the modification time? + //DateTimeToPngTime(Now, time); + //png_set_tIME(png_ptr, info_ptr, @time); + + if (SDL_MUSTLOCK(Surface)) then + SDL_LockSurface(Surface); + + // setup data + SetLength(rowData, Surface.h); + for row := 0 to Surface.h-1 do + begin + // set rowData-elements to beginning of each image row + // Note: the byte-count of a row is pitch (which is not width*bitsPerPixel if the image is aligned) + rowData[row] := @PChar(Surface.pixels)[(Surface.h-row-1) * Surface.pitch]; + end; + + if (SDL_MUSTLOCK(Surface)) then + SDL_UnlockSurface(Surface); + + png_write_info(png_ptr, info_ptr); + png_write_image(png_ptr, png_bytepp(rowData)); + png_write_end(png_ptr, nil); + + Result := true; + except on E: Exception do + Log.LogError(E.message, 'WritePngImage'); + end; + + // free row-data + SetLength(rowData, 0); + + // free png-resources + if (png_ptr <> nil) then + png_destroy_write_struct(@png_ptr, nil); + + if (converted) then + SDL_FreeSurface(Surface); + + // close file + pngFile.Free; +end; + +{$ENDIF} + +(*************************** + * BMP section + *****************************) + +{$IFDEF HaveBMP} + +{$IFNDEF MSWINDOWS} +const + (* constants for the biCompression field *) + BI_RGB = 0; + BI_RLE8 = 1; + BI_RLE4 = 2; + BI_BITFIELDS = 3; + BI_JPEG = 4; + BI_PNG = 5; + +type + BITMAPINFOHEADER = record + biSize: longword; + biWidth: longint; + biHeight: longint; + biPlanes: word; + biBitCount: word; + biCompression: longword; + biSizeImage: longword; + biXPelsPerMeter: longint; + biYPelsPerMeter: longint; + biClrUsed: longword; + biClrImportant: longword; + end; + LPBITMAPINFOHEADER = ^BITMAPINFOHEADER; + TBITMAPINFOHEADER = BITMAPINFOHEADER; + PBITMAPINFOHEADER = ^BITMAPINFOHEADER; + + RGBTRIPLE = record + rgbtBlue: byte; + rgbtGreen: byte; + rgbtRed: byte; + end; + tagRGBTRIPLE = RGBTRIPLE; + TRGBTRIPLE = RGBTRIPLE; + PRGBTRIPLE = ^RGBTRIPLE; + + RGBQUAD = record + rgbBlue: byte; + rgbGreen: byte; + rgbRed: byte; + rgbReserved: byte; + end; + tagRGBQUAD = RGBQUAD; + TRGBQUAD = RGBQUAD; + PRGBQUAD = ^RGBQUAD; + + BITMAPINFO = record + bmiHeader: BITMAPINFOHEADER; + bmiColors: array[0..0] of RGBQUAD; + end; + LPBITMAPINFO = ^BITMAPINFO; + PBITMAPINFO = ^BITMAPINFO; + TBITMAPINFO = BITMAPINFO; + + {$PACKRECORDS 2} + BITMAPFILEHEADER = record + bfType: word; + bfSize: longword; + bfReserved1: word; + bfReserved2: word; + bfOffBits: longword; + end; + {$PACKRECORDS DEFAULT} +{$ENDIF} + +(* + * ImageData must be in BGR-format + *) +function WriteBMPImage(const FileName: string; Surface: PSDL_Surface): boolean; +var + bmpFile: TFileStream; + FileInfo: BITMAPINFOHEADER; + FileHeader: BITMAPFILEHEADER; + Converted: boolean; + Row: integer; + RowSize: integer; +begin + Result := false; + + // open file for writing + try + bmpFile := TFileStream.Create(FileName, fmCreate); + except + Log.LogError('Could not open file: "' + FileName + '"', 'WriteBMPImage'); + Exit; + end; + + // only 24bit (BGR) or 32bit (BGRA) data is supported, so convert to it + Surface := ConvertToBGR_BGRASurface(Surface, Converted); + + // aligned (4-byte) row-size in bytes + RowSize := ((Surface.w * Surface.format.BytesPerPixel + 3) div 4) * 4; + + // initialize bitmap info + FillChar(FileInfo, SizeOf(BITMAPINFOHEADER), 0); + with FileInfo do + begin + biSize := SizeOf(BITMAPINFOHEADER); + biWidth := Surface.w; + biHeight := Surface.h; + biPlanes := 1; + biBitCount := Surface^.format^.BitsPerPixel; + biCompression := BI_RGB; + biSizeImage := RowSize * Surface.h; + end; + + // initialize header-data + FillChar(FileHeader, SizeOf(BITMAPFILEHEADER), 0); + with FileHeader do + begin + bfType := $4D42; // = 'BM' + bfOffBits := SizeOf(BITMAPFILEHEADER) + SizeOf(BITMAPINFOHEADER); + bfSize := bfOffBits + FileInfo.biSizeImage; + end; + + // and move the whole stuff into the file ;-) + try + // write headers + bmpFile.Write(FileHeader, SizeOf(BITMAPFILEHEADER)); + bmpFile.Write(FileInfo, SizeOf(BITMAPINFOHEADER)); + + // write image-data + + if (SDL_MUSTLOCK(Surface)) then + SDL_LockSurface(Surface); + + // BMP needs 4-byte alignment + if (Surface.pitch mod 4 = 0) then + begin + // aligned correctly -> write whole image at once + bmpFile.Write(Surface.pixels^, FileInfo.biSizeImage); + end + else + begin + // misaligned -> write each line separately + // Note: for the last line unassigned memory (> last Surface.pixels element) + // will be copied to the padding area (last bytes of a row), + // but we do not care because the content of padding data is ignored anyhow. + for Row := 0 to Surface.h do + bmpFile.Write(PChar(Surface.pixels)[Row * Surface.pitch], RowSize); + end; + + if (SDL_MUSTLOCK(Surface)) then + SDL_UnlockSurface(Surface); + + Result := true; + finally + Log.LogError('Could not write file: "' + FileName + '"', 'WriteBMPImage'); + end; + + if (Converted) then + SDL_FreeSurface(Surface); + + // close file + bmpFile.Free; +end; + +{$ENDIF} + +(*************************** + * JPG section + *****************************) + +{$IFDEF HaveJPG} + +function WriteJPGImage(const FileName: string; Surface: PSDL_Surface; Quality: integer): boolean; +var + {$IFDEF Delphi} + Bitmap: TBitmap; + BitmapInfo: TBitmapInfo; + Jpeg: TJpegImage; + row: integer; + {$ELSE} + cinfo: jpeg_compress_struct; + jerr : jpeg_error_mgr; + jpgFile: TFileStream; + rowPtr: array[0..0] of JSAMPROW; + {$ENDIF} + converted: boolean; +begin + Result := false; + + {$IFDEF Delphi} + // only 24bit (BGR) data is supported, so convert to it + if (IsBGRSurface(Surface.format)) then + converted := false + else + begin + Surface := SDL_ConvertSurface(Surface, @PixelFmt_BGR, SDL_SWSURFACE); + converted := true; + end; + + // create and setup bitmap + Bitmap := TBitmap.Create; + Bitmap.PixelFormat := pf24bit; + Bitmap.Width := Surface.w; + Bitmap.Height := Surface.h; + + // setup bitmap info on source image (Surface parameter) + ZeroMemory(@BitmapInfo, SizeOf(BitmapInfo)); + with BitmapInfo.bmiHeader do + begin + biSize := SizeOf(BITMAPINFOHEADER); + biWidth := Surface.w; + biHeight := Surface.h; + biPlanes := 1; + biBitCount := 24; + biCompression := BI_RGB; + end; + + if (SDL_MUSTLOCK(Surface)) then + SDL_LockSurface(Surface); + + // use fast Win32-API functions to copy data instead of Bitmap.Canvas.Pixels + if (Surface.pitch mod 4 = 0) then + begin + // if the image is aligned (to a 4-byte boundary) -> copy all data at once + // Note: surfaces created with SDL (e.g. with SDL_ConvertSurface) are aligned + SetDIBits(0, Bitmap.Handle, 0, Bitmap.Height, Surface.pixels, BitmapInfo, DIB_RGB_COLORS); + end + else + begin + // wrong alignment -> copy each line separately. + // Note: for the last line unassigned memory (> last Surface.pixels element) + // will be copied to the padding area (last bytes of a row), + // but we do not care because the content of padding data is ignored anyhow. + for row := 0 to Surface.h do + begin + SetDIBits(0, Bitmap.Handle, row, 1, @PChar(Surface.pixels)[row * Surface.pitch], + BitmapInfo, DIB_RGB_COLORS); + end; + end; + + if (SDL_MUSTLOCK(Surface)) then + SDL_UnlockSurface(Surface); + + // assign Bitmap to JPEG and store the latter + Jpeg := TJPEGImage.Create; + Jpeg.Assign(Bitmap); + Bitmap.Free; + Jpeg.CompressionQuality := Quality; + try + // compress image (don't forget this line, otherwise it won't be compressed) + Jpeg.Compress(); + Jpeg.SaveToFile(FileName); + except + Log.LogError('Could not save file: "' + FileName + '"', 'WriteJPGImage'); + Exit; + end; + Jpeg.Free; + {$ELSE} + // based on example.pas in FPC's packages/base/pasjpeg directory + + // only 24bit (RGB) data is supported, so convert to it + if (IsRGBSurface(Surface.format)) then + converted := false + else + begin + Surface := SDL_ConvertSurface(Surface, @PixelFmt_RGB, SDL_SWSURFACE); + converted := true; + end; + + // allocate and initialize JPEG compression object + cinfo.err := jpeg_std_error(jerr); + // msg_level that will be displayed. (Nomssi) + //jerr.trace_level := 3; + // initialize the JPEG compression object + jpeg_create_compress(@cinfo); + + // open file for writing + try + jpgFile := TFileStream.Create(FileName, fmCreate); + except + Log.LogError('Could not open file: "' + FileName + '"', 'WriteJPGImage'); + Exit; + end; + + // specify data destination + jpeg_stdio_dest(@cinfo, @jpgFile); + + // set parameters for compression + cinfo.image_width := Surface.w; + cinfo.image_height := Surface.h; + cinfo.in_color_space := JCS_RGB; + cinfo.input_components := 3; + cinfo.data_precision := 8; + + // set default compression parameters + jpeg_set_defaults(@cinfo); + jpeg_set_quality(@cinfo, quality, true); + + // start compressor + jpeg_start_compress(@cinfo, true); + + if (SDL_MUSTLOCK(Surface)) then + SDL_LockSurface(Surface); + + while (cinfo.next_scanline < cinfo.image_height) do + begin + // Note: the byte-count of a row is pitch (which is not width*bitsPerPixel if the image is aligned) + rowPtr[0] := JSAMPROW(@PChar(Surface.pixels)[(Surface.h-cinfo.next_scanline-1) * Surface.pitch]); + jpeg_write_scanlines(@cinfo, JSAMPARRAY(@rowPtr), 1); + end; + + if (SDL_MUSTLOCK(Surface)) then + SDL_UnlockSurface(Surface); + + // finish compression + jpeg_finish_compress(@cinfo); + // close the output file + jpgFile.Free; + + // release JPEG compression object + jpeg_destroy_compress(@cinfo); + {$ENDIF} + + if (converted) then + SDL_FreeSurface(Surface); + + Result := true; +end; + +{$ENDIF} + + +(******************************************************* + * Image loading + *******************************************************) + + +(* + * Loads an image from the given file or resource + *) +function LoadImage(const Identifier: string): PSDL_Surface; +var + TexRWops: PSDL_RWops; + TexStream: TStream; + FileName: string; +begin + Result := nil; + TexRWops := nil; + + if Identifier = '' then + exit; + + //Log.LogStatus( Identifier, 'LoadImage' ); + + FileName := Identifier; + + if (FileExistsInsensitive(FileName)) then + begin + // load from file + //Log.LogStatus( 'Is File ( Loading : '+FileName+')', ' LoadImage' ); + try + Result := IMG_Load(PChar(FileName)); + //Log.LogStatus( ' '+inttostr( integer( Result ) ), ' LoadImage' ); + except + Log.LogError('Could not load from file "'+FileName+'"', 'LoadImage'); + Exit; + end; + end + else + begin + //Log.LogStatus( 'IS Resource, because file does not exist.('+Identifier+')', ' LoadImage' ); + + TexStream := GetResourceStream(Identifier, 'TEX'); + if (not assigned(TexStream)) then + begin + Log.LogError( 'Invalid file or resource "'+ Identifier+'"', 'LoadImage'); + Exit; + end; + + TexRWops := RWopsFromStream(TexStream); + if (TexRWops = nil) then + begin + Log.LogError( 'Could not assign resource "'+Identifier+'"', 'LoadImage'); + TexStream.Free(); + Exit; + end; + + //Log.LogStatus( 'resource Assigned....' , Identifier); + try + Result := IMG_Load_RW(TexRWops, 0); + except + Log.LogError( 'Could not read resource "'+Identifier+'"', 'LoadImage'); + end; + + SDL_FreeRW(TexRWops); + TexStream.Free(); + end; +end; + + +(******************************************************* + * Image manipulation + *******************************************************) + + +function PixelFormatEquals(fmt1, fmt2: PSDL_PixelFormat): boolean; +begin + if (fmt1^.BitsPerPixel = fmt2^.BitsPerPixel) and + (fmt1^.BytesPerPixel = fmt2^.BytesPerPixel) and + (fmt1^.Rloss = fmt2^.Rloss) and (fmt1^.Gloss = fmt2^.Gloss) and + (fmt1^.Bloss = fmt2^.Bloss) and (fmt1^.Rmask = fmt2^.Rmask) and + (fmt1^.Gmask = fmt2^.Gmask) and (fmt1^.Bmask = fmt2^.Bmask) and + (fmt1^.Rshift = fmt2^.Rshift) and (fmt1^.Gshift = fmt2^.Gshift) and + (fmt1^.Bshift = fmt2^.Bshift) + then + Result := true + else + Result := false; +end; + +procedure ScaleImage(var ImgSurface: PSDL_Surface; Width, Height: Cardinal); +var + TempSurface: PSDL_Surface; +begin + TempSurface := ImgSurface; + ImgSurface := SDL_ScaleSurfaceRect(TempSurface, + 0, 0, TempSurface^.W,TempSurface^.H, + Width, Height); + SDL_FreeSurface(TempSurface); +end; + +procedure FitImage(var ImgSurface: PSDL_Surface; Width, Height: Cardinal); +var + TempSurface: PSDL_Surface; + ImgFmt: PSDL_PixelFormat; +begin + TempSurface := ImgSurface; + + // create a new surface with given width and height + ImgFmt := TempSurface^.format; + ImgSurface := SDL_CreateRGBSurface( + SDL_SWSURFACE, Width, Height, ImgFmt^.BitsPerPixel, + ImgFmt^.RMask, ImgFmt^.GMask, ImgFmt^.BMask, ImgFmt^.AMask); + + // copy image from temp- to new surface + SDL_SetAlpha(ImgSurface, 0, 255); + SDL_SetAlpha(TempSurface, 0, 255); + SDL_BlitSurface(TempSurface, nil, ImgSurface, nil); + + SDL_FreeSurface(TempSurface); +end; + +(* +// Old slow floating point version of ColorizeTexture. +// For an easier understanding of the faster fixed point version below. +procedure ColorizeTexture(TexSurface: PSDL_Surface; Col: Cardinal); +var + clr: array[0..2] of Double; // [0: R, 1: G, 2: B] + hsv: array[0..2] of Double; // [0: H(ue), 1: S(aturation), 2: V(alue)] + delta, f, p, q, t: Double; + max: Double; +begin + clr[0] := PixelColors[0]/255; + clr[1] := PixelColors[1]/255; + clr[2] := PixelColors[2]/255; + max := maxvalue(clr); + delta := max - minvalue(clr); + + hsv[0] := DestinationHue; // set H(ue) + hsv[2] := max; // set V(alue) + // calc S(aturation) + if (max = 0.0) then + hsv[1] := 0.0 + else + hsv[1] := delta/max; + + //ColorizePixel(PByteArray(Pixel), DestinationHue); + h_int := trunc(hsv[0]); // h_int = |_h_| + f := hsv[0]-h_int; // f = h-h_int + p := hsv[2]*(1.0-hsv[1]); // p = v*(1-s) + q := hsv[2]*(1.0-(hsv[1]*f)); // q = v*(1-s*f) + t := hsv[2]*(1.0-(hsv[1]*(1.0-f))); // t = v*(1-s*(1-f)) + case h_int of + 0: begin clr[0] := hsv[2]; clr[1] := t; clr[2] := p; end; // (v,t,p) + 1: begin clr[0] := q; clr[1] := hsv[2]; clr[2] := p; end; // (q,v,p) + 2: begin clr[0] := p; clr[1] := hsv[2]; clr[2] := t; end; // (p,v,t) + 3: begin clr[0] := p; clr[1] := q; clr[2] := hsv[2]; end; // (p,q,v) + 4: begin clr[0] := t; clr[1] := p; clr[2] := hsv[2]; end; // (t,p,v) + 5: begin clr[0] := hsv[2]; clr[1] := p; clr[2] := q; end; // (v,p,q) + end; + + // and store new rgb back into the image + PixelColors[0] := trunc(255*clr[0]); + PixelColors[1] := trunc(255*clr[1]); + PixelColors[2] := trunc(255*clr[2]); +end; +*) + +procedure ColorizeImage(ImgSurface: PSDL_Surface; NewColor: Cardinal); + + //returns hue within range [0.0-6.0) + function col2hue(Color:Cardinal): double; + var + clr: array[0..2] of double; + hue, max, delta: double; + begin + clr[0] := ((Color and $ff0000) shr 16)/255; // R + clr[1] := ((Color and $ff00) shr 8)/255; // G + clr[2] := (Color and $ff) /255; // B + max := maxvalue(clr); + delta := max - minvalue(clr); + // calc hue + if (delta = 0.0) then hue := 0 + else if (clr[0] = max) then hue := (clr[1]-clr[2])/delta + else if (clr[1] = max) then hue := 2.0+(clr[2]-clr[0])/delta + else if (clr[2] = max) then hue := 4.0+(clr[0]-clr[1])/delta; + if (hue < 0.0) then + hue := hue + 6.0; + Result := hue; + end; + +var + DestinationHue: Double; + PixelIndex: Cardinal; + Pixel: PByte; + PixelColors: PByteArray; + clr: array[0..2] of UInt32; // [0: R, 1: G, 2: B] + hsv: array[0..2] of UInt32; // [0: H(ue), 1: S(aturation), 2: V(alue)] + dhue: UInt32; + h_int: Cardinal; + delta, f, p, q, t: Longint; + max: Uint32; +begin + DestinationHue := col2hue(NewColor); + + dhue := Trunc(DestinationHue*1024); + + Pixel := ImgSurface^.Pixels; + + for PixelIndex := 0 to (ImgSurface^.W * ImgSurface^.H)-1 do + begin + PixelColors := PByteArray(Pixel); + // inlined colorize per pixel + + // uses fixed point math + // get color values + clr[0] := PixelColors[0] shl 10; + clr[1] := PixelColors[1] shl 10; + clr[2] := PixelColors[2] shl 10; + //calculate luminance and saturation from rgb + + max := clr[0]; + if clr[1] > max then max := clr[1]; + if clr[2] > max then max := clr[2]; + delta := clr[0]; + if clr[1] < delta then delta := clr[1]; + if clr[2] < delta then delta := clr[2]; + delta := max-delta; + hsv[0] := dhue; // shl 8 + hsv[2] := max; // shl 8 + if (max = 0) then + hsv[1] := 0 + else + hsv[1] := (delta shl 10) div max; // shl 8 + h_int := hsv[0] and $fffffC00; + f := hsv[0]-h_int; //shl 10 + p := (hsv[2]*(1024-hsv[1])) shr 10; + q := (hsv[2]*(1024-(hsv[1]*f) shr 10)) shr 10; + t := (hsv[2]*(1024-(hsv[1]*(1024-f)) shr 10)) shr 10; + h_int := h_int shr 10; + case h_int of + 0: begin clr[0] := hsv[2]; clr[1] := t; clr[2] := p; end; // (v,t,p) + 1: begin clr[0] := q; clr[1] := hsv[2]; clr[2] := p; end; // (q,v,p) + 2: begin clr[0] := p; clr[1] := hsv[2]; clr[2] := t; end; // (p,v,t) + 3: begin clr[0] := p; clr[1] := q; clr[2] := hsv[2]; end; // (p,q,v) + 4: begin clr[0] := t; clr[1] := p; clr[2] := hsv[2]; end; // (t,p,v) + 5: begin clr[0] := hsv[2]; clr[1] := p; clr[2] := q; end; // (v,p,q) + end; + + PixelColors[0] := clr[0] shr 10; + PixelColors[1] := clr[1] shr 10; + PixelColors[2] := clr[2] shr 10; + + Inc(Pixel, ImgSurface^.format.BytesPerPixel); + end; +end; + +end. -- cgit v1.2.3