diff options
Diffstat (limited to 'src/classes/UImage.pas')
| -rw-r--r-- | src/classes/UImage.pas | 993 |
1 files changed, 0 insertions, 993 deletions
diff --git a/src/classes/UImage.pas b/src/classes/UImage.pas deleted file mode 100644 index d33c0d38..00000000 --- a/src/classes/UImage.pas +++ /dev/null @@ -1,993 +0,0 @@ -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. |