{ This file is part of the Mufasa Macro Library (MML) Copyright (c) 2009 by Raymond van Venetiƫ and Merlijn Wajer MML 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. MML 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 MML. If not, see . See the file COPYING, included in this distribution, for details about the copyright. Bitmaps class for the Mufasa Macro Library } unit bitmaps; {$mode objfpc}{$H+} interface uses Classes, SysUtils, FPImage,IntfGraphics,graphtype,MufasaTypes,graphics; type { TMufasaBitmap } TMufasaBitmap = class(TObject) private w,h : integer; TransparentColor : TRGB32; TransparentSet : boolean; FIndex : integer; public OnDestroy : procedure(Bitmap : TMufasaBitmap) of object; FakeData : array of TRGB32; FData : PRGB32; BmpName : string; //Optional? property Index : integer read FIndex write FIndex; procedure SetSize(AWidth,AHeight : integer); procedure StretchResize(AWidth,AHeight : integer); property Width : Integer read w; property Height : Integer read h; procedure ValidatePoint(x,y : integer); function SaveToFile(const FileName : string) :boolean; procedure LoadFromFile(const FileName : string); procedure FastSetPixel(x,y : integer; Color : TColor); procedure FastSetPixels(TPA : TPointArray; Colors : TIntegerArray); procedure DrawATPA(ATPA : T2DPointArray; Colors : TIntegerArray);overload; procedure DrawATPA(ATPA : T2DPointArray);overload; procedure DrawTPA(TPA : TPointArray; Color : TColor); function FastGetPixel(x,y : integer) : TColor; function FastGetPixels(TPA : TPointArray) : TIntegerArray; Procedure SetTransparentColor(Col : TColor); Function GetTransparentColor : TColor; property TransparentColorSet : boolean read TransparentSet; procedure FastDrawClear(Color : TColor); procedure FastDrawTransparent(x, y: Integer; TargetBitmap: TMufasaBitmap); procedure FastReplaceColor(OldColor, NewColor: TColor); procedure CopyClientToBitmap(MWindow : TObject;Resize : boolean; xs, ys, xe, ye: Integer);overload; procedure CopyClientToBitmap(MWindow : TObject;Resize : boolean;x,y : integer; xs, ys, xe, ye: Integer);overload; procedure RotateBitmap(angle: Extended;TargetBitmap : TMufasaBitmap ); procedure Desaturate;overload; procedure Desaturate(TargetBitmap : TMufasaBitmap); overload; procedure GreyScale(TargetBitmap : TMufasaBitmap);overload; procedure GreyScale; procedure Brightness(br: integer);overload; procedure Brightness(TargetBitmap : TMufasaBitmap; br : integer); overload; procedure Contrast(co: Extended);overload; procedure Contrast(TargetBitmap : TMufasaBitmap; co : Extended);overload; procedure Invert; procedure Posterize(TargetBitmap : TMufasaBitmap; Po : integer);overload; procedure Posterize(Po : integer);overload; function Copy: TMufasaBitmap; function ToTBitmap: TBitmap; procedure LoadFromTBitmap(bmp: TBitmap); procedure LoadFromRawImage(RawImage: TRawImage); function CreateTMask : TMask; constructor Create; destructor Destroy;override; end; TMufasaBmpArray = Array of TMufasaBitmap; { TMBitmaps } TMBitmaps = class(TObject) protected Client : TObject; FreeSpots : Array of integer; BmpArray : TMufasaBmpArray; BmpsCurr,BmpsHigh,FreeSpotsHigh,FreeSpotsLen : integer; public function GetBMP(Index : integer) : TMufasaBitmap; property Bmp[Index : integer]: TMufasaBitmap read GetBMP; function CreateBMP(w, h: integer): Integer; function CopyBMP( Bitmap : integer) : Integer; function CreateMirroredBitmap(bitmap: Integer; MirrorStyle : TBmpMirrorStyle): Integer; function CreateBMPFromFile(const Path : string) : integer; function CreateBMPFromString(width,height : integer; Data : string) : integer;overload; function CreateBMPFromString(BmpName : string; width,height : integer; Data : string) : integer;overload; procedure FreeBMP( Number : integer); constructor Create(Owner : TObject); destructor Destroy;override; end; implementation uses Windowutil,paszlib,DCPbase64,math, colour_conv,window,mufasatypesutil; function Min(a,b:integer) : integer; begin if a < b then result := a else result := b; end; { TMBitmaps } function TMBitmaps.GetBMP(Index: integer): TMufasaBitmap; begin Result := nil; if (Index >= 0) and (Index <= BmpsCurr) then if BmpArray[Index] <> nil then Result := BmpArray[Index]; if Result = nil then raise Exception.CreateFmt('The bitmap[%d] does not exist',[Index]); end; function TMBitmaps.CreateBMP(w,h : integer): Integer; begin if BmpsCurr < BmpsHigh then begin; inc(BmpsCurr); Result := BmpsCurr; end else if (FreeSpotsHigh > -1) then begin; Result := FreeSpots[FreeSpotsHigh]; dec(FreeSpotsHigh); end else begin; SetLength(BmpArray, BmpsHigh + 6); BmpsHigh := BmpsHigh + 5; inc(BmpsCurr); Result := BmpsCurr; end; BmpArray[Result] := TMufasaBitmap.Create; BmpArray[Result].SetSize(w,h); BmpArray[Result].Index:= Result; end; function TMBitmaps.CopyBMP(Bitmap: integer): Integer; var InputBMP : TMufasaBitmap; OutputBMP : TMUfasaBitmap; begin InputBMP := GetBMP(Bitmap); Result := CreateBMP(InputBmp.w,InputBMP.h); OutputBMP := GetBMP(Result); Move(InputBMP.FData[0],OutPutBMP.FData[0],InputBMP.w * InputBMP.h * SizeOf(TRGB32)); end; function TMBitmaps.CreateMirroredBitmap(bitmap: Integer; MirrorStyle: TBmpMirrorStyle): Integer; var w,h : integer; y,x : integer; Source,Dest : PRGB32; begin Source := Bmp[Bitmap].FData; w := BmpArray[Bitmap].Width; h := BmpArray[Bitmap].Height; if MirrorStyle = MirrorLine then Result := CreateBMP(h,w) else Result := CreateBMP(w,h); Dest := BmpArray[Result].FData; case MirrorStyle of MirrorWidth : for y := (h-1) downto 0 do for x := (w-1) downto 0 do Dest[y*w+x] := Source[y*w+w-1-x]; MirrorHeight : for y := (h-1) downto 0 do Move(Source[y*w],Dest[(h-1 - y) * w],w*SizeOf(TRGB32)); MirrorLine : for y := (h-1) downto 0 do for x := (w-1) downto 0 do Dest[x*h+y] := Source[y*w+x]; end; //Can be optmized, this is just proof of concept end; function TMBitmaps.CreateBMPFromFile(const Path: string): integer; begin Result := CreateBMP(0,0); BmpArray[result].LoadFromFile(Path); end; function HexToInt(HexNum: string): LongInt;inline; begin Result:=StrToInt('$' + HexNum); end; function TMBitmaps.CreateBMPFromString(width, height: integer; Data: string): integer; var I,II: LongWord; DestLen : LongWord; Dest,Source : string; DestPoint, Point : PByte; begin Result := CreateBMP(width,height); if (Data <> '') and (Length(Data) <> 6) then begin; Point := Pointer(BmpArray[Result].FData); if Data[1] = 'b' then begin; Source := Base64DecodeStr(Copy(Data,2,Length(Data) - 1)); Destlen := Width * Height * 3; Setlength(Dest,DestLen); if uncompress(PChar(Dest),Destlen,pchar(Source), Length(Source)) = Z_OK then begin; DestPoint := @Dest[1]; i := 0; ii := 2; Dec(DestLen); if DestLen > 2 then begin; while (ii < DestLen) do Begin; Point[i]:= DestPoint[ii+2]; Point[i+1]:= DestPoint[ii+1]; Point[i+2]:= DestPoint[ii]; ii := ii + 3; i := i + 4; end; Point[i] := DestPoint[1]; Point[i+1] := DestPoint[0]; Point[i+2] := DestPoint[ii]; end else if (Width = 1) and (Height =1 ) then begin; Point[0] := DestPoint[1]; Point[1] := DestPoint[0]; Point[2] := DestPoint[2]; end; end; end else if Data[1] = 'z' then begin; Destlen := Width * Height * 3 *2; Setlength(Dest,DestLen); ii := (Length(Data) - 1) div 2; SetLength(Source,ii); for i := 1 to ii do Source[i] := Chr(HexToInt(Data[i * 2] + Data[i * 2+1])); if uncompress(PChar(Dest),Destlen,pchar(Source), ii) = Z_OK then begin; ii := 1; i := 0; while (II < DestLen) do begin; Point[i+2]:= HexToInt(Dest[ii] + Dest[ii + 1]); Point[i+1]:= HexToInt(Dest[ii+2] + Dest[ii + 3]); Point[i]:= HexToInt(Dest[ii+4] + Dest[ii + 5]); ii := ii + 6; i := i + 4; end; end; end else if LongWord(Length(Data)) = LongWord((Width * Height * 3 * 2)) then begin; ii := 1; i := 0; Destlen := Width * Height * 3 * 2; while (II < DestLen) do begin; Point[i+2]:= HexToInt(Data[ii] + Data[ii + 1]); Point[i+1]:= HexToInt(Data[ii+2] + Data[ii + 3]); Point[i]:= HexToInt(Data[ii+4] + Data[ii + 5]); ii := ii + 6; i := i + 4; end; end; end else begin; if Length(data) = 6 then BmpArray[Result].FastDrawClear(HexToInt(Data)); // else // FastDrawClear(Result,clBlack); end; end; function TMBitmaps.CreateBMPFromString(BmpName: string; width, height: integer; Data: string): integer; begin Result := Self.CreateBMPFromString(width,height,data); Bmp[Result].BmpName:= BmpName; end; procedure TMBitmaps.FreeBMP(Number: integer); var ToDestroy : TMufasaBitmap; begin ToDestroy := GetBMP(Number); if Number = BmpsCurr then Dec(BmpsCurr) else begin; inc(FreeSpotsHigh); if FreeSpotsHigh = FreeSpotsLen then begin; inc(FreeSpotsLen); SetLength(FreeSpots, FreeSpotsLen); end; FreeSpots[FreeSpotsHigh] := Number; end; //Just for testing purposes if ToDestroy.BmpName = '' then Writeln(Format('BMP[%d] has been freed.',[number])) else Writeln(Format('BMP[%s] has been freed.',[ToDestroy.BmpName])); FreeAndNil(ToDestroy); end; function TMufasaBitmap.SaveToFile(const FileName: string): boolean; var rawImage : TRawImage; Bmp : TLazIntfImage; begin ArrDataToRawImage(FData,Point(w,h),RawImage); result := true; // Bmp := Graphics.TBitmap.Create; try Bmp := TLazIntfImage.Create(RawImage,false); Bmp.SaveToFile(FileName); Bmp.Free; except result := false; end; end; procedure TMufasaBitmap.LoadFromFile(const FileName: string); var LazIntf : TLazIntfImage; RawImageDesc : TRawImageDescription; begin if FileExists(FileName) then begin; LazIntf := TLazIntfImage.Create(0,0); RawImageDesc.Init_BPP32_B8G8R8_BIO_TTB(LazIntf.Width,LazIntf.Height); LazIntf.DataDescription := RawImageDesc; LazIntf.LoadFromFile(FileName); if Assigned(FData) then Freemem(FData); Self.W := LazIntf.Width; Self.H := LazIntf.Height; FData := GetMem(Self.W*Self.H*SizeOf(TRGB32)); Move(LazIntf.PixelData[0],FData[0],w*h*sizeOf(TRGB32)); LazIntf.Free; end; end; function RGBToBGR(Color : TColor) : TRGB32; inline; begin; Result.R := Color and $ff; Result.G := Color shr 8 and $ff; Result.B := Color shr 16 and $ff; end; function BGRToRGB(BGR : TRGB32) : TColor;inline; begin; Result := BGR.R or BGR.g shl 8 or BGR.b shl 16; end; function TMufasaBitmap.Copy: TMufasaBitmap; begin Result := TMufasaBitmap.Create; Result.SetSize(self.Width, self.Height); Move(self.FData[0], Result.FData[0],self.w * self.h * SizeOf(TRGB32)); end; function TMufasaBitmap.ToTBitmap: TBitmap; var tr:TRawImage; begin Result := TBitmap.Create; Result.SetSize(self.Width, self.Height); ArrDataToRawImage(Self.Fdata, point(self.width,self.height), tr); Result.LoadFromRawImage(tr, false); end; procedure TMufasaBitmap.LoadFromRawImage(RawImage: TRawImage); var x,y: integer; _24_old_p: PByte; rs,gs,bs:byte; data: PRGB32; begin // clear data Self.SetSize(0,0); if (RawImage.Description.BitsPerPixel <> 24) and (RawImage.Description.BitsPerPixel <> 32) then raise Exception.CreateFMT('TMufasaBitmap.LoadFromRawImage - BitsPerPixel is %d', [RawImage.Description.BitsPerPixel]); {writeln('Bits per pixel: ' + Inttostr(RawImage.Description.BitsPerPixel)); } if RawImage.Description.LineOrder <> riloTopToBottom then raise Exception.Create('TMufasaBitmap.LoadFromRawImage - LineOrder is not riloTopToBottom'); { writeln(format('LineOrder: theirs: %d, ours: %d', [RawImage.Description.LineOrder, riloTopToBottom])); } // Todo, add support for other alignments. { if RawImage.Description.LineEnd <> rileDWordBoundary then raise Exception.Create('TMufasaBitmap.LoadFromRawImage - LineEnd is not rileDWordBoundary'); } //writeln(format('LineEnd: t', [RawImage.Description.LineEnd])); if RawImage.Description.Format<>ricfRGBA then raise Exception.Create('TMufasaBitmap.LoadFromRawImage - Format is not ricfRGBA'); // Set w,h and alloc mem. Self.SetSize(RawImage.Description.Width, RawImage.Description.Height); {writeln(format('Image size: %d, %d', [w,h])); } rs := RawImage.Description.RedShift shr 3; gs := RawImage.Description.GreenShift shr 3; bs := RawImage.Description.BlueShift shr 3; { writeln(format('Shifts(R,G,B): %d, %d, %d', [rs,gs,bs])); writeln(format('Bits per line %d, expected: %d', [RawImage.Description.BitsPerLine, RawImage.Description.BitsPerPixel * self.w])); } if RawImage.Description.BitsPerPixel = 32 then Move(RawImage.Data[0], Self.FData[0], self.w * self.h * SizeOf(TRGB32)) else begin //FillChar(Self.FData[0], self.w * self.h * SizeOf(TRGB32), 0); data := self.FData; _24_old_p := RawImage.Data; for y := 0 to self.h -1 do begin for x := 0 to self.w -1 do begin // b is the first byte in the record. data^.b := _24_old_p[bs]; data^.g := _24_old_p[gs]; data^.r := _24_old_p[rs]; data^.a := 0; inc(_24_old_p, 3); inc(data); end; case RawImage.Description.LineEnd of rileTight, rileByteBoundary: ; // do nothing rileWordBoundary: while (_24_old_p - RawImage.Data) mod 2 <> 0 do inc(_24_old_p); rileDWordBoundary: while (_24_old_p - RawImage.Data) mod 4 <> 0 do inc(_24_old_p); rileQWordBoundary: while (_24_old_p - RawImage.Data) mod 4 <> 0 do inc(_24_old_p); rileDQWordBoundary: while (_24_old_p - RawImage.Data) mod 8 <> 0 do inc(_24_old_p); end; end; end; end; procedure TMufasaBitmap.LoadFromTBitmap(bmp: TBitmap); begin bmp.BeginUpdate(); LoadFromRawImage(bmp.RawImage); bmp.EndUpdate(); end; procedure TMufasaBitmap.FastSetPixel(x, y: integer; Color: TColor); begin ValidatePoint(x,y); FData[y*w+x] := RGBToBGR(Color); end; procedure TMufasaBitmap.FastSetPixels(TPA: TPointArray; Colors: TIntegerArray); var i,len : integer; begin len := High(TPA); if Len <> High(colors) then Raise Exception.CreateFMT('TPA/Colors Length differ',[]); for i := 0 to len do begin; ValidatePoint(TPA[i].x,TPA[i].y); FData[TPA[i].y * w + TPA[i].x] := RGBToBGR(Colors[i]); end; end; procedure TMufasaBitmap.DrawATPA(ATPA: T2DPointArray; Colors: TIntegerArray); var lenTPA,lenATPA : integer; i,ii : integer; Color : TRGB32; begin lenATPA := High(ATPA); if LenATPA <> High(colors) then Raise Exception.CreateFMT('TPA/Colors Length differ -> %d : %d',[LenATPA + 1,High(Colors) + 1]); for i := 0 to lenATPA do begin; lenTPA := High(ATPA[i]); Color := RGBToBGR(Colors[i]); for ii := 0 to lenTPA do begin; ValidatePoint(ATPA[i][ii].x,ATPA[i][ii].y); FData[ATPA[i][ii].y * w + ATPA[i][ii].x] := Color; end; end; end; procedure TMufasaBitmap.DrawATPA(ATPA: T2DPointArray); var Colors : TIntegerArray; i,len : integer; begin len := high(ATPA); SetLength(colors,len+1); for i := 0 to len do Colors[i] := Random(clwhite); DrawATPA(ATPA,Colors); end; procedure TMufasaBitmap.DrawTPA(TPA: TPointArray; Color: TColor); begin DrawATPA(ConvArr([TPA]),ConvArr([Color])); end; function TMufasaBitmap.FastGetPixel(x, y: integer): TColor; begin ValidatePoint(x,y); Result := BGRToRGB(FData[y*w+x]); end; function TMufasaBitmap.FastGetPixels(TPA: TPointArray): TIntegerArray; var i,len : integer; begin len := high(TPA); SetLength(result,len+1); for i := 0 to len do begin; ValidatePoint(TPA[i].x,TPA[i].y); Result[i] := BGRToRGB(FData[TPA[i].y*w + TPA[i].x]); end; end; procedure TMufasaBitmap.SetTransparentColor(Col: TColor); begin TransparentColor:= RGBToBGR(Col); TransparentSet:= True; end; function TMufasaBitmap.GetTransparentColor: TColor; begin if TransparentSet then Result := BGRToRGB(TransparentColor) else raise Exception.CreateFmt('Transparent color for Bitmap[%d] isn''t set',[index]); end; procedure TMufasaBitmap.FastDrawClear(Color: TColor); var i : integer; Rec : TRGB32; begin Rec := RGBToBGR(Color); if h > 0 then begin; for i := (w-1) downto 0 do FData[i] := Rec; for i := (h-1) downto 1 do Move(FData[0],FData[i*w],w*SizeOf(TRGB32)); end; end; procedure TMufasaBitmap.FastDrawTransparent(x, y: Integer; TargetBitmap: TMufasaBitmap); var MinW,MinH,TargetW,TargetH : Integer; loopx,loopy : integer; begin ValidatePoint(x,y); TargetW := TargetBitmap.Width; TargetH := TargetBitmap.height; MinW := Min(w-1,TargetW-x-1); MinH := Min(h-1,TargetH-y-1); if TransparentSet then begin; for loopy := 0 to MinH do for loopx := 0 to MinW do if LongWord(FData[loopy * w + loopx]) <> LongWord(TransparentColor) then TargetBitmap.FData[(loopy + y) * TargetW + loopx + x] := FData[Loopy * w + loopx]; end else for loopy := 0 to MinH do Move(FData[loopy*w],TargetBitmap.FData[(loopy+y) * TargetW + x],(MinW+1) * SizeOf(TRGB32)); end; procedure TMufasaBitmap.FastReplaceColor(OldColor, NewColor: TColor); var OldCol,NewCol : TRGB32; i : integer; begin OldCol := RGBToBGR(OldColor); NewCol := RGBToBGR(NewColor); for i := w*h-1 downto 0 do if LongWord(FData[i]) = LongWord(OldCol) then FData[i] := NewCol; end; procedure TMufasaBitmap.CopyClientToBitmap(MWindow : TObject;Resize : boolean; xs, ys, xe, ye: Integer); var y : integer; wi,hi : integer; PtrRet : TRetData; begin if Resize then Self.SetSize(xe-xs+1,ye-ys+1); wi := Min(xe-xs + 1,Self.w); hi := Min(ye-ys + 1,Self.h); PtrRet := TMWindow(MWindow).ReturnData(xs,ys,wi,hi); for y := 0 to (hi-1) do Move(PtrRet.Ptr[y * (wi + PtrRet.IncPtrWith)], FData[y * self.w],wi * SizeOf(TRGB32)); TMWindow(MWindow).FreeReturnData; end; procedure TMufasaBitmap.CopyClientToBitmap(MWindow: TObject; Resize: boolean; x, y: integer; xs, ys, xe, ye: Integer); var yy : integer; wi,hi : integer; PtrRet : TRetData; begin if Resize then Self.SetSize(xe-xs+1 + x,ye-ys+1 + y); wi := Min(xe-xs + 1 + x,Self.w); hi := Min(ye-ys + 1 + y,Self.h); PtrRet := TMWindow(MWindow).ReturnData(xs,ys,wi - x,hi - y); for yy := 0 to (hi-1 - y) do Move(PtrRet.Ptr[yy * (wi - x + PtrRet.IncPtrWith)], FData[(yy + y) * self.w + x],wi * SizeOf(TRGB32)); TMWindow(MWindow).FreeReturnData; end; function RotatePointEdited(p: TPoint; angle, mx, my: Extended): TPoint; begin Result.X := Ceil(mx + cos(angle) * (p.x - mx) - sin(angle) * (p.y - my)); Result.Y := Ceil(my + sin(angle) * (p.x - mx) + cos(angle) * (p.y- my)); end; //Scar rotates unit circle-wise.. Oh, scar doesnt update the bounds, so kinda crops ur image. procedure TMufasaBitmap.RotateBitmap(angle: Extended;TargetBitmap : TMufasaBitmap ); var NewW,NewH : integer; CosAngle,SinAngle : extended; MinX,MinY,MaxX,MaxY : integer; i : integer; x,y : integer; OldX,OldY : integer; MiddlePoint : TPoint; NewCorners : array[1..4] of TPoint; //(xs,ye);(xe,ye);(xe,ys);(xs,ys) begin MiddlePoint := Point((w-1) div 2,(h-1) div 2); CosAngle := Cos(Angle); SinAngle := Sin(Angle); MinX := MaxInt; MinY := MaxInt; MaxX := 0; MaxY := 0; NewCorners[1]:= RotatePointEdited(Point(0,h-1),angle,middlepoint.x,middlepoint.y); NewCorners[2]:= RotatePointEdited(Point(w-1,h-1),angle,middlepoint.x,middlepoint.y); NewCorners[3]:= RotatePointEdited(Point(w-1,0),angle,middlepoint.x,middlepoint.y); NewCorners[4]:= RotatePointEdited(Point(0,0),angle,middlepoint.x,middlepoint.y); for i := 1 to 4 do begin; if NewCorners[i].x > MaxX then MaxX := NewCorners[i].x; if NewCorners[i].Y > MaxY then MaxY := NewCorners[i].y; if NewCorners[i].x < MinX then MinX := NewCorners[i].x; if NewCorners[i].y < MinY then MinY := NewCorners[i].y; end; Writeln(Format('Min: (%d,%d) Max : (%d,%d)',[MinX,MinY,MaxX,MaxY])); NewW := MaxX - MinX+1; NewH := MaxY - MinY+1; Writeln(format('New bounds: %d,%d',[NewW,NewH])); TargetBitmap.SetSize(NewW,NewH); for y := NewH - 1 downto 0 do for x := NewW - 1 downto 0 do begin; Oldx := Round(MiddlePoint.x + CosAngle * (x + MinX-MiddlePoint.x) - SinAngle * (y + MinY - MiddlePoint.y)); Oldy := Round(MiddlePoint.y + SinAngle * (x + MinX-MiddlePoint.x) + CosAngle * (y + MinY-MiddlePoint.y)); if not ((Oldx <0) or (Oldx >= w) or (Oldy < 0) or (Oldy >= h)) then TargetBitmap.FData[ y * NewW + x] := Self.FData[OldY * W + OldX]; end; end; procedure TMufasaBitmap.Desaturate; var I : integer; He,Se,Le : extended; Ptr : PRGB32; begin Ptr := FData; for i := (h*w-1) downto 0 do begin; RGBToHSL(Ptr^.R,Ptr^.G,Ptr^.B,He,Se,Le); HSLtoRGB(He,0.0,Le,Ptr^.R,Ptr^.G,Ptr^.B); inc(ptr); end; end; procedure TMufasaBitmap.Desaturate(TargetBitmap: TMufasaBitmap); var I : integer; He,Se,Le : extended; PtrOld,PtrNew : PRGB32; begin TargetBitmap.SetSize(w,h); PtrOld := Self.FData; PtrNew := TargetBitmap.FData; for i := (h*w-1) downto 0 do begin; RGBToHSL(PtrOld^.R,PtrOld^.G,PtrOld^.B,He,Se,Le); HSLtoRGB(He,0.0,Le,PtrNew^.R,PtrNew^.G,PtrNew^.B); inc(ptrOld); inc(PtrNew); end; end; procedure TMufasaBitmap.GreyScale(TargetBitmap: TMufasaBitmap); var I : integer; Lum : byte; PtrOld,PtrNew : PRGB32; begin TargetBitmap.SetSize(w,h); PtrOld := Self.FData; PtrNew := TargetBitmap.FData; for i := (h*w-1) downto 0 do begin; Lum := Round(PtrOld^.r * 0.3 + PtrOld^.g * 0.59 + PtrOld^.b * 0.11); PtrNew^.r := Lum; PtrNew^.g := Lum; PtrNew^.b := Lum; inc(ptrOld); inc(PtrNew); end; end; procedure TMufasaBitmap.GreyScale; var I : integer; Lum : Byte; Ptr: PRGB32; begin Ptr := Self.FData; for i := (h*w-1) downto 0 do begin; Lum := Round(Ptr^.r * 0.3 + Ptr^.g * 0.59 + Ptr^.b * 0.11); Ptr^.r := Lum; Ptr^.g := Lum; Ptr^.b := Lum; inc(ptr); end; end; function BrightnessAdjust(Col: byte; br : integer): byte;inline; var temp : integer; begin; Temp := Col + Br; if temp < 0 then temp := 0 else if temp > 255 then temp := 255; result := temp; end; procedure TMufasaBitmap.Brightness(br: integer); var I : integer; Ptr: PRGB32; begin Ptr := Self.FData; for i := (h*w-1) downto 0 do begin; Ptr^.r := BrightnessAdjust(Ptr^.r,br); Ptr^.g := BrightnessAdjust(Ptr^.g,br); Ptr^.b := BrightnessAdjust(Ptr^.b,br); inc(ptr); end; end; procedure TMufasaBitmap.Brightness(TargetBitmap: TMufasaBitmap; br: integer); var I : integer; PtrOld,PtrNew : PRGB32; begin TargetBitmap.SetSize(w,h); PtrOld := Self.FData; PtrNew := TargetBitmap.FData; for i := (h*w-1) downto 0 do begin; PtrNew^.r := BrightnessAdjust(PtrOld^.r,br); PtrNew^.g := BrightnessAdjust(PtrOld^.g,br); PtrNew^.b := BrightnessAdjust(PtrOld^.b,br); inc(ptrOld); inc(PtrNew); end; end; const Grey = 128; function ContrastAdjust(Col: byte; co : extended): byte;inline; var temp : integer; begin; Temp := floor((col - Grey) * co) + grey; if temp < 0 then temp := 0 else if temp > 255 then temp := 255; result := temp; end; procedure TMufasaBitmap.Contrast(co: Extended); var I : integer; Ptr: PRGB32; begin Ptr := Self.FData; for i := (h*w-1) downto 0 do begin; Ptr^.r := ContrastAdjust(Ptr^.r,co); Ptr^.g := ContrastAdjust(Ptr^.g,co); Ptr^.b := ContrastAdjust(Ptr^.b,co); inc(ptr); end; end; procedure TMufasaBitmap.Contrast(TargetBitmap: TMufasaBitmap; co: Extended); var I : integer; PtrOld,PtrNew : PRGB32; begin TargetBitmap.SetSize(w,h); PtrOld := Self.FData; PtrNew := TargetBitmap.FData; for i := (h*w-1) downto 0 do begin; PtrNew^.r := ContrastAdjust(PtrOld^.r,co); PtrNew^.g := ContrastAdjust(PtrOld^.g,co); PtrNew^.b := ContrastAdjust(PtrOld^.b,co); inc(ptrOld); inc(PtrNew); end; end; procedure TMufasaBitmap.Invert; var i : integer; begin for i := (h*w-1) downto 0 do begin; Self.FData[i].r := not Self.FData[i].r; Self.FData[i].g := not Self.FData[i].g; Self.Fdata[i].b := not Self.FData[i].b; end; end; procedure TMufasaBitmap.Posterize(TargetBitmap: TMufasaBitmap; Po: integer); var I : integer; PtrOld,PtrNew : PRGB32; begin if not InRange(Po,1,255) then Raise exception.CreateFmt('Posterize Po(%d) out of range[1,255]',[Po]); TargetBitmap.SetSize(w,h); PtrOld := Self.FData; PtrNew := TargetBitmap.FData; for i := (h*w-1) downto 0 do begin; PtrNew^.r := min(Round(PtrOld^.r / po) * Po, 255); PtrNew^.g := min(Round(PtrOld^.g / po) * Po, 255); PtrNew^.b := min(Round(PtrOld^.b / po) * Po, 255); inc(ptrOld); inc(PtrNew); end; end; procedure TMufasaBitmap.Posterize(Po: integer); var I : integer; Ptr: PRGB32; {a:integer; } begin if not InRange(Po,1,255) then Raise exception.CreateFmt('Posterize Po(%d) out of range[1,255]',[Po]); Ptr := Self.FData; for i := (h*w-1) downto 0 do begin; { a := round(ptr^.r / po); a := a * po; ptr^.r := min(a,255); a := round(ptr^.g / po); a := a * po; ptr^.g := min(a,255); a := round(ptr^.b / po); a := a * po; ptr^.b := min(a,255); } ptr^.r := min(Round(ptr^.r / po) * Po, 255); ptr^.g := min(Round(ptr^.g / po) * Po, 255); ptr^.b := min(Round(ptr^.b / po) * Po, 255); inc(ptr); end; end; function TMufasaBitmap.CreateTMask: TMask; var x,y : integer; dX,dY : integer; begin Result.BlackHi:= -1; Result.WhiteHi:= -1; Result.W := Self.Width; Result.H := Self.Height; SetLength(result.Black,w*h); SetLength(result.White,w*h); dX := w-1; dY := h-1; //Search it like | | | | | instead of horizontal -> for X loop first. for x := 0 to dX do for y := 0 to dY do //Check for non-white/black pixels? Not for now atleast. if FData[y*w+x].r = 255 then begin; inc(Result.WhiteHi); Result.White[Result.WhiteHi].x := x; Result.White[Result.WhiteHi].y := y; end else begin; inc(Result.BlackHi); Result.Black[Result.BlackHi].x := x; Result.Black[Result.BlackHi].y := y; end; SetLength(result.Black,Result.BlackHi+1); SetLength(result.White,Result.WhiteHi+1); end; constructor TMBitmaps.Create(Owner: TObject); begin inherited Create; SetLength(BmpArray,50); SetLength(FreeSpots, 50); FreeSpotsLen := 50; BmpsHigh := 49; BmpsCurr := -1; FreeSpotsHigh := -1; Self.Client := Owner; end; destructor TMBitmaps.Destroy; var I : integer; begin for i := 0 to BmpsCurr do if BmpArray[i] <> nil then begin; if BmpArray[i].BmpName = '' then Writeln(Format('BMP[%d] has not been freed in the script, freeing it now.',[i])) else Writeln(Format('BMP[%s] has not been freed in the script, freeing it now.',[BmpArray[i].BmpName])); FreeAndNil(BmpArray[i]); end; SetLength(BmpArray,0); SetLength(FreeSpots,0); inherited Destroy; end; { TMufasaBitmap } procedure TMufasaBitmap.SetSize(Awidth, Aheight: integer); var NewData : PRGB32; i,minw,minh : integer; begin if (AWidth <> w) or (AHeight <> h) then begin; if AWidth*AHeight <> 0 then begin; NewData := GetMem(AWidth * AHeight * SizeOf(TRGB32)); FillDWord(NewData[0],AWidth*AHeight,0); end else NewData := nil; if Assigned(FData) and Assigned(NewData) and (w*H <> 0) then begin; minw := Min(AWidth,w); minh := Min(AHeight,h); for i := 0 to minh - 1 do Move(FData[i*w],Newdata[i*AWidth],minw * SizeOf(TRGB32)); end; if Assigned(FData) then FreeMem(FData); FData := NewData; w := AWidth; h := AHeight; end; end; procedure TMufasaBitmap.StretchResize(AWidth, AHeight: integer); var NewData : PRGB32; x,y : integer; begin if (AWidth <> w) or (AHeight <> h) then begin; if AWidth*AHeight <> 0 then begin; NewData := GetMem(AWidth * AHeight * SizeOf(TRGB32)); FillDWord(NewData[0],AWidth*AHeight,0); end else NewData := nil; if Assigned(FData) and Assigned(NewData) and (w*H <> 0) then begin; for y := 0 to AHeight - 1 do for x := 0 to AWidth -1 do NewData[y*AWidth + x] := FData[((y * h)div aheight) * W+ (x * W) div awidth]; end; if Assigned(FData) then FreeMem(FData); FData := NewData; w := AWidth; h := AHeight; end; end; procedure TMufasaBitmap.ValidatePoint(x, y: integer); begin if (x <0) or (x >= w) or (y < 0) or (y >= h) then raise Exception.CreateFmt('You are accessing an invalid point, (%d,%d) at bitmap[%d]',[x,y,index]); end; constructor TMufasaBitmap.Create; begin inherited Create; BmpName:= ''; TransparentSet:= False; setSize(0,0); {FData:= nil; w := 0; h := 0; } end; destructor TMufasaBitmap.Destroy; begin if Assigned(OnDestroy) then OnDestroy(Self); if Assigned(FData) then Freemem(FData); inherited Destroy; end; end.