Changeset 317
- Timestamp:
- Feb 1, 2012, 3:02:33 PM (13 years ago)
- Location:
- GraphicTest
- Files:
-
- 25 added
- 21 edited
Legend:
- Unmodified
- Added
- Removed
-
GraphicTest/BGRABitmap
-
Property svn:ignore
set to
lib
-
Property svn:ignore
set to
-
GraphicTest/BGRABitmap/bgraanimatedgif.pas
r210 r317 1005 1005 begin 1006 1006 PChangePix^ := PBackground^; 1007 DrawPixelInline (PBGRAPixel(PChangePix), PBGRAPixel(@newpix)^);1007 DrawPixelInlineNoAlphaCheck(PBGRAPixel(PChangePix), PBGRAPixel(@newpix)^); 1008 1008 end 1009 1009 else if PChangePix^ and AlphaMask <> 0 then … … 1045 1045 begin 1046 1046 PChangePix^ := PBackground^; 1047 DrawPixelInline (PBGRAPixel(PChangePix), PBGRAPixel(@newpix)^);1047 DrawPixelInlineNoAlphaCheck(PBGRAPixel(PChangePix), PBGRAPixel(@newpix)^); 1048 1048 end 1049 1049 else if PChangePix^ and AlphaMask <> 0 then … … 1176 1176 begin 1177 1177 PChangePix^ := MemPixEraseColor; 1178 DrawPixelInline (PBGRAPixel(PChangePix), PBGRAPixel(@newpix)^);1178 DrawPixelInlineNoAlphaCheck(PBGRAPixel(PChangePix), PBGRAPixel(@newpix)^); 1179 1179 end 1180 1180 else if PChangePix^ and AlphaMask <> 0 then -
GraphicTest/BGRABitmap/bgrabitmap.pas
r210 r317 41 41 interface 42 42 43 { Compiler directives are used to include the best version according 44 to the platform } 45 43 46 uses 44 47 Classes, SysUtils, … … 81 84 {$ENDIF} 82 85 83 86 // draw a bitmap from pure data 84 87 procedure BGRABitmapDraw(ACanvas: TCanvas; Rect: TRect; AData: Pointer; 85 88 VerticalFlip: boolean; AWidth, AHeight: integer; Opaque: boolean); 86 procedure BGRAReplace(var Source: TBGRABitmap; Temp: TObject); 89 90 { Replace the content of the variable Destination with the variable 91 Temp and frees previous object contained in Destination. 92 93 This function is useful as a shortcut for : 94 95 var 96 temp: TBGRABitmap; 97 begin 98 ... 99 temp := someBmp.Filter... as TBGRABitmap; 100 someBmp.Free; 101 someBmp := temp; 102 end; 103 104 which becomes : 105 106 begin 107 ... 108 BGRAReplace(temp, someBmp.Filter... ); 109 end; 110 } 111 procedure BGRAReplace(var Destination: TBGRABitmap; Temp: TObject); 87 112 88 113 implementation 89 114 90 uses GraphType, BGRA AnimatedGif;115 uses GraphType, BGRABitmapTypes; 91 116 92 117 var 93 bmp: TBGRABitmap;118 tempBmp: TBGRABitmap; 94 119 95 120 procedure BGRABitmapDraw(ACanvas: TCanvas; Rect: TRect; AData: Pointer; … … 98 123 LineOrder: TRawImageLineOrder; 99 124 begin 125 if tempBmp = nil then 126 tempBmp := TBGRABitmap.Create; 100 127 if VerticalFlip then 101 128 LineOrder := riloBottomToTop … … 103 130 LineOrder := riloTopToBottom; 104 131 if Opaque then 105 bmp.DataDrawOpaque(ACanvas, Rect, AData, LineOrder, AWidth, AHeight)132 tempBmp.DataDrawOpaque(ACanvas, Rect, AData, LineOrder, AWidth, AHeight) 106 133 else 107 bmp.DataDrawTransparent(ACanvas, Rect, AData, LineOrder, AWidth, AHeight);134 tempBmp.DataDrawTransparent(ACanvas, Rect, AData, LineOrder, AWidth, AHeight); 108 135 end; 109 136 110 procedure BGRAReplace(var Source: TBGRABitmap; Temp: TObject);137 procedure BGRAReplace(var Destination: TBGRABitmap; Temp: TObject); 111 138 begin 112 Source.Free;113 Source:= Temp as TBGRABitmap;139 Destination.Free; 140 Destination := Temp as TBGRABitmap; 114 141 end; 115 142 116 143 initialization 117 144 118 bmp := TBGRABitmap.Create(0, 0); 145 //this variable is assigned to access appropriate functions 146 //depending on the platform 147 BGRABitmapFactory := TBGRABitmap; 119 148 120 149 finalization 121 150 122 bmp.Free;151 tempBmp.Free; 123 152 124 153 end. -
GraphicTest/BGRABitmap/bgrabitmaptypes.pas
r210 r317 30 30 31 31 uses 32 Classes, Graphics;32 Classes, Types, Graphics, FPImage, FPImgCanv, GraphType; 33 33 34 34 type 35 //pointer for direct pixel access 35 36 PBGRAPixel = ^TBGRAPixel; 36 37 38 //pixel structure 37 39 TBGRAPixel = packed record 38 40 blue, green, red, alpha: byte; 39 41 end; 40 42 43 //gamma expanded values 41 44 TExpandedPixel = packed record 42 45 red, green, blue, alpha: word; 43 46 end; 44 47 48 //pixel color defined in HSL colorspace 45 49 THSLAPixel = packed record 46 50 hue, saturation, lightness, alpha: word; 47 51 end; 48 52 49 TDrawMode = (dmSet, dmSetExceptTransparent, dmLinearBlend, dmDrawWithTransparency); 50 TFloodfillMode = (fmSet, fmDrawWithTransparency, fmProgressive); 51 TResampleMode = (rmSimpleStretch, rmFineResample); 53 //general purpose color variable with floating point values 54 TColorF = array[1..4] of single; 55 56 { These types are used as parameters } 57 58 TDrawMode = (dmSet, //replace pixels 59 dmSetExceptTransparent, //draw pixels with alpha=255 60 dmLinearBlend, //blend without gamma correction 61 dmDrawWithTransparency, //normal blending with gamma correction 62 dmXor); //bitwise xor for all channels 63 TChannel = (cRed, cGreen, cBlue, cAlpha); 64 TChannels = set of TChannel; 65 66 //floodfill option 67 TFloodfillMode = (fmSet, //set pixels 68 fmDrawWithTransparency, //draw fill color with transparency 69 fmProgressive); //draw fill color with transparency according to similarity with start color 70 71 TResampleMode = (rmSimpleStretch, //low quality resample 72 rmFineResample); //use resample filters 73 TResampleFilter = (rfLinear, //linear interpolation 74 rfHalfCosine, //mix of rfLinear and rfCosine 75 rfCosine, //cosine-like interpolation 76 rfBicubic, //simple bi-cubic filter (blur) 77 rfMitchell, //downsizing interpolation 78 rfSpline, //upsizing interpolation 79 rfBestQuality); //mix of rfMitchell and rfSpline 80 81 TBGRAFontQuality = (fqSystem, fqSystemClearType, fqFineAntialiasing, fqFineClearTypeRGB, fqFineClearTypeBGR); 82 52 83 TMedianOption = (moNone, moLowSmooth, moMediumSmooth, moHighSmooth); 84 TRadialBlurType = (rbNormal, rbDisk, rbCorona, rbPrecise, rbFast); 85 TSplineStyle = (ssInside, ssInsideWithEnds, ssCrossing, ssCrossingWithEnds, ssOutside, ssRoundOutside, ssVertexToSide); 86 87 //Advanced blending modes 88 //see : http://www.brighthub.com/multimedia/photography/articles/18301.aspx 89 //and : http://www.pegtop.net/delphi/articles/blendmodes/ 90 TBlendOperation = (boLinearBlend, boTransparent, //blending 91 boLighten, boScreen, boAdditive, boLinearAdd, boColorDodge, boNiceGlow, //lighting 92 boGlow, boReflect, boOverlay, boDarkOverlay, boDarken, boMultiply, boColorBurn, //masking 93 boDifference, boLinearDifference, boNegation, boLinearNegation, boXor); //negative 94 95 const 96 boGlowMask = boGlow; 97 boLinearMultiply = boMultiply; 98 99 const 100 BlendOperationStr : array[TBlendOperation] of string = 101 ('LinearBlend', 'Transparent', 102 'Lighten', 'Screen', 'Additive', 'LinearAdd', 'ColorDodge', 'NiceGlow', 103 'Glow', 'Reflect', 'Overlay', 'DarkOverlay', 'Darken', 'Multiply', 'ColorBurn', 104 'Difference', 'LinearDifference', 'Negation', 'LinearNegation', 'Xor'); 105 106 function StrToBlendOperation(str: string): TBlendOperation; 107 108 type 53 109 TGradientType = (gtLinear, gtReflected, gtDiamond, gtRadial); 54 55 110 const 56 111 GradientTypeStr : array[TGradientType] of string = 57 112 ('Linear','Reflected','Diamond','Radial'); 58 113 function StrToGradientType(str: string): TGradientType; 114 59 115 type 60 TRadialBlurType = (rbNormal, rbDisk, rbCorona, rbPrecise); 61 TChannel = (cRed, cGreen, cBlue, cAlpha); 62 TBlendOperation = (boLinearBlend, boTransparent, boMultiply, 63 boLinearMultiply, boAdditive, boLinearAdd, boColorBurn, boColorDodge, boReflect, 64 boGlow, boOverlay, boDifference, boLinearDifference, boNegation, 65 boLinearNegation, boLighten, boDarken, boScreen, boXor); 66 116 { A pen style is defined as a list of floating number. The first number is the length of the first dash, 117 the second number is the length of the first gap, the third number is the length of the second dash... 118 It must have an even number of values. } 119 TBGRAPenStyle = Array Of Single; 120 TRoundRectangleOption = (rrTopLeftSquare,rrTopRightSquare,rrBottomRightSquare,rrBottomLeftSquare, 121 rrTopLeftBevel,rrTopRightBevel,rrBottomRightBevel,rrBottomLeftBevel,rrDefault); 122 TRoundRectangleOptions = set of TRoundRectangleOption; 123 TPolygonOrder = (poNone, poFirstOnTop, poLastOnTop); //see TBGRAMultiShapeFiller in BGRAPolygon 124 125 function BGRAPenStyle(dash1, space1: single; dash2: single=0; space2: single = 0; dash3: single=0; space3: single = 0; dash4 : single = 0; space4 : single = 0): TBGRAPenStyle; 126 127 { Point, polygon and curve structures } 128 type 129 PPointF = ^TPointF; 67 130 TPointF = record 68 131 x, y: single; 69 132 end; 70 133 ArrayOfTPointF = array of TPointF; 71 134 TArcOption = (aoClosePath, aoPie, aoFillPath); 135 TArcOptions = set of TArcOption; 136 137 TCubicBezierCurve = record 138 p1,c1,c2,p2: TPointF; 139 end; 140 TQuadraticBezierCurve = record 141 p1,c,p2: TPointF; 142 end; 143 144 TPoint3D = record 145 x,y,z: single; 146 end; 147 148 function ConcatPointsF(const APolylines: array of ArrayOfTPointF): ArrayOfTPointF; 149 150 function Point3D(x,y,z: single): TPoint3D; 151 operator = (const v1,v2: TPoint3D): boolean; inline; 152 operator * (const v1,v2: TPoint3D): single; inline; 153 operator * (const v1: TPoint3D; const factor: single): TPoint3D; inline; 154 operator - (const v1,v2: TPoint3D): TPoint3D; inline; 155 operator - (const v: TPoint3D): TPoint3D; inline; 156 operator + (const v1,v2: TPoint3D): TPoint3D; inline; 157 procedure VectProduct3D(u,v: TPoint3D; out w: TPoint3D); 158 procedure Normalize3D(var v: TPoint3D); inline; 159 160 function BezierCurve(origin, control1, control2, destination: TPointF) : TCubicBezierCurve; overload; 161 function BezierCurve(origin, control, destination: TPointF) : TQuadraticBezierCurve; overload; 162 163 { Useful constants } 72 164 const 73 165 dmFastBlend = dmLinearBlend; 74 75 const 76 EmptySingle: single = -3.402823e38; 77 78 const 79 EmptyPointF: TPointF = (x: -3.402823e38; y: -3.402823e38); 80 81 const 166 EmptySingle: single = -3.402823e38; //used as a separator in floating point lists 167 EmptyPointF: TPointF = (x: -3.402823e38; y: -3.402823e38); //used as a separator in TPointF lists 82 168 BGRAPixelTransparent: TBGRAPixel = (blue: 0; green: 0; red: 0; alpha: 0); 83 84 const85 169 BGRAWhite: TBGRAPixel = (blue: 255; green: 255; red: 255; alpha: 255); 86 87 const88 170 BGRABlack: TBGRAPixel = (blue: 0; green: 0; red: 0; alpha: 255); 89 171 90 const 172 //Red colors 173 CSSIndianRed: TBGRAPixel = (blue: 92; green: 92; red: 205; alpha: 255); 174 CSSLightCoral: TBGRAPixel = (blue: 128; green: 128; red: 240; alpha: 255); 175 CSSSalmon: TBGRAPixel = (blue: 114; green: 128; red: 250; alpha: 255); 176 CSSDarkSalmon: TBGRAPixel = (blue: 122; green: 150; red: 233; alpha: 255); 177 CSSRed: TBGRAPixel = (blue: 0; green: 0; red: 255; alpha: 255); 178 CSSCrimson: TBGRAPixel = (blue: 60; green: 20; red: 220; alpha: 255); 179 CSSFireBrick: TBGRAPixel = (blue: 34; green: 34; red: 178; alpha: 255); 180 CSSDarkRed: TBGRAPixel = (blue: 0; green: 0; red: 139; alpha: 255); 181 182 //Pink colors 183 CSSPink: TBGRAPixel = (blue: 203; green: 192; red: 255; alpha: 255); 184 CSSLightPink: TBGRAPixel = (blue: 193; green: 182; red: 255; alpha: 255); 185 CSSHotPink: TBGRAPixel = (blue: 180; green: 105; red: 255; alpha: 255); 186 CSSDeepPink: TBGRAPixel = (blue: 147; green: 20; red: 255; alpha: 255); 187 CSSMediumVioletRed: TBGRAPixel = (blue: 133; green: 21; red: 199; alpha: 255); 188 CSSPaleVioletRed: TBGRAPixel = (blue: 147; green: 112; red: 219; alpha: 255); 189 190 //Orange colors 191 CSSLightSalmon: TBGRAPixel = (blue: 122; green: 160; red: 255; alpha: 255); 192 CSSCoral: TBGRAPixel = (blue: 80; green: 127; red: 255; alpha: 255); 193 CSSTomato: TBGRAPixel = (blue: 71; green: 99; red: 255; alpha: 255); 194 CSSOrangeRed: TBGRAPixel = (blue: 0; green: 69; red: 255; alpha: 255); 195 CSSDarkOrange: TBGRAPixel = (blue: 0; green: 140; red: 255; alpha: 255); 196 CSSOrange: TBGRAPixel = (blue: 0; green: 165; red: 255; alpha: 255); 197 198 //Yellow colors 199 CSSGold: TBGRAPixel = (blue: 0; green: 215; red: 255; alpha: 255); 200 CSSYellow: TBGRAPixel = (blue: 0; green: 255; red: 255; alpha: 255); 201 CSSLightYellow: TBGRAPixel = (blue: 224; green: 255; red: 255; alpha: 255); 202 CSSLemonChiffon: TBGRAPixel = (blue: 205; green: 250; red: 255; alpha: 255); 203 CSSLightGoldenrodYellow: TBGRAPixel = (blue: 210; green: 250; red: 250; alpha: 255); 204 CSSPapayaWhip: TBGRAPixel = (blue: 213; green: 239; red: 255; alpha: 255); 205 CSSMoccasin: TBGRAPixel = (blue: 181; green: 228; red: 255; alpha: 255); 206 CSSPeachPuff: TBGRAPixel = (blue: 185; green: 218; red: 255; alpha: 255); 207 CSSPaleGoldenrod: TBGRAPixel = (blue: 170; green: 232; red: 238; alpha: 255); 208 CSSKhaki: TBGRAPixel = (blue: 140; green: 230; red: 240; alpha: 255); 209 CSSDarkKhaki: TBGRAPixel = (blue: 107; green: 183; red: 189; alpha: 255); 210 211 //Purple colors 212 CSSLavender: TBGRAPixel = (blue: 250; green: 230; red: 230; alpha: 255); 213 CSSThistle: TBGRAPixel = (blue: 216; green: 191; red: 216; alpha: 255); 214 CSSPlum: TBGRAPixel = (blue: 221; green: 160; red: 221; alpha: 255); 215 CSSViolet: TBGRAPixel = (blue: 238; green: 130; red: 238; alpha: 255); 216 CSSOrchid: TBGRAPixel = (blue: 214; green: 112; red: 218; alpha: 255); 217 CSSFuchsia: TBGRAPixel = (blue: 255; green: 0; red: 255; alpha: 255); 218 CSSMagenta: TBGRAPixel = (blue: 255; green: 0; red: 255; alpha: 255); 219 CSSMediumOrchid: TBGRAPixel = (blue: 211; green: 85; red: 186; alpha: 255); 220 CSSMediumPurple: TBGRAPixel = (blue: 219; green: 112; red: 147; alpha: 255); 221 CSSBlueViolet: TBGRAPixel = (blue: 226; green: 43; red: 138; alpha: 255); 222 CSSDarkViolet: TBGRAPixel = (blue: 211; green: 0; red: 148; alpha: 255); 223 CSSDarkOrchid: TBGRAPixel = (blue: 204; green: 50; red: 153; alpha: 255); 224 CSSDarkMagenta: TBGRAPixel = (blue: 139; green: 0; red: 139; alpha: 255); 225 CSSPurple: TBGRAPixel = (blue: 128; green: 0; red: 128; alpha: 255); 226 CSSIndigo: TBGRAPixel = (blue: 130; green: 0; red: 75; alpha: 255); 227 CSSDarkSlateBlue: TBGRAPixel = (blue: 139; green: 61; red: 72; alpha: 255); 228 CSSSlateBlue: TBGRAPixel = (blue: 205; green: 90; red: 106; alpha: 255); 229 CSSMediumSlateBlue: TBGRAPixel = (blue: 238; green: 104; red: 123; alpha: 255); 230 231 //Green colors 232 CSSGreenYellow: TBGRAPixel = (blue: 47; green: 255; red: 173; alpha: 255); 233 CSSChartreuse: TBGRAPixel = (blue: 0; green: 255; red: 127; alpha: 255); 234 CSSLawnGreen: TBGRAPixel = (blue: 0; green: 252; red: 124; alpha: 255); 235 CSSLime: TBGRAPixel = (blue: 0; green: 255; red: 0; alpha: 255); 236 CSSLimeGreen: TBGRAPixel = (blue: 50; green: 205; red: 50; alpha: 255); 237 CSSPaleGreen: TBGRAPixel = (blue: 152; green: 251; red: 152; alpha: 255); 238 CSSLightGreen: TBGRAPixel = (blue: 144; green: 238; red: 144; alpha: 255); 239 CSSMediumSpringGreen: TBGRAPixel = (blue: 154; green: 250; red: 0; alpha: 255); 240 CSSSpringGreen: TBGRAPixel = (blue: 127; green: 255; red: 0; alpha: 255); 241 CSSMediumSeaGreen: TBGRAPixel = (blue: 113; green: 179; red: 60; alpha: 255); 242 CSSSeaGreen: TBGRAPixel = (blue: 87; green: 139; red: 46; alpha: 255); 243 CSSForestGreen: TBGRAPixel = (blue: 34; green: 139; red: 34; alpha: 255); 244 CSSGreen: TBGRAPixel = (blue: 0; green: 128; red: 0; alpha: 255); 245 CSSDarkGreen: TBGRAPixel = (blue: 0; green: 100; red: 0; alpha: 255); 246 CSSYellowGreen: TBGRAPixel = (blue: 50; green: 205; red: 154; alpha: 255); 247 CSSOliveDrab: TBGRAPixel = (blue: 35; green: 142; red: 107; alpha: 255); 248 CSSOlive: TBGRAPixel = (blue: 0; green: 128; red: 128; alpha: 255); 249 CSSDarkOliveGreen: TBGRAPixel = (blue: 47; green: 107; red: 85; alpha: 255); 250 CSSMediumAquamarine: TBGRAPixel = (blue: 170; green: 205; red: 102; alpha: 255); 251 CSSDarkSeaGreen: TBGRAPixel = (blue: 143; green: 188; red: 143; alpha: 255); 252 CSSLightSeaGreen: TBGRAPixel = (blue: 170; green: 178; red: 32; alpha: 255); 253 CSSDarkCyan: TBGRAPixel = (blue: 139; green: 139; red: 0; alpha: 255); 254 CSSTeal: TBGRAPixel = (blue: 128; green: 128; red: 0; alpha: 255); 255 256 //Blue/Cyan colors 257 CSSAqua: TBGRAPixel = (blue: 255; green: 255; red: 0; alpha: 255); 258 CSSCyan: TBGRAPixel = (blue: 255; green: 255; red: 0; alpha: 255); 259 CSSLightCyan: TBGRAPixel = (blue: 255; green: 255; red: 224; alpha: 255); 260 CSSPaleTurquoise: TBGRAPixel = (blue: 238; green: 238; red: 175; alpha: 255); 261 CSSAquamarine: TBGRAPixel = (blue: 212; green: 255; red: 127; alpha: 255); 262 CSSTurquoise: TBGRAPixel = (blue: 208; green: 224; red: 64; alpha: 255); 263 CSSMediumTurquoise: TBGRAPixel = (blue: 204; green: 209; red: 72; alpha: 255); 264 CSSDarkTurquoise: TBGRAPixel = (blue: 209; green: 206; red: 0; alpha: 255); 265 CSSCadetBlue: TBGRAPixel = (blue: 160; green: 158; red: 95; alpha: 255); 266 CSSSteelBlue: TBGRAPixel = (blue: 180; green: 130; red: 70; alpha: 255); 267 CSSLightSteelBlue: TBGRAPixel = (blue: 222; green: 196; red: 176; alpha: 255); 268 CSSPowderBlue: TBGRAPixel = (blue: 230; green: 224; red: 176; alpha: 255); 269 CSSLightBlue: TBGRAPixel = (blue: 230; green: 216; red: 173; alpha: 255); 270 CSSSkyBlue: TBGRAPixel = (blue: 235; green: 206; red: 135; alpha: 255); 271 CSSLightSkyBlue: TBGRAPixel = (blue: 250; green: 206; red: 135; alpha: 255); 272 CSSDeepSkyBlue: TBGRAPixel = (blue: 255; green: 191; red: 0; alpha: 255); 273 CSSDodgerBlue: TBGRAPixel = (blue: 255; green: 144; red: 30; alpha: 255); 274 CSSCornflowerBlue: TBGRAPixel = (blue: 237; green: 149; red: 100; alpha: 255); 275 CSSRoyalBlue: TBGRAPixel = (blue: 255; green: 105; red: 65; alpha: 255); 276 CSSBlue: TBGRAPixel = (blue: 255; green: 0; red: 0; alpha: 255); 277 CSSMediumBlue: TBGRAPixel = (blue: 205; green: 0; red: 0; alpha: 255); 278 CSSDarkBlue: TBGRAPixel = (blue: 139; green: 0; red: 0; alpha: 255); 279 CSSNavy: TBGRAPixel = (blue: 128; green: 0; red: 0; alpha: 255); 280 CSSMidnightBlue: TBGRAPixel = (blue: 112; green: 25; red: 25; alpha: 255); 281 282 //Brown colors 283 CSSCornsilk: TBGRAPixel = (blue: 220; green: 248; red: 255; alpha: 255); 284 CSSBlanchedAlmond: TBGRAPixel = (blue: 205; green: 235; red: 255; alpha: 255); 285 CSSBisque: TBGRAPixel = (blue: 196; green: 228; red: 255; alpha: 255); 286 CSSNavajoWhite: TBGRAPixel = (blue: 173; green: 222; red: 255; alpha: 255); 287 CSSWheat: TBGRAPixel = (blue: 179; green: 222; red: 245; alpha: 255); 288 CSSBurlyWood: TBGRAPixel = (blue: 135; green: 184; red: 222; alpha: 255); 289 CSSTan: TBGRAPixel = (blue: 140; green: 180; red: 210; alpha: 255); 290 CSSRosyBrown: TBGRAPixel = (blue: 143; green: 143; red: 188; alpha: 255); 291 CSSSandyBrown: TBGRAPixel = (blue: 96; green: 164; red: 244; alpha: 255); 292 CSSGoldenrod: TBGRAPixel = (blue: 32; green: 165; red: 218; alpha: 255); 293 CSSDarkGoldenrod: TBGRAPixel = (blue: 11; green: 134; red: 184; alpha: 255); 294 CSSPeru: TBGRAPixel = (blue: 63; green: 133; red: 205; alpha: 255); 295 CSSChocolate: TBGRAPixel = (blue: 30; green: 105; red: 210; alpha: 255); 296 CSSSaddleBrown: TBGRAPixel = (blue: 19; green: 69; red: 139; alpha: 255); 297 CSSSienna: TBGRAPixel = (blue: 45; green: 82; red: 160; alpha: 255); 298 CSSBrown: TBGRAPixel = (blue: 42; green: 42; red: 165; alpha: 255); 299 CSSMaroon: TBGRAPixel = (blue: 0; green: 0; red: 128; alpha: 255); 300 301 //White colors 302 CSSWhite: TBGRAPixel = (blue: 255; green: 255; red: 255; alpha: 255); 303 CSSSnow: TBGRAPixel = (blue: 250; green: 250; red: 255; alpha: 255); 304 CSSHoneydew: TBGRAPixel = (blue: 240; green: 255; red: 250; alpha: 255); 305 CSSMintCream: TBGRAPixel = (blue: 250; green: 255; red: 245; alpha: 255); 306 CSSAzure: TBGRAPixel = (blue: 255; green: 255; red: 240; alpha: 255); 307 CSSAliceBlue: TBGRAPixel = (blue: 255; green: 248; red: 240; alpha: 255); 308 CSSGhostWhite: TBGRAPixel = (blue: 255; green: 248; red: 248; alpha: 255); 309 CSSWhiteSmoke: TBGRAPixel = (blue: 245; green: 245; red: 245; alpha: 255); 310 CSSSeashell: TBGRAPixel = (blue: 255; green: 245; red: 238; alpha: 255); 311 CSSBeige: TBGRAPixel = (blue: 220; green: 245; red: 245; alpha: 255); 312 CSSOldLace: TBGRAPixel = (blue: 230; green: 245; red: 253; alpha: 255); 313 CSSFloralWhite: TBGRAPixel = (blue: 240; green: 250; red: 255; alpha: 255); 314 CSSIvory: TBGRAPixel = (blue: 240; green: 255; red: 255; alpha: 255); 315 CSSAntiqueWhite: TBGRAPixel = (blue: 215; green: 235; red: 250; alpha: 255); 316 CSSLinen: TBGRAPixel = (blue: 230; green: 240; red: 250; alpha: 255); 317 CSSLavenderBlush: TBGRAPixel = (blue: 245; green: 240; red: 255; alpha: 255); 318 CSSMistyRose: TBGRAPixel = (blue: 255; green: 228; red: 255; alpha: 255); 319 320 //Gray colors 321 CSSGainsboro: TBGRAPixel = (blue: 220; green: 220; red: 220; alpha: 255); 322 CSSLightGray: TBGRAPixel = (blue: 211; green: 211; red: 211; alpha: 255); 323 CSSSilver: TBGRAPixel = (blue: 192; green: 192; red: 192; alpha: 255); 324 CSSDarkGray: TBGRAPixel = (blue: 169; green: 169; red: 169; alpha: 255); 325 CSSGray: TBGRAPixel = (blue: 128; green: 128; red: 128; alpha: 255); 326 CSSDimGray: TBGRAPixel = (blue: 105; green: 105; red: 105; alpha: 255); 327 CSSLightSlateGray: TBGRAPixel = (blue: 153; green: 136; red: 119; alpha: 255); 328 CSSSlateGray: TBGRAPixel = (blue: 144; green: 128; red: 112; alpha: 255); 329 CSSDarkSlateGray: TBGRAPixel = (blue: 79; green: 79; red: 47; alpha: 255); 330 CSSBlack: TBGRAPixel = (blue: 0; green: 0; red: 0; alpha: 255); 331 332 { This color is needed for drawing black shapes on the standard TCanvas, because 333 when drawing with pure black, there is no way to know if something has been 334 drawn or if it is transparent } 91 335 clBlackOpaque = TColor($010000); 92 336 337 type 338 TBGRAColorDefinition = record 339 Name: string; 340 Color: TBGRAPixel; 341 end; 342 343 { TBGRAColorList } 344 345 TBGRAColorList = class 346 protected 347 FFinished: boolean; 348 FNbColors: integer; 349 FColors: array of TBGRAColorDefinition; 350 function GetByIndex(Index: integer): TBGRAPixel; 351 function GetByName(Name: string): TBGRAPixel; 352 function GetName(Index: integer): string; 353 public 354 constructor Create; 355 procedure Add(Name: string; Color: TBGRAPixel); 356 procedure Finished; 357 function IndexOf(Name: string): integer; 358 359 property ByName[Name: string]: TBGRAPixel read GetByName; 360 property ByIndex[Index: integer]: TBGRAPixel read GetByIndex; default; 361 property Name[Index: integer]: string read GetName; 362 property Count: integer read FNbColors; 363 end; 364 365 var 366 CSSColors: TBGRAColorList; 367 93 368 function isEmptyPointF(pt: TPointF): boolean; 94 369 370 type 371 TFontPixelMetric = record 372 Defined: boolean; 373 Baseline, xLine, CapLine, DescentLine, Lineheight: integer; 374 end; 375 376 { A scanner is like an image, but its content has no limit and can be calculated on the fly. 377 It must not implement reference counting. } 378 IBGRAScanner = interface 379 procedure ScanMoveTo(X,Y: Integer); 380 function ScanNextPixel: TBGRAPixel; 381 function ScanAt(X,Y: Single): TBGRAPixel; 382 procedure ScanPutPixels(pdest: PBGRAPixel; count: integer; mode: TDrawMode); 383 function IsScanPutPixelsDefined: boolean; 384 end; 385 386 TScanAtFunction = function (X,Y: Single): TBGRAPixel of object; 387 TScanNextPixelFunction = function: TBGRAPixel of object; 388 TBGRACustomGradient = class; 389 390 { TBGRACustomBitmap } 391 392 TBGRACustomBitmap = class(TFPCustomImage,IBGRAScanner) // a bitmap can be used as a scanner 393 private 394 function GetFontAntialias: Boolean; 395 procedure SetFontAntialias(const AValue: Boolean); 396 protected 397 { accessors to properies } 398 function GetHeight: integer; virtual; abstract; 399 function GetWidth: integer; virtual; abstract; 400 function GetDataPtr: PBGRAPixel; virtual; abstract; 401 function GetNbPixels: integer; virtual; abstract; 402 function CheckEmpty: boolean; virtual; abstract; 403 function GetHasTransparentPixels: boolean; virtual; abstract; 404 function GetAverageColor: TColor; virtual; abstract; 405 function GetAveragePixel: TBGRAPixel; virtual; abstract; 406 procedure SetCanvasOpacity(AValue: byte); virtual; abstract; 407 function GetScanLine(y: integer): PBGRAPixel; virtual; abstract; 408 function GetRefCount: integer; virtual; abstract; 409 function GetBitmap: TBitmap; virtual; abstract; 410 function GetLineOrder: TRawImageLineOrder; virtual; abstract; 411 function GetCanvasFP: TFPImageCanvas; virtual; abstract; 412 function GetCanvasDrawModeFP: TDrawMode; virtual; abstract; 413 procedure SetCanvasDrawModeFP(const AValue: TDrawMode); virtual; abstract; 414 function GetCanvas: TCanvas; virtual; abstract; 415 function GetCanvasOpacity: byte; virtual; abstract; 416 function GetCanvasAlphaCorrection: boolean; virtual; abstract; 417 procedure SetCanvasAlphaCorrection(const AValue: boolean); virtual; abstract; 418 function GetFontHeight: integer; virtual; abstract; 419 procedure SetFontHeight(AHeight: integer); virtual; abstract; 420 function GetFontFullHeight: integer; virtual; abstract; 421 procedure SetFontFullHeight(AHeight: integer); virtual; abstract; 422 function GetPenStyle: TPenStyle; virtual; abstract; 423 procedure SetPenStyle(const AValue: TPenStyle); virtual; abstract; 424 function GetCustomPenStyle: TBGRAPenStyle; virtual; abstract; 425 procedure SetCustomPenStyle(const AValue: TBGRAPenStyle); virtual; abstract; 426 function GetClipRect: TRect; virtual; abstract; 427 procedure SetClipRect(const AValue: TRect); virtual; abstract; 428 function GetFontPixelMetric: TFontPixelMetric; virtual; abstract; 429 function LoadAsBmp32(Str: TStream): boolean; virtual; abstract; 430 431 public 432 Caption: string; //user defined caption 433 434 //font style 435 FontName: string; 436 FontStyle: TFontStyles; 437 FontQuality : TBGRAFontQuality; 438 FontOrientation: integer; 439 440 //line style 441 LineCap: TPenEndCap; 442 JoinStyle: TPenJoinStyle; 443 JoinMiterLimit: single; 444 445 FillMode: TFillMode; //winding or alternate 446 447 { The resample filter is used when resizing the bitmap, and 448 scan interpolation filter is used when the bitmap is used 449 as a scanner (IBGRAScanner) } 450 ResampleFilter, 451 ScanInterpolationFilter: TResampleFilter; 452 ScanOffset: TPoint; 453 454 constructor Create; virtual; abstract; overload; 455 constructor Create(ABitmap: TBitmap); virtual; abstract; overload; 456 constructor Create(AWidth, AHeight: integer; Color: TColor); virtual; abstract; overload; 457 constructor Create(AWidth, AHeight: integer; Color: TBGRAPixel); virtual; abstract; overload; 458 constructor Create(AFilename: string); virtual; abstract; overload; 459 constructor Create(AStream: TStream); virtual; abstract; overload; 460 461 function NewBitmap(AWidth, AHeight: integer): TBGRACustomBitmap; virtual; abstract; overload; 462 function NewBitmap(AWidth, AHeight: integer; Color: TBGRAPixel): TBGRACustomBitmap; virtual; abstract; overload; 463 function NewBitmap(Filename: string): TBGRACustomBitmap; virtual; abstract; overload; 464 465 procedure LoadFromFile(const filename: string); virtual; 466 procedure LoadFromStream(Str: TStream); virtual; 467 procedure LoadFromStream(Str: TStream; Handler: TFPCustomImageReader); virtual; 468 procedure SaveToFile(const filename: string); virtual; 469 procedure SaveToFile(const filename: string; Handler:TFPCustomImageWriter); virtual; 470 procedure SaveToStreamAsPng(Str: TStream); virtual; abstract; 471 procedure Assign(ABitmap: TBitmap); virtual; abstract; overload; 472 procedure Assign(MemBitmap: TBGRACustomBitmap); virtual; abstract; overload; 473 procedure Serialize(AStream: TStream); virtual; abstract; 474 procedure Deserialize(AStream: TStream); virtual; abstract; 475 476 {Pixel functions} 477 procedure SetPixel(x, y: integer; c: TColor); virtual; abstract; overload; 478 procedure XorPixel(x, y: integer; c: TBGRAPixel); virtual; abstract; overload; 479 procedure SetPixel(x, y: integer; c: TBGRAPixel); virtual; abstract; overload; 480 procedure DrawPixel(x, y: integer; c: TBGRAPixel); virtual; abstract; overload; 481 procedure DrawPixel(x, y: integer; ec: TExpandedPixel); virtual; abstract; overload; 482 procedure FastBlendPixel(x, y: integer; c: TBGRAPixel); virtual; abstract; 483 procedure ErasePixel(x, y: integer; alpha: byte); virtual; abstract; 484 procedure AlphaPixel(x, y: integer; alpha: byte); virtual; abstract; 485 function GetPixel(x, y: integer): TBGRAPixel; virtual; abstract; 486 function GetPixel(x, y: single; AResampleFilter: TResampleFilter = rfLinear): TBGRAPixel; virtual; abstract; overload; 487 function GetPixelCycle(x, y: integer): TBGRAPixel; virtual; 488 function GetPixelCycle(x, y: single; AResampleFilter: TResampleFilter = rfLinear): TBGRAPixel; virtual; abstract; overload; 489 function GetPixelCycle(x, y: single; AResampleFilter: TResampleFilter; repeatX: boolean; repeatY: boolean): TBGRAPixel; virtual; abstract; overload; 490 491 {Line primitives} 492 procedure SetHorizLine(x, y, x2: integer; c: TBGRAPixel); virtual; abstract; 493 procedure XorHorizLine(x, y, x2: integer; c: TBGRAPixel); virtual; abstract; 494 procedure DrawHorizLine(x, y, x2: integer; c: TBGRAPixel); virtual; abstract; overload; 495 procedure DrawHorizLine(x, y, x2: integer; ec: TExpandedPixel); virtual; abstract; overload; 496 procedure DrawHorizLine(x, y, x2: integer; texture: IBGRAScanner); virtual; abstract; overload; 497 procedure FastBlendHorizLine(x, y, x2: integer; c: TBGRAPixel); virtual; abstract; 498 procedure AlphaHorizLine(x, y, x2: integer; alpha: byte); virtual; abstract; 499 procedure SetVertLine(x, y, y2: integer; c: TBGRAPixel); virtual; abstract; 500 procedure XorVertLine(x, y, y2: integer; c: TBGRAPixel); virtual; abstract; 501 procedure DrawVertLine(x, y, y2: integer; c: TBGRAPixel); virtual; abstract; 502 procedure AlphaVertLine(x, y, y2: integer; alpha: byte); virtual; abstract; 503 procedure FastBlendVertLine(x, y, y2: integer; c: TBGRAPixel); virtual; abstract; 504 procedure DrawHorizLineDiff(x, y, x2: integer; c, compare: TBGRAPixel; 505 maxDiff: byte); virtual; abstract; 506 507 {Shapes} 508 procedure DrawLine(x1, y1, x2, y2: integer; c: TBGRAPixel; DrawLastPixel: boolean); virtual; abstract; 509 procedure DrawLineAntialias(x1, y1, x2, y2: integer; c: TBGRAPixel; DrawLastPixel: boolean); virtual; abstract; overload; 510 procedure DrawLineAntialias(x1, y1, x2, y2: integer; c1, c2: TBGRAPixel; dashLen: integer; DrawLastPixel: boolean); virtual; abstract; overload; 511 procedure DrawLineAntialias(x1, y1, x2, y2: single; c: TBGRAPixel; w: single); virtual; abstract; overload; 512 procedure DrawLineAntialias(x1, y1, x2, y2: single; texture: IBGRAScanner; w: single); virtual; abstract; overload; 513 procedure DrawLineAntialias(x1, y1, x2, y2: single; c: TBGRAPixel; w: single; Closed: boolean); virtual; abstract; overload; 514 procedure DrawLineAntialias(x1, y1, x2, y2: single; texture: IBGRAScanner; w: single; Closed: boolean); virtual; abstract; overload; 515 516 procedure DrawPolyLineAntialias(const points: array of TPoint; c: TBGRAPixel; DrawLastPixel: boolean); virtual; overload; 517 procedure DrawPolyLineAntialias(const points: array of TPoint; c1, c2: TBGRAPixel; dashLen: integer; DrawLastPixel: boolean); virtual; overload; 518 procedure DrawPolyLineAntialias(const points: array of TPointF; c: TBGRAPixel; w: single); virtual; abstract; overload; 519 procedure DrawPolyLineAntialias(const points: array of TPointF; texture: IBGRAScanner; w: single); virtual; abstract; overload; 520 procedure DrawPolyLineAntialias(const points: array of TPointF; c: TBGRAPixel; w: single; Closed: boolean); virtual; abstract; overload; 521 procedure DrawPolygonAntialias(const points: array of TPointF; c: TBGRAPixel; w: single); virtual; abstract; overload; 522 procedure DrawPolygonAntialias(const points: array of TPointF; texture: IBGRAScanner; w: single); virtual; abstract; overload; 523 procedure EraseLineAntialias(x1, y1, x2, y2: single; alpha: byte; w: single); virtual; abstract; overload; 524 procedure EraseLineAntialias(x1, y1, x2, y2: single; alpha: byte; w: single; Closed: boolean); virtual; abstract; overload; 525 procedure ErasePolyLineAntialias(const points: array of TPointF; alpha: byte; w: single); virtual; abstract; overload; 526 527 procedure FillTriangleLinearColor(pt1,pt2,pt3: TPointF; c1,c2,c3: TBGRAPixel); virtual; abstract; overload; 528 procedure FillTriangleLinearColorAntialias(pt1,pt2,pt3: TPointF; c1,c2,c3: TBGRAPixel); virtual; abstract; overload; 529 procedure FillTriangleLinearMapping(pt1,pt2,pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF; TextureInterpolation: Boolean= True); virtual; abstract; overload; 530 procedure FillTriangleLinearMappingLightness(pt1,pt2,pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF; light1,light2,light3: word; TextureInterpolation: Boolean= True); virtual; abstract; overload; 531 procedure FillTriangleLinearMappingAntialias(pt1,pt2,pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF); virtual; abstract; overload; 532 533 procedure FillQuadLinearColor(pt1,pt2,pt3,pt4: TPointF; c1,c2,c3,c4: TBGRAPixel); virtual; abstract; overload; 534 procedure FillQuadLinearColorAntialias(pt1,pt2,pt3,pt4: TPointF; c1,c2,c3,c4: TBGRAPixel); virtual; abstract; overload; 535 procedure FillQuadLinearMapping(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF; TextureInterpolation: Boolean= True); virtual; abstract; overload; 536 procedure FillQuadLinearMappingLightness(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF; light1,light2,light3,light4: word; TextureInterpolation: Boolean= True); virtual; abstract; overload; 537 procedure FillQuadLinearMappingAntialias(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF); virtual; abstract; overload; 538 procedure FillQuadPerspectiveMapping(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF); virtual; abstract; overload; 539 procedure FillQuadPerspectiveMappingAntialias(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF); virtual; abstract; overload; 540 541 procedure FillPolyLinearColor(const points: array of TPointF; AColors: array of TBGRAPixel); virtual; abstract; overload; 542 procedure FillPolyLinearMapping(const points: array of TPointF; texture: IBGRAScanner; texCoords: array of TPointF; TextureInterpolation: Boolean); virtual; abstract; overload; 543 procedure FillPolyLinearMappingLightness(const points: array of TPointF; texture: IBGRAScanner; texCoords: array of TPointF; lightnesses: array of word; TextureInterpolation: Boolean); virtual; abstract; overload; 544 procedure FillPolyPerspectiveMapping(const points: array of TPointF; const pointsZ: array of single; texture: IBGRAScanner; texCoords: array of TPointF; TextureInterpolation: Boolean); virtual; abstract; overload; 545 procedure FillPolyPerspectiveMappingLightness(const points: array of TPointF; const pointsZ: array of single; texture: IBGRAScanner; texCoords: array of TPointF; lightnesses: array of word; TextureInterpolation: Boolean); virtual; abstract; overload; 546 547 procedure FillPoly(const points: array of TPointF; c: TBGRAPixel; drawmode: TDrawMode); virtual; abstract; 548 procedure FillPoly(const points: array of TPointF; texture: IBGRAScanner; drawmode: TDrawMode); virtual; abstract; 549 procedure FillPolyAntialias(const points: array of TPointF; c: TBGRAPixel); virtual; abstract; 550 procedure FillPolyAntialias(const points: array of TPointF; texture: IBGRAScanner); virtual; abstract; 551 procedure ErasePoly(const points: array of TPointF; alpha: byte); virtual; abstract; 552 procedure ErasePolyAntialias(const points: array of TPointF; alpha: byte); virtual; abstract; 553 554 procedure EllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel; w: single); virtual; abstract; 555 procedure EllipseAntialias(x, y, rx, ry: single; texture: IBGRAScanner; w: single); virtual; abstract; 556 procedure EllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel; w: single; back: TBGRAPixel); virtual; abstract; 557 procedure FillEllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel); virtual; abstract; 558 procedure FillEllipseAntialias(x, y, rx, ry: single; texture: IBGRAScanner); virtual; abstract; 559 procedure FillEllipseLinearColorAntialias(x, y, rx, ry: single; outercolor, innercolor: TBGRAPixel); virtual; abstract; 560 procedure EraseEllipseAntialias(x, y, rx, ry: single; alpha: byte); virtual; abstract; 561 562 procedure Rectangle(x, y, x2, y2: integer; c: TBGRAPixel; mode: TDrawMode); virtual; abstract; overload; 563 procedure Rectangle(x, y, x2, y2: integer; BorderColor, FillColor: TBGRAPixel; mode: TDrawMode); virtual; abstract; overload; 564 procedure Rectangle(x, y, x2, y2: integer; c: TColor); virtual; overload; 565 procedure Rectangle(r: TRect; c: TBGRAPixel; mode: TDrawMode); virtual; overload; 566 procedure Rectangle(r: TRect; BorderColor, FillColor: TBGRAPixel; mode: TDrawMode); virtual;overload; 567 procedure Rectangle(r: TRect; c: TColor); virtual; overload; 568 procedure RectangleAntialias(x, y, x2, y2: single; c: TBGRAPixel; w: single); virtual; overload; 569 procedure RectangleAntialias(x, y, x2, y2: single; c: TBGRAPixel; w: single; back: TBGRAPixel); virtual; abstract; overload; 570 procedure RectangleAntialias(x, y, x2, y2: single; texture: IBGRAScanner; w: single); virtual; abstract; overload; 571 572 procedure RoundRect(X1, Y1, X2, Y2: integer; DX, DY: integer; BorderColor, FillColor: TBGRAPixel); virtual; abstract; 573 procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; c: TBGRAPixel; w: single; options: TRoundRectangleOptions = []); virtual; abstract; 574 procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; pencolor: TBGRAPixel; w: single; fillcolor: TBGRAPixel; options: TRoundRectangleOptions = []); virtual; abstract; 575 procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; penTexture: IBGRAScanner; w: single; fillTexture: IBGRAScanner; options: TRoundRectangleOptions = []); virtual; abstract; 576 procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; texture: IBGRAScanner; w: single; options: TRoundRectangleOptions = []); virtual; abstract; 577 procedure FillRoundRectAntialias(x,y,x2,y2,rx,ry: single; c: TBGRAPixel; options: TRoundRectangleOptions = []); virtual; abstract; 578 procedure FillRoundRectAntialias(x,y,x2,y2,rx,ry: single; texture: IBGRAScanner; options: TRoundRectangleOptions = []); virtual; abstract; 579 procedure EraseRoundRectAntialias(x,y,x2,y2,rx,ry: single; alpha: byte; options: TRoundRectangleOptions = []); virtual; abstract; 580 581 procedure FillRect(r: TRect; c: TColor); virtual; overload; 582 procedure FillRect(r: TRect; c: TBGRAPixel; mode: TDrawMode); virtual; overload; 583 procedure FillRect(x, y, x2, y2: integer; c: TColor); virtual; overload; 584 procedure FillRect(x, y, x2, y2: integer; c: TBGRAPixel; mode: TDrawMode); virtual; abstract; overload; 585 procedure FillRect(x, y, x2, y2: integer; texture: IBGRAScanner; mode: TDrawMode); virtual; abstract; 586 procedure FillRectAntialias(x, y, x2, y2: single; c: TBGRAPixel); virtual; abstract; 587 procedure FillRectAntialias(x, y, x2, y2: single; texture: IBGRAScanner); virtual; abstract; 588 procedure EraseRectAntialias(x, y, x2, y2: single; alpha: byte); virtual; abstract; 589 procedure AlphaFillRect(x, y, x2, y2: integer; alpha: byte); virtual; abstract; 590 591 procedure TextOut(x, y: integer; s: string; c: TBGRAPixel; align: TAlignment); virtual; abstract; overload; 592 procedure TextOut(x, y: integer; s: string; texture: IBGRAScanner; align: TAlignment); virtual; abstract; overload; 593 procedure TextOutAngle(x, y, orientation: integer; s: string; c: TBGRAPixel; align: TAlignment); virtual; abstract; 594 procedure TextOutAngle(x, y, orientation: integer; s: string; texture: IBGRAScanner; align: TAlignment); virtual; abstract; 595 procedure TextOut(x, y: integer; s: string; c: TBGRAPixel); virtual; overload; 596 procedure TextOut(x, y: integer; s: string; c: TColor); virtual; overload; 597 procedure TextOut(x, y: integer; s: string; texture: IBGRAScanner); virtual; overload; 598 procedure TextRect(ARect: TRect; x, y: integer; s: string; style: TTextStyle; c: TBGRAPixel); virtual; abstract; overload; 599 procedure TextRect(ARect: TRect; x, y: integer; s: string; style: TTextStyle; texture: IBGRAScanner); virtual; abstract; overload; 600 procedure TextRect(ARect: TRect; s: string; halign: TAlignment; valign: TTextLayout; c: TBGRAPixel); virtual; overload; 601 procedure TextRect(ARect: TRect; s: string; halign: TAlignment; valign: TTextLayout; texture: IBGRAScanner); virtual; overload; 602 function TextSize(s: string): TSize; virtual; abstract; 603 604 {Spline} 605 function ComputeClosedSpline(const APoints: array of TPointF; AStyle: TSplineStyle): ArrayOfTPointF; virtual; abstract; 606 function ComputeOpenedSpline(const APoints: array of TPointF; AStyle: TSplineStyle): ArrayOfTPointF; virtual; abstract; 607 function ComputeBezierCurve(const curve: TCubicBezierCurve): ArrayOfTPointF; virtual; abstract; 608 function ComputeBezierCurve(const curve: TQuadraticBezierCurve): ArrayOfTPointF; virtual; abstract; 609 function ComputeBezierSpline(const spline: array of TCubicBezierCurve): ArrayOfTPointF; virtual; abstract; 610 function ComputeBezierSpline(const spline: array of TQuadraticBezierCurve): ArrayOfTPointF; virtual; abstract; 611 612 function ComputeWidePolyline(const points: array of TPointF; w: single): ArrayOfTPointF; virtual; abstract; 613 function ComputeWidePolyline(const points: array of TPointF; w: single; Closed: boolean): ArrayOfTPointF; virtual; abstract; 614 function ComputeWidePolygon(const points: array of TPointF; w: single): ArrayOfTPointF; virtual; abstract; 615 616 function ComputeEllipse(x,y,rx,ry: single): ArrayOfTPointF; virtual; abstract; 617 function ComputeEllipse(x,y,rx,ry,w: single): ArrayOfTPointF; virtual; abstract; 618 function ComputeArc65536(x,y,rx,ry: single; start65536,end65536: word): ArrayOfTPointF; virtual; abstract; 619 function ComputeArcRad(x,y,rx,ry: single; startRad,endRad: single): ArrayOfTPointF; virtual; abstract; 620 function ComputeRoundRect(x1,y1,x2,y2,rx,ry: single): ArrayOfTPointF; virtual; abstract; 621 function ComputeRoundRect(x1,y1,x2,y2,rx,ry: single; options: TRoundRectangleOptions): ArrayOfTPointF; virtual; abstract; 622 function ComputePie65536(x,y,rx,ry: single; start65536,end65536: word): ArrayOfTPointF; virtual; abstract; 623 function ComputePieRad(x,y,rx,ry: single; startRad,endRad: single): ArrayOfTPointF; virtual; abstract; 624 625 {Filling} 626 procedure FillTransparent; virtual; 627 procedure NoClip; virtual; abstract; 628 procedure ApplyGlobalOpacity(alpha: byte); virtual; abstract; 629 procedure Fill(c: TColor); virtual; overload; 630 procedure Fill(c: TBGRAPixel); virtual; overload; 631 procedure Fill(texture: IBGRAScanner; mode: TDrawMode); virtual; abstract; overload; 632 procedure Fill(texture: IBGRAScanner); virtual; abstract; overload; 633 procedure Fill(c: TBGRAPixel; start, Count: integer); virtual; abstract; overload; 634 procedure DrawPixels(c: TBGRAPixel; start, Count: integer); virtual; abstract; 635 procedure AlphaFill(alpha: byte); virtual; overload; 636 procedure AlphaFill(alpha: byte; start, Count: integer); virtual; abstract; overload; 637 procedure FillMask(x,y: integer; AMask: TBGRACustomBitmap; color: TBGRAPixel); virtual; abstract; overload; 638 procedure FillMask(x,y: integer; AMask: TBGRACustomBitmap; texture: IBGRAScanner); virtual; abstract; overload; 639 procedure FillClearTypeMask(x,y: integer; xThird: integer; AMask: TBGRACustomBitmap; color: TBGRAPixel; ARGBOrder: boolean = true); virtual; abstract; overload; 640 procedure FillClearTypeMask(x,y: integer; xThird: integer; AMask: TBGRACustomBitmap; texture: IBGRAScanner; ARGBOrder: boolean = true); virtual; abstract; overload; 641 procedure ReplaceColor(before, after: TColor); virtual; abstract; overload; 642 procedure ReplaceColor(before, after: TBGRAPixel); virtual; abstract; overload; 643 procedure ReplaceTransparent(after: TBGRAPixel); virtual; abstract; overload; 644 procedure FloodFill(X, Y: integer; Color: TBGRAPixel; 645 mode: TFloodfillMode; Tolerance: byte = 0); virtual; 646 procedure ParallelFloodFill(X, Y: integer; Dest: TBGRACustomBitmap; Color: TBGRAPixel; 647 mode: TFloodfillMode; Tolerance: byte = 0); virtual; abstract; 648 procedure GradientFill(x, y, x2, y2: integer; c1, c2: TBGRAPixel; 649 gtype: TGradientType; o1, o2: TPointF; mode: TDrawMode; 650 gammaColorCorrection: boolean = True; Sinus: Boolean=False); virtual; abstract; 651 procedure GradientFill(x, y, x2, y2: integer; gradient: TBGRACustomGradient; 652 gtype: TGradientType; o1, o2: TPointF; mode: TDrawMode; 653 Sinus: Boolean=False); virtual; abstract; 654 function CreateBrushTexture(ABrushStyle: TBrushStyle; APatternColor, ABackgroundColor: TBGRAPixel; 655 AWidth: integer = 8; AHeight: integer = 8; APenWidth: single = 1): TBGRACustomBitmap; virtual; abstract; 656 657 {Canvas drawing functions} 658 procedure DataDrawTransparent(ACanvas: TCanvas; Rect: TRect; 659 AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); virtual; abstract; 660 procedure DataDrawOpaque(ACanvas: TCanvas; Rect: TRect; AData: Pointer; 661 ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); virtual; abstract; 662 procedure GetImageFromCanvas(CanvasSource: TCanvas; x, y: integer); virtual; abstract; 663 procedure Draw(ACanvas: TCanvas; x, y: integer; Opaque: boolean = True); virtual; abstract; 664 procedure Draw(ACanvas: TCanvas; Rect: TRect; Opaque: boolean = True); virtual; abstract; 665 procedure DrawPart(ARect: TRect; Canvas: TCanvas; x, y: integer; Opaque: boolean); virtual; 666 function GetPart(ARect: TRect): TBGRACustomBitmap; virtual; abstract; 667 function GetPtrBitmap(Top,Bottom: Integer): TBGRACustomBitmap; virtual; abstract; 668 procedure InvalidateBitmap; virtual; abstract; //call if you modify with Scanline 669 procedure LoadFromBitmapIfNeeded; virtual; abstract; //call to ensure that bitmap data is up to date 670 671 {BGRA bitmap functions} 672 procedure PutImage(x, y: integer; Source: TBGRACustomBitmap; mode: TDrawMode; AOpacity: byte = 255); virtual; abstract; 673 procedure PutImageSubpixel(x, y: single; Source: TBGRACustomBitmap); 674 procedure PutImageAffine(Origin,HAxis,VAxis: TPointF; Source: TBGRACustomBitmap; AOpacity: Byte=255); virtual; abstract; 675 procedure PutImageAngle(x,y: single; Source: TBGRACustomBitmap; angle: single; imageCenterX: single = 0; imageCenterY: single = 0; AOpacity: Byte=255); virtual; abstract; 676 procedure BlendImage(x, y: integer; Source: TBGRACustomBitmap; 677 operation: TBlendOperation); virtual; abstract; 678 function Duplicate(DuplicateProperties: Boolean = False): TBGRACustomBitmap; virtual; abstract; 679 function Equals(comp: TBGRACustomBitmap): boolean; virtual; abstract; 680 function Equals(comp: TBGRAPixel): boolean; virtual; abstract; 681 function Resample(newWidth, newHeight: integer; 682 mode: TResampleMode = rmFineResample): TBGRACustomBitmap; virtual; abstract; 683 procedure VerticalFlip; virtual; abstract; 684 procedure HorizontalFlip; virtual; abstract; 685 function RotateCW: TBGRACustomBitmap; virtual; abstract; 686 function RotateCCW: TBGRACustomBitmap; virtual; abstract; 687 procedure Negative; virtual; abstract; 688 procedure LinearNegative; virtual; abstract; 689 procedure SwapRedBlue; virtual; abstract; 690 procedure GrayscaleToAlpha; virtual; abstract; 691 procedure AlphaToGrayscale; virtual; abstract; 692 procedure ApplyMask(mask: TBGRACustomBitmap); virtual; abstract; 693 function GetImageBounds(Channel: TChannel = cAlpha): TRect; virtual; abstract; 694 function GetImageBounds(Channels: TChannels): TRect; virtual; abstract; 695 function MakeBitmapCopy(BackgroundColor: TColor): TBitmap; virtual; abstract; 696 697 {Filters} 698 function FilterSmartZoom3(Option: TMedianOption): TBGRACustomBitmap; virtual; abstract; 699 function FilterMedian(Option: TMedianOption): TBGRACustomBitmap; virtual; abstract; 700 function FilterSmooth: TBGRACustomBitmap; virtual; abstract; 701 function FilterSharpen: TBGRACustomBitmap; virtual; abstract; 702 function FilterContour: TBGRACustomBitmap; virtual; abstract; 703 function FilterBlurRadial(radius: integer; 704 blurType: TRadialBlurType): TBGRACustomBitmap; virtual; abstract; 705 function FilterPixelate(pixelSize: integer; useResample: boolean; filter: TResampleFilter = rfLinear): TBGRACustomBitmap; virtual; abstract; 706 function FilterBlurMotion(distance: integer; angle: single; 707 oriented: boolean): TBGRACustomBitmap; virtual; abstract; 708 function FilterCustomBlur(mask: TBGRACustomBitmap): TBGRACustomBitmap; virtual; abstract; 709 function FilterEmboss(angle: single): TBGRACustomBitmap; virtual; abstract; 710 function FilterEmbossHighlight(FillSelection: boolean): TBGRACustomBitmap; virtual; abstract; 711 function FilterGrayscale: TBGRACustomBitmap; virtual; abstract; 712 function FilterNormalize(eachChannel: boolean = True): TBGRACustomBitmap; virtual; abstract; 713 function FilterRotate(origin: TPointF; angle: single): TBGRACustomBitmap; virtual; abstract; 714 function FilterSphere: TBGRACustomBitmap; virtual; abstract; 715 function FilterTwirl(ACenter: TPoint; ARadius: Single; ATurn: Single=1; AExponent: Single=3): TBGRACustomBitmap; virtual; abstract; 716 function FilterCylinder: TBGRACustomBitmap; virtual; abstract; 717 function FilterPlane: TBGRACustomBitmap; virtual; abstract; 718 719 property Data: PBGRAPixel Read GetDataPtr; 720 property Width: integer Read GetWidth; 721 property Height: integer Read GetHeight; 722 property NbPixels: integer Read GetNbPixels; 723 property Empty: boolean Read CheckEmpty; 724 725 property ScanLine[y: integer]: PBGRAPixel Read GetScanLine; 726 property RefCount: integer Read GetRefCount; 727 property Bitmap: TBitmap Read GetBitmap; //don't forget to call InvalidateBitmap before if you changed something with Scanline 728 property HasTransparentPixels: boolean Read GetHasTransparentPixels; 729 property AverageColor: TColor Read GetAverageColor; 730 property AveragePixel: TBGRAPixel Read GetAveragePixel; 731 property LineOrder: TRawImageLineOrder Read GetLineOrder; 732 property CanvasFP: TFPImageCanvas read GetCanvasFP; 733 property CanvasDrawModeFP: TDrawMode read GetCanvasDrawModeFP write SetCanvasDrawModeFP; 734 property Canvas: TCanvas Read GetCanvas; 735 property CanvasOpacity: byte Read GetCanvasOpacity Write SetCanvasOpacity; 736 property CanvasAlphaCorrection: boolean 737 Read GetCanvasAlphaCorrection Write SetCanvasAlphaCorrection; 738 739 property FontHeight: integer Read GetFontHeight Write SetFontHeight; 740 property PenStyle: TPenStyle read GetPenStyle Write SetPenStyle; 741 property CustomPenStyle: TBGRAPenStyle read GetCustomPenStyle write SetCustomPenStyle; 742 property ClipRect: TRect read GetClipRect write SetClipRect; 743 property FontAntialias: Boolean read GetFontAntialias write SetFontAntialias; //antialiasing (it's different from TFont antialiasing mode) 744 property FontFullHeight: integer read GetFontFullHeight write SetFontFullHeight; 745 property FontPixelMetric: TFontPixelMetric read GetFontPixelMetric; 746 747 //interface 748 function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND}; 749 function _AddRef: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND}; 750 function _Release: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND}; 751 752 //IBGRAScanner 753 procedure ScanMoveTo(X,Y: Integer); virtual; abstract; 754 function ScanNextPixel: TBGRAPixel; virtual; abstract; 755 function ScanAt(X,Y: Single): TBGRAPixel; virtual; abstract; 756 procedure ScanPutPixels(pdest: PBGRAPixel; count: integer; mode: TDrawMode); virtual; 757 function IsScanPutPixelsDefined: boolean; virtual; 758 end; 759 760 { TBGRACustomScanner } 761 762 TBGRACustomScanner = class(IBGRAScanner) 763 private 764 FCurX,FCurY: integer; 765 public 766 procedure ScanMoveTo(X,Y: Integer); virtual; 767 function ScanNextPixel: TBGRAPixel; virtual; 768 function ScanAt(X,Y: Single): TBGRAPixel; virtual; abstract; 769 procedure ScanPutPixels(pdest: PBGRAPixel; count: integer; mode: TDrawMode); virtual; 770 function IsScanPutPixelsDefined: boolean; virtual; 771 function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND}; 772 function _AddRef: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND}; 773 function _Release: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND}; 774 end; 775 776 TBGRACustomGradient = class 777 public 778 function GetColorAt(position: integer): TBGRAPixel; virtual; abstract; 779 function GetAverageColor: TBGRAPixel; virtual; abstract; 780 function GetMonochrome: boolean; virtual; abstract; 781 property Monochrome: boolean read GetMonochrome; 782 end; 783 784 type 785 TBGRABitmapAny = class of TBGRACustomBitmap; //used to create instances of the same type (see NewBitmap) 786 787 var 788 BGRABitmapFactory : TBGRABitmapAny; 789 790 { Color functions } 95 791 function GetIntensity(c: TExpandedPixel): word; inline; 96 792 function SetIntensity(c: TExpandedPixel; intensity: word): TExpandedPixel; 97 793 function GetLightness(c: TExpandedPixel): word; inline; 98 794 function SetLightness(c: TExpandedPixel; lightness: word): TExpandedPixel; 795 function ApplyLightnessFast(color: TBGRAPixel; lightness: word): TBGRAPixel; inline; 99 796 function BGRAToHSLA(c: TBGRAPixel): THSLAPixel; 797 function HSLAToExpanded(c: THSLAPixel): TExpandedPixel; 100 798 function HSLAToBGRA(c: THSLAPixel): TBGRAPixel; 799 function GtoH(ghue: word): word; 800 function HtoG(hue: word): word; 801 function HueDiff(h1, h2: word): word; 802 function GetHue(ec: TExpandedPixel): word; 803 function ColorImportance(ec: TExpandedPixel): word; 804 function GSBAToBGRA(c: THSLAPixel): TBGRAPixel; 805 function GSBAToHSLA(c: THSLAPixel): THSLAPixel; 101 806 function GammaExpansion(c: TBGRAPixel): TExpandedPixel; inline; 102 807 function GammaCompression(ec: TExpandedPixel): TBGRAPixel; inline; 808 function GammaCompression(red,green,blue,alpha: word): TBGRAPixel; inline; 103 809 function BGRAToGrayscale(c: TBGRAPixel): TBGRAPixel; 104 function MergeBGRA(c1, c2: TBGRAPixel): TBGRAPixel; 810 function GrayscaleToBGRA(lightness: word): TBGRAPixel; 811 function MergeBGRA(c1, c2: TBGRAPixel): TBGRAPixel; overload; 812 function MergeBGRA(c1: TBGRAPixel; weight1: integer; c2: TBGRAPixel; weight2: integer): TBGRAPixel; overload; 813 function MergeBGRA(ec1, ec2: TExpandedPixel): TExpandedPixel; overload; 105 814 function BGRA(red, green, blue, alpha: byte): TBGRAPixel; overload; inline; 106 815 function BGRA(red, green, blue: byte): TBGRAPixel; overload; inline; 107 816 function ColorToBGRA(color: TColor): TBGRAPixel; overload; 108 817 function ColorToBGRA(color: TColor; opacity: byte): TBGRAPixel; overload; 818 function BGRAToFPColor(AValue: TBGRAPixel): TFPColor; inline; 819 function FPColorToBGRA(AValue: TFPColor): TBGRAPixel; 109 820 function BGRAToColor(c: TBGRAPixel): TColor; 110 821 operator = (const c1, c2: TBGRAPixel): boolean; inline; 111 822 function ExpandedDiff(ec1, ec2: TExpandedPixel): word; 823 function BGRAWordDiff(c1, c2: TBGRAPixel): word; 112 824 function BGRADiff(c1, c2: TBGRAPixel): byte; 113 function PointF(x, y: single): TPointF;114 115 function PtInRect(pt: TPoint; r: TRect): boolean;116 117 function StrToGradientType(str: string): TGradientType;825 operator - (const c1, c2: TColorF): TColorF; inline; 826 operator + (const c1, c2: TColorF): TColorF; inline; 827 operator * (const c1, c2: TColorF): TColorF; inline; 828 operator * (const c1: TColorF; factor: single): TColorF; inline; 829 function ColorF(red,green,blue,alpha: single): TColorF; 118 830 function BGRAToStr(c: TBGRAPixel): string; 119 831 function StrToBGRA(str: string): TBGRAPixel; 120 832 833 { Get height [0..1] stored in a TBGRAPixel } 834 function MapHeight(Color: TBGRAPixel): Single; 835 836 { Get TBGRAPixel to store height [0..1] } 837 function MapHeightToBGRA(Height: Single; Alpha: Byte): TBGRAPixel; 838 839 840 { Gamma conversion arrays. Should be used as readonly } 121 841 var 842 // TBGRAPixel -> TExpandedPixel 122 843 GammaExpansionTab: packed array[0..255] of word; 844 845 // TExpandedPixel -> TBGRAPixel 123 846 GammaCompressionTab: packed array[0..65535] of byte; 124 847 848 { Point functions } 849 function PointF(x, y: single): TPointF; 850 function PointsF(const pts: array of TPointF): ArrayOfTPointF; 851 operator = (const pt1, pt2: TPointF): boolean; inline; 852 operator - (const pt1, pt2: TPointF): TPointF; inline; 853 operator - (const pt2: TPointF): TPointF; inline; 854 operator + (const pt1, pt2: TPointF): TPointF; inline; 855 operator * (const pt1, pt2: TPointF): single; inline; //scalar product 856 operator * (const pt1: TPointF; factor: single): TPointF; inline; 857 operator * (factor: single; const pt1: TPointF): TPointF; inline; 858 function PtInRect(pt: TPoint; r: TRect): boolean; 859 function VectLen(dx,dy: single): single; overload; 860 function VectLen(v: TPointF): single; overload; 861 862 { Line and polygon functions } 863 type 864 TLineDef = record 865 origin, dir: TPointF; 866 end; 867 868 function IntersectLine(line1, line2: TLineDef): TPointF; 869 function IntersectLine(line1, line2: TLineDef; out parallel: boolean): TPointF; 870 function IsConvex(const pts: array of TPointF; IgnoreAlign: boolean = true): boolean; 871 function DoesQuadIntersect(pt1,pt2,pt3,pt4: TPointF): boolean; 872 function DoesSegmentIntersect(pt1,pt2,pt3,pt4: TPointF): boolean; 873 874 { Cyclic functions } 875 function PositiveMod(value, cycle: integer): integer; inline; 876 877 { Sin65536 and Cos65536 are fast routines to compute sine and cosine as integer values. 878 They use a table to store already computed values. The return value is an integer 879 ranging from 0 to 65536, so the mean value is 32768 and the half amplitude is 880 32768 instead of 1. The input has a period of 65536, so you can supply any integer 881 without applying a modulo. } 882 procedure PrecalcSin65536; // compute all values now 883 function Sin65536(value: word): integer; inline; 884 function Cos65536(value: word): integer; inline; 885 125 886 implementation 126 887 127 888 uses Math, SysUtils; 128 889 890 function StrToBlendOperation(str: string): TBlendOperation; 891 var op: TBlendOperation; 892 begin 893 result := boTransparent; 894 str := LowerCase(str); 895 for op := low(TBlendOperation) to high(TBlendOperation) do 896 if str = LowerCase(BlendOperationStr[op]) then 897 begin 898 result := op; 899 exit; 900 end; 901 end; 902 903 function StrToGradientType(str: string): TGradientType; 904 var gt: TGradientType; 905 begin 906 result := gtLinear; 907 str := LowerCase(str); 908 for gt := low(TGradientType) to high(TGradientType) do 909 if str = LowerCase(GradientTypeStr[gt]) then 910 begin 911 result := gt; 912 exit; 913 end; 914 end; 915 916 { Make a pen style. Need an even number of values. See TBGRAPenStyle } 917 function BGRAPenStyle(dash1, space1: single; dash2: single; space2: single; 918 dash3: single; space3: single; dash4: single; space4: single): TBGRAPenStyle; 919 var 920 i: Integer; 921 begin 922 if dash4 <> 0 then 923 begin 924 setlength(result,8); 925 result[6] := dash4; 926 result[7] := space4; 927 result[4] := dash3; 928 result[5] := space3; 929 result[2] := dash2; 930 result[3] := space2; 931 end else 932 if dash3 <> 0 then 933 begin 934 setlength(result,6); 935 result[4] := dash3; 936 result[5] := space3; 937 result[2] := dash2; 938 result[3] := space2; 939 end else 940 if dash2 <> 0 then 941 begin 942 setlength(result,4); 943 result[2] := dash2; 944 result[3] := space2; 945 end else 946 begin 947 setlength(result,2); 948 end; 949 result[0] := dash1; 950 result[1] := space1; 951 for i := 0 to high(result) do 952 if result[i]=0 then 953 raise exception.Create('Zero is not a valid value'); 954 end; 955 956 { Bézier curves definitions. See : http://en.wikipedia.org/wiki/B%C3%A9zier_curve } 957 958 function ConcatPointsF(const APolylines: array of ArrayOfTPointF 959 ): ArrayOfTPointF; 960 var 961 i,pos,count:integer; 962 j: Integer; 963 begin 964 count := 0; 965 for i := 0 to high(APolylines) do 966 inc(count,length(APolylines[i])); 967 setlength(result,count); 968 pos := 0; 969 for i := 0 to high(APolylines) do 970 for j := 0 to high(APolylines[i]) do 971 begin 972 result[pos] := APolylines[i][j]; 973 inc(pos); 974 end; 975 end; 976 977 operator-(const v: TPoint3D): TPoint3D; 978 begin 979 result.x := -v.x; 980 result.y := -v.y; 981 result.z := -v.z; 982 end; 983 984 operator + (const v1,v2: TPoint3D): TPoint3D; inline; 985 begin 986 result.x := v1.x+v2.x; 987 result.y := v1.y+v2.y; 988 result.z := v1.z+v2.z; 989 end; 990 991 operator - (const v1,v2: TPoint3D): TPoint3D; inline; 992 begin 993 result.x := v1.x-v2.x; 994 result.y := v1.y-v2.y; 995 result.z := v1.z-v2.z; 996 end; 997 998 operator * (const v1: TPoint3D; const factor: single): TPoint3D; inline; 999 begin 1000 result.x := v1.x*factor; 1001 result.y := v1.y*factor; 1002 result.z := v1.z*factor; 1003 end; 1004 1005 function Point3D(x, y, z: single): TPoint3D; 1006 begin 1007 result.x := x; 1008 result.y := y; 1009 result.z := z; 1010 end; 1011 1012 operator=(const v1, v2: TPoint3D): boolean; 1013 begin 1014 result := (v1.x=v2.x) and (v1.y=v2.y) and (v1.z=v2.z); 1015 end; 1016 1017 operator * (const v1,v2: TPoint3D): single; inline; 1018 begin 1019 result := v1.x*v2.x + v1.y*v2.y + v1.z*v2.z; 1020 end; 1021 1022 procedure Normalize3D(var v: TPoint3D); inline; 1023 var len: double; 1024 begin 1025 len := v*v; 1026 if len = 0 then exit; 1027 len := sqrt(len); 1028 v.x /= len; 1029 v.y /= len; 1030 v.z /= len; 1031 end; 1032 1033 procedure VectProduct3D(u,v: TPoint3D; out w: TPoint3D); 1034 begin 1035 w.x := u.y*v.z-u.z*v.y; 1036 w.y := u.z*v.x-u.x*v.z; 1037 w.z := u.x*v.Y-u.y*v.x; 1038 end; 1039 1040 // Define a Bézier curve with two control points. 1041 function BezierCurve(origin, control1, control2, destination: TPointF): TCubicBezierCurve; 1042 begin 1043 result.p1 := origin; 1044 result.c1 := control1; 1045 result.c2 := control2; 1046 result.p2 := destination; 1047 end; 1048 1049 // Define a Bézier curve with one control point. 1050 function BezierCurve(origin, control, destination: TPointF 1051 ): TQuadraticBezierCurve; 1052 begin 1053 result.p1 := origin; 1054 result.c := control; 1055 result.p2 := destination; 1056 end; 1057 1058 { Check if a PointF structure is empty or should be treated as a list separator } 129 1059 function isEmptyPointF(pt: TPointF): boolean; 130 1060 begin … … 132 1062 end; 133 1063 1064 { TBGRAColorList } 1065 1066 function TBGRAColorList.GetByIndex(Index: integer): TBGRAPixel; 1067 begin 1068 if (Index < 0) or (Index >= FNbColors) then 1069 result := BGRAPixelTransparent 1070 else 1071 result := FColors[Index].Color; 1072 end; 1073 1074 function TBGRAColorList.GetByName(Name: string): TBGRAPixel; 1075 var i: integer; 1076 begin 1077 i := IndexOf(Name); 1078 if i = -1 then 1079 result := BGRAPixelTransparent 1080 else 1081 result := FColors[i].Color; 1082 end; 1083 1084 function TBGRAColorList.GetName(Index: integer): string; 1085 begin 1086 if (Index < 0) or (Index >= FNbColors) then 1087 result := '' 1088 else 1089 result := FColors[Index].Name; 1090 end; 1091 1092 constructor TBGRAColorList.Create; 1093 begin 1094 FNbColors:= 0; 1095 FColors := nil; 1096 FFinished:= false; 1097 end; 1098 1099 procedure TBGRAColorList.Add(Name: string; Color: TBGRAPixel); 1100 begin 1101 if FFinished then 1102 raise Exception.Create('This list is already finished'); 1103 if length(FColors) = FNbColors then 1104 SetLength(FColors, FNbColors*2+1); 1105 FColors[FNbColors].Name := Name; 1106 FColors[FNbColors].Color := Color; 1107 inc(FNbColors); 1108 end; 1109 1110 procedure TBGRAColorList.Finished; 1111 begin 1112 if FFinished then exit; 1113 FFinished := true; 1114 SetLength(FColors, FNbColors); 1115 end; 1116 1117 function TBGRAColorList.IndexOf(Name: string): integer; 1118 var i: integer; 1119 begin 1120 for i := 0 to FNbColors-1 do 1121 if CompareText(Name, FColors[i].Name) = 0 then 1122 begin 1123 result := i; 1124 exit; 1125 end; 1126 result := -1; 1127 end; 1128 1129 { TBGRACustomBitmap } 1130 1131 function TBGRACustomBitmap.GetFontAntialias: Boolean; 1132 begin 1133 result := FontQuality <> fqSystem; 1134 end; 1135 1136 procedure TBGRACustomBitmap.SetFontAntialias(const AValue: Boolean); 1137 begin 1138 if AValue and not FontAntialias then 1139 FontQuality := fqFineAntialiasing 1140 else if not AValue and (FontQuality <> fqSystem) then 1141 FontQuality := fqSystem; 1142 end; 1143 1144 { These declaration make sure that these methods are virtual } 1145 procedure TBGRACustomBitmap.LoadFromFile(const filename: string); 1146 begin 1147 inherited LoadFromFile(filename); 1148 end; 1149 1150 procedure TBGRACustomBitmap.SaveToFile(const filename: string); 1151 begin 1152 inherited SaveToFile(filename); 1153 end; 1154 1155 procedure TBGRACustomBitmap.SaveToFile(const filename: string; 1156 Handler: TFPCustomImageWriter); 1157 begin 1158 inherited SaveToFile(filename, Handler); 1159 end; 1160 1161 { LoadFromStream uses TFPCustomImage routine, which uses 1162 Colors property to access pixels. That's why the 1163 FP drawing mode is temporarily changed to load 1164 bitmaps properly } 1165 procedure TBGRACustomBitmap.LoadFromStream(Str: TStream); 1166 var 1167 OldDrawMode: TDrawMode; 1168 begin 1169 OldDrawMode := CanvasDrawModeFP; 1170 CanvasDrawModeFP := dmSet; 1171 try 1172 if not LoadAsBmp32(Str) then 1173 inherited LoadFromStream(Str); 1174 finally 1175 CanvasDrawModeFP := OldDrawMode; 1176 end; 1177 end; 1178 1179 { See above } 1180 procedure TBGRACustomBitmap.LoadFromStream(Str: TStream; 1181 Handler: TFPCustomImageReader); 1182 var 1183 OldDrawMode: TDrawMode; 1184 begin 1185 OldDrawMode := CanvasDrawModeFP; 1186 CanvasDrawModeFP := dmSet; 1187 try 1188 inherited LoadFromStream(Str, Handler); 1189 finally 1190 CanvasDrawModeFP := OldDrawMode; 1191 end; 1192 end; 1193 1194 { Look for a pixel considering the bitmap is repeated in both directions } 1195 function TBGRACustomBitmap.GetPixelCycle(x, y: integer): TBGRAPixel; 1196 begin 1197 if (Width = 0) or (Height = 0) then 1198 Result := BGRAPixelTransparent 1199 else 1200 Result := (Scanline[PositiveMod(y,Height)] + PositiveMod(x,Width))^; 1201 end; 1202 1203 { Pixel polylines are constructed by concatenation } 1204 procedure TBGRACustomBitmap.DrawPolyLineAntialias(const points: array of TPoint; 1205 c: TBGRAPixel; DrawLastPixel: boolean); 1206 var i: integer; 1207 begin 1208 if length(points) = 1 then 1209 begin 1210 if DrawLastPixel then DrawPixel(points[0].x,points[0].y,c); 1211 end 1212 else 1213 for i := 0 to high(points)-1 do 1214 DrawLineAntialias(points[i].x,points[i].Y,points[i+1].x,points[i+1].y,c,DrawLastPixel and (i=high(points)-1)); 1215 end; 1216 1217 procedure TBGRACustomBitmap.DrawPolyLineAntialias(const points: array of TPoint; c1, 1218 c2: TBGRAPixel; dashLen: integer; DrawLastPixel: boolean); 1219 var i: integer; 1220 begin 1221 if length(points) = 1 then 1222 begin 1223 if DrawLastPixel then DrawPixel(points[0].x,points[0].y,c1); 1224 end 1225 else 1226 for i := 0 to high(points)-1 do 1227 DrawLineAntialias(points[i].x,points[i].Y,points[i+1].x,points[i+1].y,c1,c2,dashLen,DrawLastPixel and (i=high(points)-1)); 1228 end; 1229 1230 { Following functions are defined for convenience } 1231 procedure TBGRACustomBitmap.Rectangle(x, y, x2, y2: integer; c: TColor); 1232 begin 1233 Rectangle(x, y, x2, y2, ColorToBGRA(c), dmSet); 1234 end; 1235 1236 procedure TBGRACustomBitmap.Rectangle(r: TRect; c: TBGRAPixel; mode: TDrawMode 1237 ); 1238 begin 1239 Rectangle(r.left, r.top, r.right, r.bottom, c, mode); 1240 end; 1241 1242 procedure TBGRACustomBitmap.Rectangle(r: TRect; BorderColor, 1243 FillColor: TBGRAPixel; mode: TDrawMode); 1244 begin 1245 Rectangle(r.left, r.top, r.right, r.bottom, BorderColor, FillColor, mode); 1246 end; 1247 1248 procedure TBGRACustomBitmap.Rectangle(r: TRect; c: TColor); 1249 begin 1250 Rectangle(r.left, r.top, r.right, r.bottom, c); 1251 end; 1252 1253 procedure TBGRACustomBitmap.RectangleAntialias(x, y, x2, y2: single; 1254 c: TBGRAPixel; w: single); 1255 begin 1256 RectangleAntialias(x, y, x2, y2, c, w, BGRAPixelTransparent); 1257 end; 1258 1259 procedure TBGRACustomBitmap.FillRect(r: TRect; c: TColor); 1260 begin 1261 FillRect(r.Left, r.top, r.right, r.bottom, c); 1262 end; 1263 1264 procedure TBGRACustomBitmap.FillRect(r: TRect; c: TBGRAPixel; mode: TDrawMode); 1265 begin 1266 FillRect(r.Left, r.top, r.right, r.bottom, c, mode); 1267 end; 1268 1269 procedure TBGRACustomBitmap.FillRect(x, y, x2, y2: integer; c: TColor); 1270 begin 1271 FillRect(x, y, x2, y2, ColorToBGRA(c), dmSet); 1272 end; 1273 1274 procedure TBGRACustomBitmap.TextOut(x, y: integer; s: string; c: TBGRAPixel); 1275 begin 1276 TextOut(x, y, s, c, taLeftJustify); 1277 end; 1278 1279 procedure TBGRACustomBitmap.TextOut(x, y: integer; s: string; c: TColor); 1280 begin 1281 TextOut(x, y, s, ColorToBGRA(c)); 1282 end; 1283 1284 procedure TBGRACustomBitmap.TextOut(x, y: integer; s: string; 1285 texture: IBGRAScanner); 1286 begin 1287 TextOut(x, y, s, texture, taLeftJustify); 1288 end; 1289 1290 procedure TBGRACustomBitmap.TextRect(ARect: TRect; s: string; 1291 halign: TAlignment; valign: TTextLayout; c: TBGRAPixel); 1292 var 1293 style: TTextStyle; 1294 begin 1295 {$hints off} 1296 FillChar(style,sizeof(style),0); 1297 {$hints on} 1298 style.Alignment := halign; 1299 style.Layout := valign; 1300 style.Wordbreak := true; 1301 style.ShowPrefix := false; 1302 style.Clipping := false; 1303 TextRect(ARect,ARect.Left,ARect.Top,s,style,c); 1304 end; 1305 1306 procedure TBGRACustomBitmap.TextRect(ARect: TRect; s: string; 1307 halign: TAlignment; valign: TTextLayout; texture: IBGRAScanner); 1308 var 1309 style: TTextStyle; 1310 begin 1311 {$hints off} 1312 FillChar(style,sizeof(style),0); 1313 {$hints on} 1314 style.Alignment := halign; 1315 style.Layout := valign; 1316 style.Wordbreak := true; 1317 style.ShowPrefix := false; 1318 style.Clipping := false; 1319 TextRect(ARect,ARect.Left,ARect.Top,s,style,texture); 1320 end; 1321 1322 procedure TBGRACustomBitmap.FillTransparent; 1323 begin 1324 Fill(BGRAPixelTransparent); 1325 end; 1326 1327 procedure TBGRACustomBitmap.Fill(c: TColor); 1328 begin 1329 Fill(ColorToBGRA(c)); 1330 end; 1331 1332 procedure TBGRACustomBitmap.Fill(c: TBGRAPixel); 1333 begin 1334 Fill(c, 0, NbPixels); 1335 end; 1336 1337 procedure TBGRACustomBitmap.AlphaFill(alpha: byte); 1338 begin 1339 AlphaFill(alpha, 0, NbPixels); 1340 end; 1341 1342 procedure TBGRACustomBitmap.FloodFill(X, Y: integer; Color: TBGRAPixel; 1343 mode: TFloodfillMode; Tolerance: byte); 1344 begin 1345 ParallelFloodFill(X,Y,Self,Color,mode,Tolerance); 1346 end; 1347 1348 procedure TBGRACustomBitmap.DrawPart(ARect: TRect; Canvas: TCanvas; x, 1349 y: integer; Opaque: boolean); 1350 var 1351 partial: TBGRACustomBitmap; 1352 begin 1353 partial := GetPart(ARect); 1354 if partial <> nil then 1355 begin 1356 partial.Draw(Canvas, x, y, Opaque); 1357 partial.Free; 1358 end; 1359 end; 1360 1361 procedure TBGRACustomBitmap.PutImageSubpixel(x, y: single; Source: TBGRACustomBitmap); 1362 begin 1363 PutImageAngle(x,y,source,0); 1364 end; 1365 1366 { Interface gateway } 1367 function TBGRACustomBitmap.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND}; 1368 begin 1369 if GetInterface(iid, obj) then 1370 Result := S_OK 1371 else 1372 Result := longint(E_NOINTERFACE); 1373 end; 1374 1375 { There is no automatic reference counting, but it is compulsory to define these functions } 1376 function TBGRACustomBitmap._AddRef: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND}; 1377 begin 1378 result := 0; 1379 end; 1380 1381 function TBGRACustomBitmap._Release: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND}; 1382 begin 1383 result := 0; 1384 end; 1385 1386 {$hints off} 1387 procedure TBGRACustomBitmap.ScanPutPixels(pdest: PBGRAPixel; count: integer; 1388 mode: TDrawMode); 1389 begin 1390 //do nothing 1391 end; 1392 {$hints on} 1393 1394 function TBGRACustomBitmap.IsScanPutPixelsDefined: boolean; 1395 begin 1396 result := False; 1397 end; 1398 1399 {********************** End of TBGRACustomBitmap **************************} 1400 1401 { TBGRACustomScanner } 1402 { The abstract class record the position so that a derived class 1403 need only to redefine ScanAt } 1404 1405 procedure TBGRACustomScanner.ScanMoveTo(X, Y: Integer); 1406 begin 1407 FCurX := X; 1408 FCurY := Y; 1409 end; 1410 1411 { Call ScanAt to determine pixel value } 1412 function TBGRACustomScanner.ScanNextPixel: TBGRAPixel; 1413 begin 1414 result := ScanAt(FCurX,FCurY); 1415 Inc(FCurX); 1416 end; 1417 1418 {$hints off} 1419 procedure TBGRACustomScanner.ScanPutPixels(pdest: PBGRAPixel; count: integer; 1420 mode: TDrawMode); 1421 begin 1422 //do nothing 1423 end; 1424 {$hints on} 1425 1426 function TBGRACustomScanner.IsScanPutPixelsDefined: boolean; 1427 begin 1428 result := false; 1429 end; 1430 1431 { Interface gateway } 1432 function TBGRACustomScanner.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND}; 1433 begin 1434 if GetInterface(iid, obj) then 1435 Result := S_OK 1436 else 1437 Result := longint(E_NOINTERFACE); 1438 end; 1439 1440 { There is no automatic reference counting, but it is compulsory to define these functions } 1441 function TBGRACustomScanner._AddRef: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND}; 1442 begin 1443 result := 0; 1444 end; 1445 1446 function TBGRACustomScanner._Release: Integer; {$IF (not defined(WINDOWS)) AND (FPC_FULLVERSION>=20501)}cdecl{$ELSE}stdcall{$IFEND}; 1447 begin 1448 result := 0; 1449 end; 1450 1451 {********************** End of TBGRACustomScanner **************************} 1452 1453 { The gamma correction is approximated here by a power function } 134 1454 const 135 GammaExpFactor = 1.7; 136 { redWeight = 0.299; 137 greenWeight = 0.587; 138 blueWeight = 0.114;} 139 redWeightShl10 = 306; 140 greenWeightShl10 = 601; 141 blueWeightShl10 = 117; 1455 GammaExpFactor = 1.7; //exponent 1456 redWeightShl10 = 306; // = 0.299 1457 greenWeightShl10 = 601; // = 0.587 1458 blueWeightShl10 = 117; // = 0.114 142 1459 143 1460 var … … 146 1463 procedure InitGamma; 147 1464 var 148 i: integer; {t: textfile; prevval,val: byte; } 149 begin 1465 i: integer; 1466 {$IFDEF WINCE} 1467 j,prevpos,curpos,midpos: integer; 1468 {$ENDIF} 1469 begin 1470 //the linear factor is used to normalize expanded values in the range 0..65535 150 1471 GammaLinearFactor := 65535 / power(255, GammaExpFactor); 1472 1473 {$IFDEF WINCE} 1474 curpos := 0; 1475 GammaExpansionTab[0] := 0; 1476 GammaCompressionTab[0] := 0; 1477 for i := 0 to 255 do 1478 begin 1479 prevpos := curpos; 1480 curpos := round(power(i, GammaExpFactor) * GammaLinearFactor); 1481 if i = 1 then curpos := 1; //to avoid information loss 1482 GammaExpansionTab[i] := curpos; 1483 midpos := (prevpos+1+curpos) div 2; 1484 for j := prevpos+1 to midpos-1 do 1485 GammaCompressionTab[j] := i-1; 1486 for j := midpos to curpos do 1487 GammaCompressionTab[j] := i; 1488 end; 1489 {$ELSE} 151 1490 for i := 0 to 255 do 152 1491 GammaExpansionTab[i] := round(power(i, GammaExpFactor) * GammaLinearFactor); … … 155 1494 GammaCompressionTab[i] := round(power(i / GammaLinearFactor, 1 / GammaExpFactor)); 156 1495 157 GammaExpansionTab[1] := 1; //to avoid information los t1496 GammaExpansionTab[1] := 1; //to avoid information loss 158 1497 GammaCompressionTab[1] := 1; 159 { 160 assignfile(t,'gammaout.txt'); 161 rewrite(t); 162 prevval := 255; 163 for i := 0 to 255 do 164 begin 165 val := GammaCompressionTab[i*256+128]; 166 if val <> prevval then writeln(t,val); 167 prevval := val; 168 end; 169 closefile(t);} 170 end; 171 172 {$hints off} 173 1498 {$ENDIF} 1499 end; 1500 1501 {************************** Color functions **************************} 1502 1503 { The intensity is defined here as the maximum value of any color component } 174 1504 function GetIntensity(c: TExpandedPixel): word; inline; 175 1505 begin … … 186 1516 begin 187 1517 curIntensity := GetIntensity(c); 188 if curIntensity = 0 then 1518 if curIntensity = 0 then //suppose it's gray if there is no color information 189 1519 Result := c 190 1520 else 191 1521 begin 1522 //linear interpolation to reached wanted intensity 192 1523 Result.red := (c.red * intensity + (curIntensity shr 1)) div curIntensity; 193 1524 Result.green := (c.green * intensity + (curIntensity shr 1)) div curIntensity; … … 197 1528 end; 198 1529 1530 { The lightness here is defined as the subjective sensation of luminosity, where 1531 blue is the darkest component and green the lightest } 199 1532 function GetLightness(c: TExpandedPixel): word; inline; 200 1533 begin … … 286 1619 end; 287 1620 1621 function ApplyLightnessFast(color: TBGRAPixel; lightness: word): TBGRAPixel; inline; 1622 var lightness256: byte; 1623 begin 1624 if lightness <= 32768 then 1625 begin 1626 if lightness = 32768 then 1627 result := color else 1628 begin 1629 lightness256 := GammaCompressionTab[lightness shl 1]; 1630 result := BGRA(color.red * lightness256 shr 8, color.green*lightness256 shr 8, 1631 color.blue * lightness256 shr 8, color.alpha); 1632 end; 1633 end else 1634 begin 1635 if lightness = 65535 then 1636 result := BGRAWhite else 1637 begin 1638 lightness256 := GammaCompressionTab[(lightness-32767) shl 1]; 1639 result := BGRA(color.red + (255-color.red)*lightness256 shr 8, 1640 color.green + (255-color.green)*lightness256 shr 8, 1641 color.blue + (255-color.blue)*lightness256 shr 8, 1642 color.alpha); 1643 end; 1644 end; 1645 end; 1646 1647 { Conversion from RGB value to HSL colorspace. See : http://en.wikipedia.org/wiki/HSL_color_space } 288 1648 function BGRAToHSLA(c: TBGRAPixel): THSLAPixel; 289 1649 const … … 294 1654 var 295 1655 ec: TExpandedPixel; 296 min, max, minMax: word;1656 min, max, minMax: integer; 297 1657 twiceLightness: integer; 1658 r,g,b: integer; 298 1659 begin 299 1660 ec := GammaExpansion(c); 300 min := ec.red; 301 max := ec.red; 302 if ec.green > max then 303 max := ec.green 304 else 305 if ec.green < min then 306 min := ec.green; 307 if ec.blue > max then 308 max := ec.blue 309 else 310 if ec.blue < min then 311 min := ec.blue; 1661 r := ec.red; 1662 g := ec.green; 1663 b := ec.blue; 1664 min := r; 1665 max := r; 1666 if g > max then 1667 max := g 1668 else 1669 if g < min then 1670 min := g; 1671 if b > max then 1672 max := b 1673 else 1674 if b < min then 1675 min := b; 312 1676 minMax := max - min; 313 1677 … … 315 1679 Result.hue := 0 316 1680 else 317 if max = ec.redthen318 Result.hue := ((( ec.green - ec.blue) * deg60 + (minMax shr 1)) div1681 if max = r then 1682 Result.hue := (((g - b) * deg60) div 319 1683 minMax + deg360) mod deg360 320 1684 else 321 if max = ec.greenthen322 Result.hue := (( ec.blue - ec.red) * deg60 + (minMax shr 1)) div minMax + deg120323 else 324 {max = ec.blue} Result.hue :=325 (( ec.red - ec.green) * deg60 + (minMax shr 1)) div minMax + deg240;1685 if max = g then 1686 Result.hue := ((b - r) * deg60) div minMax + deg120 1687 else 1688 {max = b} Result.hue := 1689 ((r - g) * deg60) div minMax + deg240; 326 1690 twiceLightness := max + min; 327 1691 if min = max then 328 1692 Result.saturation := 0 329 1693 else 1694 {$hints off} 330 1695 if twiceLightness < 65536 then 331 Result.saturation := (minMax shl 16) div (twiceLightness + 1) 332 else 333 Result.saturation := (minMax shl 16) div (131072 - twiceLightness); 1696 Result.saturation := (int64(minMax) shl 16) div (twiceLightness + 1) 1697 else 1698 Result.saturation := (int64(minMax) shl 16) div (131072 - twiceLightness); 1699 {$hints on} 334 1700 Result.lightness := twiceLightness shr 1; 335 1701 Result.alpha := ec.alpha; 336 Result.hue := Result.hue * 65536 div deg360; 337 end; 338 339 function HSLAToBGRA(c: THSLAPixel): TBGRAPixel; 1702 Result.hue := (Result.hue shl 16) div deg360; 1703 end; 1704 1705 function HtoG(hue: word): word; 1706 const 1707 segmentDest: array[0..5] of word = 1708 (13653, 10923, 8192, 13653, 10923, 8192); 1709 segmentSrc: array[0..5] of word = 1710 (10923, 10922, 10923, 10923, 10922, 10923); 1711 begin 1712 if hue < segmentSrc[0] then 1713 result := hue * segmentDest[0] div segmentSrc[0] 1714 else 1715 begin 1716 result := segmentDest[0]; 1717 hue -= segmentSrc[0]; 1718 if hue < segmentSrc[1] then 1719 result += hue * segmentDest[1] div segmentSrc[1] 1720 else 1721 begin 1722 result += segmentDest[1]; 1723 hue -= segmentSrc[1]; 1724 if hue < segmentSrc[2] then 1725 result += hue * segmentDest[2] div segmentSrc[2] 1726 else 1727 begin 1728 result += segmentDest[2]; 1729 hue -= segmentSrc[2]; 1730 if hue < segmentSrc[3] then 1731 result += hue * segmentDest[3] div segmentSrc[3] 1732 else 1733 begin 1734 result += segmentDest[3]; 1735 hue -= segmentSrc[3]; 1736 if hue < segmentSrc[4] then 1737 result += hue * segmentDest[4] div segmentSrc[4] 1738 else 1739 begin 1740 result += segmentDest[4]; 1741 hue -= segmentSrc[4]; 1742 result += hue * segmentDest[5] div segmentSrc[5]; 1743 end; 1744 end; 1745 end; 1746 end; 1747 end; 1748 end; 1749 1750 function GtoH(ghue: word): word; 1751 const 1752 segment: array[0..5] of word = 1753 (13653, 10923, 8192, 13653, 10923, 8192); 1754 begin 1755 if ghue < segment[0] then 1756 result := ghue * 10923 div segment[0] 1757 else 1758 begin 1759 ghue -= segment[0]; 1760 if ghue < segment[1] then 1761 result := ghue * (21845-10923) div segment[1] + 10923 1762 else 1763 begin 1764 ghue -= segment[1]; 1765 if ghue < segment[2] then 1766 result := ghue * (32768-21845) div segment[2] + 21845 1767 else 1768 begin 1769 ghue -= segment[2]; 1770 if ghue < segment[3] then 1771 result := ghue * (43691-32768) div segment[3] + 32768 1772 else 1773 begin 1774 ghue -= segment[3]; 1775 if ghue < segment[4] then 1776 result := ghue * (54613-43691) div segment[4] + 43691 1777 else 1778 begin 1779 ghue -= segment[4]; 1780 result := ghue * (65536-54613) div segment[5] + 54613; 1781 end; 1782 end; 1783 end; 1784 end; 1785 end; 1786 end; 1787 1788 function HSLAToExpanded(c: THSLAPixel): TExpandedPixel; 340 1789 const 341 1790 deg30 = 4096; … … 364 1813 var 365 1814 q, p: integer; 366 ec: TExpandedPixel;367 1815 begin 368 1816 c.hue := c.hue * deg360 shr 16; 369 1817 if c.saturation = 0 then //gray 370 1818 begin 371 ec.red := c.lightness; 372 ec.green := c.lightness; 373 ec.blue := c.lightness; 374 ec.alpha := c.alpha; 375 Result := GammaCompression(ec); 1819 result.red := c.lightness; 1820 result.green := c.lightness; 1821 result.blue := c.lightness; 1822 result.alpha := c.alpha; 376 1823 exit; 377 1824 end; 1825 {$hints off} 378 1826 if c.lightness < 32768 then 379 1827 q := (c.lightness shr 1) * ((65535 + c.saturation) shr 1) shr 14 … … 381 1829 q := c.lightness + c.saturation - ((c.lightness shr 1) * 382 1830 (c.saturation shr 1) shr 14); 1831 {$hints on} 383 1832 if q > 65535 then 384 1833 q := 65535; … … 386 1835 if p > 65535 then 387 1836 p := 65535; 388 ec.red := ComputeColor(p, q, c.hue + deg120); 389 ec.green := ComputeColor(p, q, c.hue); 390 ec.blue := ComputeColor(p, q, c.hue + deg240); 391 ec.alpha := c.alpha; 392 Result := GammaCompression(ec); 393 end; 394 1837 result.red := ComputeColor(p, q, c.hue + deg120); 1838 result.green := ComputeColor(p, q, c.hue); 1839 result.blue := ComputeColor(p, q, c.hue + deg240); 1840 result.alpha := c.alpha; 1841 end; 1842 1843 { Conversion from HSL colorspace to RGB. See : http://en.wikipedia.org/wiki/HSL_color_space } 1844 function HSLAToBGRA(c: THSLAPixel): TBGRAPixel; 1845 var ec: TExpandedPixel; 1846 begin 1847 ec := HSLAToExpanded(c); 1848 Result := GammaCompression(ec); 1849 end; 1850 1851 function HueDiff(h1, h2: word): word; 1852 begin 1853 result := abs(integer(h1)-integer(h2)); 1854 if result > 32768 then result := 65536-result; 1855 end; 1856 1857 function GetHue(ec: TExpandedPixel): word; 1858 const 1859 deg60 = 8192; 1860 deg120 = deg60 * 2; 1861 deg240 = deg60 * 4; 1862 deg360 = deg60 * 6; 1863 var 1864 min, max, minMax: integer; 1865 r,g,b: integer; 1866 begin 1867 r := ec.red; 1868 g := ec.green; 1869 b := ec.blue; 1870 min := r; 1871 max := r; 1872 if g > max then 1873 max := g 1874 else 1875 if g < min then 1876 min := g; 1877 if b > max then 1878 max := b 1879 else 1880 if b < min then 1881 min := b; 1882 minMax := max - min; 1883 1884 if minMax = 0 then 1885 Result := 0 1886 else 1887 if max = r then 1888 Result := (((g - b) * deg60) div 1889 minMax + deg360) mod deg360 1890 else 1891 if max = g then 1892 Result := ((b - r) * deg60) div minMax + deg120 1893 else 1894 {max = b} Result := 1895 ((r - g) * deg60) div minMax + deg240; 1896 1897 Result := (Result shl 16) div deg360; //normalize 1898 end; 1899 1900 function ColorImportance(ec: TExpandedPixel): word; 1901 var min,max: word; 1902 begin 1903 min := ec.red; 1904 max := ec.red; 1905 if ec.green > max then 1906 max := ec.green 1907 else 1908 if ec.green < min then 1909 min := ec.green; 1910 if ec.blue > max then 1911 max := ec.blue 1912 else 1913 if ec.blue < min then 1914 min := ec.blue; 1915 result := max - min; 1916 end; 1917 1918 function GSBAToBGRA(c: THSLAPixel): TBGRAPixel; 1919 var ec: TExpandedPixel; 1920 lightness: word; 1921 begin 1922 c.hue := GtoH(c.hue); 1923 lightness := c.lightness; 1924 c.lightness := 32768; 1925 ec := HSLAToExpanded(c); 1926 result := GammaCompression(SetLightness(ec, lightness)); 1927 end; 1928 1929 function GSBAToHSLA(c: THSLAPixel): THSLAPixel; 1930 begin 1931 result := BGRAToHSLA(GSBAToBGRA(c)); 1932 end; 1933 1934 { Apply gamma correction using conversion tables } 395 1935 function GammaExpansion(c: TBGRAPixel): TExpandedPixel; 396 1936 begin … … 398 1938 Result.green := GammaExpansionTab[c.green]; 399 1939 Result.blue := GammaExpansionTab[c.blue]; 400 Result.alpha := c.alpha shl 8 + 128; 401 end; 402 403 {$hints on} 1940 Result.alpha := c.alpha shl 8 + c.alpha; 1941 end; 404 1942 405 1943 function GammaCompression(ec: TExpandedPixel): TBGRAPixel; … … 411 1949 end; 412 1950 1951 function GammaCompression(red, green, blue, alpha: word): TBGRAPixel; 1952 begin 1953 Result.red := GammaCompressionTab[red]; 1954 Result.green := GammaCompressionTab[green]; 1955 Result.blue := GammaCompressionTab[blue]; 1956 Result.alpha := alpha shr 8; 1957 end; 1958 1959 // Conversion to grayscale by taking into account 1960 // different color weights 413 1961 function BGRAToGrayscale(c: TBGRAPixel): TBGRAPixel; 414 1962 var … … 430 1978 end; 431 1979 1980 function GrayscaleToBGRA(lightness: word): TBGRAPixel; 1981 begin 1982 result.red := GammaCompressionTab[lightness]; 1983 result.green := result.red; 1984 result.blue := result.red; 1985 result.alpha := $ff; 1986 end; 1987 1988 { Merge linearly two colors of same importance } 432 1989 function MergeBGRA(c1, c2: TBGRAPixel): TBGRAPixel; 1990 var c12: cardinal; 433 1991 begin 434 1992 if (c1.alpha = 0) then … … 439 1997 else 440 1998 begin 441 Result.red := round((c1.red * c1.alpha + c2.red * c2.alpha) / 442 (c1.alpha + c2.alpha)); 443 Result.green := round((c1.green * c1.alpha + c2.green * c2.alpha) / 444 (c1.alpha + c2.alpha)); 445 Result.blue := round((c1.blue * c1.alpha + c2.blue * c2.alpha) / 446 (c1.alpha + c2.alpha)); 447 Result.alpha := (c1.alpha + c2.alpha + 1) div 2; 1999 c12 := c1.alpha + c2.alpha; 2000 Result.red := (c1.red * c1.alpha + c2.red * c2.alpha + c12 shr 1) div c12; 2001 Result.green := (c1.green * c1.alpha + c2.green * c2.alpha + c12 shr 1) div c12; 2002 Result.blue := (c1.blue * c1.alpha + c2.blue * c2.alpha + c12 shr 1) div c12; 2003 Result.alpha := (c12 + 1) shr 1; 2004 end; 2005 end; 2006 2007 function MergeBGRA(c1: TBGRAPixel; weight1: integer; c2: TBGRAPixel; 2008 weight2: integer): TBGRAPixel; 2009 var 2010 f1,f2,f12: integer; 2011 begin 2012 f1 := c1.alpha*weight1; 2013 f2 := c2.alpha*weight2; 2014 if (f1 = 0) then 2015 begin 2016 if (f2 = 0) then 2017 result := BGRAPixelTransparent 2018 else 2019 Result := c2 2020 end 2021 else 2022 if (f2 = 0) then 2023 Result := c1 2024 else 2025 if (weight1+weight2 = 0) then 2026 Result := BGRAPixelTransparent 2027 else 2028 begin 2029 f12 := f1+f2; 2030 if f12 = 0 then 2031 result := BGRAPixelTransparent 2032 else 2033 begin 2034 Result.red := (c1.red * f1 + c2.red * f2 + f12 shr 1) div f12; 2035 Result.green := (c1.green * f1 + c2.green * f2 + f12 shr 1) div f12; 2036 Result.blue := (c1.blue * f1 + c2.blue * f2 + f12 shr 1) div f12; 2037 Result.alpha := (f12 + ((weight1+weight2) shr 1)) div (weight1+weight2); 2038 end; 2039 end; 2040 end; 2041 2042 { Merge two colors of same importance } 2043 function MergeBGRA(ec1, ec2: TExpandedPixel): TExpandedPixel; 2044 var c12: cardinal; 2045 begin 2046 if (ec1.alpha = 0) then 2047 Result := ec2 2048 else 2049 if (ec2.alpha = 0) then 2050 Result := ec1 2051 else 2052 begin 2053 c12 := ec1.alpha + ec2.alpha; 2054 Result.red := (int64(ec1.red) * ec1.alpha + int64(ec2.red) * ec2.alpha + c12 shr 1) div c12; 2055 Result.green := (int64(ec1.green) * ec1.alpha + int64(ec2.green) * ec2.alpha + c12 shr 1) div c12; 2056 Result.blue := (int64(ec1.blue) * ec1.alpha + int64(ec2.blue) * ec2.alpha + c12 shr 1) div c12; 2057 Result.alpha := (c12 + 1) shr 1; 448 2058 end; 449 2059 end; … … 465 2075 end; 466 2076 2077 { Convert a TColor value to a TBGRAPixel value. Note that 2078 you need to call ColorToRGB first if you use a system 2079 color identifier like clWindow. } 467 2080 {$PUSH}{$R-} 468 2081 function ColorToBGRA(color: TColor): TBGRAPixel; overload; … … 483 2096 {$POP} 484 2097 485 {$hints off} 2098 { Conversion from TFPColor to TBGRAPixel assuming TFPColor 2099 is already gamma compressed } 2100 function FPColorToBGRA(AValue: TFPColor): TBGRAPixel; 2101 begin 2102 with AValue do 2103 Result := BGRA(red shr 8, green shr 8, blue shr 8, alpha shr 8); 2104 end; 2105 2106 function BGRAToFPColor(AValue: TBGRAPixel): TFPColor; inline; 2107 begin 2108 result.red := AValue.red shl 8 + AValue.red; 2109 result.green := AValue.green shl 8 + AValue.green; 2110 result.blue := AValue.blue shl 8 + AValue.blue; 2111 result.alpha := AValue.alpha shl 8 + AValue.alpha; 2112 end; 2113 486 2114 function BGRAToColor(c: TBGRAPixel): TColor; 487 2115 begin 488 2116 Result := c.red + (c.green shl 8) + (c.blue shl 16); 489 2117 end; 490 491 {$hints on}492 2118 493 2119 operator = (const c1, c2: TBGRAPixel): boolean; … … 500 2126 end; 501 2127 502 function BGRADiff(c1, c2: TBGRAPixel): byte; 2128 function LessStartSlope65535(value: word): word; 2129 var factor: word; 2130 begin 2131 factor := 4096 - (not value)*3 shr 7; 2132 result := value*factor shr 12; 2133 end; 2134 2135 function ExpandedDiff(ec1, ec2: TExpandedPixel): word; 503 2136 var 504 2137 CompRedAlpha1, CompGreenAlpha1, CompBlueAlpha1, CompRedAlpha2, 505 2138 CompGreenAlpha2, CompBlueAlpha2: integer; 506 DiffAlpha: byte; 507 begin 508 {$hints off} 509 CompRedAlpha1 := c1.red * c1.alpha; 510 CompGreenAlpha1 := c1.green * c1.alpha; 511 CompBlueAlpha1 := c1.blue * c1.alpha; 512 CompRedAlpha2 := c2.red * c2.alpha; 513 CompGreenAlpha2 := c2.green * c2.alpha; 514 CompBlueAlpha2 := c2.blue * c2.alpha; 515 {$hints on} 516 Result := (Abs(CompRedAlpha2 - CompRedAlpha1) + 517 Abs(CompBlueAlpha2 - CompBlueAlpha1) + Abs(CompGreenAlpha2 - CompGreenAlpha1)) div 518 (3 * 255); 519 DiffAlpha := Abs(c2.Alpha - c1.Alpha) * 3 shr 2; 2139 DiffAlpha: word; 2140 ColorDiff: word; 2141 TempHueDiff: word; 2142 begin 2143 CompRedAlpha1 := ec1.red * ec1.alpha shr 16; //gives 0..65535 2144 CompGreenAlpha1 := ec1.green * ec1.alpha shr 16; 2145 CompBlueAlpha1 := ec1.blue * ec1.alpha shr 16; 2146 CompRedAlpha2 := ec2.red * ec2.alpha shr 16; 2147 CompGreenAlpha2 := ec2.green * ec2.alpha shr 16; 2148 CompBlueAlpha2 := ec2.blue * ec2.alpha shr 16; 2149 Result := (Abs(CompRedAlpha2 - CompRedAlpha1)*redWeightShl10 + 2150 Abs(CompBlueAlpha2 - CompBlueAlpha1)*blueWeightShl10 + 2151 Abs(CompGreenAlpha2 - CompGreenAlpha1)*greenWeightShl10) shr 10; 2152 ColorDiff := min(ColorImportance(ec1),ColorImportance(ec2)); 2153 if ColorDiff > 0 then 2154 begin 2155 TempHueDiff := HueDiff(HtoG(GetHue(ec1)),HtoG(GetHue(ec2))); 2156 if TempHueDiff < 32768 then 2157 TempHueDiff := LessStartSlope65535(TempHueDiff shl 1) shr 4 2158 else 2159 TempHueDiff := TempHueDiff shr 3; 2160 Result := ((Result shr 4)* (not ColorDiff) + TempHueDiff*ColorDiff) shr 12; 2161 end; 2162 DiffAlpha := Abs(integer(ec2.Alpha) - integer(ec1.Alpha)); 520 2163 if DiffAlpha > Result then 521 2164 Result := DiffAlpha; 522 2165 end; 523 2166 2167 function BGRAWordDiff(c1, c2: TBGRAPixel): word; 2168 begin 2169 result := ExpandedDiff(GammaExpansion(c1),GammaExpansion(c2)); 2170 end; 2171 2172 function BGRADiff(c1,c2: TBGRAPixel): byte; 2173 begin 2174 result := ExpandedDiff(GammaExpansion(c1),GammaExpansion(c2)) shr 8; 2175 end; 2176 2177 operator-(const c1, c2: TColorF): TColorF; 2178 begin 2179 result[1] := c1[1]-c2[1]; 2180 result[2] := c1[2]-c2[2]; 2181 result[3] := c1[3]-c2[3]; 2182 result[4] := c1[4]-c2[4]; 2183 end; 2184 2185 operator+(const c1, c2: TColorF): TColorF; 2186 begin 2187 result[1] := c1[1]+c2[1]; 2188 result[2] := c1[2]+c2[2]; 2189 result[3] := c1[3]+c2[3]; 2190 result[4] := c1[4]+c2[4]; 2191 end; 2192 2193 operator*(const c1, c2: TColorF): TColorF; 2194 begin 2195 result[1] := c1[1]*c2[1]; 2196 result[2] := c1[2]*c2[2]; 2197 result[3] := c1[3]*c2[3]; 2198 result[4] := c1[4]*c2[4]; 2199 end; 2200 2201 operator*(const c1: TColorF; factor: single): TColorF; 2202 begin 2203 result[1] := c1[1]*factor; 2204 result[2] := c1[2]*factor; 2205 result[3] := c1[3]*factor; 2206 result[4] := c1[4]*factor; 2207 end; 2208 2209 function ColorF(red, green, blue, alpha: single): TColorF; 2210 begin 2211 result[1] := red; 2212 result[2] := green; 2213 result[3] := blue; 2214 result[4] := alpha; 2215 end; 2216 2217 { Write a color in hexadecimal format RRGGBBAA } 2218 function BGRAToStr(c: TBGRAPixel): string; 2219 begin 2220 result := IntToHex(c.red,2)+IntToHex(c.green,2)+IntToHex(c.Blue,2)+IntToHex(c.Alpha,2); 2221 end; 2222 2223 type 2224 arrayOfString = array of string; 2225 2226 function SimpleParseFuncParam(str: string): arrayOfString; 2227 var idxOpen,start,cur: integer; 2228 begin 2229 result := nil; 2230 idxOpen := pos('(',str); 2231 if idxOpen = 0 then exit; 2232 start := idxOpen+1; 2233 cur := start; 2234 while cur <= length(str) do 2235 begin 2236 if str[cur] in[',',')'] then 2237 begin 2238 setlength(result,length(result)+1); 2239 result[high(result)] := copy(str,start,cur-start); 2240 start := cur+1; 2241 end; 2242 inc(cur); 2243 end; 2244 if start <= length(str) then 2245 begin 2246 setlength(result,length(result)+1); 2247 result[high(result)] := copy(str,start,length(str)-start+1); 2248 end; 2249 end; 2250 2251 function ParseColorValue(str: string): byte; 2252 var pourcent,unclipped,errPos: integer; 2253 begin 2254 if str = '' then result := 0 else 2255 begin 2256 if str[length(str)]='%' then 2257 begin 2258 val(copy(str,1,length(str)-1),pourcent,errPos); 2259 if pourcent < 0 then result := 0 else 2260 if pourcent > 100 then result := 255 else 2261 result := pourcent*255 div 100; 2262 end else 2263 begin 2264 val(str,unclipped,errPos); 2265 if unclipped < 0 then result := 0 else 2266 if unclipped > 255 then result := 255 else 2267 result := unclipped; 2268 end; 2269 end; 2270 end; 2271 2272 { Read a color in hexadecimal format RRGGBB(AA) or RGB(A) } 2273 function StrToBGRA(str: string): TBGRAPixel; 2274 var errPos: integer; 2275 values: array of string; 2276 alphaF: single; 2277 idx: integer; 2278 begin 2279 if str = '' then 2280 begin 2281 result := BGRAPixelTransparent; 2282 exit; 2283 end; 2284 str := lowerCase(str); 2285 2286 //VGA color names 2287 if str='black' then result := BGRA(0,0,0) else 2288 if str='silver' then result := BGRA(192,192,192) else 2289 if str='gray' then result := BGRA(128,128,128) else 2290 if str='white' then result := BGRA(255,255,255) else 2291 if str='maroon' then result := BGRA(128,0,0) else 2292 if str='red' then result := BGRA(255,0,0) else 2293 if str='purple' then result := BGRA(128,0,128) else 2294 if str='fuchsia' then result := BGRA(255,0,255) else 2295 if str='green' then result := BGRA(0,128,0) else 2296 if str='lime' then result := BGRA(0,255,0) else 2297 if str='olive' then result := BGRA(128,128,0) else 2298 if str='yellow' then result := BGRA(255,255,0) else 2299 if str='navy' then result := BGRA(0,0,128) else 2300 if str='blue' then result := BGRA(0,0,255) else 2301 if str='teal' then result := BGRA(0,128,128) else 2302 if str='aqua' then result := BGRA(0,255,255) else 2303 if str='transparent' then result := BGRAPixelTransparent else 2304 begin 2305 //check CSS color 2306 idx := CSSColors.IndexOf(str); 2307 if idx <> -1 then 2308 begin 2309 result := CSSColors[idx]; 2310 exit; 2311 end; 2312 2313 //CSS RGB notation 2314 if (copy(str,1,4)='rgb(') or (copy(str,1,5)='rgba(') then 2315 begin 2316 values := SimpleParseFuncParam(str); 2317 if (length(values)=3) or (length(values)=4) then 2318 begin 2319 result.red := ParseColorValue(values[0]); 2320 result.green := ParseColorValue(values[1]); 2321 result.blue := ParseColorValue(values[2]); 2322 if length(values)=4 then 2323 begin 2324 val(values[3],alphaF,errPos); 2325 if alphaF < 0 then 2326 result.alpha := 0 else 2327 if alphaF > 1 then 2328 result.alpha := 255 2329 else 2330 result.alpha := round(alphaF*255); 2331 end else 2332 result.alpha := 255; 2333 end else 2334 result := BGRAPixelTransparent; 2335 exit; 2336 end; 2337 2338 //remove HTML notation header 2339 if str[1]='#' then delete(str,1,1); 2340 2341 //add alpha if missing 2342 if length(str)=6 then str += 'FF'; 2343 if length(str)=3 then str += 'F'; 2344 2345 //hex notation 2346 if length(str)=8 then 2347 begin 2348 val('$'+copy(str,1,2),result.red,errPos); 2349 val('$'+copy(str,3,2),result.green,errPos); 2350 val('$'+copy(str,5,2),result.blue,errPos); 2351 val('$'+copy(str,7,2),result.alpha,errPos); 2352 end else 2353 if length(str)=4 then 2354 begin 2355 val('$'+copy(str,1,1),result.red,errPos); 2356 val('$'+copy(str,2,1),result.green,errPos); 2357 val('$'+copy(str,3,1),result.blue,errPos); 2358 val('$'+copy(str,4,1),result.alpha,errPos); 2359 result.red *= $11; 2360 result.green *= $11; 2361 result.blue *= $11; 2362 result.alpha *= $11; 2363 end else 2364 result := BGRAPixelTransparent; 2365 end; 2366 2367 end; 2368 2369 2370 function MapHeight(Color: TBGRAPixel): Single; 2371 var intval: integer; 2372 begin 2373 intval := color.Green shl 16 + color.red shl 8 + color.blue; 2374 result := intval/16777215; 2375 end; 2376 2377 function MapHeightToBGRA(Height: Single; Alpha: Byte): TBGRAPixel; 2378 var intval: integer; 2379 begin 2380 if Height >= 1 then result := BGRA(255,255,255,alpha) else 2381 if Height <= 0 then result := BGRA(0,0,0,alpha) else 2382 begin 2383 intval := round(Height*16777215); 2384 result := BGRA(intval shr 8,intval shr 16,intval,alpha); 2385 end; 2386 end; 2387 2388 {********************** Point functions **************************} 2389 524 2390 function PointF(x, y: single): TPointF; 525 2391 begin 526 2392 Result.x := x; 527 2393 Result.y := y; 2394 end; 2395 2396 function PointsF(const pts: array of TPointF): ArrayOfTPointF; 2397 var 2398 i: Integer; 2399 begin 2400 setlength(result, length(pts)); 2401 for i := 0 to high(pts) do result[i] := pts[i]; 2402 end; 2403 2404 operator =(const pt1, pt2: TPointF): boolean; 2405 begin 2406 result := (pt1.x = pt2.x) and (pt1.y = pt2.y); 2407 end; 2408 2409 operator-(const pt1, pt2: TPointF): TPointF; 2410 begin 2411 result.x := pt1.x-pt2.x; 2412 result.y := pt1.y-pt2.y; 2413 end; 2414 2415 operator-(const pt2: TPointF): TPointF; 2416 begin 2417 result.x := -pt2.x; 2418 result.y := -pt2.y; 2419 end; 2420 2421 operator+(const pt1, pt2: TPointF): TPointF; 2422 begin 2423 result.x := pt1.x+pt2.x; 2424 result.y := pt1.y+pt2.y; 2425 end; 2426 2427 operator*(const pt1, pt2: TPointF): single; 2428 begin 2429 result := pt1.x*pt2.x + pt1.y*pt2.y; 2430 end; 2431 2432 operator*(const pt1: TPointF; factor: single): TPointF; 2433 begin 2434 result.x := pt1.x*factor; 2435 result.y := pt1.y*factor; 2436 end; 2437 2438 operator*(factor: single; const pt1: TPointF): TPointF; 2439 begin 2440 result.x := pt1.x*factor; 2441 result.y := pt1.y*factor; 528 2442 end; 529 2443 … … 548 2462 end; 549 2463 550 function StrToGradientType(str: string): TGradientType; 551 var gt: TGradientType; 552 begin 553 result := gtLinear; 554 str := LowerCase(str); 555 for gt := low(TGradientType) to high(TGradientType) do 556 if str = LowerCase(GradientTypeStr[gt]) then 2464 function VectLen(dx, dy: single): single; 2465 begin 2466 result := sqrt(dx*dx+dy*dy); 2467 end; 2468 2469 function VectLen(v: TPointF): single; 2470 begin 2471 result := sqrt(v.x*v.x+v.y*v.y); 2472 end; 2473 2474 function IntersectLine(line1, line2: TLineDef): TPointF; 2475 var parallel: boolean; 2476 begin 2477 result := IntersectLine(line1,line2,parallel); 2478 end; 2479 2480 function IntersectLine(line1, line2: TLineDef; out parallel: boolean): TPointF; 2481 var divFactor: double; 2482 begin 2483 parallel := false; 2484 //if lines are parallel 2485 if ((line1.dir.x = line2.dir.x) and (line1.dir.y = line2.dir.y)) or 2486 ((abs(line1.dir.y) < 1e-6) and (abs(line2.dir.y) < 1e-6)) then 2487 begin 2488 parallel := true; 2489 //return the center of the segment between line origins 2490 result.x := (line1.origin.x+line2.origin.x)/2; 2491 result.y := (line1.origin.y+line2.origin.y)/2; 2492 end else 2493 if abs(line1.dir.y) < 1e-6 then //line1 is horizontal 2494 begin 2495 result.y := line1.origin.y; 2496 result.x := line2.origin.x + (result.y - line2.origin.y) 2497 /line2.dir.y*line2.dir.x; 2498 end else 2499 if abs(line2.dir.y) < 1e-6 then //line2 is horizontal 2500 begin 2501 result.y := line2.origin.y; 2502 result.x := line1.origin.x + (result.y - line1.origin.y) 2503 /line1.dir.y*line1.dir.x; 2504 end else 2505 begin 2506 divFactor := line1.dir.x/line1.dir.y - line2.dir.x/line2.dir.y; 2507 if abs(divFactor) < 1e-6 then //almost parallel 2508 begin 2509 parallel := true; 2510 //return the center of the segment between line origins 2511 result.x := (line1.origin.x+line2.origin.x)/2; 2512 result.y := (line1.origin.y+line2.origin.y)/2; 2513 end else 2514 begin 2515 result.y := (line2.origin.x - line1.origin.x + 2516 line1.origin.y*line1.dir.x/line1.dir.y - 2517 line2.origin.y*line2.dir.x/line2.dir.y) 2518 / divFactor; 2519 result.x := line1.origin.x + (result.y - line1.origin.y) 2520 /line1.dir.y*line1.dir.x; 2521 end; 2522 end; 2523 end; 2524 2525 { Check if a polygon is convex, i.e. it always turns in the same direction } 2526 function IsConvex(const pts: array of TPointF; IgnoreAlign: boolean = true): boolean; 2527 var 2528 positive,negative,zero: boolean; 2529 product: single; 2530 i: Integer; 2531 begin 2532 positive := false; 2533 negative := false; 2534 zero := false; 2535 for i := 0 to high(pts) do 2536 begin 2537 product := (pts[(i+1) mod length(pts)].x-pts[i].x)*(pts[(i+2) mod length(pts)].y-pts[i].y) - 2538 (pts[(i+1) mod length(pts)].y-pts[i].y)*(pts[(i+2) mod length(pts)].x-pts[i].x); 2539 if product > 0 then 557 2540 begin 558 result := gt; 559 exit; 2541 if negative then 2542 begin 2543 result := false; 2544 exit; 2545 end; 2546 positive := true; 2547 end else 2548 if product < 0 then 2549 begin 2550 if positive then 2551 begin 2552 result := false; 2553 exit; 2554 end; 2555 negative := true; 2556 end else 2557 zero := true; 2558 end; 2559 if not IgnoreAlign and zero then 2560 result := false 2561 else 2562 result := true; 2563 end; 2564 2565 { Check if two segments intersect } 2566 function DoesSegmentIntersect(pt1,pt2,pt3,pt4: TPointF): boolean; 2567 var 2568 seg1: TLineDef; 2569 seg1len: single; 2570 seg2: TLineDef; 2571 seg2len: single; 2572 inter: TPointF; 2573 pos1,pos2: single; 2574 para: boolean; 2575 2576 begin 2577 { Determine line definitions } 2578 seg1.origin := pt1; 2579 seg1.dir := pt2-pt1; 2580 seg1len := sqrt(sqr(seg1.dir.X)+sqr(seg1.dir.Y)); 2581 if seg1len = 0 then 2582 begin 2583 result := false; 2584 exit; 2585 end; 2586 seg1.dir *= 1/seg1len; 2587 2588 seg2.origin := pt3; 2589 seg2.dir := pt4-pt3; 2590 seg2len := sqrt(sqr(seg2.dir.X)+sqr(seg2.dir.Y)); 2591 if seg2len = 0 then 2592 begin 2593 result := false; 2594 exit; 2595 end; 2596 seg2.dir *= 1/seg2len; 2597 2598 //obviously parallel 2599 if seg1.dir = seg2.dir then 2600 result := false 2601 else 2602 begin 2603 //try to compute intersection 2604 inter := IntersectLine(seg1,seg2,para); 2605 if para then 2606 result := false 2607 else 2608 begin 2609 //check if intersections are inside the segments 2610 pos1 := (inter-seg1.origin)*seg1.dir; 2611 pos2 := (inter-seg2.origin)*seg2.dir; 2612 if (pos1 >= 0) and (pos1 <= seg1len) and 2613 (pos2 >= 0) and (pos2 <= seg2len) then 2614 result := true 2615 else 2616 result := false; 560 2617 end; 561 end; 562 563 function BGRAToStr(c: TBGRAPixel): string; 564 begin 565 result := IntToHex(c.red,2)+IntToHex(c.green,2)+IntToHex(c.Blue,2)+IntToHex(c.Alpha,2); 566 end; 567 568 {$hints off} 569 {$notes off} 570 function StrToBGRA(str: string): TBGRAPixel; 571 var errPos: integer; 572 begin 573 if length(str)=6 then str += 'FF'; 574 if length(str)=3 then str += 'F'; 575 if length(str)=8 then 576 begin 577 val('$'+copy(str,1,2),result.red,errPos); 578 val('$'+copy(str,3,2),result.green,errPos); 579 val('$'+copy(str,5,2),result.blue,errPos); 580 val('$'+copy(str,7,2),result.alpha,errPos); 2618 end; 2619 end; 2620 2621 { Check if a quaduadrilateral intersects itself } 2622 function DoesQuadIntersect(pt1,pt2,pt3,pt4: TPointF): boolean; 2623 begin 2624 result := DoesSegmentIntersect(pt1,pt2,pt3,pt4) or DoesSegmentIntersect(pt2,pt3,pt4,pt1); 2625 end; 2626 2627 {************************** Cyclic functions *******************} 2628 2629 // Get the cyclic value in the range [0..cycle-1] 2630 function PositiveMod(value, cycle: integer): integer; inline; 2631 begin 2632 result := value mod cycle; 2633 if result < 0 then //modulo can be negative 2634 Inc(result, cycle); 2635 end; 2636 2637 { Table of precalc values. Note : the value is stored for 2638 the first half of the cycle, and values are stored 'minus 1' 2639 in order to stay in the range 0..65535 } 2640 var 2641 sinTab65536: packed array of word; 2642 2643 function Sin65536(value: word): integer; 2644 var b: integer; 2645 begin 2646 //allocate array 2647 if sinTab65536 = nil then 2648 setlength(sinTab65536,32768); 2649 2650 if value >= 32768 then //function is upside down after half-period 2651 begin 2652 b := value xor 32768; 2653 if sinTab65536[b] = 0 then //precalc 2654 sinTab65536[b] := round((sin(b*2*Pi/65536)+1)*65536/2)-1; 2655 result := not sinTab65536[b]; 581 2656 end else 582 if length(str)=4 then 583 begin 584 val('$'+copy(str,1,1),result.red,errPos); 585 val('$'+copy(str,2,1),result.green,errPos); 586 val('$'+copy(str,3,1),result.blue,errPos); 587 val('$'+copy(str,4,1),result.alpha,errPos); 588 result.red *= $11; 589 result.green *= $11; 590 result.blue *= $11; 591 result.alpha *= $11; 592 end else 593 result := BGRAPixelTransparent; 594 end; 595 {$notes on} 596 {$hints on} 2657 begin 2658 b := value; 2659 if sinTab65536[b] = 0 then //precalc 2660 sinTab65536[b] := round((sin(b*2*Pi/65536)+1)*65536/2)-1; 2661 {$hints off} 2662 result := sinTab65536[b]+1; 2663 {$hints on} 2664 end; 2665 end; 2666 2667 function Cos65536(value: word): integer; 2668 begin 2669 result := Sin65536(value+16384); //cosine is translated 2670 end; 2671 2672 procedure PrecalcSin65536; 2673 var 2674 i: Integer; 2675 begin 2676 for i := 0 to 32767 do Sin65536(i); 2677 end; 597 2678 598 2679 initialization 599 2680 600 2681 InitGamma; 2682 CSSColors := TBGRAColorList.Create; 2683 CSSColors.Add('AliceBlue',CSSAliceBlue); 2684 CSSColors.Add('AntiqueWhite',CSSAntiqueWhite); 2685 CSSColors.Add('Aqua',CSSAqua); 2686 CSSColors.Add('Aquamarine',CSSAquamarine); 2687 CSSColors.Add('Azure',CSSAzure); 2688 CSSColors.Add('Beige',CSSBeige); 2689 CSSColors.Add('Bisque',CSSBisque); 2690 CSSColors.Add('Black',CSSBlack); 2691 CSSColors.Add('BlanchedAlmond',CSSBlanchedAlmond); 2692 CSSColors.Add('Blue',CSSBlue); 2693 CSSColors.Add('BlueViolet',CSSBlueViolet); 2694 CSSColors.Add('Brown',CSSBrown); 2695 CSSColors.Add('BurlyWood',CSSBurlyWood); 2696 CSSColors.Add('CadetBlue',CSSCadetBlue); 2697 CSSColors.Add('Chartreuse',CSSChartreuse); 2698 CSSColors.Add('Chocolate',CSSChocolate); 2699 CSSColors.Add('Coral',CSSCoral); 2700 CSSColors.Add('CornflowerBlue',CSSCornflowerBlue); 2701 CSSColors.Add('Cornsilk',CSSCornsilk); 2702 CSSColors.Add('Crimson',CSSCrimson); 2703 CSSColors.Add('Cyan',CSSCyan); 2704 CSSColors.Add('DarkBlue',CSSDarkBlue); 2705 CSSColors.Add('DarkCyan',CSSDarkCyan); 2706 CSSColors.Add('DarkGoldenrod',CSSDarkGoldenrod); 2707 CSSColors.Add('DarkGray',CSSDarkGray); 2708 CSSColors.Add('DarkGreen',CSSDarkGreen); 2709 CSSColors.Add('DarkKhaki',CSSDarkKhaki); 2710 CSSColors.Add('DarkMagenta',CSSDarkMagenta); 2711 CSSColors.Add('DarkOliveGreen',CSSDarkOliveGreen); 2712 CSSColors.Add('DarkOrange',CSSDarkOrange); 2713 CSSColors.Add('DarkOrchid',CSSDarkOrchid); 2714 CSSColors.Add('DarkRed',CSSDarkRed); 2715 CSSColors.Add('DarkSalmon',CSSDarkSalmon); 2716 CSSColors.Add('DarkSeaGreen',CSSDarkSeaGreen); 2717 CSSColors.Add('DarkSlateBlue',CSSDarkSlateBlue); 2718 CSSColors.Add('DarkSlateGray',CSSDarkSlateGray); 2719 CSSColors.Add('DarkTurquoise',CSSDarkTurquoise); 2720 CSSColors.Add('DarkViolet',CSSDarkViolet); 2721 CSSColors.Add('DeepPink',CSSDeepPink); 2722 CSSColors.Add('DeepSkyBlue',CSSDeepSkyBlue); 2723 CSSColors.Add('DimGray',CSSDimGray); 2724 CSSColors.Add('DodgerBlue',CSSDodgerBlue); 2725 CSSColors.Add('FireBrick',CSSFireBrick); 2726 CSSColors.Add('FloralWhite',CSSFloralWhite); 2727 CSSColors.Add('ForestGreen',CSSForestGreen); 2728 CSSColors.Add('Fuchsia',CSSFuchsia); 2729 CSSColors.Add('Gainsboro',CSSGainsboro); 2730 CSSColors.Add('GhostWhite',CSSGhostWhite); 2731 CSSColors.Add('Gold',CSSGold); 2732 CSSColors.Add('Goldenrod',CSSGoldenrod); 2733 CSSColors.Add('Gray',CSSGray); 2734 CSSColors.Add('Green',CSSGreen); 2735 CSSColors.Add('GreenYellow',CSSGreenYellow); 2736 CSSColors.Add('Honeydew',CSSHoneydew); 2737 CSSColors.Add('HotPink',CSSHotPink); 2738 CSSColors.Add('IndianRed',CSSIndianRed); 2739 CSSColors.Add('Indigo',CSSIndigo); 2740 CSSColors.Add('Ivory',CSSIvory); 2741 CSSColors.Add('Khaki',CSSKhaki); 2742 CSSColors.Add('Lavender',CSSLavender); 2743 CSSColors.Add('LavenderBlush',CSSLavenderBlush); 2744 CSSColors.Add('LawnGreen',CSSLawnGreen); 2745 CSSColors.Add('LemonChiffon',CSSLemonChiffon); 2746 CSSColors.Add('LightBlue',CSSLightBlue); 2747 CSSColors.Add('LightCoral',CSSLightCoral); 2748 CSSColors.Add('LightCyan',CSSLightCyan); 2749 CSSColors.Add('LightGoldenrodYellow',CSSLightGoldenrodYellow); 2750 CSSColors.Add('LightGray',CSSLightGray); 2751 CSSColors.Add('LightGreen',CSSLightGreen); 2752 CSSColors.Add('LightPink',CSSLightPink); 2753 CSSColors.Add('LightSalmon',CSSLightSalmon); 2754 CSSColors.Add('LightSeaGreen',CSSLightSeaGreen); 2755 CSSColors.Add('LightSkyBlue',CSSLightSkyBlue); 2756 CSSColors.Add('LightSlateGray',CSSLightSlateGray); 2757 CSSColors.Add('LightSteelBlue',CSSLightSteelBlue); 2758 CSSColors.Add('LightYellow',CSSLightYellow); 2759 CSSColors.Add('Lime',CSSLime); 2760 CSSColors.Add('LimeGreen',CSSLimeGreen); 2761 CSSColors.Add('Linen',CSSLinen); 2762 CSSColors.Add('Magenta',CSSMagenta); 2763 CSSColors.Add('Maroon',CSSMaroon); 2764 CSSColors.Add('MediumAquamarine',CSSMediumAquamarine); 2765 CSSColors.Add('MediumBlue',CSSMediumBlue); 2766 CSSColors.Add('MediumOrchid',CSSMediumOrchid); 2767 CSSColors.Add('MediumPurple',CSSMediumPurple); 2768 CSSColors.Add('MediumSeaGreen',CSSMediumSeaGreen); 2769 CSSColors.Add('MediumSlateBlue',CSSMediumSlateBlue); 2770 CSSColors.Add('MediumSpringGreen',CSSMediumSpringGreen); 2771 CSSColors.Add('MediumTurquoise',CSSMediumTurquoise); 2772 CSSColors.Add('MediumVioletRed',CSSMediumVioletRed); 2773 CSSColors.Add('MidnightBlue',CSSMidnightBlue); 2774 CSSColors.Add('MintCream',CSSMintCream); 2775 CSSColors.Add('MistyRose',CSSMistyRose); 2776 CSSColors.Add('Moccasin',CSSMoccasin); 2777 CSSColors.Add('NavajoWhite',CSSNavajoWhite); 2778 CSSColors.Add('Navy',CSSNavy); 2779 CSSColors.Add('OldLace',CSSOldLace); 2780 CSSColors.Add('Olive',CSSOlive); 2781 CSSColors.Add('OliveDrab',CSSOliveDrab); 2782 CSSColors.Add('Orange',CSSOrange); 2783 CSSColors.Add('OrangeRed',CSSOrangeRed); 2784 CSSColors.Add('Orchid',CSSOrchid); 2785 CSSColors.Add('PaleGoldenrod',CSSPaleGoldenrod); 2786 CSSColors.Add('PaleGreen',CSSPaleGreen); 2787 CSSColors.Add('PaleTurquoise',CSSPaleTurquoise); 2788 CSSColors.Add('PaleVioletRed',CSSPaleVioletRed); 2789 CSSColors.Add('PapayaWhip',CSSPapayaWhip); 2790 CSSColors.Add('PeachPuff',CSSPeachPuff); 2791 CSSColors.Add('Peru',CSSPeru); 2792 CSSColors.Add('Pink',CSSPink); 2793 CSSColors.Add('Plum',CSSPlum); 2794 CSSColors.Add('PowderBlue',CSSPowderBlue); 2795 CSSColors.Add('Purple',CSSPurple); 2796 CSSColors.Add('Red',CSSRed); 2797 CSSColors.Add('RosyBrown',CSSRosyBrown); 2798 CSSColors.Add('RoyalBlue',CSSRoyalBlue); 2799 CSSColors.Add('SaddleBrown',CSSSaddleBrown); 2800 CSSColors.Add('Salmon',CSSSalmon); 2801 CSSColors.Add('SandyBrown',CSSSandyBrown); 2802 CSSColors.Add('SeaGreen',CSSSeaGreen); 2803 CSSColors.Add('Seashell',CSSSeashell); 2804 CSSColors.Add('Sienna',CSSSienna); 2805 CSSColors.Add('Silver',CSSSilver); 2806 CSSColors.Add('SkyBlue',CSSSkyBlue); 2807 CSSColors.Add('SlateBlue',CSSSlateBlue); 2808 CSSColors.Add('SlateGray',CSSSlateGray); 2809 CSSColors.Add('Snow',CSSSnow); 2810 CSSColors.Add('SpringGreen',CSSSpringGreen); 2811 CSSColors.Add('SteelBlue',CSSSteelBlue); 2812 CSSColors.Add('Tan',CSSTan); 2813 CSSColors.Add('Teal',CSSTeal); 2814 CSSColors.Add('Thistle',CSSThistle); 2815 CSSColors.Add('Tomato',CSSTomato); 2816 CSSColors.Add('Turquoise',CSSTurquoise); 2817 CSSColors.Add('Violet',CSSViolet); 2818 CSSColors.Add('Wheat',CSSWheat); 2819 CSSColors.Add('White',CSSWhite); 2820 CSSColors.Add('WhiteSmoke',CSSWhiteSmoke); 2821 CSSColors.Add('Yellow',CSSYellow); 2822 CSSColors.Add('YellowGreen',CSSYellowGreen); 2823 CSSColors.Finished; 2824 2825 finalization 2826 2827 CSSColors.Free; 601 2828 602 2829 end. 603 -
GraphicTest/BGRABitmap/bgrablend.pas
r210 r317 1 1 unit BGRABlend; 2 3 { This unit contains pixel blending functions. They take a destination adress as parameter, 4 and draw pixels at this address with different blending modes. These functions are used 5 by many functions in BGRABitmap library to do the low level drawing. } 2 6 3 7 {$mode objfpc}{$H+} … … 8 12 Classes, SysUtils, BGRABitmapTypes; 9 13 14 { Draw one pixel with alpha blending } 15 procedure DrawPixelInlineWithAlphaCheck(dest: PBGRAPixel; const c: TBGRAPixel); inline; overload; 16 procedure DrawPixelInlineWithAlphaCheck(dest: PBGRAPixel; c: TBGRAPixel; appliedOpacity: byte); inline; overload; 17 procedure DrawExpandedPixelInlineWithAlphaCheck(dest: PBGRAPixel; const ec: TExpandedPixel); inline; overload; 18 procedure DrawPixelInlineExpandedOrNotWithAlphaCheck(dest: PBGRAPixel; const ec: TExpandedPixel; c: TBGRAPixel); inline; overload; //alpha in 'c' parameter 19 procedure DrawPixelInlineNoAlphaCheck(dest: PBGRAPixel; const c: TBGRAPixel); inline; overload; 20 procedure DrawExpandedPixelInlineNoAlphaCheck(dest: PBGRAPixel; const ec: TExpandedPixel; calpha: byte); inline; overload; 21 22 procedure CopyPixelsWithOpacity(dest,src: PBGRAPixel; opacity: byte; Count: integer); inline; 23 function ApplyOpacity(opacity1,opacity2: byte): byte; inline; 24 function FastRoundDiv255(value: cardinal): cardinal; inline; 25 26 { Draw a series of pixels with alpha blending } 27 procedure DrawPixelsInline(dest: PBGRAPixel; c: TBGRAPixel; Count: integer); inline; overload; 28 procedure DrawExpandedPixelsInline(dest: PBGRAPixel; ec: TExpandedPixel; Count: integer); inline; overload; 29 procedure DrawPixelsInlineExpandedOrNot(dest: PBGRAPixel; ec: TExpandedPixel; c: TBGRAPixel; Count: integer); inline; overload; //alpha in 'c' parameter 30 31 { Draw one pixel with linear alpha blending } 32 procedure FastBlendPixelInline(dest: PBGRAPixel; const c: TBGRAPixel); inline; overload; 33 procedure FastBlendPixelInline(dest: PBGRAPixel; c: TBGRAPixel; appliedOpacity: byte); inline; overload; 34 35 { Draw a series of pixels with linear alpha blending } 36 procedure FastBlendPixelsInline(dest: PBGRAPixel; c: TBGRAPixel; Count: integer); inline; 37 38 { Replace a series of pixels } 39 procedure FillInline(dest: PBGRAPixel; c: TBGRAPixel; Count: integer); inline; 40 41 { Xor a series of pixels } 42 procedure XorInline(dest: PBGRAPixel; c: TBGRAPixel; Count: integer); inline; 43 procedure XorPixels(pdest, psrc: PBGRAPixel; count: integer); 44 45 { Set alpha value for a series of pixels } 46 procedure AlphaFillInline(dest: PBGRAPixel; alpha: byte; Count: integer); inline; 47 48 { Erase a series of pixels, i.e. decrease alpha value } 49 procedure ErasePixelInline(dest: PBGRAPixel; alpha: byte); inline; 50 51 { Draw a pixel to the extent the current pixel is close enough to compare value. 52 It should not be called on pixels that have not been checked to be close enough } 53 procedure DrawPixelInlineDiff(dest: PBGRAPixel; c, compare: TBGRAPixel; 54 maxDiff: byte); inline; 55 { Draw a series of pixel to the extent the current pixel is close enough to compare value } 56 procedure DrawPixelsInlineDiff(dest: PBGRAPixel; c: TBGRAPixel; 57 Count: integer; compare: TBGRAPixel; maxDiff: byte); inline; 58 59 { Blend pixels with scanner content } 60 procedure ScannerPutPixels(scan: IBGRAScanner; pdest: PBGRAPixel; count: integer; mode: TDrawMode); 61 62 { Perform advanced blending operation } 10 63 procedure BlendPixels(pdest: PBGRAPixel; psrc: PBGRAPixel; 11 64 blendOp: TBlendOperation; Count: integer); 12 65 13 procedure DrawPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline;14 procedure DrawPixelsInline(dest: PBGRAPixel; c: TBGRAPixel; Count: integer); inline;15 16 procedure FillInline(dest: PBGRAPixel; c: TBGRAPixel; Count: integer); inline;17 procedure AlphaFillInline(dest: PBGRAPixel; alpha: byte; Count: integer); inline;18 procedure ErasePixelInline(dest: PBGRAPixel; alpha: byte); inline;19 20 procedure FastBlendPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline;21 procedure FastBlendPixelsInline(dest: PBGRAPixel; c: TBGRAPixel; Count: integer); inline;22 23 procedure DrawPixelInlineDiff(dest: PBGRAPixel; c, compare: TBGRAPixel;24 maxDiff: byte); inline;25 procedure DrawPixelsInlineDiff(dest: PBGRAPixel; c: TBGRAPixel;26 Count: integer; compare: TBGRAPixel; maxDiff: byte); inline;27 28 66 //layer blend modes ( http://www.pegtop.net/delphi/articles/blendmodes/ ) 29 procedure MultiplyPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline;30 67 procedure LinearMultiplyPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline; 31 68 procedure AddPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline; … … 34 71 procedure ColorDodgePixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline; 35 72 procedure ReflectPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline; 73 procedure NonLinearReflectPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline; 36 74 procedure GlowPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline; 75 procedure NiceGlowPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline; 37 76 procedure OverlayPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline; 77 procedure LinearOverlayPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline; 38 78 procedure DifferencePixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline; 39 79 procedure LinearDifferencePixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline; … … 47 87 implementation 48 88 89 procedure ScannerPutPixels(scan: IBGRAScanner; pdest: PBGRAPixel; count: integer; mode: TDrawMode); 90 var c : TBGRAPixel; 91 i: Integer; 92 scanNextFunc: function(): TBGRAPixel of object; 93 begin 94 if scan.IsScanPutPixelsDefined then 95 scan.ScanPutPixels(pdest,count,mode) else 96 begin 97 scanNextFunc := @scan.ScanNextPixel; 98 case mode of 99 dmLinearBlend: 100 for i := 0 to count-1 do 101 begin 102 FastBlendPixelInline(pdest, scanNextFunc()); 103 inc(pdest); 104 end; 105 dmDrawWithTransparency: 106 for i := 0 to count-1 do 107 begin 108 DrawPixelInlineWithAlphaCheck(pdest, scanNextFunc()); 109 inc(pdest); 110 end; 111 dmSet: 112 for i := 0 to count-1 do 113 begin 114 pdest^ := scanNextFunc(); 115 inc(pdest); 116 end; 117 dmXor: 118 for i := 0 to count-1 do 119 begin 120 PDWord(pdest)^ := PDWord(pdest)^ xor DWord(scanNextFunc()); 121 inc(pdest); 122 end; 123 dmSetExceptTransparent: 124 for i := 0 to count-1 do 125 begin 126 c := scanNextFunc(); 127 if c.alpha = 255 then pdest^ := c; 128 inc(pdest); 129 end; 130 end; 131 end; 132 end; 133 49 134 procedure BlendPixels(pdest: PBGRAPixel; psrc: PBGRAPixel; 50 135 blendOp: TBlendOperation; Count: integer); … … 61 146 boTransparent: while Count > 0 do 62 147 begin 63 DrawPixelInline (pdest, psrc^);148 DrawPixelInlineWithAlphaCheck(pdest, psrc^); 64 149 Inc(pdest); 65 150 Inc(psrc); … … 69 154 boMultiply: while Count > 0 do 70 155 begin 71 MultiplyPixelInline(pdest, psrc^); 72 Inc(pdest); 73 Inc(psrc); 74 Dec(Count); 75 end; 76 77 boLinearMultiply: while Count > 0 do 78 begin 79 LinearMultiplyPixelInline(pdest, psrc^); 156 LinearMultiplyPixelInline(pdest, psrc^); //same look with non linear 80 157 Inc(pdest); 81 158 Inc(psrc); … … 131 208 end; 132 209 210 boNiceGlow: while Count > 0 do 211 begin 212 NiceGlowPixelInline(pdest, psrc^); 213 Inc(pdest); 214 Inc(psrc); 215 Dec(Count); 216 end; 217 133 218 boOverlay: while Count > 0 do 134 219 begin 220 LinearOverlayPixelInline(pdest, psrc^); 221 Inc(pdest); 222 Inc(psrc); 223 Dec(Count); 224 end; 225 226 boDarkOverlay: while Count > 0 do 227 begin 135 228 OverlayPixelInline(pdest, psrc^); 136 229 Inc(pdest); … … 202 295 Dec(Count); 203 296 end; 297 end; 298 end; 299 300 procedure XorInline(dest: PBGRAPixel; c: TBGRAPixel; Count: integer); 301 begin 302 while Count > 0 do 303 begin 304 PDWord(dest)^ := PDWord(dest)^ xor DWord(c); 305 Inc(dest); 306 Dec(Count); 307 end; 308 end; 309 310 procedure XorPixels(pdest, psrc: PBGRAPixel; count: integer); 311 begin 312 while Count > 0 do 313 begin 314 PDWord(pdest)^ := PDWord(psrc)^ xor PDWord(pdest)^; 315 Inc(pdest); 316 Inc(psrc); 317 Dec(Count); 204 318 end; 205 319 end; … … 224 338 n: integer; 225 339 begin 340 if c.alpha = 0 then exit; 226 341 for n := Count - 1 downto 0 do 227 342 begin … … 234 349 var 235 350 n: integer; 236 begin 351 ec: TExpandedPixel; 352 begin 353 if c.alpha = 0 then exit; 354 if c.alpha = 255 then 355 begin 356 filldword(dest^,count,longword(c)); 357 exit; 358 end; 359 ec := GammaExpansion(c); 237 360 for n := Count - 1 downto 0 do 238 361 begin 239 DrawPixelInline(dest, c); 362 DrawExpandedPixelInlineNoAlphaCheck(dest, ec,c.alpha); 363 Inc(dest); 364 end; 365 end; 366 367 procedure DrawExpandedPixelsInline(dest: PBGRAPixel; ec: TExpandedPixel; 368 Count: integer); 369 var 370 n: integer; 371 c: TBGRAPixel; 372 begin 373 if ec.alpha < $0100 then exit; 374 if ec.alpha >= $FF00 then 375 begin 376 c := GammaCompression(ec); 377 filldword(dest^,count,longword(c)); 378 exit; 379 end; 380 for n := Count - 1 downto 0 do 381 begin 382 DrawExpandedPixelInlineNoAlphaCheck(dest, ec, ec.alpha shr 8); 383 Inc(dest); 384 end; 385 end; 386 387 procedure DrawPixelsInlineExpandedOrNot(dest: PBGRAPixel; ec: TExpandedPixel; c: TBGRAPixel; Count: integer 388 ); 389 var 390 n: integer; 391 begin 392 if c.alpha = 0 then exit; 393 if c.alpha = 255 then 394 begin 395 filldword(dest^,count,longword(c)); 396 exit; 397 end; 398 for n := Count - 1 downto 0 do 399 begin 400 DrawExpandedPixelInlineNoAlphaCheck(dest, ec, c.alpha); 240 401 Inc(dest); 241 402 end; … … 255 416 256 417 {$hints off} 257 procedure DrawPixelInline(dest: PBGRAPixel; c: TBGRAPixel); 418 procedure DrawPixelInlineWithAlphaCheck(dest: PBGRAPixel; const c: TBGRAPixel); 419 begin 420 if c.alpha = 0 then 421 exit; 422 if c.alpha = 255 then 423 begin 424 dest^ := c; 425 exit; 426 end; 427 DrawPixelInlineNoAlphaCheck(dest,c); 428 end; 429 430 procedure DrawPixelInlineWithAlphaCheck(dest: PBGRAPixel; c: TBGRAPixel; appliedOpacity: byte); 431 begin 432 c.alpha := ApplyOpacity(c.alpha,appliedOpacity); 433 if c.alpha = 0 then 434 exit; 435 if c.alpha = 255 then 436 begin 437 dest^ := c; 438 exit; 439 end; 440 DrawPixelInlineNoAlphaCheck(dest,c); 441 end; 442 443 procedure CopyPixelsWithOpacity(dest, src: PBGRAPixel; opacity: byte; 444 Count: integer); 445 var c: TBGRAPixel; 446 begin 447 while count > 0 do 448 begin 449 c := src^; 450 c.alpha := ApplyOpacity(c.alpha,opacity); 451 dest^ := c; 452 inc(src); 453 inc(dest); 454 dec(count); 455 end; 456 end; 457 458 function ApplyOpacity(opacity1, opacity2: byte): byte; 459 begin 460 result := opacity1*(opacity2+1) shr 8; 461 end; 462 463 function FastRoundDiv255(value: cardinal): cardinal; inline; 464 begin 465 result := (value + (value shr 7)) shr 8; 466 end; 467 468 procedure DrawExpandedPixelInlineWithAlphaCheck(dest: PBGRAPixel; const ec: TExpandedPixel); 469 var 470 calpha: byte; 471 begin 472 calpha := ec.alpha shr 8; 473 if calpha = 0 then 474 exit; 475 if calpha = 255 then 476 begin 477 dest^ := GammaCompression(ec); 478 exit; 479 end; 480 DrawExpandedPixelInlineNoAlphaCheck(dest,ec,calpha); 481 end; 482 483 procedure DrawPixelInlineExpandedOrNotWithAlphaCheck(dest: PBGRAPixel; const ec: TExpandedPixel; c: TBGRAPixel); 484 begin 485 if c.alpha = 0 then 486 exit; 487 if c.alpha = 255 then 488 begin 489 dest^ := c; 490 exit; 491 end; 492 DrawExpandedPixelInlineNoAlphaCheck(dest,ec,c.alpha); 493 end; 494 495 procedure DrawPixelInlineNoAlphaCheck(dest: PBGRAPixel; const c: TBGRAPixel); 258 496 var 259 497 p: PByte; 260 498 a1f, a2f, a12, a12m: cardinal; 261 499 begin 262 if c.alpha = 0 then263 exit;264 if c.alpha = 255 then265 begin266 dest^ := c;267 exit;268 end;269 270 500 a12 := 65025 - (not dest^.alpha) * (not c.alpha); 271 501 a12m := a12 shr 1; … … 289 519 end; 290 520 291 procedure FastBlendPixelInline(dest: PBGRAPixel; c: TBGRAPixel); 521 procedure DrawExpandedPixelInlineNoAlphaCheck(dest: PBGRAPixel; 522 const ec: TExpandedPixel; calpha: byte); 523 var 524 p: PByte; 525 a1f, a2f, a12, a12m: cardinal; 526 begin 527 a12 := 65025 - (not dest^.alpha) * (not calpha); 528 a12m := a12 shr 1; 529 530 a1f := dest^.alpha * (not calpha); 531 a2f := (calpha shl 8) - calpha; 532 533 p := PByte(dest); 534 535 p^ := GammaCompressionTab[(GammaExpansionTab[dest^.blue] * a1f + 536 ec.blue * a2f + a12m) div a12]; 537 Inc(p); 538 p^ := GammaCompressionTab[(GammaExpansionTab[dest^.green] * a1f + 539 ec.green * a2f + a12m) div a12]; 540 Inc(p); 541 p^ := GammaCompressionTab[(GammaExpansionTab[dest^.red] * a1f + 542 ec.red * a2f + a12m) div a12]; 543 Inc(p); 544 545 p^ := (a12 + a12 shr 7) shr 8; 546 end; 547 548 procedure FastBlendPixelInline(dest: PBGRAPixel; const c: TBGRAPixel); 292 549 var 293 550 p: PByte; … … 320 577 end; 321 578 579 procedure FastBlendPixelInline(dest: PBGRAPixel; c: TBGRAPixel; 580 appliedOpacity: byte); 581 begin 582 c.alpha := ApplyOpacity(c.alpha,appliedOpacity); 583 FastBlendPixelInline(dest,c); 584 end; 585 322 586 procedure DrawPixelInlineDiff(dest: PBGRAPixel; c, compare: TBGRAPixel; 323 587 maxDiff: byte); inline; 324 588 begin 325 DrawPixelInline (dest, BGRA(c.red, c.green, c.blue,589 DrawPixelInlineWithAlphaCheck(dest, BGRA(c.red, c.green, c.blue, 326 590 (c.alpha * (maxDiff + 1 - BGRADiff(dest^, compare)) + (maxDiff + 1) shr 1) div 327 591 (maxDiff + 1))); … … 332 596 newAlpha: byte; 333 597 begin 334 newAlpha := dest^.alpha * (255 - alpha) div 255;598 newAlpha := ApplyOpacity(dest^.alpha, not alpha); 335 599 if newAlpha = 0 then 336 600 dest^ := BGRAPixelTransparent … … 343 607 {--------------------------------------- Layer blending -----------------------------------------} 344 608 345 function ByteMultiplyInline(a, b: byte): byte;346 begin347 Result := GammaCompressionTab[GammaExpansionTab[a] * GammaExpansionTab[b] shr 16];348 end;349 350 609 function ByteLinearMultiplyInline(a, b: byte): byte; 351 610 begin 352 611 Result := (a * b) shr 8; 353 end;354 355 procedure MultiplyPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline;356 var357 destalpha: byte;358 begin359 destalpha := dest^.alpha;360 dest^.red := (ByteMultiplyInline(dest^.red, c.red) * destalpha +361 c.red * (not destalpha)) shr 8;362 dest^.green := (ByteMultiplyInline(dest^.green, c.green) * destalpha +363 c.green * (not destalpha)) shr 8;364 dest^.blue := (ByteMultiplyInline(dest^.blue, c.blue) * destalpha +365 c.blue * (not destalpha)) shr 8;366 dest^.alpha := c.alpha;367 612 end; 368 613 … … 456 701 end; 457 702 703 {$hints off} 458 704 function ByteDodgeInline(a, b: byte): byte; inline; 459 705 var … … 464 710 else 465 711 begin 466 temp := (a shl 8) div ( 255 -b);712 temp := (a shl 8) div (not b); 467 713 if temp > 255 then 468 714 Result := 255 … … 471 717 end; 472 718 end; 719 {$hints on} 473 720 474 721 procedure ColorDodgePixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline; … … 486 733 end; 487 734 488 function ByteReflectInline(a, b: byte): byte; inline; 489 var 490 temp: integer; 735 {$hints off} 736 function ByteNonLinearReflectInline(a, b: byte): byte; inline; 737 var 738 temp: longword; 739 wa,wb: word; 491 740 begin 492 741 if b = 255 then … … 494 743 else 495 744 begin 496 temp := a * a div (255 - b); 745 wa := GammaExpansionTab[a]; 746 wb := GammaExpansionTab[b]; 747 temp := wa * wa div (not wb); 748 if temp >= 65535 then 749 Result := 255 750 else 751 Result := GammaCompressionTab[ temp ]; 752 end; 753 end; 754 755 function ByteReflectInline(a, b: byte): byte; inline; 756 var 757 temp: integer; 758 begin 759 if b = 255 then 760 Result := 255 761 else 762 begin 763 temp := a * a div (not b); 497 764 if temp > 255 then 498 765 Result := 255 … … 501 768 end; 502 769 end; 770 {$hints on} 771 503 772 504 773 procedure ReflectPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline; … … 526 795 c.green * (not destalpha)) shr 8; 527 796 dest^.blue := (ByteReflectInline(c.blue, dest^.blue) * destalpha + 797 c.blue * (not destalpha)) shr 8; 798 dest^.alpha := c.alpha; 799 end; 800 801 procedure NiceGlowPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline; 802 var 803 destalpha: byte; 804 begin 805 destalpha := dest^.alpha; 806 dest^.red := (ByteReflectInline(c.red, dest^.red) * destalpha + 807 c.red * (not destalpha)) shr 8; 808 dest^.green := (ByteReflectInline(c.green, dest^.green) * destalpha + 809 c.green * (not destalpha)) shr 8; 810 dest^.blue := (ByteReflectInline(c.blue, dest^.blue) * destalpha + 811 c.blue * (not destalpha)) shr 8; 812 813 if (c.red > c.green) and (c.red > c.blue) then 814 dest^.alpha := c.red else 815 if (c.green > c.blue) then 816 dest^.alpha := c.green else 817 dest^.alpha := c.blue; 818 dest^.alpha := ApplyOpacity(GammaExpansionTab[dest^.alpha] shr 8,c.alpha); 819 end; 820 821 procedure NonLinearReflectPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline; 822 var 823 destalpha: byte; 824 begin 825 destalpha := dest^.alpha; 826 dest^.red := (ByteNonLinearReflectInline(dest^.red, c.red) * destalpha + 827 c.red * (not destalpha)) shr 8; 828 dest^.green := (ByteNonLinearReflectInline(dest^.green, c.green) * destalpha + 829 c.green * (not destalpha)) shr 8; 830 dest^.blue := (ByteNonLinearReflectInline(dest^.blue, c.blue) * destalpha + 528 831 c.blue * (not destalpha)) shr 8; 529 832 dest^.alpha := c.alpha; … … 532 835 {$hints off} 533 836 function ByteOverlayInline(a, b: byte): byte; inline; 837 var wa,wb: word; 838 begin 839 wa := GammaExpansionTab[a]; 840 wb := GammaExpansionTab[b]; 841 if wa < 32768 then 842 Result := GammaCompressionTab[ (wa * wb) shr 15 ] 843 else 844 Result := GammaCompressionTab[ 65535 - ((not wa) * (not wb) shr 15) ]; 845 end; 846 847 function ByteLinearOverlayInline(a, b: byte): byte; inline; 534 848 begin 535 849 if a < 128 then 536 850 Result := (a * b) shr 7 537 851 else 538 Result := 255 - (( 255 - a) * (255 -b) shr 7);852 Result := 255 - ((not a) * (not b) shr 7); 539 853 end; 540 854 … … 551 865 c.green * (not destalpha)) shr 8; 552 866 dest^.blue := (ByteOverlayInline(dest^.blue, c.blue) * destalpha + 867 c.blue * (not destalpha)) shr 8; 868 dest^.alpha := c.alpha; 869 end; 870 871 procedure LinearOverlayPixelInline(dest: PBGRAPixel; c: TBGRAPixel); inline; 872 var 873 destalpha: byte; 874 begin 875 destalpha := dest^.alpha; 876 dest^.red := (ByteLinearOverlayInline(dest^.red, c.red) * destalpha + 877 c.red * (not destalpha)) shr 8; 878 dest^.green := (ByteLinearOverlayInline(dest^.green, c.green) * destalpha + 879 c.green * (not destalpha)) shr 8; 880 dest^.blue := (ByteLinearOverlayInline(dest^.blue, c.blue) * destalpha + 553 881 c.blue * (not destalpha)) shr 8; 554 882 dest^.alpha := c.alpha; -
GraphicTest/BGRABitmap/bgracompressablebitmap.pas
r210 r317 1 unit bgracompressablebitmap;1 unit BGRACompressableBitmap; 2 2 3 3 {$mode objfpc}{$H+} 4 4 5 5 interface 6 7 { This unit contains the TBGRACompressableBitmap class, which 8 can be used to temporarily compress bitmaps in memory. 9 To use it, create an instance with the bitmap you want 10 to compress. You can then free the original bitmap because 11 TBGRACompressableBitmap contains all information necessary 12 to build it again. To construct again your bitmap, call 13 the GetBitmap function. 14 15 When you have your bitmap in TBGRACompressableBitmap, 16 you can call Compress function as many times as necessary 17 until all data is compressed. It does only a part of the 18 work at each call, so you can put it in a loop or in 19 a timer. When it's done, Compress returns false to 20 notify that it did nothing, which means you can 21 stop calling Compress. 22 23 In this implementation, the memory usage grows during 24 the compression process and is lower only after it is 25 finished. So it is recommended to compress one bitmap 26 at a time. } 6 27 7 28 uses … … 16 37 FWidth,FHeight: integer; 17 38 FCaption: String; 39 FBounds: TRect; 18 40 FCompressedDataArray: array of TMemoryStream; 19 41 FUncompressedData: TMemoryStream; … … 25 47 constructor Create(Source: TBGRABitmap); 26 48 function GetBitmap: TBGRABitmap; 27 function Compress: boolean; 49 50 //call Compress as many times as necessary 51 //when it returns false, it means that 52 //the image compression is finished 53 function Compress: boolean; 54 28 55 function UsedMemory: Int64; 29 56 procedure Assign(Source: TBGRABitmap); … … 38 65 uses zstream, BGRABitmapTypes; 39 66 40 const maxPartSize = 1048576; 67 // size of each chunk treated by Compress function 68 const maxPartSize = 524288; 41 69 42 70 { TBGRACompressedBitmap } … … 63 91 end; 64 92 93 { Constructs the bitmap again, decompressing if necessary. 94 After this, the image is not compressed anymore so the 95 memoy usage grows again and the access becomes fast 96 because there is no need to decompress anymore. } 65 97 function TBGRACompressableBitmap.GetBitmap: TBGRABitmap; 98 var UsedPart: TBGRABitmap; 99 UsedNbPixels: Integer; 66 100 begin 67 101 Decompress; … … 74 108 result.Caption := FCaption; 75 109 FUncompressedData.Position := 0; 76 FUncompressedData.Read(result.Data^,result.NbPixels*Sizeof(TBGRAPixel)); 77 end; 78 110 if (FBounds.Left <> 0) or (FBounds.Top <> 0) 111 or (FBounds.Right <> FWidth) or (FBounds.Bottom <> FHeight) then 112 begin 113 UsedNbPixels := (FBounds.Right-FBounds.Left)*(FBounds.Bottom-FBounds.Top); 114 if UsedNbPixels > 0 then 115 begin 116 UsedPart := TBGRABitmap.Create(FBounds.Right-FBounds.Left,FBounds.Bottom-FBounds.Top); 117 FUncompressedData.Read(UsedPart.Data^,UsedPart.NbPixels*Sizeof(TBGRAPixel)); 118 result.PutImage(FBounds.Left,FBounds.Top,UsedPart,dmSet); 119 UsedPart.Free; 120 end; 121 end else 122 FUncompressedData.Read(result.Data^,result.NbPixels*Sizeof(TBGRAPixel)); 123 end; 124 125 { Returns the total memory used by this object for storing bitmap data } 79 126 function TBGRACompressableBitmap.UsedMemory: Int64; 80 127 var i: integer; … … 86 133 end; 87 134 135 { Do one compress step or return false } 88 136 function TBGRACompressableBitmap.Compress: boolean; 89 137 var comp: Tcompressionstream; … … 91 139 begin 92 140 if FCompressedDataArray = nil then FCompressionProgress := 0; 93 if FUncompressedData = nilthen141 if (FUncompressedData = nil) or (FUncompressedData.Size = 0) then 94 142 begin 95 143 result := false; … … 104 152 partSize := maxPartSize else 105 153 partSize := integer(FUncompressedData.Size - FCompressionProgress); 154 155 //use fast compression to avoid slowing down the application 106 156 comp := Tcompressionstream.Create(clfastest,FCompressedDataArray[high(FCompressedDataArray)]); 107 157 comp.write(partSize,sizeof(partSize)); … … 136 186 end; 137 187 188 { Free all data } 138 189 procedure TBGRACompressableBitmap.FreeData; 139 190 var i: integer; … … 148 199 end; 149 200 201 { Copy a bitmap into this object. As it is copied, you need not 202 keep a copy of the source } 150 203 procedure TBGRACompressableBitmap.Assign(Source: TBGRABitmap); 204 var 205 UsedPart: TBGRABitmap; 206 NbUsedPixels: integer; 151 207 begin 152 208 FreeData; … … 161 217 FHeight := Source.Height; 162 218 FCaption := Source.Caption; 219 FBounds := Source.GetImageBounds([cRed,cGreen,cBlue,cAlpha]); 220 NbUsedPixels := (FBounds.Right-FBounds.Left)*(FBounds.Bottom-FBounds.Top); 163 221 FUncompressedData := TMemoryStream.Create; 164 FUncompressedData.Write(Source.Data^,Source.NbPixels*Sizeof(TBGRAPixel)); 222 if NbUsedPixels = 0 then exit; 223 224 if (FBounds.Left <> 0) or (FBounds.Top <> 0) 225 or (FBounds.Right <> Source.Width) or (FBounds.Bottom <> Source.Height) then 226 begin 227 UsedPart := Source.GetPart(FBounds) as TBGRABitmap; 228 FUncompressedData.Write(UsedPart.Data^,NbUsedPixels*Sizeof(TBGRAPixel)); 229 UsedPart.Free; 230 end else 231 FUncompressedData.Write(Source.Data^,Source.NbPixels*Sizeof(TBGRAPixel)); 165 232 end; 166 233 -
GraphicTest/BGRABitmap/bgradefaultbitmap.pas
r210 r317 29 29 interface 30 30 31 { This unit contains TBGRADefaultBitmap class. This class contains basic drawing routines, 32 and call functions from other units to perform advanced drawing functions. } 33 31 34 uses 32 Classes, SysUtils, Types, FPImage, Graphics, BGRABitmapTypes, GraphType ;35 Classes, SysUtils, Types, FPImage, Graphics, BGRABitmapTypes, GraphType, FPImgCanv, BGRACanvas, BGRACanvas2D, FPWritePng; 33 36 34 37 type 35 TBGRADefaultBitmap = class;36 TBGRABitmapAny = class of TBGRADefaultBitmap;37 38 38 { TBGRADefaultBitmap } 39 39 40 TBGRADefaultBitmap = class(T FPCustomImage)40 TBGRADefaultBitmap = class(TBGRACustomBitmap) 41 41 private 42 FEraseMode: boolean; 43 FBitmapModified: boolean; //if TBitmap has changed 44 FFontHeightSign: integer; 45 FFont: TFont; 42 { Bounds checking which are shared by drawing functions. These functions check 43 if the coordinates are visible and return true if it is the case, swap 44 coordinates if necessary and make them fit into the clipping rectangle } 45 function CheckHorizLineBounds(var x, y, x2: integer): boolean; inline; 46 function CheckVertLineBounds(var x, y, y2: integer; out delta: integer): boolean; inline; 47 function CheckRectBounds(var x,y,x2,y2: integer; minsize: integer): boolean; inline; 48 function CheckClippedRectBounds(var x,y,x2,y2: integer): boolean; inline; 49 function CheckPutImageBounds(x, y, tx, ty: integer; out minxb, minyb, maxxb, maxyb, ignoreleft: integer): boolean; inline; 50 function CheckAntialiasRectBounds(var x,y,x2,y2: single; w: single): boolean; 51 function GetCanvasBGRA: TBGRACanvas; 52 function GetCanvas2D: TBGRACanvas2D; 53 protected 54 FRefCount: integer; //reference counter (not related to interface reference counter) 55 56 //Pixel data 57 FData: PBGRAPixel; //pointer to pixels 58 FWidth, FHeight, FNbPixels: integer; //dimensions 59 FDataModified: boolean; //if data image has changed so TBitmap should be updated 60 FLineOrder: TRawImageLineOrder; 61 FClipRect: TRect; //clipping (can be the whole image if there is no clipping) 62 63 //Scan 64 FScanPtr : PBGRAPixel; //current scan address 65 FScanCurX,FScanCurY: integer; //current scan coordinates 66 67 //LCL bitmap object 68 FBitmap: TBitmap; 69 FBitmapModified: boolean; //if TBitmap has changed so pixel data should be updated 70 FCanvasOpacity: byte; //opacity used with standard canvas functions 71 FAlphaCorrectionNeeded: boolean; //the alpha channel is not correct because standard functions do not 72 //take it into account 73 74 //FreePascal drawing routines 75 FCanvasFP: TFPImageCanvas; 76 FCanvasDrawModeFP: TDrawMode; 77 FCanvasPixelProcFP: procedure(x, y: integer; col: TBGRAPixel) of object; 78 79 //canvas-like with antialiasing and texturing 80 FCanvasBGRA: TBGRACanvas; 81 FCanvas2D: TBGRACanvas2D; 82 83 //drawing options 84 FEraseMode: boolean; //when polygons are erased instead of drawn 85 FFont: TFont; //font parameters 46 86 FFontHeight: integer; 47 function GetCanvasAlphaCorrection: boolean; 48 procedure SetCanvasAlphaCorrection(const AValue: boolean); 49 procedure UpdateFont; 50 procedure SetFontHeight(AHeight: integer); 87 FFontHeightSign: integer; //sign correction 88 89 { Pen style can be defined by PenStyle property of by CustomPenStyle property. 90 When PenStyle property is assigned, CustomPenStyle property is assigned the actual 91 pen pattern. } 92 FCustomPenStyle: TBGRAPenStyle; 93 FPenStyle: TPenStyle; 94 95 //Pixel data 96 function GetRefCount: integer; override; 97 function GetScanLine(y: integer): PBGRAPixel; override; //don't forget to call InvalidateBitmap after modifications 98 function LoadFromRawImage(ARawImage: TRawImage; DefaultOpacity: byte; 99 AlwaysReplaceAlpha: boolean = False; RaiseErrorOnInvalidPixelFormat: boolean = True): boolean; 100 function GetDataPtr: PBGRAPixel; override; 101 procedure ClearTransparentPixels; 51 102 function GetScanlineFast(y: integer): PBGRAPixel; inline; 52 protected 53 FBitmap: TBitmap; //LCL bitmap object 54 FRefCount: integer; //reference counter 55 56 {Pixel data} 57 FData: PBGRAPixel; 58 FWidth, FHeight, FNbPixels: integer; 59 FDataModified: boolean; //if data image has changed 60 FLineOrder: TRawImageLineOrder; 61 FCanvasOpacity: byte; 62 FAlphaCorrectionNeeded: boolean; 63 64 function GetScanLine(y: integer): PBGRAPixel; 65 //don't forget to call InvalidateBitmap after modifications 66 function GetBitmap: TBitmap; 67 function GetCanvas: TCanvas; 103 function GetLineOrder: TRawImageLineOrder; override; 104 function GetNbPixels: integer; override; 105 function GetWidth: integer; override; 106 function GetHeight: integer; override; 107 108 //LCL bitmap object 109 function GetBitmap: TBitmap; override; 110 function GetCanvas: TCanvas; override; 68 111 procedure DiscardBitmapChange; inline; 69 procedure LoadFromRawImage(ARawImage: TRawImage; DefaultOpacity: byte; 70 AlwaysReplaceAlpha: boolean = False); 112 procedure DoAlphaCorrection; 113 procedure SetCanvasOpacity(AValue: byte); override; 114 function GetCanvasOpacity: byte; override; 115 function GetCanvasAlphaCorrection: boolean; override; 116 procedure SetCanvasAlphaCorrection(const AValue: boolean); override; 117 118 //FreePascal drawing routines 119 function GetCanvasFP: TFPImageCanvas; override; 120 procedure SetCanvasDrawModeFP(const AValue: TDrawMode); override; 121 function GetCanvasDrawModeFP: TDrawMode; override; 71 122 72 123 {Allocation routines} … … 78 129 79 130 procedure Init; virtual; 131 80 132 {TFPCustomImage} 81 133 procedure SetInternalColor(x, y: integer; const Value: TFPColor); override; … … 84 136 function GetInternalPixel(x, y: integer): integer; override; 85 137 86 {resample} 87 function FineResample(NewWidth, NewHeight: integer): TBGRADefaultBitmap; 88 function SimpleStretch(NewWidth, NewHeight: integer): TBGRADefaultBitmap; 89 90 function CheckEmpty: boolean; 91 function GetHasTransparentPixels: boolean; 92 function GetAverageColor: TColor; 93 function GetAveragePixel: TBGRAPixel; 94 procedure SetCanvasOpacity(AValue: byte); 95 function GetDataPtr: PBGRAPixel; 96 procedure DoAlphaCorrection; 97 procedure ClearTransparentPixels; 98 99 {Spline} 100 function Spline(y0, y1, y2, y3: single; t: single): single; 138 {Image functions} 139 function FineResample(NewWidth, NewHeight: integer): TBGRACustomBitmap; 140 function SimpleStretch(NewWidth, NewHeight: integer): TBGRACustomBitmap; 141 function CheckEmpty: boolean; override; 142 function GetHasTransparentPixels: boolean; override; 143 function GetAverageColor: TColor; override; 144 function GetAveragePixel: TBGRAPixel; override; 145 function CreateAdaptedPngWriter: TFPWriterPNG; 146 function LoadAsBmp32(Str: TStream): boolean; override; 147 148 //drawing 149 function GetCustomPenStyle: TBGRAPenStyle; override; 150 procedure SetCustomPenStyle(const AValue: TBGRAPenStyle); override; 151 procedure SetPenStyle(const AValue: TPenStyle); override; 152 function GetPenStyle: TPenStyle; override; 153 154 procedure UpdateFont; 155 function GetFontHeight: integer; override; 156 procedure SetFontHeight(AHeight: integer); override; 157 function GetFontFullHeight: integer; override; 158 procedure SetFontFullHeight(AHeight: integer); override; 159 function GetFontPixelMetric: TFontPixelMetric; override; 160 161 function GetClipRect: TRect; override; 162 procedure SetClipRect(const AValue: TRect); override; 101 163 102 164 public 103 Caption: string;104 FontName: string;105 FontStyle: TFontStyles;106 107 165 {Reference counter functions} 108 function NewReference: TBGRA DefaultBitmap;166 function NewReference: TBGRACustomBitmap; 109 167 procedure FreeReference; 110 function GetUnique: TBGRADefaultBitmap; 111 function NewBitmap(AWidth, AHeight: integer): TBGRADefaultBitmap; 112 function NewBitmap(Filename: string): TBGRADefaultBitmap; 168 function GetUnique: TBGRACustomBitmap; 113 169 114 170 {TFPCustomImage override} … … 117 173 118 174 {Constructors} 119 constructor Create; 120 constructor Create(ABitmap: TBitmap); 121 constructor Create(AWidth, AHeight: integer; Color: TColor); 122 constructor Create(AWidth, AHeight: integer; Color: TBGRAPixel); 175 constructor Create; override; 176 constructor Create(ABitmap: TBitmap); override; 177 constructor Create(AWidth, AHeight: integer; Color: TColor); override; 178 constructor Create(AWidth, AHeight: integer; Color: TBGRAPixel); override; 179 constructor Create(AFilename: string); override; 180 constructor Create(AStream: TStream); override; 123 181 destructor Destroy; override; 124 182 125 183 {Loading functions} 126 procedure LoadFromFile(const filename: string); 127 procedure SaveToFile(const filename: string); 128 constructor Create(AFilename: string); 129 constructor Create(AStream: TStream); 130 procedure Assign(Bitmap: TBitmap); overload; 131 procedure Assign(MemBitmap: TBGRADefaultBitmap); overload; 184 function NewBitmap(AWidth, AHeight: integer): TBGRACustomBitmap; override; 185 function NewBitmap(AWidth, AHeight: integer; Color: TBGRAPixel): TBGRACustomBitmap; override; 186 function NewBitmap(Filename: string): TBGRACustomBitmap; override; 187 188 procedure LoadFromFile(const filename: string); override; 189 procedure SaveToFile(const filename: string); override; 190 procedure SaveToStreamAsPng(Str: TStream); override; 191 procedure Assign(ABitmap: TBitmap); override; overload; 192 procedure Assign(MemBitmap: TBGRACustomBitmap);override; overload; 193 procedure Serialize(AStream: TStream); override; 194 procedure Deserialize(AStream: TStream); override; 195 class procedure SerializeEmpty(AStream: TStream); 132 196 133 197 {Pixel functions} 134 procedure SetPixel(x, y: integer; c: TColor); overload; 135 procedure SetPixel(x, y: integer; c: TBGRAPixel); overload; 136 procedure DrawPixel(x, y: integer; c: TBGRAPixel); 137 procedure FastBlendPixel(x, y: integer; c: TBGRAPixel); 138 procedure ErasePixel(x, y: integer; alpha: byte); 139 procedure AlphaPixel(x, y: integer; alpha: byte); 140 function GetPixel(x, y: integer): TBGRAPixel; overload; 141 function GetPixel(x, y: single): TBGRAPixel; overload; 142 function GetPixelCycle(x, y: integer): TBGRAPixel; 198 function PtInClipRect(x, y: integer): boolean; inline; 199 procedure SetPixel(x, y: integer; c: TColor); override; 200 procedure SetPixel(x, y: integer; c: TBGRAPixel); override; 201 procedure XorPixel(x, y: integer; c: TBGRAPixel); override; 202 procedure DrawPixel(x, y: integer; c: TBGRAPixel); override; 203 procedure DrawPixel(x, y: integer; ec: TExpandedPixel); override; 204 procedure FastBlendPixel(x, y: integer; c: TBGRAPixel); override; 205 procedure ErasePixel(x, y: integer; alpha: byte); override; 206 procedure AlphaPixel(x, y: integer; alpha: byte); override; 207 function GetPixel(x, y: integer): TBGRAPixel; override; 208 function GetPixel(x, y: single; AResampleFilter: TResampleFilter = rfLinear): TBGRAPixel; override; 209 function GetPixelCycle(x, y: single; AResampleFilter: TResampleFilter = rfLinear): TBGRAPixel; override; 210 function GetPixelCycle(x, y: single; AResampleFilter: TResampleFilter; 211 repeatX: boolean; repeatY: boolean): TBGRAPixel; override; overload; 143 212 144 213 {Line primitives} 145 procedure SetHorizLine(x, y, x2: integer; c: TBGRAPixel); 146 procedure DrawHorizLine(x, y, x2: integer; c: TBGRAPixel); 147 procedure FastBlendHorizLine(x, y, x2: integer; c: TBGRAPixel); 148 procedure AlphaHorizLine(x, y, x2: integer; alpha: byte); 149 procedure SetVertLine(x, y, y2: integer; c: TBGRAPixel); 150 procedure DrawVertLine(x, y, y2: integer; c: TBGRAPixel); 151 procedure AlphaVertLine(x, y, y2: integer; alpha: byte); 152 procedure FastBlendVertLine(x, y, y2: integer; c: TBGRAPixel); 214 procedure SetHorizLine(x, y, x2: integer; c: TBGRAPixel); override; 215 procedure XorHorizLine(x, y, x2: integer; c: TBGRAPixel); override; 216 procedure DrawHorizLine(x, y, x2: integer; c: TBGRAPixel); override; 217 procedure DrawHorizLine(x, y, x2: integer; ec: TExpandedPixel); override; 218 procedure DrawHorizLine(x, y, x2: integer; texture: IBGRAScanner); override; 219 procedure FastBlendHorizLine(x, y, x2: integer; c: TBGRAPixel); override; 220 procedure AlphaHorizLine(x, y, x2: integer; alpha: byte); override; 221 procedure SetVertLine(x, y, y2: integer; c: TBGRAPixel); override; 222 procedure XorVertLine(x, y, y2: integer; c: TBGRAPixel); override; 223 procedure DrawVertLine(x, y, y2: integer; c: TBGRAPixel); override; 224 procedure AlphaVertLine(x, y, y2: integer; alpha: byte); override; 225 procedure FastBlendVertLine(x, y, y2: integer; c: TBGRAPixel); override; 153 226 procedure DrawHorizLineDiff(x, y, x2: integer; c, compare: TBGRAPixel; 154 maxDiff: byte); 227 maxDiff: byte); override; 155 228 156 229 {Shapes} 157 procedure DrawLine(x1, y1, x2, y2: integer; c: TBGRAPixel; DrawLastPixel: boolean); 158 procedure DrawLineAntialias(x1, y1, x2, y2: integer; c: TBGRAPixel; 159 DrawLastPixel: boolean); overload; 160 procedure DrawPolyLineAntialias(points: array of TPoint; c: TBGRAPixel; 161 DrawLastPixel: boolean); overload; 162 procedure DrawLineAntialias(x1, y1, x2, y2: integer; c1, c2: TBGRAPixel; 163 dashLen: integer; DrawLastPixel: boolean); overload; 164 procedure DrawPolyLineAntialias(points: array of TPoint; c1, c2: TBGRAPixel; 165 dashLen: integer; DrawLastPixel: boolean); overload; 166 procedure DrawLineAntialias(x1, y1, x2, y2: single; c: TBGRAPixel; 167 w: single; Closed: boolean); overload; 168 procedure DrawPolyLineAntialias(points: array of TPointF; c: TBGRAPixel; 169 w: single; Closed: boolean); overload; 170 procedure DrawPolygonAntialias(points: array of TPointF; c: TBGRAPixel; 171 w: single); overload; 172 procedure EraseLineAntialias(x1, y1, x2, y2: single; alpha: byte; 173 w: single; Closed: boolean); overload; 174 procedure FillPolyAntialias(points: array of TPointF; c: TBGRAPixel); 175 procedure ErasePolyAntialias(points: array of TPointF; alpha: byte); 176 procedure EllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel; w: single); 177 procedure FillEllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel); 178 procedure EraseEllipseAntialias(x, y, rx, ry: single; alpha: byte); 179 procedure Rectangle(x, y, x2, y2: integer; c: TBGRAPixel; mode: TDrawMode); 180 procedure Rectangle(x, y, x2, y2: integer; BorderColor, FillColor: TBGRAPixel; 181 mode: TDrawMode); 182 procedure Rectangle(x, y, x2, y2: integer; c: TColor); 183 procedure Rectangle(r: TRect; c: TBGRAPixel; mode: TDrawMode); 184 procedure Rectangle(r: TRect; BorderColor, FillColor: TBGRAPixel; 185 mode: TDrawMode); 186 procedure Rectangle(r: TRect; c: TColor); 187 procedure RectangleAntialias(x, y, x2, y2: single; c: TBGRAPixel; 188 w: single); overload; 189 procedure RectangleAntialias(x, y, x2, y2: single; c: TBGRAPixel; 190 w: single; back: TBGRAPixel); overload; 191 procedure FillRect(r: TRect; c: TColor); 192 procedure FillRect(r: TRect; c: TBGRAPixel; mode: TDrawMode); 193 procedure FillRect(x, y, x2, y2: integer; c: TColor); 194 procedure FillRect(x, y, x2, y2: integer; c: TBGRAPixel; mode: TDrawMode); 195 procedure FillRectAntialias(x, y, x2, y2: single; c: TBGRAPixel); 196 procedure AlphaFillRect(x, y, x2, y2: integer; alpha: byte); 197 procedure RoundRect(X1, Y1, X2, Y2: integer; RX, RY: integer; 198 BorderColor, FillColor: TBGRAPixel); 199 procedure TextOut(x, y: integer; s: string; c: TBGRAPixel; 200 align: TAlignment); overload; 201 procedure TextOut(x, y: integer; s: string; c: TBGRAPixel); overload; 202 procedure TextOut(x, y: integer; s: string; c: TColor); overload; 203 procedure TextRect(ARect: TRect; x, y: integer; s: string; 204 style: TTextStyle; c: TBGRAPixel); overload; 205 function TextSize(s: string): TSize; 230 procedure DrawLine(x1, y1, x2, y2: integer; c: TBGRAPixel; DrawLastPixel: boolean); override; 231 procedure DrawLineAntialias(x1, y1, x2, y2: integer; c: TBGRAPixel; DrawLastPixel: boolean); override; 232 procedure DrawLineAntialias(x1, y1, x2, y2: integer; c1, c2: TBGRAPixel; dashLen: integer; DrawLastPixel: boolean); override; 233 procedure DrawLineAntialias(x1, y1, x2, y2: single; c: TBGRAPixel; w: single); override; 234 procedure DrawLineAntialias(x1, y1, x2, y2: single; texture: IBGRAScanner; w: single); override; 235 procedure DrawLineAntialias(x1, y1, x2, y2: single; c: TBGRAPixel; w: single; Closed: boolean); override; 236 procedure DrawLineAntialias(x1, y1, x2, y2: single; texture: IBGRAScanner; w: single; Closed: boolean); override; 237 238 procedure DrawPolyLineAntialias(const points: array of TPointF; c: TBGRAPixel; w: single); override; 239 procedure DrawPolyLineAntialias(const points: array of TPointF; texture: IBGRAScanner; w: single); override; 240 procedure DrawPolyLineAntialias(const points: array of TPointF; c: TBGRAPixel; w: single; Closed: boolean); override; 241 procedure DrawPolygonAntialias(const points: array of TPointF; c: TBGRAPixel; w: single); override; 242 procedure DrawPolygonAntialias(const points: array of TPointF; texture: IBGRAScanner; w: single); override; 243 244 procedure EraseLineAntialias(x1, y1, x2, y2: single; alpha: byte; w: single); override; 245 procedure EraseLineAntialias(x1, y1, x2, y2: single; alpha: byte; w: single; Closed: boolean); override; 246 procedure ErasePolyLineAntialias(const points: array of TPointF; alpha: byte; w: single); override; 247 248 procedure FillTriangleLinearColor(pt1,pt2,pt3: TPointF; c1,c2,c3: TBGRAPixel); override; 249 procedure FillTriangleLinearColorAntialias(pt1,pt2,pt3: TPointF; c1,c2,c3: TBGRAPixel); override; 250 procedure FillTriangleLinearMapping(pt1,pt2,pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF; TextureInterpolation: Boolean= True); override; 251 procedure FillTriangleLinearMappingLightness(pt1,pt2,pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF; light1,light2,light3: word; TextureInterpolation: Boolean= True); override; 252 procedure FillTriangleLinearMappingAntialias(pt1,pt2,pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF); override; 253 254 procedure FillQuadLinearColor(pt1,pt2,pt3,pt4: TPointF; c1,c2,c3,c4: TBGRAPixel); override; 255 procedure FillQuadLinearColorAntialias(pt1,pt2,pt3,pt4: TPointF; c1,c2,c3,c4: TBGRAPixel); override; 256 procedure FillQuadLinearMapping(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF; TextureInterpolation: Boolean= True); override; 257 procedure FillQuadLinearMappingLightness(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF; light1,light2,light3,light4: word; TextureInterpolation: Boolean= True); override; 258 procedure FillQuadLinearMappingAntialias(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF); override; 259 procedure FillQuadPerspectiveMapping(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF); override; 260 procedure FillQuadPerspectiveMappingAntialias(pt1,pt2,pt3,pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF); override; 261 262 procedure FillPolyLinearMapping(const points: array of TPointF; texture: IBGRAScanner; texCoords: array of TPointF; TextureInterpolation: Boolean); override; 263 procedure FillPolyLinearMappingLightness(const points: array of TPointF; texture: IBGRAScanner; texCoords: array of TPointF; lightnesses: array of word; TextureInterpolation: Boolean); override; 264 procedure FillPolyLinearColor(const points: array of TPointF; AColors: array of TBGRAPixel); override; 265 procedure FillPolyPerspectiveMapping(const points: array of TPointF; const pointsZ: array of single; texture: IBGRAScanner; texCoords: array of TPointF; TextureInterpolation: Boolean); override; 266 procedure FillPolyPerspectiveMappingLightness(const points: array of TPointF; const pointsZ: array of single; texture: IBGRAScanner; texCoords: array of TPointF; lightnesses: array of word; TextureInterpolation: Boolean); override; 267 procedure FillPoly(const points: array of TPointF; c: TBGRAPixel; drawmode: TDrawMode); override; 268 procedure FillPoly(const points: array of TPointF; texture: IBGRAScanner; drawmode: TDrawMode); override; 269 procedure FillPolyAntialias(const points: array of TPointF; c: TBGRAPixel); override; 270 procedure FillPolyAntialias(const points: array of TPointF; texture: IBGRAScanner); override; 271 procedure ErasePoly(const points: array of TPointF; alpha: byte); override; 272 procedure ErasePolyAntialias(const points: array of TPointF; alpha: byte); override; 273 274 procedure EllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel; w: single); override; 275 procedure EllipseAntialias(x, y, rx, ry: single; texture: IBGRAScanner; w: single); override; 276 procedure EllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel; w: single; back: TBGRAPixel); override; 277 procedure FillEllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel); override; 278 procedure FillEllipseAntialias(x, y, rx, ry: single; texture: IBGRAScanner); override; 279 procedure FillEllipseLinearColorAntialias(x, y, rx, ry: single; outercolor, innercolor: TBGRAPixel); override; 280 procedure EraseEllipseAntialias(x, y, rx, ry: single; alpha: byte); override; 281 282 procedure Rectangle(x, y, x2, y2: integer; c: TBGRAPixel; mode: TDrawMode); override; 283 procedure Rectangle(x, y, x2, y2: integer; BorderColor, FillColor: TBGRAPixel; mode: TDrawMode); override; 284 procedure RectangleAntialias(x, y, x2, y2: single; c: TBGRAPixel; w: single; back: TBGRAPixel); override; 285 procedure RectangleAntialias(x, y, x2, y2: single; texture: IBGRAScanner; w: single); override; 286 287 procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; c: TBGRAPixel; w: single; options: TRoundRectangleOptions = []); override; 288 procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; texture: IBGRAScanner; w: single; options: TRoundRectangleOptions = []); override; 289 procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; pencolor: TBGRAPixel; w: single; fillcolor: TBGRAPixel; options: TRoundRectangleOptions = []); override; 290 procedure RoundRectAntialias(x,y,x2,y2,rx,ry: single; penTexture: IBGRAScanner; w: single; fillTexture: IBGRAScanner; options: TRoundRectangleOptions = []); override; 291 292 procedure FillRect(x, y, x2, y2: integer; c: TBGRAPixel; mode: TDrawMode); override; 293 procedure FillRect(x, y, x2, y2: integer; texture: IBGRAScanner; mode: TDrawMode); override; 294 procedure FillRectAntialias(x, y, x2, y2: single; c: TBGRAPixel); override; 295 procedure EraseRectAntialias(x, y, x2, y2: single; alpha: byte); override; 296 procedure FillRectAntialias(x, y, x2, y2: single; texture: IBGRAScanner); override; 297 procedure FillRoundRectAntialias(x,y,x2,y2,rx,ry: single; c: TBGRAPixel; options: TRoundRectangleOptions = []); override; 298 procedure FillRoundRectAntialias(x,y,x2,y2,rx,ry: single; texture: IBGRAScanner; options: TRoundRectangleOptions = []); override; 299 procedure EraseRoundRectAntialias(x,y,x2,y2,rx,ry: single; alpha: byte; options: TRoundRectangleOptions = []); override; 300 procedure AlphaFillRect(x, y, x2, y2: integer; alpha: byte); override; 301 procedure RoundRect(X1, Y1, X2, Y2: integer; DX, DY: integer; 302 BorderColor, FillColor: TBGRAPixel); override; 303 304 procedure TextOutAngle(x, y, orientation: integer; s: string; c: TBGRAPixel; align: TAlignment); override; 305 procedure TextOutAngle(x, y, orientation: integer; s: string; texture: IBGRAScanner; align: TAlignment); override; 306 procedure TextOut(x, y: integer; s: string; texture: IBGRAScanner; align: TAlignment); override; 307 procedure TextOut(x, y: integer; s: string; c: TBGRAPixel; align: TAlignment); override; 308 procedure TextRect(ARect: TRect; x, y: integer; s: string; style: TTextStyle; c: TBGRAPixel); override; 309 procedure TextRect(ARect: TRect; x, y: integer; s: string; style: TTextStyle; texture: IBGRAScanner); override; 310 function TextSize(s: string): TSize; override; 206 311 207 312 {Spline} 208 function ComputeClosedSpline(points: array of TPointF): ArrayOfTPointF; 209 function ComputeOpenedSpline(points: array of TPointF): ArrayOfTPointF; 313 function ComputeClosedSpline(const APoints: array of TPointF; AStyle: TSplineStyle): ArrayOfTPointF; override; 314 function ComputeOpenedSpline(const APoints: array of TPointF; AStyle: TSplineStyle): ArrayOfTPointF; override; 315 316 function ComputeBezierCurve(const ACurve: TCubicBezierCurve): ArrayOfTPointF; override; 317 function ComputeBezierCurve(const ACurve: TQuadraticBezierCurve): ArrayOfTPointF; override; 318 function ComputeBezierSpline(const ASpline: array of TCubicBezierCurve): ArrayOfTPointF; override; 319 function ComputeBezierSpline(const ASpline: array of TQuadraticBezierCurve): ArrayOfTPointF; override; 320 321 function ComputeWidePolyline(const points: array of TPointF; w: single): ArrayOfTPointF; override; 322 function ComputeWidePolyline(const points: array of TPointF; w: single; Closed: boolean): ArrayOfTPointF; override; 323 function ComputeWidePolygon(const points: array of TPointF; w: single): ArrayOfTPointF; override; 324 325 function ComputeEllipse(x,y,rx,ry: single): ArrayOfTPointF; override; 326 function ComputeEllipse(x,y,rx,ry,w: single): ArrayOfTPointF; override; 327 function ComputeArc65536(x,y,rx,ry: single; start65536,end65536: word): ArrayOfTPointF; override; 328 function ComputeArcRad(x,y,rx,ry: single; startRad,endRad: single): ArrayOfTPointF; override; 329 function ComputeRoundRect(x1,y1,x2,y2,rx,ry: single): ArrayOfTPointF; override; 330 function ComputeRoundRect(x1,y1,x2,y2,rx,ry: single; options: TRoundRectangleOptions): ArrayOfTPointF; override; 331 function ComputePie65536(x,y,rx,ry: single; start65536,end65536: word): ArrayOfTPointF; override; 332 function ComputePieRad(x,y,rx,ry: single; startRad,endRad: single): ArrayOfTPointF; override; 210 333 211 334 {Filling} 212 procedure FillTransparent;213 procedure ApplyGlobalOpacity(alpha: byte);214 procedure Fill( c: TColor); overload;215 procedure Fill(c: TBGRAPixel ); overload;216 procedure Fill(c: TBGRAPixel; start, Count: integer); overload;217 procedure DrawPixels(c: TBGRAPixel; start, Count: integer);218 procedure AlphaFill(alpha: byte); overload;219 procedure AlphaFill(alpha: byte; start, Count: integer); overload;220 procedure ReplaceColor(before, after: TColor); overload;221 procedure ReplaceColor(before, after: TBGRAPixel); overload;222 procedure Replace Transparent(after: TBGRAPixel); overload;223 procedure FloodFill(X, Y: integer; Color: TBGRAPixel;224 mode: TFloodfillMode; Tolerance: byte = 0);225 procedure ParallelFloodFill(X, Y: integer; Dest: TBGRA DefaultBitmap; Color: TBGRAPixel;226 mode: TFloodfillMode; Tolerance: byte = 0); 335 procedure NoClip; override; 336 procedure Fill(texture: IBGRAScanner; mode: TDrawMode); override; 337 procedure Fill(texture: IBGRAScanner); override; 338 procedure Fill(c: TBGRAPixel; start, Count: integer); override; 339 procedure DrawPixels(c: TBGRAPixel; start, Count: integer); override; 340 procedure AlphaFill(alpha: byte; start, Count: integer); override; 341 procedure FillMask(x,y: integer; AMask: TBGRACustomBitmap; color: TBGRAPixel); override; 342 procedure FillMask(x,y: integer; AMask: TBGRACustomBitmap; texture: IBGRAScanner); override; 343 procedure FillClearTypeMask(x,y: integer; xThird: integer; AMask: TBGRACustomBitmap; color: TBGRAPixel; ARGBOrder: boolean = true); override; 344 procedure FillClearTypeMask(x,y: integer; xThird: integer; AMask: TBGRACustomBitmap; texture: IBGRAScanner; ARGBOrder: boolean = true); override; 345 procedure ReplaceColor(before, after: TColor); override; 346 procedure ReplaceColor(before, after: TBGRAPixel); override; 347 procedure ReplaceTransparent(after: TBGRAPixel); override; 348 procedure ParallelFloodFill(X, Y: integer; Dest: TBGRACustomBitmap; Color: TBGRAPixel; 349 mode: TFloodfillMode; Tolerance: byte = 0); override; 227 350 procedure GradientFill(x, y, x2, y2: integer; c1, c2: TBGRAPixel; 228 351 gtype: TGradientType; o1, o2: TPointF; mode: TDrawMode; 229 gammaColorCorrection: boolean = True; Sinus: Boolean=False); 352 gammaColorCorrection: boolean = True; Sinus: Boolean=False); override; 353 procedure GradientFill(x, y, x2, y2: integer; gradient: TBGRACustomGradient; 354 gtype: TGradientType; o1, o2: TPointF; mode: TDrawMode; 355 Sinus: Boolean=False); override; 356 function CreateBrushTexture(ABrushStyle: TBrushStyle; APatternColor, ABackgroundColor: TBGRAPixel; 357 AWidth: integer = 8; AHeight: integer = 8; APenWidth: single = 1): TBGRACustomBitmap; override; 358 procedure ScanMoveTo(X,Y: Integer); override; 359 function ScanNextPixel: TBGRAPixel; override; 360 function ScanAt(X,Y: Single): TBGRAPixel; override; 361 function IsScanPutPixelsDefined: boolean; override; 362 procedure ScanPutPixels(pdest: PBGRAPixel; count: integer; mode: TDrawMode); override; 230 363 231 364 {Canvas drawing functions} 232 365 procedure DataDrawTransparent(ACanvas: TCanvas; Rect: TRect; 233 AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); virtual;366 AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); override; 234 367 procedure DataDrawOpaque(ACanvas: TCanvas; Rect: TRect; AData: Pointer; 235 ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); virtual; 236 procedure GetImageFromCanvas(CanvasSource: TCanvas; x, y: integer); virtual; 237 procedure Draw(ACanvas: TCanvas; x, y: integer; Opaque: boolean = True); virtual; 238 procedure Draw(ACanvas: TCanvas; Rect: TRect; Opaque: boolean = True); virtual; 239 procedure DrawPart(ARect: TRect; Canvas: TCanvas; x, y: integer; Opaque: boolean); 240 function GetPart(ARect: TRect): TBGRADefaultBitmap; 241 procedure InvalidateBitmap; inline; //call if you modify with Scanline 242 procedure LoadFromBitmapIfNeeded; //call to ensure that bitmap data is up to date 368 ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); override; 369 procedure GetImageFromCanvas(CanvasSource: TCanvas; x, y: integer); override; 370 procedure Draw(ACanvas: TCanvas; x, y: integer; Opaque: boolean = True); override; 371 procedure Draw(ACanvas: TCanvas; Rect: TRect; Opaque: boolean = True); override; 372 procedure InvalidateBitmap; override; //call if you modify with Scanline 373 procedure LoadFromBitmapIfNeeded; override; //call to ensure that bitmap data is up to date 243 374 244 375 {BGRA bitmap functions} 245 procedure PutImage(x, y: integer; Source: TBGRADefaultBitmap; mode: TDrawMode); 246 procedure BlendImage(x, y: integer; Source: TBGRADefaultBitmap; 247 operation: TBlendOperation); 248 function Duplicate: TBGRADefaultBitmap; virtual; 249 function Equals(comp: TBGRADefaultBitmap): boolean; 250 function Equals(comp: TBGRAPixel): boolean; 376 procedure PutImage(x, y: integer; Source: TBGRACustomBitmap; mode: TDrawMode; AOpacity: byte = 255); override; 377 procedure PutImageAngle(x,y: single; Source: TBGRACustomBitmap; angle: single; imageCenterX: single = 0; imageCenterY: single = 0; AOpacity: Byte=255); override; 378 procedure PutImageAffine(Origin,HAxis,VAxis: TPointF; Source: TBGRACustomBitmap; AOpacity: Byte=255); override; 379 procedure BlendImage(x, y: integer; Source: TBGRACustomBitmap; operation: TBlendOperation); override; 380 381 function GetPart(ARect: TRect): TBGRACustomBitmap; override; 382 function GetPtrBitmap(Top,Bottom: Integer): TBGRACustomBitmap; override; 383 function Duplicate(DuplicateProperties: Boolean = False) : TBGRACustomBitmap; override; 384 procedure CopyPropertiesTo(ABitmap: TBGRADefaultBitmap); 385 function Equals(comp: TBGRACustomBitmap): boolean; override; 386 function Equals(comp: TBGRAPixel): boolean; override; 387 function GetImageBounds(Channel: TChannel = cAlpha): TRect; override; 388 function GetImageBounds(Channels: TChannels): TRect; override; 389 function MakeBitmapCopy(BackgroundColor: TColor): TBitmap; override; 390 251 391 function Resample(newWidth, newHeight: integer; 252 mode: TResampleMode = rmFineResample): TBGRADefaultBitmap; 253 procedure VerticalFlip; 254 procedure HorizontalFlip; 255 function RotateCW: TBGRADefaultBitmap; 256 function RotateCCW: TBGRADefaultBitmap; 257 procedure Negative; 258 procedure LinearNegative; 259 procedure SwapRedBlue; 260 procedure GrayscaleToAlpha; 261 procedure AlphaToGrayscale; 262 procedure ApplyMask(mask: TBGRADefaultBitmap); 263 function GetImageBounds(Channel: TChannel = cAlpha): TRect; 264 function MakeBitmapCopy(BackgroundColor: TColor): TBitmap; 392 mode: TResampleMode = rmFineResample): TBGRACustomBitmap; override; 393 procedure VerticalFlip; override; 394 procedure HorizontalFlip; override; 395 function RotateCW: TBGRACustomBitmap; override; 396 function RotateCCW: TBGRACustomBitmap; override; 397 procedure Negative; override; 398 procedure LinearNegative; override; 399 procedure SwapRedBlue; override; 400 procedure GrayscaleToAlpha; override; 401 procedure AlphaToGrayscale; override; 402 procedure ApplyMask(mask: TBGRACustomBitmap); override; 403 procedure ApplyGlobalOpacity(alpha: byte); override; 265 404 266 405 {Filters} 267 function FilterSmartZoom3(Option: TMedianOption): TBGRA DefaultBitmap;268 function FilterMedian(Option: TMedianOption): TBGRA DefaultBitmap;269 function FilterSmooth: TBGRA DefaultBitmap;270 function FilterSharpen: TBGRA DefaultBitmap;271 function FilterContour: TBGRA DefaultBitmap;406 function FilterSmartZoom3(Option: TMedianOption): TBGRACustomBitmap; override; 407 function FilterMedian(Option: TMedianOption): TBGRACustomBitmap; override; 408 function FilterSmooth: TBGRACustomBitmap; override; 409 function FilterSharpen: TBGRACustomBitmap; override; 410 function FilterContour: TBGRACustomBitmap; override; 272 411 function FilterBlurRadial(radius: integer; 273 blurType: TRadialBlurType): TBGRADefaultBitmap; 412 blurType: TRadialBlurType): TBGRACustomBitmap; override; 413 function FilterPixelate(pixelSize: integer; useResample: boolean; filter: TResampleFilter = rfLinear): TBGRACustomBitmap; override; 274 414 function FilterBlurMotion(distance: integer; angle: single; 275 oriented: boolean): TBGRADefaultBitmap; 276 function FilterCustomBlur(mask: TBGRADefaultBitmap): TBGRADefaultBitmap; 277 function FilterEmboss(angle: single): TBGRADefaultBitmap; 278 function FilterEmbossHighlight(FillSelection: boolean): TBGRADefaultBitmap; 279 function FilterGrayscale: TBGRADefaultBitmap; 280 function FilterNormalize(eachChannel: boolean = True): TBGRADefaultBitmap; 281 function FilterRotate(origin: TPointF; angle: single): TBGRADefaultBitmap; 282 function FilterSphere: TBGRADefaultBitmap; 283 function FilterCylinder: TBGRADefaultBitmap; 284 function FilterPlane: TBGRADefaultBitmap; 285 286 property Data: PBGRAPixel Read GetDataPtr; 287 property Width: integer Read FWidth; 288 property Height: integer Read FHeight; 289 property NbPixels: integer Read FNbPixels; 290 property Empty: boolean Read CheckEmpty; 291 292 property ScanLine[y: integer]: PBGRAPixel Read GetScanLine; 293 property RefCount: integer Read FRefCount; 294 property Bitmap: TBitmap Read GetBitmap; 295 //don't forget to call InvalidateBitmap before if you changed something with Scanline 296 property HasTransparentPixels: boolean Read GetHasTransparentPixels; 297 property AverageColor: TColor Read GetAverageColor; 298 property AveragePixel: TBGRAPixel Read GetAveragePixel; 299 property LineOrder: TRawImageLineOrder Read FLineOrder; 300 property Canvas: TCanvas Read GetCanvas; 301 property CanvasOpacity: byte Read FCanvasOpacity Write SetCanvasOpacity; 302 property CanvasAlphaCorrection: boolean 303 Read GetCanvasAlphaCorrection Write SetCanvasAlphaCorrection; 304 305 property FontHeight: integer Read FFontHeight Write SetFontHeight; 306 end; 307 308 type 415 oriented: boolean): TBGRACustomBitmap; override; 416 function FilterCustomBlur(mask: TBGRACustomBitmap): TBGRACustomBitmap; override; 417 function FilterEmboss(angle: single): TBGRACustomBitmap; override; 418 function FilterEmbossHighlight(FillSelection: boolean): TBGRACustomBitmap; override; 419 function FilterGrayscale: TBGRACustomBitmap; override; 420 function FilterNormalize(eachChannel: boolean = True): TBGRACustomBitmap; override; 421 function FilterRotate(origin: TPointF; angle: single): TBGRACustomBitmap; override; 422 function FilterSphere: TBGRACustomBitmap; override; 423 function FilterTwirl(ACenter: TPoint; ARadius: Single; ATurn: Single=1; AExponent: Single=3): TBGRACustomBitmap; override; 424 function FilterCylinder: TBGRACustomBitmap; override; 425 function FilterPlane: TBGRACustomBitmap; override; 426 427 property CanvasBGRA: TBGRACanvas read GetCanvasBGRA; 428 property Canvas2D: TBGRACanvas2D read GetCanvas2D; 429 end; 430 309 431 { TBGRAPtrBitmap } 310 432 … … 315 437 public 316 438 constructor Create(AWidth, AHeight: integer; AData: Pointer); overload; 317 function Duplicate : TBGRADefaultBitmap; override;439 function Duplicate(DuplicateProperties: Boolean = False): TBGRACustomBitmap; override; 318 440 procedure SetDataPtr(AData: Pointer); 319 441 property LineOrder: TRawImageLineOrder Read FLineOrder Write FLineOrder; … … 323 445 DefaultTextStyle: TTextStyle; 324 446 447 procedure BGRAGradientFill(bmp: TBGRACustomBitmap; x, y, x2, y2: integer; 448 c1, c2: TBGRAPixel; gtype: TGradientType; o1, o2: TPointF; mode: TDrawMode; 449 gammaColorCorrection: boolean = True; Sinus: Boolean=False); 450 325 451 implementation 326 452 327 uses FPWritePng, Math, LCLIntf, LCLType, BGRAPolygon, BGRAResample, 328 BGRAFilters, BGRABlend, BGRAPaintNet, 329 FPReadPcx, FPWritePcx, FPReadXPM, FPWriteXPM; 453 uses Math, LCLIntf, LCLType, 454 BGRABlend, BGRAFilters, BGRAPen, BGRAText, BGRATextFX, BGRAGradientScanner, 455 BGRAResample, BGRATransform, BGRAPolygon, BGRAPolygonAliased, 456 BGRAPath, FPReadPcx, FPWritePcx, FPReadXPM, FPWriteXPM; 330 457 331 458 type … … 375 502 end; 376 503 504 function TBGRADefaultBitmap.GetCustomPenStyle: TBGRAPenStyle; 505 begin 506 result := DuplicatePenStyle(FCustomPenStyle); 507 end; 508 377 509 procedure TBGRADefaultBitmap.SetCanvasAlphaCorrection(const AValue: boolean); 378 510 begin … … 386 518 end; 387 519 520 procedure TBGRADefaultBitmap.SetCanvasDrawModeFP(const AValue: TDrawMode); 521 begin 522 FCanvasDrawModeFP := AValue; 523 Case AValue of 524 dmLinearBlend: FCanvasPixelProcFP := @FastBlendPixel; 525 dmDrawWithTransparency: FCanvasPixelProcFP := @DrawPixel; 526 dmXor: FCanvasPixelProcFP:= @XorPixel; 527 else FCanvasPixelProcFP := @SetPixel; 528 end; 529 end; 530 531 function TBGRADefaultBitmap.GetCanvasDrawModeFP: TDrawMode; 532 begin 533 Result:= FCanvasDrawModeFP; 534 end; 535 536 procedure TBGRADefaultBitmap.SetCustomPenStyle(const AValue: TBGRAPenStyle); 537 begin 538 FCustomPenStyle := DuplicatePenStyle(AValue); 539 end; 540 541 procedure TBGRADefaultBitmap.SetPenStyle(const AValue: TPenStyle); 542 begin 543 Case AValue of 544 psSolid: CustomPenStyle := SolidPenStyle; 545 psDash: CustomPenStyle := DashPenStyle; 546 psDot: CustomPenStyle := DotPenStyle; 547 psDashDot: CustomPenStyle := DashDotPenStyle; 548 psDashDotDot: CustomPenStyle := DashDotDotPenStyle; 549 else CustomPenStyle := ClearPenStyle; 550 end; 551 FPenStyle := AValue; 552 end; 553 554 function TBGRADefaultBitmap.GetPenStyle: TPenStyle; 555 begin 556 Result:= FPenStyle; 557 end; 558 559 { Update font properties to internal TFont object } 388 560 procedure TBGRADefaultBitmap.UpdateFont; 389 561 begin … … 394 566 if FFont.Height <> FFontHeight * FFontHeightSign then 395 567 FFont.Height := FFontHeight * FFontHeightSign; 568 if FFont.Orientation <> FontOrientation then 569 FFont.Orientation := FontOrientation; 570 if FontQuality = fqSystemClearType then 571 FFont.Quality := fqCleartype 572 else 573 FFont.Quality := FontDefaultQuality; 396 574 end; 397 575 398 576 procedure TBGRADefaultBitmap.SetFontHeight(AHeight: integer); 399 577 begin 400 if AHeight < 0 then401 raise ERangeError.Create('Font height must be positive');402 578 FFontHeight := AHeight; 403 579 end; 404 580 581 function TBGRADefaultBitmap.GetFontFullHeight: integer; 582 begin 583 if FontHeight < 0 then 584 result := -FontHeight 585 else 586 result := TextSize('Hg').cy; 587 end; 588 589 procedure TBGRADefaultBitmap.SetFontFullHeight(AHeight: integer); 590 begin 591 if AHeight > 0 then 592 FontHeight := -AHeight 593 else 594 FontHeight := 1; 595 end; 596 597 function TBGRADefaultBitmap.GetFontPixelMetric: TFontPixelMetric; 598 var fxFont: TFont; 599 begin 600 UpdateFont; 601 if FontQuality = fqSystem then 602 result := BGRAText.GetFontPixelMetric(FFont) 603 else 604 begin 605 FxFont := TFont.Create; 606 FxFont.Assign(FFont); 607 FxFont.Height := fxFont.Height*FontAntialiasingLevel; 608 Result:= BGRAText.GetFontPixelMetric(FxFont); 609 if Result.Baseline <> -1 then Result.Baseline:= round((Result.Baseline-1)/FontAntialiasingLevel); 610 if Result.CapLine <> -1 then Result.CapLine:= round(Result.CapLine/FontAntialiasingLevel); 611 if Result.DescentLine <> -1 then Result.DescentLine:= round((Result.DescentLine-1)/FontAntialiasingLevel); 612 if Result.Lineheight <> -1 then Result.Lineheight:= round(Result.Lineheight/FontAntialiasingLevel); 613 if Result.xLine <> -1 then Result.xLine:= round(Result.xLine/FontAntialiasingLevel); 614 end; 615 end; 616 617 { Get scanline without checking bounds nor updated from TBitmap } 405 618 function TBGRADefaultBitmap.GetScanlineFast(y: integer): PBGRAPixel; inline; 406 619 begin … … 423 636 424 637 {------------------------- Reference counter functions ------------------------} 425 426 function TBGRADefaultBitmap.NewReference: TBGRADefaultBitmap; 638 { These functions are not related to reference counting for interfaces : 639 a reference must be explicitely freed with FreeReference } 640 641 { Add a new reference and gives a pointer to it } 642 function TBGRADefaultBitmap.NewReference: TBGRACustomBitmap; 427 643 begin 428 644 Inc(FRefCount); … … 430 646 end; 431 647 648 { Free the current reference, and free the bitmap if necessary } 432 649 procedure TBGRADefaultBitmap.FreeReference; 433 650 begin … … 445 662 end; 446 663 447 function TBGRADefaultBitmap.GetUnique: TBGRADefaultBitmap; 664 { Make sure there is only one copy of the bitmap and return 665 the new pointer for it. If the bitmap is already unique, 666 then it does nothing } 667 function TBGRADefaultBitmap.GetUnique: TBGRACustomBitmap; 448 668 begin 449 669 if FRefCount > 1 then … … 456 676 end; 457 677 458 function TBGRADefaultBitmap.NewBitmap(AWidth, AHeight: integer): TBGRADefaultBitmap; 678 { Creates a new bitmap. Internally, it uses the same type so that if you 679 use an optimized version, you get a new bitmap with the same optimizations } 680 function TBGRADefaultBitmap.NewBitmap(AWidth, AHeight: integer): TBGRACustomBitmap; 459 681 var 460 682 BGRAClass: TBGRABitmapAny; … … 466 688 end; 467 689 468 function TBGRADefaultBitmap.NewBitmap(Filename: string): TBGRADefaultBitmap; 690 function TBGRADefaultBitmap.NewBitmap(AWidth, AHeight: integer; 691 Color: TBGRAPixel): TBGRACustomBitmap; 692 var 693 BGRAClass: TBGRABitmapAny; 694 begin 695 BGRAClass := TBGRABitmapAny(self.ClassType); 696 if BGRAClass = TBGRAPtrBitmap then 697 BGRAClass := TBGRADefaultBitmap; 698 Result := BGRAClass.Create(AWidth, AHeight, Color); 699 end; 700 701 { Creates a new bitmap and loads it contents from a file } 702 function TBGRADefaultBitmap.NewBitmap(Filename: string): TBGRACustomBitmap; 469 703 var 470 704 BGRAClass: TBGRABitmapAny; … … 476 710 {----------------------- TFPCustomImage override ------------------------------} 477 711 712 { Creates a new bitmap, initialize properties and bitmap data } 478 713 constructor TBGRADefaultBitmap.Create(AWidth, AHeight: integer); 479 714 begin … … 484 719 end; 485 720 486 721 { Set the size of the current bitmap. All data is lost during the process } 487 722 procedure TBGRADefaultBitmap.SetSize(AWidth, AHeight: integer); 488 723 begin … … 497 732 FHeight := AHeight; 498 733 FNbPixels := AWidth * AHeight; 499 if FNbPixels < 0 then 734 if FNbPixels < 0 then // 2 Go limit 500 735 raise EOutOfMemory.Create('Image too big'); 501 736 FreeBitmap; 502 737 ReallocData; 738 NoClip; 503 739 end; 504 740 … … 515 751 Init; 516 752 inherited Create(ABitmap.Width, ABitmap.Height); 517 LoadFromRawImage(ABitmap.RawImage,0);753 Assign(ABitmap); 518 754 end; 519 755 … … 535 771 begin 536 772 FreeData; 773 FFont.Free; 537 774 FBitmap.Free; 775 FCanvasFP.Free; 776 FCanvasBGRA.Free; 777 FCanvas2D.Free; 538 778 inherited Destroy; 539 779 end; … … 553 793 end; 554 794 555 procedure TBGRADefaultBitmap.Assign(Bitmap: TBitmap); 795 procedure TBGRADefaultBitmap.Assign(ABitmap: TBitmap); 796 var TempBmp: TBitmap; 797 ConvertOk: boolean; 556 798 begin 557 799 DiscardBitmapChange; 558 SetSize(Bitmap.Width, bitmap.Height); 559 GetImageFromCanvas(Bitmap.Canvas, 0, 0); 560 end; 561 562 procedure TBGRADefaultBitmap.Assign(MemBitmap: TBGRADefaultBitmap); 800 SetSize(ABitmap.Width, ABitmap.Height); 801 if not LoadFromRawImage(ABitmap.RawImage,0,False,False) then 802 begin //try to convert 803 TempBmp := TBitmap.Create; 804 TempBmp.Width := ABitmap.Width; 805 TempBmp.Height := ABitmap.Height; 806 TempBmp.Canvas.Draw(0,0,ABitmap); 807 ConvertOk := LoadFromRawImage(TempBmp.RawImage,0,False,False); 808 TempBmp.Free; 809 if not ConvertOk then 810 raise Exception.Create('Unable to convert image to 24 bit'); 811 end; 812 If Empty then AlphaFill(255); // if bitmap seems to be empty, assume 813 // it is an opaque bitmap without alpha channel 814 end; 815 816 procedure TBGRADefaultBitmap.Assign(MemBitmap: TBGRACustomBitmap); 563 817 begin 564 818 DiscardBitmapChange; … … 567 821 end; 568 822 823 procedure TBGRADefaultBitmap.Serialize(AStream: TStream); 824 var lWidth,lHeight: integer; 825 begin 826 lWidth := NtoLE(Width); 827 lHeight := NtoLE(Height); 828 AStream.Write(lWidth,sizeof(lWidth)); 829 AStream.Write(lHeight,sizeof(lHeight)); 830 AStream.Write(Data^, NbPixels*sizeof(TBGRAPixel)); 831 end; 832 833 {$hints off} 834 procedure TBGRADefaultBitmap.Deserialize(AStream: TStream); 835 var lWidth,lHeight: integer; 836 begin 837 AStream.Read(lWidth,sizeof(lWidth)); 838 AStream.Read(lHeight,sizeof(lHeight)); 839 lWidth := LEtoN(lWidth); 840 lHeight := LEtoN(lHeight); 841 SetSize(lWidth,lHeight); 842 AStream.Read(Data^, NbPixels*sizeof(TBGRAPixel)); 843 end; 844 {$hints on} 845 846 class procedure TBGRADefaultBitmap.SerializeEmpty(AStream: TStream); 847 var zero: integer; 848 begin 849 zero := 0; 850 AStream.Write(zero,sizeof(zero)); 851 AStream.Write(zero,sizeof(zero)); 852 end; 853 569 854 procedure TBGRADefaultBitmap.LoadFromFile(const filename: string); 570 855 var 571 tempBitmap: TBGRADefaultBitmap; 572 begin 573 if IsPaintDotNetFile(filename) then 574 begin 575 tempBitmap := LoadPaintDotNetFile(filename); 576 Assign(tempBitmap); 577 tempBitmap.Free; 578 end 579 else 580 begin 856 OldDrawMode: TDrawMode; 857 begin 858 OldDrawMode := CanvasDrawModeFP; 859 CanvasDrawModeFP := dmSet; 860 ClipRect := rect(0,0,Width,Height); 861 try 581 862 inherited LoadFromfile(filename); 863 finally 864 CanvasDrawModeFP := OldDrawMode; 582 865 ClearTransparentPixels; 583 866 end; … … 588 871 ext: string; 589 872 writer: TFPCustomImageWriter; 590 pngWriter: TFPWriterPNG;591 873 begin 592 874 ext := AnsiLowerCase(ExtractFileExt(filename)); 593 875 876 { When saving to PNG, define some parameters so that the 877 image be readable by most programs } 594 878 if ext = '.png' then 595 begin 596 pngWriter := TFPWriterPNG.Create; 597 pngWriter.Indexed := False; 598 pngWriter.UseAlpha := HasTransparentPixels; 599 pngWriter.WordSized := false; 600 writer := pngWriter; 601 end else 602 if (ext='.xpm') and (Width*Height > 32768) then 879 writer := CreateAdaptedPngWriter 880 else 881 if (ext='.xpm') and (Width*Height > 32768) then //xpm is slow so avoid big images 603 882 raise exception.Create('Image is too big to be saved as XPM') else 604 883 writer := nil; 605 884 606 if writer <> nil then 885 if writer <> nil then //use custom writer if defined 607 886 begin 608 887 inherited SaveToFile(Filename, writer); … … 613 892 end; 614 893 894 procedure TBGRADefaultBitmap.SaveToStreamAsPng(Str: TStream); 895 var writer: TFPWriterPNG; 896 begin 897 writer := CreateAdaptedPngWriter; 898 SaveToStream(Str,writer); 899 writer.Free; 900 end; 901 902 {------------------------- Clipping -------------------------------} 903 904 { Check if a point is in the clipping rectangle } 905 function TBGRADefaultBitmap.PtInClipRect(x, y: integer): boolean; 906 begin 907 result := (x >= FClipRect.Left) and (y >= FClipRect.Top) and (x < FClipRect.Right) and (y < FClipRect.Bottom); 908 end; 909 910 procedure TBGRADefaultBitmap.NoClip; 911 begin 912 FClipRect := rect(0,0,FWidth,FHeight); 913 end; 914 915 procedure TBGRADefaultBitmap.Fill(texture: IBGRAScanner; mode: TDrawMode); 916 begin 917 FillRect(FClipRect.Left,FClipRect.Top,FClipRect.Right,FClipRect.Bottom,texture,mode); 918 end; 919 920 function TBGRADefaultBitmap.GetClipRect: TRect; 921 begin 922 Result:= FClipRect; 923 end; 924 925 procedure TBGRADefaultBitmap.SetClipRect(const AValue: TRect); 926 begin 927 IntersectRect(FClipRect,AValue,Rect(0,0,FWidth,FHeight)); 928 end; 929 615 930 {-------------------------- Pixel functions -----------------------------------} 616 931 617 932 procedure TBGRADefaultBitmap.SetPixel(x, y: integer; c: TBGRAPixel); 618 933 begin 619 if (x < 0) or (x >= Width) or (y < 0) or (y >= Height) then620 exit;621 ( Scanline[y]+x)^ := c;934 if not PtInClipRect(x,y) then exit; 935 LoadFromBitmapIfNeeded; 936 (GetScanlineFast(y) +x)^ := c; 622 937 InvalidateBitmap; 623 938 end; 624 939 940 procedure TBGRADefaultBitmap.XorPixel(x, y: integer; c: TBGRAPixel); 941 var 942 p : PDWord; 943 begin 944 if not PtInClipRect(x,y) then exit; 945 LoadFromBitmapIfNeeded; 946 p := PDWord(GetScanlineFast(y) +x); 947 p^ := p^ xor DWord(c); 948 InvalidateBitmap; 949 end; 950 625 951 procedure TBGRADefaultBitmap.SetPixel(x, y: integer; c: TColor); 626 952 var 627 953 p: PByte; 628 954 begin 629 if (x < 0) or (x >= Width) or (y < 0) or (y >= Height) then630 exit;631 p := PByte( Scanline[y]+ x);955 if not PtInClipRect(x,y) then exit; 956 LoadFromBitmapIfNeeded; 957 p := PByte(GetScanlineFast(y) + x); 632 958 p^ := c shr 16; 633 959 Inc(p); … … 642 968 procedure TBGRADefaultBitmap.DrawPixel(x, y: integer; c: TBGRAPixel); 643 969 begin 644 if (x < 0) or (x >= Width) or (y < 0) or (y >= Height) then645 exit;646 DrawPixelInline (Scanline[y]+ x, c);970 if not PtInClipRect(x,y) then exit; 971 LoadFromBitmapIfNeeded; 972 DrawPixelInlineWithAlphaCheck(GetScanlineFast(y) + x, c); 647 973 InvalidateBitmap; 648 974 end; 649 975 976 procedure TBGRADefaultBitmap.DrawPixel(x, y: integer; ec: TExpandedPixel); 977 begin 978 if not PtInClipRect(x,y) then exit; 979 LoadFromBitmapIfNeeded; 980 DrawExpandedPixelInlineWithAlphaCheck(GetScanlineFast(y) + x, ec); 981 InvalidateBitmap; 982 end; 983 650 984 procedure TBGRADefaultBitmap.FastBlendPixel(x, y: integer; c: TBGRAPixel); 651 985 begin 652 if (x < 0) or (x >= Width) or (y < 0) or (y >= Height) then653 exit;654 FastBlendPixelInline( Scanline[y]+ x, c);986 if not PtInClipRect(x,y) then exit; 987 LoadFromBitmapIfNeeded; 988 FastBlendPixelInline(GetScanlineFast(y) + x, c); 655 989 InvalidateBitmap; 656 990 end; … … 658 992 procedure TBGRADefaultBitmap.ErasePixel(x, y: integer; alpha: byte); 659 993 begin 660 if (x < 0) or (x >= Width) or (y < 0) or (y >= Height) then661 exit;662 ErasePixelInline( Scanline[y]+ x, alpha);994 if not PtInClipRect(x,y) then exit; 995 LoadFromBitmapIfNeeded; 996 ErasePixelInline(GetScanlineFast(y) + x, alpha); 663 997 InvalidateBitmap; 664 998 end; … … 666 1000 procedure TBGRADefaultBitmap.AlphaPixel(x, y: integer; alpha: byte); 667 1001 begin 668 if (x < 0) or (x >= Width) or (y < 0) or (y >= Height) then669 exit;1002 if not PtInClipRect(x,y) then exit; 1003 LoadFromBitmapIfNeeded; 670 1004 if alpha = 0 then 671 ( Scanline[y]+x)^ := BGRAPixelTransparent1005 (GetScanlineFast(y) +x)^ := BGRAPixelTransparent 672 1006 else 673 ( Scanline[y]+x)^.alpha := alpha;1007 (GetScanlineFast(y) +x)^.alpha := alpha; 674 1008 InvalidateBitmap; 675 1009 end; … … 677 1011 function TBGRADefaultBitmap.GetPixel(x, y: integer): TBGRAPixel; 678 1012 begin 679 if (x < 0) or (x >= Width) or (y < 0) or (y >= Height) then 1013 if (x < 0) or (x >= Width) or (y < 0) or (y >= Height) then //it is possible to read pixels outside of the cliprect 680 1014 Result := BGRAPixelTransparent 681 1015 else 682 Result := (Scanline[y] + x)^; 1016 begin 1017 LoadFromBitmapIfNeeded; 1018 Result := (GetScanlineFast(y) + x)^; 1019 end; 683 1020 end; 684 1021 685 1022 {$hints off} 686 function TBGRADefaultBitmap.GetPixel(x, y: single): TBGRAPixel; 687 var 688 ix, iy, w: integer; 689 rSum, gSum, bSum, rgbDiv: cardinal; 690 aSum, aDiv: cardinal; 1023 { This function compute an interpolated pixel at floating point coordinates } 1024 function TBGRADefaultBitmap.GetPixel(x, y: single; AResampleFilter: TResampleFilter = rfLinear): TBGRAPixel; 1025 var 1026 ix, iy: integer; 1027 w1,w2,w3,w4,alphaW: cardinal; 1028 rSum, gSum, bSum: cardinal; //rgbDiv = aSum 1029 aSum: cardinal; 691 1030 c: TBGRAPixel; 692 1031 scan: PBGRAPixel; 693 begin 694 if (frac(x) = 0) and (frac(y) = 0) then 695 begin 696 Result := GetPixel(round(x), round(y)); 1032 factX,factY: single; 1033 iFactX,iFactY: integer; 1034 begin 1035 ix := floor(x); 1036 iy := floor(y); 1037 factX := x-ix; //distance from integer coordinate 1038 factY := y-iy; 1039 1040 //if the coordinate is integer, then call standard GetPixel function 1041 if (factX = 0) and (factY = 0) then 1042 begin 1043 Result := GetPixel(ix, iy); 697 1044 exit; 698 1045 end; 699 1046 LoadFromBitmapIfNeeded; 1047 1048 rSum := 0; 1049 gSum := 0; 1050 bSum := 0; 1051 aSum := 0; 1052 1053 //apply interpolation filter 1054 factX := FineInterpolation( factX, AResampleFilter ); 1055 factY := FineInterpolation( factY, AResampleFilter ); 1056 1057 iFactX := round(factX*256); //integer values for fractionnal part 1058 iFactY := round(factY*256); 1059 1060 w4 := (iFactX*iFactY+127) shr 8; 1061 w3 := iFactY-w4; 1062 w1 := (256-iFactX)-w3; 1063 w2 := iFactX-w4; 1064 1065 { For each pixel around the coordinate, compute 1066 the weight for it and multiply values by it before 1067 adding to the sum } 1068 if (iy >= 0) and (iy < Height) then 1069 begin 1070 scan := GetScanlineFast(iy); 1071 1072 if (ix >= 0) and (ix < Width) then 1073 begin 1074 c := (scan + ix)^; 1075 alphaW := c.alpha * w1; 1076 aSum += alphaW; 1077 rSum += c.red * alphaW; 1078 gSum += c.green * alphaW; 1079 bSum += c.blue * alphaW; 1080 end; 1081 1082 Inc(ix); 1083 if (ix >= 0) and (ix < Width) then 1084 begin 1085 c := (scan + ix)^; 1086 alphaW := c.alpha * w2; 1087 aSum += alphaW; 1088 rSum += c.red * alphaW; 1089 gSum += c.green * alphaW; 1090 bSum += c.blue * alphaW; 1091 end; 1092 end 1093 else 1094 begin 1095 Inc(ix); 1096 end; 1097 1098 Inc(iy); 1099 if (iy >= 0) and (iy < Height) then 1100 begin 1101 scan := GetScanlineFast(iy); 1102 1103 if (ix >= 0) and (ix < Width) then 1104 begin 1105 c := (scan + ix)^; 1106 alphaW := c.alpha * w4; 1107 aSum += alphaW; 1108 rSum += c.red * alphaW; 1109 gSum += c.green * alphaW; 1110 bSum += c.blue * alphaW; 1111 end; 1112 1113 Dec(ix); 1114 if (ix >= 0) and (ix < Width) then 1115 begin 1116 c := (scan + ix)^; 1117 alphaW := c.alpha * w3; 1118 aSum += alphaW; 1119 rSum += c.red * alphaW; 1120 gSum += c.green * alphaW; 1121 bSum += c.blue * alphaW; 1122 end; 1123 end; 1124 1125 if aSum = 0 then //if there is no alpha 1126 Result := BGRAPixelTransparent 1127 else 1128 begin 1129 Result.red := (rSum + aSum shr 1) div aSum; 1130 Result.green := (gSum + aSum shr 1) div aSum; 1131 Result.blue := (bSum + aSum shr 1) div aSum; 1132 Result.alpha := (aSum + 128) shr 8; 1133 end; 1134 end; 1135 1136 { Same as GetPixel(single,single,TResampleFilter) but with coordinate cycle, supposing the image repeats itself in both directions } 1137 function TBGRADefaultBitmap.GetPixelCycle(x, y: single; AResampleFilter: TResampleFilter = rfLinear): TBGRAPixel; 1138 var 1139 ix, iy, ixMod1,ixMod2: integer; 1140 w1,w2,w3,w4,alphaW: cardinal; 1141 bSum, gSum, rSum, rgbDiv: cardinal; 1142 aSum: cardinal; 1143 1144 c: TBGRAPixel; 1145 scan: PBGRAPixel; 1146 factX,factY: single; 1147 iFactX,iFactY: integer; 1148 begin 1149 ix := floor(x); 1150 iy := floor(y); 1151 factX := x-ix; 1152 factY := y-iy; 1153 1154 if (factX = 0) and (factY = 0) then 1155 begin 1156 Result := GetPixelCycle(ix, iy); 1157 exit; 1158 end; 1159 LoadFromBitmapIfNeeded; 1160 1161 factX := FineInterpolation( factX, AResampleFilter ); 1162 factY := FineInterpolation( factY, AResampleFilter ); 1163 1164 iFactX := round(factX*256); 1165 iFactY := round(factY*256); 1166 1167 1168 w4 := (iFactX*iFactY+127) shr 8; 1169 w3 := iFactY-w4; 1170 w1 := (256-iFactX)-w3; 1171 w2 := iFactX-w4; 700 1172 701 1173 rSum := 0; … … 703 1175 bSum := 0; 704 1176 rgbDiv := 0; 1177 705 1178 aSum := 0; 706 aDiv := 0; 707 708 ix := floor(x); 709 iy := floor(y); 710 711 if (iy >= 0) and (iy < Height) then 712 begin 713 scan := GetScanlineFast(iy); 714 715 if (ix >= 0) and (ix < Width) then 716 begin 717 c := (scan + ix)^; 718 w := round((1 - (x - ix)) * (1 - (y - iy)) * 255); 719 aDiv += w; 720 aSum += c.alpha * w; 721 c.alpha := c.alpha * w div 255; 722 rSum += c.red * c.alpha; 723 gSum += c.green * c.alpha; 724 bSum += c.blue * c.alpha; 725 rgbDiv += c.alpha; 726 end; 727 728 Inc(ix); 729 if (ix >= 0) and (ix < Width) then 730 begin 731 c := (scan + ix)^; 732 w := round((1 - (ix - x)) * (1 - (y - iy)) * 255); 733 aDiv += w; 734 aSum += c.alpha * w; 735 c.alpha := c.alpha * w div 255; 736 rSum += c.red * c.alpha; 737 gSum += c.green * c.alpha; 738 bSum += c.blue * c.alpha; 739 rgbDiv += c.alpha; 740 end; 741 end 742 else 743 Inc(ix); 1179 1180 scan := GetScanlineFast(PositiveMod(iy,Height)); 1181 1182 ixMod1 := PositiveMod(ix,Width); //apply cycle 1183 c := (scan + ixMod1)^; 1184 alphaW := c.alpha * w1; 1185 aSum += alphaW; 1186 1187 rSum += c.red * alphaW; 1188 gSum += c.green * alphaW; 1189 bSum += c.blue * alphaW; 1190 rgbDiv += alphaW; 1191 1192 Inc(ix); 1193 ixMod2 := PositiveMod(ix,Width); //apply cycle 1194 c := (scan + ixMod2)^; 1195 alphaW := c.alpha * w2; 1196 aSum += alphaW; 1197 1198 rSum += c.red * alphaW; 1199 gSum += c.green * alphaW; 1200 bSum += c.blue * alphaW; 1201 rgbDiv += alphaW; 744 1202 745 1203 Inc(iy); 746 if (iy >= 0) and (iy < Height) then 747 begin 748 scan := GetScanlineFast(iy); 749 750 if (ix >= 0) and (ix < Width) then 751 begin 752 c := (scan + ix)^; 753 w := round((1 - (ix - x)) * (1 - (iy - y)) * 255); 754 aDiv += w; 755 aSum += c.alpha * w; 756 c.alpha := c.alpha * w div 255; 757 rSum += c.red * c.alpha; 758 gSum += c.green * c.alpha; 759 bSum += c.blue * c.alpha; 760 rgbDiv += c.alpha; 761 end; 762 763 Dec(ix); 764 if (ix >= 0) and (ix < Width) then 765 begin 766 c := (scan + ix)^; 767 w := round((1 - (x - ix)) * (1 - (iy - y)) * 255); 768 aDiv += w; 769 aSum += c.alpha * w; 770 c.alpha := c.alpha * w div 255; 771 rSum += c.red * c.alpha; 772 gSum += c.green * c.alpha; 773 bSum += c.blue * c.alpha; 774 rgbDiv += c.alpha; 775 end; 776 end; 777 778 if (rgbDiv = 0) or (aDiv = 0) then 1204 scan := GetScanlineFast(PositiveMod(iy,Height)); 1205 1206 c := (scan + ixMod2)^; 1207 alphaW := c.alpha * w4; 1208 aSum += alphaW; 1209 1210 rSum += c.red * alphaW; 1211 gSum += c.green * alphaW; 1212 bSum += c.blue * alphaW; 1213 rgbDiv += alphaW; 1214 1215 c := (scan + ixMod1)^; 1216 alphaW := c.alpha * w3; 1217 aSum += alphaW; 1218 1219 rSum += c.red * alphaW; 1220 gSum += c.green * alphaW; 1221 bSum += c.blue * alphaW; 1222 rgbDiv += alphaW; 1223 1224 if (rgbDiv = 0) then 779 1225 Result := BGRAPixelTransparent 780 1226 else … … 783 1229 Result.green := (gSum + rgbDiv shr 1) div rgbDiv; 784 1230 Result.blue := (bSum + rgbDiv shr 1) div rgbDiv; 785 Result.alpha := (aSum + aDiv shr 1) div aDiv; 786 end; 1231 Result.alpha := (aSum + 128) shr 8; 1232 end; 1233 end; 1234 1235 function TBGRADefaultBitmap.GetPixelCycle(x, y: single; 1236 AResampleFilter: TResampleFilter; repeatX: boolean; repeatY: boolean 1237 ): TBGRAPixel; 1238 var 1239 alpha: byte; 1240 begin 1241 alpha := 255; 1242 if not repeatX then 1243 begin 1244 if (x < -0.5) or (x > Width-0.5) then 1245 begin 1246 result := BGRAPixelTransparent; 1247 exit; 1248 end; 1249 if x < 0 then 1250 alpha := round((0.5+x)*510) 1251 else 1252 if x > Width-1 then 1253 alpha := round((Width-0.5-x)*510); 1254 end; 1255 if not repeatY then 1256 begin 1257 if (y < -0.5) or (y > Height-0.5) then 1258 begin 1259 result := BGRAPixelTransparent; 1260 exit; 1261 end; 1262 if y < 0 then 1263 alpha := round((0.5+y)*2*alpha) 1264 else 1265 if y > Height-1 then 1266 alpha := round((Height-0.5-y)*2*alpha); 1267 end; 1268 result := GetPixelCycle(x,y,AResampleFilter); 1269 if alpha<>255 then 1270 result.alpha := ApplyOpacity(result.alpha,alpha); 787 1271 end; 788 1272 789 1273 {$hints on} 790 791 function TBGRADefaultBitmap.GetPixelCycle(x, y: integer): TBGRAPixel;792 begin793 if (Width = 0) or (Height = 0) then794 Result := BGRAPixelTransparent795 else796 begin797 x := x mod Width;798 if x < 0 then799 Inc(x, Width);800 y := y mod Height;801 if y < 0 then802 Inc(y, Height);803 Result := (Scanline[y] + x)^;804 end;805 end;806 1274 807 1275 procedure TBGRADefaultBitmap.InvalidateBitmap; … … 827 1295 end; 828 1296 829 procedure TBGRADefaultBitmap.LoadFromRawImage(ARawImage: TRawImage; 830 DefaultOpacity: byte; AlwaysReplaceAlpha: boolean); 831 var 832 psource_byte, pdest_byte: PByte; 833 n, x, y, delta: integer; 834 psource_pix, pdest_pix: PBGRAPixel; 835 sourceval: longword; 836 OpacityOrMask: longword; 1297 function TBGRADefaultBitmap.GetCanvasFP: TFPImageCanvas; 1298 begin 1299 {$warnings off} 1300 if FCanvasFP = nil then 1301 FCanvasFP := TFPImageCanvas.Create(self); 1302 {$warnings on} 1303 result := FCanvasFP; 1304 end; 1305 1306 { Load raw image data. It must be 32bit or 24 bits per pixel} 1307 function TBGRADefaultBitmap.LoadFromRawImage(ARawImage: TRawImage; 1308 DefaultOpacity: byte; AlwaysReplaceAlpha: boolean; RaiseErrorOnInvalidPixelFormat: boolean): boolean; 1309 var 1310 psource_byte, pdest_byte, 1311 psource_first, pdest_first: PByte; 1312 psource_delta, pdest_delta: integer; 1313 1314 n: integer; 1315 mustSwapRedBlue, mustReverse32: boolean; 1316 1317 procedure CopyAndSwapIfNecessary(psrc: PBGRAPixel; pdest: PBGRAPixel; count: integer); 1318 begin 1319 if mustReverse32 then 1320 begin 1321 while count > 0 do 1322 begin 1323 pdest^.blue := psrc^.alpha; 1324 pdest^.green := psrc^.red; 1325 pdest^.red := psrc^.green; 1326 pdest^.alpha := psrc^.blue; 1327 dec(count); 1328 inc(pdest); 1329 inc(psrc); 1330 end; 1331 end else 1332 if mustSwapRedBlue then 1333 begin 1334 while count > 0 do 1335 begin 1336 pdest^.red := psrc^.blue; 1337 pdest^.green := psrc^.green; 1338 pdest^.blue := psrc^.red; 1339 pdest^.alpha := psrc^.alpha; 1340 dec(count); 1341 inc(pdest); 1342 inc(psrc); 1343 end; 1344 end else 1345 move(psrc^,pdest^,count*sizeof(TBGRAPixel)); 1346 end; 1347 1348 procedure CopyRGBAndSwapIfNecessary(psrc: PByte; pdest: PBGRAPixel; count: integer); 1349 begin 1350 if mustSwapRedBlue then 1351 begin 1352 while count > 0 do 1353 begin 1354 pdest^.blue := (psource_byte+2)^; 1355 pdest^.green := (psource_byte+1)^; 1356 pdest^.red := psource_byte^; 1357 pdest^.alpha := DefaultOpacity; 1358 inc(psrc,3); 1359 inc(pdest); 1360 dec(count); 1361 end; 1362 end else 1363 begin 1364 while count > 0 do 1365 begin 1366 PWord(pdest)^ := PWord(psource_byte)^; 1367 pdest^.red := (psource_byte+2)^; 1368 pdest^.alpha := DefaultOpacity; 1369 inc(psrc,3); 1370 inc(pdest); 1371 dec(count); 1372 end; 1373 end; 1374 end; 1375 1376 procedure CopyAndSwapIfNecessaryAndSetAlpha(psrc: PBGRAPixel; pdest: PBGRAPixel; count: integer); 1377 begin 1378 if mustReverse32 then 1379 begin 1380 while count > 0 do 1381 begin 1382 pdest^.blue := psrc^.alpha; 1383 pdest^.green := psrc^.red; 1384 pdest^.red := psrc^.green; 1385 pdest^.alpha := DefaultOpacity; //use default opacity 1386 inc(psrc); 1387 inc(pdest); 1388 dec(count); 1389 end; 1390 end else 1391 if mustSwapRedBlue then 1392 begin 1393 while count > 0 do 1394 begin 1395 pdest^.red := psrc^.blue; 1396 pdest^.green := psrc^.green; 1397 pdest^.blue := psrc^.red; 1398 pdest^.alpha := DefaultOpacity; //use default opacity 1399 inc(psrc); 1400 inc(pdest); 1401 dec(count); 1402 end; 1403 end else 1404 begin 1405 while count > 0 do 1406 begin 1407 PWord(pdest)^ := PWord(psource_byte)^; 1408 pdest^.red := psrc^.red; 1409 pdest^.alpha := DefaultOpacity; //use default opacity 1410 inc(psrc); 1411 inc(pdest); 1412 dec(count); 1413 end; 1414 end; 1415 end; 1416 1417 procedure CopyAndSwapIfNecessaryAndReplaceAlpha(psrc: PBGRAPixel; pdest: PBGRAPixel; count: integer); 1418 var OpacityOrMask, OpacityAndMask, sourceval: Longword; 1419 begin 1420 OpacityOrMask := NtoLE(longword(DefaultOpacity) shl 24); 1421 OpacityAndMask := NtoLE($FFFFFF); 1422 if mustReverse32 then 1423 begin 1424 OpacityAndMask := NtoBE($FFFFFF); 1425 while count > 0 do 1426 begin 1427 sourceval := plongword(psrc)^ and OpacityAndMask; 1428 if (sourceval <> 0) and (psrc^.blue{=alpha} = 0) then //if not black but transparent 1429 begin 1430 pdest^.blue := psrc^.alpha; 1431 pdest^.green := psrc^.red; 1432 pdest^.red := psrc^.green; 1433 pdest^.alpha := DefaultOpacity; //use default opacity 1434 end 1435 else 1436 begin 1437 pdest^.blue := psrc^.alpha; 1438 pdest^.green := psrc^.red; 1439 pdest^.red := psrc^.green; 1440 pdest^.alpha := psrc^.blue; 1441 end; 1442 dec(count); 1443 inc(pdest); 1444 inc(psrc); 1445 end; 1446 end else 1447 if mustSwapRedBlue then 1448 begin 1449 while count > 0 do 1450 begin 1451 sourceval := plongword(psrc)^ and OpacityAndMask; 1452 if (sourceval <> 0) and (psrc^.alpha = 0) then //if not black but transparent 1453 begin 1454 pdest^.red := psrc^.blue; 1455 pdest^.green := psrc^.green; 1456 pdest^.blue := psrc^.red; 1457 pdest^.alpha := DefaultOpacity; //use default opacity 1458 end 1459 else 1460 begin 1461 pdest^.red := psrc^.blue; 1462 pdest^.green := psrc^.green; 1463 pdest^.blue := psrc^.red; 1464 pdest^.alpha := psrc^.alpha; 1465 end; 1466 dec(count); 1467 inc(pdest); 1468 inc(psrc); 1469 end; 1470 end else 1471 begin 1472 while count > 0 do 1473 begin 1474 sourceval := plongword(psrc)^ and OpacityAndMask; 1475 if (sourceval <> 0) and (psrc^.alpha = 0) then //if not black but transparent 1476 plongword(pdest)^ := sourceval or OpacityOrMask //use default opacity 1477 else 1478 pdest^ := psrc^; 1479 dec(count); 1480 inc(pdest); 1481 inc(psrc); 1482 end; 1483 end; 1484 end; 1485 837 1486 begin 838 1487 if (ARawImage.Description.Width <> cardinal(Width)) or 839 1488 (ARawImage.Description.Height <> cardinal(Height)) then 840 begin841 1489 raise Exception.Create('Bitmap size is inconsistant'); 842 end 1490 1491 DiscardBitmapChange; 1492 if (Height=0) or (Width=0) then 1493 begin 1494 result := true; 1495 exit; 1496 end; 1497 1498 if ARawImage.Description.LineOrder = riloTopToBottom then 1499 begin 1500 psource_first := ARawImage.Data; 1501 psource_delta := ARawImage.Description.BytesPerLine; 1502 end else 1503 begin 1504 psource_first := ARawImage.Data + (ARawImage.Description.Height-1) * ARawImage.Description.BytesPerLine; 1505 psource_delta := -ARawImage.Description.BytesPerLine; 1506 end; 1507 1508 if ((ARawImage.Description.RedShift = 0) and 1509 (ARawImage.Description.BlueShift = 16) and 1510 (ARawImage.Description.ByteOrder = riboLSBFirst)) or 1511 ((ARawImage.Description.RedShift = 24) and 1512 (ARawImage.Description.BlueShift = 8) and 1513 (ARawImage.Description.ByteOrder = riboMSBFirst)) then 1514 mustSwapRedBlue:= true 843 1515 else 1516 begin 1517 mustSwapRedBlue:= false; 1518 if ((ARawImage.Description.RedShift = 8) and 1519 (ARawImage.Description.GreenShift = 16) and 1520 (ARawImage.Description.BlueShift = 24) and 1521 (ARawImage.Description.ByteOrder = riboLSBFirst)) or 1522 ((ARawImage.Description.RedShift = 16) and 1523 (ARawImage.Description.GreenShift = 8) and 1524 (ARawImage.Description.BlueShift = 0) and 1525 (ARawImage.Description.ByteOrder = riboMSBFirst)) then 1526 mustReverse32 := true 1527 else 1528 mustReverse32 := false; 1529 end; 1530 1531 if self.LineOrder = riloTopToBottom then 1532 begin 1533 pdest_first := PByte(self.Data); 1534 pdest_delta := self.Width*sizeof(TBGRAPixel); 1535 end else 1536 begin 1537 pdest_first := PByte(self.Data) + (self.Height-1)*self.Width*sizeof(TBGRAPixel); 1538 pdest_delta := -self.Width*sizeof(TBGRAPixel); 1539 end; 1540 1541 { 32 bits per pixel } 844 1542 if (ARawImage.Description.BitsPerPixel = 32) and 845 (ARawImage.DataSize = longword(NbPixels) * sizeof(TBGRAPixel)) then 846 begin 1543 (ARawImage.DataSize >= longword(NbPixels) * 4) then 1544 begin 1545 { If there is an alpha channel } 847 1546 if (ARawImage.Description.AlphaPrec = 8) and not AlwaysReplaceAlpha then 848 1547 begin 849 psource_pix := PBGRAPixel(ARawImage.Data);850 pdest_pix := FData;851 1548 if DefaultOpacity = 0 then 852 move(psource_pix^, pdest_pix^, NbPixels * sizeof(TBGRAPixel)) 1549 begin 1550 if ARawImage.Description.LineOrder = FLineOrder then 1551 CopyAndSwapIfNecessary(PBGRAPixel(ARawImage.Data), FData, NbPixels) else 1552 begin 1553 psource_byte := psource_first; 1554 pdest_byte := pdest_first; 1555 for n := FHeight-1 downto 0 do 1556 begin 1557 CopyAndSwapIfNecessary(PBGRAPixel(psource_byte), PBGRAPixel(pdest_byte), FWidth); 1558 inc(psource_byte, psource_delta); 1559 inc(pdest_byte, pdest_delta); 1560 end; 1561 end; 1562 end 853 1563 else 854 1564 begin 855 OpacityOrMask := longword(DefaultOpacity) shl 24; 856 for n := NbPixels - 1 downto 0 do 1565 psource_byte := psource_first; 1566 pdest_byte := pdest_first; 1567 for n := FHeight-1 downto 0 do 857 1568 begin 858 sourceval := plongword(psource_pix)^ and $FFFFFF; 859 if (sourceval <> 0) and (psource_pix^.alpha = 0) then 860 begin 861 plongword(pdest_pix)^ := sourceval or OpacityOrMask; 862 InvalidateBitmap; 863 end 864 else 865 pdest_pix^ := psource_pix^; 866 Inc(pdest_pix); 867 Inc(psource_pix); 1569 CopyAndSwapIfNecessaryAndReplaceAlpha(PBGRAPixel(psource_byte), PBGRAPixel(pdest_byte), FWidth); 1570 inc(psource_byte, psource_delta); 1571 inc(pdest_byte, pdest_delta); 868 1572 end; 869 1573 end; 870 1574 end 871 1575 else 872 begin 873 psource_byte := ARawImage.Data;874 pdest_byte := PByte(FData);875 for n := NbPixels -1 downto 0 do1576 begin { If there isn't any alpha channel } 1577 psource_byte := psource_first; 1578 pdest_byte := pdest_first; 1579 for n := FHeight-1 downto 0 do 876 1580 begin 877 PWord(pdest_byte)^ := PWord(psource_byte)^; 878 Inc(pdest_byte, 2); 879 Inc(psource_byte, 2); 880 pdest_byte^ := psource_byte^; 881 Inc(pdest_byte); 882 Inc(psource_byte, 2); 883 pdest_byte^ := DefaultOpacity; 884 Inc(pdest_byte); 1581 CopyAndSwapIfNecessaryAndSetAlpha(PBGRAPixel(psource_byte), PBGRAPixel(pdest_byte), FWidth); 1582 inc(psource_byte, psource_delta); 1583 inc(pdest_byte, pdest_delta); 885 1584 end; 886 1585 end; 887 1586 end 888 1587 else 1588 { 24 bit per pixel } 889 1589 if (ARawImage.Description.BitsPerPixel = 24) then 890 1590 begin 891 psource_byte := ARawImage.Data; 892 pdest_byte := PByte(FData); 893 delta := integer(ARawImage.Description.BytesPerLine) - FWidth * 3; 894 for y := 0 to FHeight - 1 do 895 begin 896 for x := 0 to FWidth - 1 do 897 begin 898 PWord(pdest_byte)^ := PWord(psource_byte)^; 899 Inc(pdest_byte, 2); 900 Inc(psource_byte, 2); 901 pdest_byte^ := psource_byte^; 902 Inc(pdest_byte); 903 Inc(psource_byte); 904 pdest_byte^ := DefaultOpacity; 905 Inc(pdest_byte); 906 end; 907 Inc(psource_byte, delta); 1591 psource_byte := psource_first; 1592 pdest_byte := pdest_first; 1593 for n := FHeight-1 downto 0 do 1594 begin 1595 CopyRGBAndSwapIfNecessary(psource_byte, PBGRAPixel(pdest_byte), FWidth); 1596 inc(psource_byte, psource_delta); 1597 inc(pdest_byte, pdest_delta); 908 1598 end; 909 1599 end 910 1600 else 911 raise Exception.Create('Invalid raw image format (' + IntToStr( 912 ARawImage.Description.Depth) + ' found)'); 913 DiscardBitmapChange; 914 if (ARawImage.Description.RedShift = 0) and 915 (ARawImage.Description.BlueShift = 16) then 916 SwapRedBlue; 917 if ARawImage.Description.LineOrder <> FLineOrder then 918 VerticalFlip; 1601 begin 1602 if RaiseErrorOnInvalidPixelFormat then 1603 raise Exception.Create('Invalid raw image format (' + IntToStr( 1604 ARawImage.Description.Depth) + ' found)') else 1605 begin 1606 result := false; 1607 exit; 1608 end; 1609 end; 1610 1611 InvalidateBitmap; 1612 result := true; 919 1613 end; 920 1614 … … 938 1632 end; 939 1633 1634 { Initialize properties } 940 1635 procedure TBGRADefaultBitmap.Init; 941 var942 HeightP1, HeightM1: integer;943 1636 begin 944 1637 FRefCount := 1; 945 1638 FBitmap := nil; 1639 FCanvasFP := nil; 1640 FCanvasBGRA := nil; 1641 CanvasDrawModeFP := dmDrawWithTransparency; 946 1642 FData := nil; 947 1643 FWidth := 0; … … 951 1647 FAlphaCorrectionNeeded := False; 952 1648 FEraseMode := False; 1649 FillMode := fmWinding; 953 1650 954 1651 FFont := TFont.Create; 955 1652 FontName := 'Arial'; 956 1653 FontStyle := []; 1654 FontAntialias := False; 957 1655 FFontHeight := 20; 958 FFontHeightSign := 1;959 HeightP1 := TextSize('Hg').cy; 960 FFontHeightSign := -1;961 HeightM1 := TextSize('Hg').cy;962 963 if HeightP1 > HeightM1 then964 FFontHeightSign := 1965 else966 FFontHeightSign := -1;1656 FFontHeightSign := GetFontHeightSign(FFont); 1657 1658 PenStyle := psSolid; 1659 LineCap := pecRound; 1660 JoinStyle := pjsBevel; 1661 JoinMiterLimit := 2; 1662 ResampleFilter := rfHalfCosine; 1663 ScanInterpolationFilter := rfLinear; 1664 ScanOffset := Point(0,0); 967 1665 end; 968 1666 969 1667 procedure TBGRADefaultBitmap.SetInternalColor(x, y: integer; const Value: TFPColor); 970 var 971 p: PByte; 972 begin 973 if (x < 0) or (y < 0) or (x >= Width) or (y >= Height) then 974 exit; 975 p := PByte(Scanline[y] + x); 976 p^ := Value.blue shr 8; 977 Inc(p); 978 p^ := Value.green shr 8; 979 Inc(p); 980 p^ := Value.red shr 8; 981 Inc(p); 982 p^ := Value.alpha shr 8; 1668 begin 1669 FCanvasPixelProcFP(x,y, FPColorToBGRA(Value)); 1670 end; 1671 1672 function TBGRADefaultBitmap.GetInternalColor(x, y: integer): TFPColor; 1673 begin 1674 if (x < 0) or (y < 0) or (x >= Width) or (y >= Height) then exit; 1675 result := BGRAToFPColor((Scanline[y] + x)^); 1676 end; 1677 1678 procedure TBGRADefaultBitmap.SetInternalPixel(x, y: integer; Value: integer); 1679 var 1680 c: TFPColor; 1681 begin 1682 if not PtInClipRect(x,y) then exit; 1683 c := Palette.Color[Value]; 1684 (Scanline[y] + x)^ := FPColorToBGRA(c); 983 1685 InvalidateBitmap; 984 1686 end; 985 1687 986 {$hints off} 987 function TBGRADefaultBitmap.GetInternalColor(x, y: integer): TFPColor; 988 var 989 p: PByte; 990 v: byte; 991 begin 992 if (x < 0) or (y < 0) or (x >= Width) or (y >= Height) then 993 exit; 994 p := PByte(Scanline[y] + x); 995 v := p^; 996 Result.blue := v shl 8 + v; 997 Inc(p); 998 v := p^; 999 Result.green := v shl 8 + v; 1000 Inc(p); 1001 v := p^; 1002 Result.red := v shl 8 + v; 1003 Inc(p); 1004 v := p^; 1005 Result.alpha := v shl 8 + v; 1006 end; 1007 1008 {$hints on} 1009 1010 procedure TBGRADefaultBitmap.SetInternalPixel(x, y: integer; Value: integer); 1011 var 1012 p: PByte; 1688 function TBGRADefaultBitmap.GetInternalPixel(x, y: integer): integer; 1689 var 1013 1690 c: TFPColor; 1014 1691 begin 1015 if (x < 0) or (y < 0) or (x >= Width) or (y >= Height) then 1016 exit; 1017 c := Palette.Color[Value]; 1018 p := PByte(Scanline[y] + x); 1019 p^ := c.blue shr 8; 1020 Inc(p); 1021 p^ := c.green shr 8; 1022 Inc(p); 1023 p^ := c.red shr 8; 1024 Inc(p); 1025 p^ := c.alpha shr 8; 1026 InvalidateBitmap; 1027 end; 1028 1029 {$hints off} 1030 function TBGRADefaultBitmap.GetInternalPixel(x, y: integer): integer; 1031 var 1032 p: PByte; 1033 v: byte; 1034 c: TFPColor; 1035 begin 1036 if (x < 0) or (y < 0) or (x >= Width) or (y >= Height) then 1037 exit; 1038 p := PByte(Scanline[y] + x); 1039 v := p^; 1040 c.blue := v shl 8 + v; 1041 Inc(p); 1042 v := p^; 1043 c.green := v shl 8 + v; 1044 Inc(p); 1045 v := p^; 1046 c.red := v shl 8 + v; 1047 Inc(p); 1048 v := p^; 1049 c.alpha := v shl 8 + v; 1692 if (x < 0) or (y < 0) or (x >= Width) or (y >= Height) then exit; 1693 c := BGRAToFPColor((Scanline[y] + x)^); 1050 1694 Result := palette.IndexOf(c); 1051 1695 end; 1052 1053 {$hints on}1054 1696 1055 1697 procedure TBGRADefaultBitmap.Draw(ACanvas: TCanvas; x, y: integer; Opaque: boolean); … … 1086 1728 {---------------------------- Line primitives ---------------------------------} 1087 1729 1088 procedure TBGRADefaultBitmap.SetHorizLine(x, y, x2: integer; c: TBGRAPixel);1730 function TBGRADefaultBitmap.CheckHorizLineBounds(var x,y,x2: integer): boolean; inline; 1089 1731 var 1090 1732 temp: integer; … … 1096 1738 x2 := temp; 1097 1739 end; 1098 if (x >= Width) or (x2 < 0) or (y < 0) or (y >= Height) then 1740 if (x >= FClipRect.Right) or (x2 < FClipRect.Left) or (y < FClipRect.Top) or (y >= FClipRect.Bottom) then 1741 begin 1742 result := false; 1099 1743 exit; 1100 if x < 0 then 1101 x := 0; 1102 if x2 >= Width then 1103 x2 := Width - 1; 1744 end; 1745 if x < FClipRect.Left then 1746 x := FClipRect.Left; 1747 if x2 >= FClipRect.Right then 1748 x2 := FClipRect.Right - 1; 1749 result := true; 1750 end; 1751 1752 procedure TBGRADefaultBitmap.SetHorizLine(x, y, x2: integer; c: TBGRAPixel); 1753 begin 1754 if not CheckHorizLineBounds(x,y,x2) then exit; 1104 1755 FillInline(scanline[y] + x, c, x2 - x + 1); 1105 1756 InvalidateBitmap; 1106 1757 end; 1107 1758 1759 procedure TBGRADefaultBitmap.XorHorizLine(x, y, x2: integer; c: TBGRAPixel); 1760 begin 1761 if not CheckHorizLineBounds(x,y,x2) then exit; 1762 XorInline(scanline[y] + x, c, x2 - x + 1); 1763 InvalidateBitmap; 1764 end; 1765 1108 1766 procedure TBGRADefaultBitmap.DrawHorizLine(x, y, x2: integer; c: TBGRAPixel); 1109 var 1110 temp: integer; 1111 begin 1112 if (x2 < x) then 1113 begin 1114 temp := x; 1115 x := x2; 1116 x2 := temp; 1117 end; 1118 if (x >= Width) or (x2 < 0) or (y < 0) or (y >= Height) then 1119 exit; 1120 if x < 0 then 1121 x := 0; 1122 if x2 >= Width then 1123 x2 := Width - 1; 1767 begin 1768 if not CheckHorizLineBounds(x,y,x2) then exit; 1124 1769 DrawPixelsInline(scanline[y] + x, c, x2 - x + 1); 1125 1770 InvalidateBitmap; 1126 1771 end; 1127 1772 1773 procedure TBGRADefaultBitmap.DrawHorizLine(x, y, x2: integer; ec: TExpandedPixel 1774 ); 1775 begin 1776 if not CheckHorizLineBounds(x,y,x2) then exit; 1777 DrawExpandedPixelsInline(scanline[y] + x, ec, x2 - x + 1); 1778 InvalidateBitmap; 1779 end; 1780 1781 procedure TBGRADefaultBitmap.DrawHorizLine(x, y, x2: integer; 1782 texture: IBGRAScanner); 1783 begin 1784 if not CheckHorizLineBounds(x,y,x2) then exit; 1785 texture.ScanMoveTo(x,y); 1786 ScannerPutPixels(texture,scanline[y] + x, x2 - x + 1,dmDrawWithTransparency); 1787 InvalidateBitmap; 1788 end; 1789 1128 1790 procedure TBGRADefaultBitmap.FastBlendHorizLine(x, y, x2: integer; c: TBGRAPixel); 1129 var 1130 temp: integer; 1131 begin 1132 if (x2 < x) then 1133 begin 1134 temp := x; 1135 x := x2; 1136 x2 := temp; 1137 end; 1138 if (x >= Width) or (x2 < 0) or (y < 0) or (y >= Height) then 1139 exit; 1140 if x < 0 then 1141 x := 0; 1142 if x2 >= Width then 1143 x2 := Width - 1; 1791 begin 1792 if not CheckHorizLineBounds(x,y,x2) then exit; 1144 1793 FastBlendPixelsInline(scanline[y] + x, c, x2 - x + 1); 1145 1794 InvalidateBitmap; … … 1147 1796 1148 1797 procedure TBGRADefaultBitmap.AlphaHorizLine(x, y, x2: integer; alpha: byte); 1149 var1150 temp: integer;1151 1798 begin 1152 1799 if alpha = 0 then … … 1155 1802 exit; 1156 1803 end; 1157 if (x2 < x) then 1158 begin 1159 temp := x; 1160 x := x2; 1161 x2 := temp; 1162 end; 1163 if (x >= Width) or (x2 < 0) or (y < 0) or (y >= Height) then 1164 exit; 1165 if x < 0 then 1166 x := 0; 1167 if x2 >= Width then 1168 x2 := Width - 1; 1804 if not CheckHorizLineBounds(x,y,x2) then exit; 1169 1805 AlphaFillInline(scanline[y] + x, alpha, x2 - x + 1); 1170 1806 InvalidateBitmap; 1171 1807 end; 1172 1808 1173 procedure TBGRADefaultBitmap.SetVertLine(x, y, y2: integer; c: TBGRAPixel); 1174 var 1175 temp, n, delta: integer; 1176 p: PBGRAPixel; 1177 begin 1178 if (y2 < y) then 1179 begin 1180 temp := y; 1181 y := y2; 1182 y2 := temp; 1183 end; 1184 if (y >= Height) or (y2 < 0) or (x < 0) or (x >= Width) then 1185 exit; 1186 if y < 0 then 1187 y := 0; 1188 if y2 >= Height then 1189 y2 := Height - 1; 1190 p := scanline[y] + x; 1809 function TBGRADefaultBitmap.CheckVertLineBounds(var x,y,y2: integer; out delta: integer): boolean; inline; 1810 var 1811 temp: integer; 1812 begin 1191 1813 if FLineOrder = riloBottomToTop then 1192 1814 delta := -Width 1193 1815 else 1194 1816 delta := Width; 1195 for n := y2 - y downto 0 do 1196 begin 1197 p^ := c; 1198 Inc(p, delta); 1199 end; 1200 InvalidateBitmap; 1201 end; 1202 1203 procedure TBGRADefaultBitmap.DrawVertLine(x, y, y2: integer; c: TBGRAPixel); 1204 var 1205 temp, n, delta: integer; 1206 p: PBGRAPixel; 1207 begin 1817 1208 1818 if (y2 < y) then 1209 1819 begin … … 1212 1822 y2 := temp; 1213 1823 end; 1214 if (y >= Height) or (y2 < 0) or (x < 0) or (x >= Width) then 1824 1825 if y < FClipRect.Top then 1826 y := FClipRect.Top; 1827 if y2 >= FClipRect.Bottom then 1828 y2 := FClipRect.Bottom - 1; 1829 1830 if (y >= FClipRect.Bottom) or (y2 < FClipRect.Top) or (x < FClipRect.Left) or (x >= FClipRect.Right) then 1831 begin 1832 result := false; 1215 1833 exit; 1216 if y < 0 then 1217 y := 0; 1218 if y2 >= Height then 1219 y2 := Height - 1; 1834 end; 1835 1836 result := true; 1837 end; 1838 1839 procedure TBGRADefaultBitmap.SetVertLine(x, y, y2: integer; c: TBGRAPixel); 1840 var 1841 n, delta: integer; 1842 p: PBGRAPixel; 1843 begin 1844 if not CheckVertLineBounds(x,y,y2,delta) then exit; 1220 1845 p := scanline[y] + x; 1221 if FLineOrder = riloBottomToTop then1222 delta := -Width1223 else1224 delta := Width;1225 1846 for n := y2 - y downto 0 do 1226 1847 begin 1227 DrawPixelInline(p, c);1848 p^ := c; 1228 1849 Inc(p, delta); 1229 1850 end; … … 1231 1852 end; 1232 1853 1854 procedure TBGRADefaultBitmap.XorVertLine(x, y, y2: integer; c: TBGRAPixel); 1855 var 1856 n, delta: integer; 1857 p: PBGRAPixel; 1858 begin 1859 if not CheckVertLineBounds(x,y,y2,delta) then exit; 1860 p := scanline[y] + x; 1861 for n := y2 - y downto 0 do 1862 begin 1863 PDword(p)^ := PDword(p)^ xor DWord(c); 1864 Inc(p, delta); 1865 end; 1866 InvalidateBitmap; 1867 end; 1868 1869 procedure TBGRADefaultBitmap.DrawVertLine(x, y, y2: integer; c: TBGRAPixel); 1870 var 1871 n, delta: integer; 1872 p: PBGRAPixel; 1873 begin 1874 if c.alpha = 255 then 1875 begin 1876 SetVertLine(x,y,y2,c); 1877 exit; 1878 end; 1879 if not CheckVertLineBounds(x,y,y2,delta) or (c.alpha=0) then exit; 1880 p := scanline[y] + x; 1881 for n := y2 - y downto 0 do 1882 begin 1883 DrawPixelInlineNoAlphaCheck(p, c); 1884 Inc(p, delta); 1885 end; 1886 InvalidateBitmap; 1887 end; 1888 1233 1889 procedure TBGRADefaultBitmap.AlphaVertLine(x, y, y2: integer; alpha: byte); 1234 1890 var 1235 temp,n, delta: integer;1891 n, delta: integer; 1236 1892 p: PBGRAPixel; 1237 1893 begin … … 1241 1897 exit; 1242 1898 end; 1243 if (y2 < y) then 1899 if not CheckVertLineBounds(x,y,y2,delta) then exit; 1900 p := scanline[y] + x; 1901 for n := y2 - y downto 0 do 1902 begin 1903 p^.alpha := alpha; 1904 Inc(p, delta); 1905 end; 1906 InvalidateBitmap; 1907 end; 1908 1909 procedure TBGRADefaultBitmap.FastBlendVertLine(x, y, y2: integer; c: TBGRAPixel); 1910 var 1911 n, delta: integer; 1912 p: PBGRAPixel; 1913 begin 1914 if not CheckVertLineBounds(x,y,y2,delta) then exit; 1915 p := scanline[y] + x; 1916 for n := y2 - y downto 0 do 1917 begin 1918 FastBlendPixelInline(p, c); 1919 Inc(p, delta); 1920 end; 1921 InvalidateBitmap; 1922 end; 1923 1924 procedure TBGRADefaultBitmap.DrawHorizLineDiff(x, y, x2: integer; 1925 c, compare: TBGRAPixel; maxDiff: byte); 1926 begin 1927 if not CheckHorizLineBounds(x,y,x2) then exit; 1928 DrawPixelsInlineDiff(scanline[y] + x, c, x2 - x + 1, compare, maxDiff); 1929 InvalidateBitmap; 1930 end; 1931 1932 {---------------------------- Lines ---------------------------------} 1933 { Call appropriate functions } 1934 1935 procedure TBGRADefaultBitmap.DrawLine(x1, y1, x2, y2: integer; 1936 c: TBGRAPixel; DrawLastPixel: boolean); 1937 begin 1938 BGRADrawLineAliased(self,x1,y1,x2,y2,c,DrawLastPixel); 1939 end; 1940 1941 procedure TBGRADefaultBitmap.DrawLineAntialias(x1, y1, x2, y2: integer; 1942 c: TBGRAPixel; DrawLastPixel: boolean); 1943 begin 1944 BGRADrawLineAntialias(self,x1,y1,x2,y2,c,DrawLastPixel); 1945 end; 1946 1947 procedure TBGRADefaultBitmap.DrawLineAntialias(x1, y1, x2, y2: integer; 1948 c1, c2: TBGRAPixel; dashLen: integer; DrawLastPixel: boolean); 1949 begin 1950 BGRADrawLineAntialias(self,x1,y1,x2,y2,c1,c2,dashLen,DrawLastPixel); 1951 end; 1952 1953 procedure TBGRADefaultBitmap.DrawLineAntialias(x1, y1, x2, y2: single; 1954 c: TBGRAPixel; w: single); 1955 begin 1956 BGRAPolyLine(self,[PointF(x1,y1),PointF(x2,y2)],w,c,LineCap,JoinStyle,FCustomPenStyle,[],nil,JoinMiterLimit); 1957 end; 1958 1959 procedure TBGRADefaultBitmap.DrawLineAntialias(x1, y1, x2, y2: single; 1960 texture: IBGRAScanner; w: single); 1961 begin 1962 BGRAPolyLine(self,[PointF(x1,y1),PointF(x2,y2)],w,BGRAPixelTransparent,LineCap,JoinStyle,FCustomPenStyle,[],texture,JoinMiterLimit); 1963 end; 1964 1965 procedure TBGRADefaultBitmap.DrawLineAntialias(x1, y1, x2, y2: single; 1966 c: TBGRAPixel; w: single; closed: boolean); 1967 var 1968 options: TBGRAPolyLineOptions; 1969 begin 1970 if not closed then options := [plRoundCapOpen] else options := []; 1971 BGRAPolyLine(self,[PointF(x1,y1),PointF(x2,y2)],w,c,pecRound,pjsRound,FCustomPenStyle,options,nil,JoinMiterLimit); 1972 end; 1973 1974 procedure TBGRADefaultBitmap.DrawLineAntialias(x1, y1, x2, y2: single; 1975 texture: IBGRAScanner; w: single; Closed: boolean); 1976 var 1977 options: TBGRAPolyLineOptions; 1978 c: TBGRAPixel; 1979 begin 1980 if not closed then 1981 begin 1982 options := [plRoundCapOpen]; 1983 c := BGRAWhite; //needed for alpha junction 1984 end else 1985 begin 1986 options := []; 1987 c := BGRAPixelTransparent; 1988 end; 1989 BGRAPolyLine(self,[PointF(x1,y1),PointF(x2,y2)],w,c,pecRound,pjsRound,FCustomPenStyle,options,texture,JoinMiterLimit); 1990 end; 1991 1992 procedure TBGRADefaultBitmap.DrawPolyLineAntialias(const points: array of TPointF; 1993 c: TBGRAPixel; w: single); 1994 begin 1995 BGRAPolyLine(self,points,w,c,LineCap,JoinStyle,FCustomPenStyle,[],nil,JoinMiterLimit); 1996 end; 1997 1998 procedure TBGRADefaultBitmap.DrawPolyLineAntialias( 1999 const points: array of TPointF; texture: IBGRAScanner; w: single); 2000 begin 2001 BGRAPolyLine(self,points,w,BGRAPixelTransparent,LineCap,JoinStyle,FCustomPenStyle,[],texture,JoinMiterLimit); 2002 end; 2003 2004 procedure TBGRADefaultBitmap.DrawPolyLineAntialias(const points: array of TPointF; 2005 c: TBGRAPixel; w: single; Closed: boolean); 2006 var 2007 options: TBGRAPolyLineOptions; 2008 begin 2009 if not closed then options := [plRoundCapOpen] else options := []; 2010 BGRAPolyLine(self,points,w,c,pecRound,JoinStyle,FCustomPenStyle,options,nil,JoinMiterLimit); 2011 end; 2012 2013 procedure TBGRADefaultBitmap.DrawPolygonAntialias(const points: array of TPointF; 2014 c: TBGRAPixel; w: single); 2015 begin 2016 BGRAPolyLine(self,points,w,c,LineCap,JoinStyle,FCustomPenStyle,[plCycle],nil,JoinMiterLimit); 2017 end; 2018 2019 procedure TBGRADefaultBitmap.DrawPolygonAntialias( 2020 const points: array of TPointF; texture: IBGRAScanner; w: single); 2021 begin 2022 BGRAPolyLine(self,points,w,BGRAPixelTransparent,LineCap,JoinStyle,FCustomPenStyle,[plCycle],texture,JoinMiterLimit); 2023 end; 2024 2025 procedure TBGRADefaultBitmap.EraseLineAntialias(x1, y1, x2, y2: single; 2026 alpha: byte; w: single; Closed: boolean); 2027 begin 2028 FEraseMode := True; 2029 DrawLineAntialias(x1, y1, x2, y2, BGRA(0, 0, 0, alpha), w, Closed); 2030 FEraseMode := False; 2031 end; 2032 2033 procedure TBGRADefaultBitmap.ErasePolyLineAntialias(const points: array of TPointF; 2034 alpha: byte; w: single); 2035 begin 2036 FEraseMode := True; 2037 DrawPolyLineAntialias(points, BGRA(0,0,0,alpha),w); 2038 FEraseMode := False; 2039 end; 2040 2041 {------------------------ Shapes ----------------------------------------------} 2042 { Call appropriate functions } 2043 2044 procedure TBGRADefaultBitmap.FillTriangleLinearColor(pt1, pt2, pt3: TPointF; 2045 c1, c2, c3: TBGRAPixel); 2046 begin 2047 FillPolyLinearColor([pt1,pt2,pt3],[c1,c2,c3]); 2048 end; 2049 2050 procedure TBGRADefaultBitmap.FillTriangleLinearColorAntialias(pt1, pt2, 2051 pt3: TPointF; c1, c2, c3: TBGRAPixel); 2052 var 2053 grad: TBGRAGradientTriangleScanner; 2054 begin 2055 grad := TBGRAGradientTriangleScanner.Create(pt1,pt2,pt3, c1,c2,c3); 2056 FillPolyAntialias([pt1,pt2,pt3],grad); 2057 grad.Free; 2058 end; 2059 2060 procedure TBGRADefaultBitmap.FillTriangleLinearMapping(pt1, pt2, pt3: TPointF; 2061 texture: IBGRAScanner; tex1, tex2, tex3: TPointF; TextureInterpolation: Boolean= True); 2062 begin 2063 FillPolyLinearMapping([pt1,pt2,pt3],texture,[tex1,tex2,tex3],TextureInterpolation); 2064 end; 2065 2066 procedure TBGRADefaultBitmap.FillTriangleLinearMappingLightness(pt1, pt2, 2067 pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF; light1, 2068 light2, light3: word; TextureInterpolation: Boolean); 2069 begin 2070 FillPolyLinearMappingLightness([pt1,pt2,pt3],texture,[tex1,tex2,tex3],[light1,light2,light3],TextureInterpolation); 2071 end; 2072 2073 procedure TBGRADefaultBitmap.FillTriangleLinearMappingAntialias(pt1, pt2, 2074 pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF); 2075 var 2076 mapping: TBGRATriangleLinearMapping; 2077 begin 2078 mapping := TBGRATriangleLinearMapping.Create(texture, pt1,pt2,pt3, tex1, tex2, tex3); 2079 FillPolyAntialias([pt1,pt2,pt3],mapping); 2080 mapping.Free; 2081 end; 2082 2083 procedure TBGRADefaultBitmap.FillQuadLinearColor(pt1, pt2, pt3, pt4: TPointF; 2084 c1, c2, c3, c4: TBGRAPixel); 2085 var 2086 center: TPointF; 2087 centerColor: TBGRAPixel; 2088 multi: TBGRAMultishapeFiller; 2089 begin 2090 if not IsConvex([pt1,pt2,pt3,pt4]) then //need to merge colors 2091 begin 2092 multi := TBGRAMultishapeFiller.Create; 2093 multi.AddQuadLinearColor(pt1,pt2,pt3,pt4,c1,c2,c3,c4); 2094 multi.Antialiasing:= false; 2095 multi.Draw(self); 2096 multi.Free; 2097 exit; 2098 end; 2099 center := (pt1+pt2+pt3+pt4)*(1/4); 2100 centerColor := GammaCompression( MergeBGRA(MergeBGRA(GammaExpansion(c1),GammaExpansion(c2)), 2101 MergeBGRA(GammaExpansion(c3),GammaExpansion(c4))) ); 2102 FillTriangleLinearColor(pt1,pt2,center, c1,c2,centerColor); 2103 FillTriangleLinearColor(pt2,pt3,center, c2,c3,centerColor); 2104 FillTriangleLinearColor(pt3,pt4,center, c3,c4,centerColor); 2105 FillTriangleLinearColor(pt4,pt1,center, c4,c1,centerColor); 2106 end; 2107 2108 procedure TBGRADefaultBitmap.FillQuadLinearColorAntialias(pt1, pt2, pt3, 2109 pt4: TPointF; c1, c2, c3, c4: TBGRAPixel); 2110 var multi : TBGRAMultishapeFiller; 2111 begin 2112 multi := TBGRAMultishapeFiller.Create; 2113 multi.AddQuadLinearColor(pt1, pt2, pt3, pt4, c1, c2, c3, c4); 2114 multi.Draw(self); 2115 multi.free; 2116 end; 2117 2118 procedure TBGRADefaultBitmap.FillQuadLinearMapping(pt1, pt2, pt3, pt4: TPointF; 2119 texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF; TextureInterpolation: Boolean= True); 2120 var 2121 center: TPointF; 2122 centerTex: TPointF; 2123 begin 2124 center := (pt1+pt2+pt3+pt4)*(1/4); 2125 centerTex := (tex1+tex2+tex3+tex4)*(1/4); 2126 FillTriangleLinearMapping(pt1,pt2,center, texture,tex1,tex2,centerTex, TextureInterpolation); 2127 FillTriangleLinearMapping(pt2,pt3,center, texture,tex2,tex3,centerTex, TextureInterpolation); 2128 FillTriangleLinearMapping(pt3,pt4,center, texture,tex3,tex4,centerTex, TextureInterpolation); 2129 FillTriangleLinearMapping(pt4,pt1,center, texture,tex4,tex1,centerTex, TextureInterpolation); 2130 end; 2131 2132 procedure TBGRADefaultBitmap.FillQuadLinearMappingLightness(pt1, pt2, pt3, 2133 pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF; light1, 2134 light2, light3, light4: word; TextureInterpolation: Boolean); 2135 var 2136 center: TPointF; 2137 centerTex: TPointF; 2138 centerLight: word; 2139 begin 2140 center := (pt1+pt2+pt3+pt4)*(1/4); 2141 centerTex := (tex1+tex2+tex3+tex4)*(1/4); 2142 centerLight := (light1+light2+light3+light4) div 4; 2143 FillTriangleLinearMappingLightness(pt1,pt2,center, texture,tex1,tex2,centerTex, light1,light2,centerLight, TextureInterpolation); 2144 FillTriangleLinearMappingLightness(pt2,pt3,center, texture,tex2,tex3,centerTex, light2,light3,centerLight, TextureInterpolation); 2145 FillTriangleLinearMappingLightness(pt3,pt4,center, texture,tex3,tex4,centerTex, light3,light4,centerLight, TextureInterpolation); 2146 FillTriangleLinearMappingLightness(pt4,pt1,center, texture,tex4,tex1,centerTex, light4,light1,centerLight, TextureInterpolation); 2147 end; 2148 2149 procedure TBGRADefaultBitmap.FillQuadLinearMappingAntialias(pt1, pt2, pt3, 2150 pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF); 2151 var multi : TBGRAMultishapeFiller; 2152 begin 2153 multi := TBGRAMultishapeFiller.Create; 2154 multi.AddQuadLinearMapping(pt1, pt2, pt3, pt4, texture, tex1,tex2,tex3,tex4); 2155 multi.Draw(self); 2156 multi.free; 2157 end; 2158 2159 procedure TBGRADefaultBitmap.FillQuadPerspectiveMapping(pt1, pt2, pt3, 2160 pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF); 2161 var 2162 persp: TBGRAPerspectiveScannerTransform; 2163 begin 2164 persp := TBGRAPerspectiveScannerTransform.Create(texture,[tex1,tex2,tex3,tex4],[pt1,pt2,pt3,pt4]); 2165 FillPoly([pt1,pt2,pt3,pt4],persp,dmDrawWithTransparency); 2166 persp.Free; 2167 end; 2168 2169 procedure TBGRADefaultBitmap.FillQuadPerspectiveMappingAntialias(pt1, pt2, pt3, 2170 pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF); 2171 var 2172 persp: TBGRAPerspectiveScannerTransform; 2173 begin 2174 persp := TBGRAPerspectiveScannerTransform.Create(texture,[tex1,tex2,tex3,tex4],[pt1,pt2,pt3,pt4]); 2175 FillPolyAntialias([pt1,pt2,pt3,pt4],persp); 2176 persp.Free; 2177 end; 2178 2179 procedure TBGRADefaultBitmap.FillPolyLinearMapping(const points: array of TPointF; 2180 texture: IBGRAScanner; texCoords: array of TPointF; 2181 TextureInterpolation: Boolean); 2182 begin 2183 PolygonLinearTextureMappingAliased(self,points,texture,texCoords,TextureInterpolation, FillMode = fmWinding); 2184 end; 2185 2186 procedure TBGRADefaultBitmap.FillPolyLinearMappingLightness( 2187 const points: array of TPointF; texture: IBGRAScanner; 2188 texCoords: array of TPointF; lightnesses: array of word; 2189 TextureInterpolation: Boolean); 2190 begin 2191 PolygonLinearTextureMappingAliasedWithLightness(self,points,texture,texCoords,TextureInterpolation,lightnesses,FillMode = fmWinding); 2192 end; 2193 2194 procedure TBGRADefaultBitmap.FillPolyLinearColor( 2195 const points: array of TPointF; AColors: array of TBGRAPixel); 2196 begin 2197 PolygonLinearColorGradientAliased(self,points,AColors, FillMode = fmWinding); 2198 end; 2199 2200 procedure TBGRADefaultBitmap.FillPolyPerspectiveMapping( 2201 const points: array of TPointF; const pointsZ: array of single; 2202 texture: IBGRAScanner; texCoords: array of TPointF; 2203 TextureInterpolation: Boolean); 2204 begin 2205 PolygonPerspectiveTextureMappingAliased(self,points,pointsZ,texture,texCoords,TextureInterpolation, FillMode = fmWinding); 2206 end; 2207 2208 procedure TBGRADefaultBitmap.FillPolyPerspectiveMappingLightness( 2209 const points: array of TPointF; const pointsZ: array of single; 2210 texture: IBGRAScanner; texCoords: array of TPointF; 2211 lightnesses: array of word; TextureInterpolation: Boolean); 2212 begin 2213 PolygonPerspectiveTextureMappingAliasedWithLightness(self,points,pointsZ,texture,texCoords,TextureInterpolation,lightnesses, FillMode = fmWinding); 2214 end; 2215 2216 procedure TBGRADefaultBitmap.FillPoly(const points: array of TPointF; 2217 c: TBGRAPixel; drawmode: TDrawMode); 2218 begin 2219 BGRAPolygon.FillPolyAliased(self, points, c, FEraseMode, FillMode = fmWinding, drawmode); 2220 end; 2221 2222 procedure TBGRADefaultBitmap.FillPoly(const points: array of TPointF; 2223 texture: IBGRAScanner; drawmode: TDrawMode); 2224 begin 2225 BGRAPolygon.FillPolyAliasedWithTexture(self, points, texture, FillMode = fmWinding, drawmode); 2226 end; 2227 2228 procedure TBGRADefaultBitmap.EraseLineAntialias(x1, y1, x2, y2: single; 2229 alpha: byte; w: single); 2230 begin 2231 FEraseMode := True; 2232 DrawLineAntialias(x1,y1,x2,y2, BGRA(0,0,0,alpha),w); 2233 FEraseMode := False; 2234 end; 2235 2236 procedure TBGRADefaultBitmap.FillPolyAntialias(const points: array of TPointF; c: TBGRAPixel); 2237 begin 2238 BGRAPolygon.FillPolyAntialias(self, points, c, FEraseMode, FillMode = fmWinding); 2239 end; 2240 2241 procedure TBGRADefaultBitmap.FillPolyAntialias(const points: array of TPointF; 2242 texture: IBGRAScanner); 2243 begin 2244 BGRAPolygon.FillPolyAntialiasWithTexture(self, points, texture, FillMode = fmWinding); 2245 end; 2246 2247 procedure TBGRADefaultBitmap.ErasePoly(const points: array of TPointF; 2248 alpha: byte); 2249 begin 2250 BGRAPolygon.FillPolyAliased(self, points, BGRA(0, 0, 0, alpha), True, FillMode = fmWinding, dmDrawWithTransparency); 2251 end; 2252 2253 procedure TBGRADefaultBitmap.ErasePolyAntialias(const points: array of TPointF; alpha: byte); 2254 begin 2255 FEraseMode := True; 2256 FillPolyAntialias(points, BGRA(0, 0, 0, alpha)); 2257 FEraseMode := False; 2258 end; 2259 2260 procedure TBGRADefaultBitmap.EllipseAntialias(x, y, rx, ry: single; 2261 c: TBGRAPixel; w: single); 2262 begin 2263 if IsClearPenStyle(FCustomPenStyle) or (c.alpha = 0) then exit; 2264 if IsSolidPenStyle(FCustomPenStyle) then 2265 BGRAPolygon.BorderEllipseAntialias(self, x, y, rx, ry, w, c, FEraseMode) 2266 else 2267 DrawPolygonAntialias(ComputeEllipse(x,y,rx,ry),c,w); 2268 end; 2269 2270 procedure TBGRADefaultBitmap.EllipseAntialias(x, y, rx, ry: single; 2271 texture: IBGRAScanner; w: single); 2272 begin 2273 if IsClearPenStyle(FCustomPenStyle) then exit; 2274 if IsSolidPenStyle(FCustomPenStyle) then 2275 BGRAPolygon.BorderEllipseAntialiasWithTexture(self, x, y, rx, ry, w, texture) 2276 else 2277 DrawPolygonAntialias(ComputeEllipse(x,y,rx,ry),texture,w); 2278 end; 2279 2280 procedure TBGRADefaultBitmap.EllipseAntialias(x, y, rx, ry: single; 2281 c: TBGRAPixel; w: single; back: TBGRAPixel); 2282 var multi: TBGRAMultishapeFiller; 2283 hw: single; 2284 begin 2285 if w=0 then exit; 2286 rx := abs(rx); 2287 ry := abs(ry); 2288 hw := w/2; 2289 if (rx <= hw) or (ry <= hw) then 2290 begin 2291 FillEllipseAntialias(x,y,rx+hw,ry+hw,c); 2292 exit; 2293 end; 2294 { use multishape filler for fine junction between polygons } 2295 multi := TBGRAMultishapeFiller.Create; 2296 if not IsClearPenStyle(FCustomPenStyle) and (c.alpha <> 0) then 2297 begin 2298 if IsSolidPenStyle(FCustomPenStyle) then 2299 begin 2300 multi.AddEllipse(x,y,rx-hw,ry-hw,back); 2301 multi.AddEllipseBorder(x,y,rx,ry,w,c) 2302 end 2303 else 2304 begin 2305 multi.AddEllipse(x,y,rx,ry,back); 2306 multi.AddPolygon(ComputeWidePolygon(ComputeEllipse(x,y,rx,ry),w),c); 2307 multi.PolygonOrder := poLastOnTop; 2308 end; 2309 end; 2310 multi.Draw(self); 2311 multi.Free; 2312 end; 2313 2314 procedure TBGRADefaultBitmap.FillEllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel); 2315 begin 2316 BGRAPolygon.FillEllipseAntialias(self, x, y, rx, ry, c, FEraseMode); 2317 end; 2318 2319 procedure TBGRADefaultBitmap.FillEllipseAntialias(x, y, rx, ry: single; 2320 texture: IBGRAScanner); 2321 begin 2322 BGRAPolygon.FillEllipseAntialiasWithTexture(self, x, y, rx, ry, texture); 2323 end; 2324 2325 procedure TBGRADefaultBitmap.FillEllipseLinearColorAntialias(x, y, rx, 2326 ry: single; outercolor, innercolor: TBGRAPixel); 2327 var 2328 grad: TBGRAGradientScanner; 2329 affine: TBGRAAffineScannerTransform; 2330 begin 2331 if (rx=0) or (ry=0) then exit; 2332 if rx=ry then 2333 begin 2334 grad := TBGRAGradientScanner.Create(innercolor,outercolor,gtRadial,PointF(x,y),PointF(x+rx,y),True); 2335 FillEllipseAntialias(x,y,rx,ry,grad); 2336 grad.Free; 2337 end else 2338 begin 2339 grad := TBGRAGradientScanner.Create(innercolor,outercolor,gtRadial,PointF(0,0),PointF(1,0),True); 2340 affine := TBGRAAffineScannerTransform.Create(grad); 2341 affine.Scale(rx,ry); 2342 affine.Translate(x,y); 2343 FillEllipseAntialias(x,y,rx,ry,affine); 2344 affine.Free; 2345 grad.Free; 2346 end; 2347 end; 2348 2349 procedure TBGRADefaultBitmap.EraseEllipseAntialias(x, y, rx, ry: single; alpha: byte); 2350 begin 2351 FEraseMode := True; 2352 FillEllipseAntialias(x, y, rx, ry, BGRA(0, 0, 0, alpha)); 2353 FEraseMode := False; 2354 end; 2355 2356 procedure TBGRADefaultBitmap.RectangleAntialias(x, y, x2, y2: single; 2357 c: TBGRAPixel; w: single; back: TBGRAPixel); 2358 var 2359 bevel: single; 2360 multi: TBGRAMultishapeFiller; 2361 hw: single; 2362 begin 2363 if IsClearPenStyle(FCustomPenStyle) or (c.alpha=0) or (w=0) then 2364 begin 2365 if back <> BGRAPixelTransparent then 2366 FillRectAntialias(x,y,x2,y2,back); 2367 exit; 2368 end; 2369 2370 hw := w/2; 2371 if not CheckAntialiasRectBounds(x,y,x2,y2,w) then 2372 begin 2373 if JoinStyle = pjsBevel then 2374 begin 2375 bevel := (2-sqrt(2))*hw; 2376 FillRoundRectAntialias(x - hw, y - hw, x2 + hw, y2 + hw, bevel,bevel, c, [rrTopLeftBevel, rrTopRightBevel, rrBottomLeftBevel, rrBottomRightBevel]); 2377 end else 2378 if JoinStyle = pjsRound then 2379 FillRoundRectAntialias(x - hw, y - hw, x2 + hw, y2 + hw, hw,hw, c) 2380 else 2381 FillRectAntialias(x - hw, y - hw, x2 + hw, y2 + hw, c); 2382 exit; 2383 end; 2384 2385 { use multishape filler for fine junction between polygons } 2386 multi := TBGRAMultishapeFiller.Create; 2387 multi.FillMode := FillMode; 2388 if (JoinStyle = pjsMiter) and IsSolidPenStyle(FCustomPenStyle) then 2389 multi.AddRectangleBorder(x,y,x2,y2,w,c) 2390 else 2391 multi.AddPolygon(ComputeWidePolygon([Pointf(x,y),Pointf(x2,y),Pointf(x2,y2),Pointf(x,y2)],w),c); 2392 2393 if (frac(x + hw) = 0.5) and (frac(y + hw)=0.5) and (frac(x2 - hw)=0.5) and (frac(y2 - hw)=0.5) then 2394 FillRect(ceil(x + hw), ceil(y + hw), ceil(x2 - hw), ceil(y2 - hw), back, dmDrawWithTransparency) 2395 else 2396 multi.AddRectangle(x + hw, y + hw, x2 - hw, y2 - hw, back); 2397 multi.Draw(self); 2398 multi.Free; 2399 end; 2400 2401 procedure TBGRADefaultBitmap.RectangleAntialias(x, y, x2, y2: single; 2402 texture: IBGRAScanner; w: single); 2403 var 2404 bevel,hw: single; 2405 multi: TBGRAMultishapeFiller; 2406 begin 2407 if IsClearPenStyle(FCustomPenStyle) or (w=0) then exit; 2408 2409 hw := w/2; 2410 if not CheckAntialiasRectBounds(x,y,x2,y2,w) then 2411 begin 2412 if JoinStyle = pjsBevel then 2413 begin 2414 bevel := (2-sqrt(2))*hw; 2415 FillRoundRectAntialias(x - hw, y - hw, x2 + hw, y2 + hw, bevel,bevel, texture, [rrTopLeftBevel, rrTopRightBevel, rrBottomLeftBevel, rrBottomRightBevel]); 2416 end else 2417 if JoinStyle = pjsRound then 2418 FillRoundRectAntialias(x - hw, y - hw, x2 + hw, y2 + hw, hw,hw, texture) 2419 else 2420 FillRectAntialias(x - hw, y - hw, x2 + hw, y2 + hw, texture); 2421 exit; 2422 end; 2423 2424 { use multishape filler for fine junction between polygons } 2425 multi := TBGRAMultishapeFiller.Create; 2426 multi.FillMode := FillMode; 2427 if (JoinStyle = pjsMiter) and IsSolidPenStyle(FCustomPenStyle) then 2428 multi.AddRectangleBorder(x,y,x2,y2,w, texture) 2429 else 2430 multi.AddPolygon(ComputeWidePolygon([Pointf(x,y),Pointf(x2,y),Pointf(x2,y2),Pointf(x,y2)],w), texture); 2431 multi.Draw(self); 2432 multi.Free; 2433 end; 2434 2435 procedure TBGRADefaultBitmap.RoundRectAntialias(x, y, x2, y2, rx, ry: single; 2436 c: TBGRAPixel; w: single; options: TRoundRectangleOptions); 2437 begin 2438 if IsClearPenStyle(FCustomPenStyle) or (c.alpha = 0) then exit; 2439 if IsSolidPenStyle(FCustomPenStyle) then 2440 BGRAPolygon.BorderRoundRectangleAntialias(self,x,y,x2,y2,rx,ry,w,options,c,False) 2441 else 2442 DrawPolygonAntialias(BGRAPath.ComputeRoundRect(x,y,x2,y2,rx,ry,options),c,w); 2443 end; 2444 2445 procedure TBGRADefaultBitmap.RoundRectAntialias(x, y, x2, y2, rx, ry: single; 2446 pencolor: TBGRAPixel; w: single; fillcolor: TBGRAPixel; 2447 options: TRoundRectangleOptions); 2448 var 2449 multi: TBGRAMultishapeFiller; 2450 begin 2451 if IsClearPenStyle(FCustomPenStyle) or (pencolor.alpha = 0) then 2452 begin 2453 FillRoundRectAntialias(x,y,x2,y2,rx,ry,fillColor,options); 2454 exit; 2455 end; 2456 if IsSolidPenStyle(FCustomPenStyle) then 2457 BGRAPolygon.BorderAndFillRoundRectangleAntialias(self,x,y,x2,y2,rx,ry,w,options,pencolor,fillcolor,nil,nil,False) 2458 else 2459 begin 2460 multi := TBGRAMultishapeFiller.Create; 2461 multi.PolygonOrder := poLastOnTop; 2462 multi.AddRoundRectangle(x,y,x2,y2,rx,ry,fillColor,options); 2463 multi.AddPolygon(ComputeWidePolygon(BGRAPath.ComputeRoundRect(x,y,x2,y2,rx,ry,options),w),pencolor); 2464 multi.Draw(self); 2465 multi.Free; 2466 end; 2467 end; 2468 2469 procedure TBGRADefaultBitmap.RoundRectAntialias(x, y, x2, y2, rx, ry: single; 2470 penTexture: IBGRAScanner; w: single; fillTexture: IBGRAScanner; 2471 options: TRoundRectangleOptions); 2472 var 2473 multi: TBGRAMultishapeFiller; 2474 begin 2475 if IsClearPenStyle(FCustomPenStyle) then 2476 begin 2477 FillRoundRectAntialias(x,y,x2,y2,rx,ry,fillTexture,options); 2478 exit; 2479 end else 2480 if IsSolidPenStyle(FCustomPenStyle) then 2481 BGRAPolygon.BorderAndFillRoundRectangleAntialias(self,x,y,x2,y2,rx,ry,w,options,BGRAPixelTransparent,BGRAPixelTransparent,pentexture,filltexture,False) 2482 else 2483 begin 2484 multi := TBGRAMultishapeFiller.Create; 2485 multi.PolygonOrder := poLastOnTop; 2486 multi.AddRoundRectangle(x,y,x2,y2,rx,ry,fillTexture,options); 2487 multi.AddPolygon(ComputeWidePolygon(ComputeRoundRect(x,y,x2,y2,rx,ry,options),w),penTexture); 2488 multi.Draw(self); 2489 multi.Free; 2490 end; 2491 end; 2492 2493 procedure TBGRADefaultBitmap.RoundRectAntialias(x, y, x2, y2, rx, ry: single; 2494 texture: IBGRAScanner; w: single; options: TRoundRectangleOptions); 2495 begin 2496 if IsClearPenStyle(FCustomPenStyle) then exit; 2497 if IsSolidPenStyle(FCustomPenStyle) then 2498 BGRAPolygon.BorderRoundRectangleAntialiasWithTexture(self,x,y,x2,y2,rx,ry,w,options,texture) 2499 else 2500 DrawPolygonAntialias(BGRAPath.ComputeRoundRect(x,y,x2,y2,rx,ry,options),texture,w); 2501 end; 2502 2503 function TBGRADefaultBitmap.CheckRectBounds(var x, y, x2, y2: integer; minsize: integer): boolean; inline; 2504 var 2505 temp: integer; 2506 begin 2507 //swap coordinates if needed 2508 if (x > x2) then 2509 begin 2510 temp := x; 2511 x := x2; 2512 x2 := temp; 2513 end; 2514 if (y > y2) then 1244 2515 begin 1245 2516 temp := y; … … 1247 2518 y2 := temp; 1248 2519 end; 1249 if (y >= Height) or (y2 < 0) or (x < 0) or (x >= Width) then 2520 if (x2 - x <= minsize) or (y2 - y <= minsize) then 2521 begin 2522 result := false; 1250 2523 exit; 1251 if y < 0 then 1252 y := 0; 1253 if y2 >= Height then 1254 y2 := Height - 1; 1255 p := scanline[y] + x; 1256 if FLineOrder = riloBottomToTop then 1257 delta := -Width 1258 else 1259 delta := Width; 1260 for n := y2 - y downto 0 do 1261 begin 1262 p^.alpha := alpha; 1263 Inc(p, delta); 1264 end; 1265 InvalidateBitmap; 1266 end; 1267 1268 procedure TBGRADefaultBitmap.FastBlendVertLine(x, y, y2: integer; c: TBGRAPixel); 1269 var 1270 temp, n, delta: integer; 1271 p: PBGRAPixel; 1272 begin 1273 if (y2 < y) then 1274 begin 1275 temp := y; 1276 y := y2; 1277 y2 := temp; 1278 end; 1279 if (y >= Height) or (y2 < 0) or (x < 0) or (x >= Width) then 1280 exit; 1281 if y < 0 then 1282 y := 0; 1283 if y2 >= Height then 1284 y2 := Height - 1; 1285 p := scanline[y] + x; 1286 if FLineOrder = riloBottomToTop then 1287 delta := -Width 1288 else 1289 delta := Width; 1290 for n := y2 - y downto 0 do 1291 begin 1292 FastBlendPixelInline(p, c); 1293 Inc(p, delta); 1294 end; 1295 InvalidateBitmap; 1296 end; 1297 1298 procedure TBGRADefaultBitmap.DrawHorizLineDiff(x, y, x2: integer; 1299 c, compare: TBGRAPixel; maxDiff: byte); 1300 var 1301 temp: integer; 1302 begin 1303 if (x2 < x) then 1304 begin 1305 temp := x; 1306 x := x2; 1307 x2 := temp; 1308 end; 1309 if (x >= Width) or (x2 < 0) or (y < 0) or (y >= Height) then 1310 exit; 1311 if x < 0 then 1312 x := 0; 1313 if x2 >= Width then 1314 x2 := Width - 1; 1315 DrawPixelsInlineDiff(scanline[y] + x, c, x2 - x + 1, compare, maxDiff); 1316 InvalidateBitmap; 1317 end; 1318 1319 {---------------------------- Shapes ---------------------------------} 1320 1321 procedure TBGRADefaultBitmap.DrawLine(x1, y1, x2, y2: integer; 1322 c: TBGRAPixel; DrawLastPixel: boolean); 1323 var 1324 Y, X: integer; 1325 DX, DY, SX, SY, E: integer; 1326 begin 1327 1328 if (Y1 = Y2) and (X1 = X2) then 1329 begin 1330 if DrawLastPixel then 1331 DrawPixel(X1, Y1, c); 1332 Exit; 1333 end; 1334 1335 DX := X2 - X1; 1336 DY := Y2 - Y1; 1337 1338 if DX < 0 then 1339 begin 1340 SX := -1; 1341 DX := -DX; 1342 end 1343 else 1344 SX := 1; 1345 1346 if DY < 0 then 1347 begin 1348 SY := -1; 1349 DY := -DY; 1350 end 1351 else 1352 SY := 1; 1353 1354 DX := DX shl 1; 1355 DY := DY shl 1; 1356 1357 X := X1; 1358 Y := Y1; 1359 if DX > DY then 1360 begin 1361 E := DY - DX shr 1; 1362 1363 while X <> X2 do 1364 begin 1365 DrawPixel(X, Y, c); 1366 if E >= 0 then 1367 begin 1368 Inc(Y, SY); 1369 Dec(E, DX); 1370 end; 1371 Inc(X, SX); 1372 Inc(E, DY); 1373 end; 1374 end 1375 else 1376 begin 1377 E := DX - DY shr 1; 1378 1379 while Y <> Y2 do 1380 begin 1381 DrawPixel(X, Y, c); 1382 if E >= 0 then 1383 begin 1384 Inc(X, SX); 1385 Dec(E, DY); 1386 end; 1387 Inc(Y, SY); 1388 Inc(E, DX); 1389 end; 1390 end; 1391 1392 if DrawLastPixel then 1393 DrawPixel(X2, Y2, c); 1394 end; 1395 1396 procedure TBGRADefaultBitmap.DrawLineAntialias(x1, y1, x2, y2: integer; 1397 c: TBGRAPixel; DrawLastPixel: boolean); 1398 var 1399 Y, X: integer; 1400 DX, DY, SX, SY, E: integer; 1401 alpha: single; 1402 begin 1403 1404 if (Y1 = Y2) and (X1 = X2) then 1405 begin 1406 if DrawLastPixel then 1407 DrawPixel(X1, Y1, c); 1408 Exit; 1409 end; 1410 1411 DX := X2 - X1; 1412 DY := Y2 - Y1; 1413 1414 if DX < 0 then 1415 begin 1416 SX := -1; 1417 DX := -DX; 1418 end 1419 else 1420 SX := 1; 1421 1422 if DY < 0 then 1423 begin 1424 SY := -1; 1425 DY := -DY; 1426 end 1427 else 1428 SY := 1; 1429 1430 DX := DX shl 1; 1431 DY := DY shl 1; 1432 1433 X := X1; 1434 Y := Y1; 1435 1436 if DX > DY then 1437 begin 1438 E := 0; 1439 1440 while X <> X2 do 1441 begin 1442 alpha := 1 - E / DX; 1443 DrawPixel(X, Y, BGRA(c.red, c.green, c.blue, round(c.alpha * sqrt(alpha)))); 1444 DrawPixel(X, Y + SY, BGRA(c.red, c.green, c.blue, 1445 round(c.alpha * sqrt(1 - alpha)))); 1446 Inc(E, DY); 1447 if E >= DX then 1448 begin 1449 Inc(Y, SY); 1450 Dec(E, DX); 1451 end; 1452 Inc(X, SX); 1453 end; 1454 end 1455 else 1456 begin 1457 E := 0; 1458 1459 while Y <> Y2 do 1460 begin 1461 alpha := 1 - E / DY; 1462 DrawPixel(X, Y, BGRA(c.red, c.green, c.blue, round(c.alpha * sqrt(alpha)))); 1463 DrawPixel(X + SX, Y, BGRA(c.red, c.green, c.blue, 1464 round(c.alpha * sqrt(1 - alpha)))); 1465 Inc(E, DX); 1466 if E >= DY then 1467 begin 1468 Inc(X, SX); 1469 Dec(E, DY); 1470 end; 1471 Inc(Y, SY); 1472 end; 1473 end; 1474 if DrawLastPixel then 1475 DrawPixel(X2, Y2, c); 1476 end; 1477 1478 procedure TBGRADefaultBitmap.DrawPolyLineAntialias(points: array of TPoint; 1479 c: TBGRAPixel; DrawLastPixel: boolean); 1480 var i: integer; 1481 begin 1482 if length(points) = 1 then 1483 begin 1484 if DrawLastPixel then DrawPixel(points[0].x,points[0].y,c); 1485 end 1486 else 1487 for i := 0 to high(points)-1 do 1488 DrawLineAntialias(points[i].x,points[i].Y,points[i+1].x,points[i+1].y,c,DrawLastPixel and (i=high(points)-1)); 1489 end; 1490 1491 procedure TBGRADefaultBitmap.DrawLineAntialias(x1, y1, x2, y2: integer; 1492 c1, c2: TBGRAPixel; dashLen: integer; DrawLastPixel: boolean); 1493 var 1494 Y, X: integer; 1495 DX, DY, SX, SY, E: integer; 1496 alpha: single; 1497 c: TBGRAPixel; 1498 DashPos: integer; 1499 begin 1500 1501 c := c1; 1502 DashPos := 0; 1503 1504 if (Y1 = Y2) and (X1 = X2) then 1505 begin 1506 if DrawLastPixel then 1507 DrawPixel(X1, Y1, c); 1508 Exit; 1509 end; 1510 1511 DX := X2 - X1; 1512 DY := Y2 - Y1; 1513 1514 if DX < 0 then 1515 begin 1516 SX := -1; 1517 DX := -DX; 1518 end 1519 else 1520 SX := 1; 1521 1522 if DY < 0 then 1523 begin 1524 SY := -1; 1525 DY := -DY; 1526 end 1527 else 1528 SY := 1; 1529 1530 DX := DX shl 1; 1531 DY := DY shl 1; 1532 1533 X := X1; 1534 Y := Y1; 1535 1536 if DX > DY then 1537 begin 1538 E := 0; 1539 1540 while X <> X2 do 1541 begin 1542 alpha := 1 - E / DX; 1543 DrawPixel(X, Y, BGRA(c.red, c.green, c.blue, round(c.alpha * sqrt(alpha)))); 1544 DrawPixel(X, Y + SY, BGRA(c.red, c.green, c.blue, 1545 round(c.alpha * sqrt(1 - alpha)))); 1546 Inc(E, DY); 1547 if E >= DX then 1548 begin 1549 Inc(Y, SY); 1550 Dec(E, DX); 1551 end; 1552 Inc(X, SX); 1553 1554 Inc(DashPos); 1555 if DashPos = DashLen then 1556 c := c2 1557 else 1558 if DashPos = DashLen + DashLen then 1559 begin 1560 c := c1; 1561 DashPos := 0; 1562 end; 1563 end; 1564 end 1565 else 1566 begin 1567 E := 0; 1568 1569 while Y <> Y2 do 1570 begin 1571 alpha := 1 - E / DY; 1572 DrawPixel(X, Y, BGRA(c.red, c.green, c.blue, round(c.alpha * sqrt(alpha)))); 1573 DrawPixel(X + SX, Y, BGRA(c.red, c.green, c.blue, 1574 round(c.alpha * sqrt(1 - alpha)))); 1575 Inc(E, DX); 1576 if E >= DY then 1577 begin 1578 Inc(X, SX); 1579 Dec(E, DY); 1580 end; 1581 Inc(Y, SY); 1582 1583 Inc(DashPos); 1584 if DashPos = DashLen then 1585 c := c2 1586 else 1587 if DashPos = DashLen + DashLen then 1588 begin 1589 c := c1; 1590 DashPos := 0; 1591 end; 1592 end; 1593 end; 1594 if DrawLastPixel then 1595 DrawPixel(X2, Y2, c); 1596 end; 1597 1598 procedure TBGRADefaultBitmap.DrawPolyLineAntialias(points: array of TPoint; c1, 1599 c2: TBGRAPixel; dashLen: integer; DrawLastPixel: boolean); 1600 var i: integer; 1601 begin 1602 if length(points) = 1 then 1603 begin 1604 if DrawLastPixel then DrawPixel(points[0].x,points[0].y,c1); 1605 end 1606 else 1607 for i := 0 to high(points)-1 do 1608 DrawLineAntialias(points[i].x,points[i].Y,points[i+1].x,points[i+1].y,c1,c2,dashLen,DrawLastPixel and (i=high(points)-1)); 1609 end; 1610 1611 procedure TBGRADefaultBitmap.DrawLineAntialias(x1, y1, x2, y2: single; 1612 c: TBGRAPixel; w: single; closed: boolean); 1613 var 1614 dx, dy, d, hx, hy, wx, wy, t, t2, t3: single; 1615 nbInter, i: integer; 1616 1617 poly: array of tpointf; 1618 alphaFactor: single; 1619 begin 1620 if (w <= 0) then 1621 exit; 1622 if (w = 1) and (frac(x1) = 0) and (frac(y1) = 0) and (frac(x2) = 0) and 1623 (frac(y2) = 0) then 1624 begin 1625 DrawLineAntialias(round(x1), round(y1), round(x2), round(y2), c, closed); 1626 exit; 1627 end; 1628 1629 dx := x2 - x1; 1630 dy := y2 - y1; 1631 if (dx = 0) and (dy = 0) then 1632 begin 1633 if closed then 1634 FillEllipseAntialias(x1, y1, w / 2, w / 2, c); 1635 exit; 1636 end; 1637 1638 d := sqrt(sqr(dx) + sqr(dy)); 1639 dx /= d; 1640 dy /= d; 1641 hx := dy * w / 2; 1642 hy := -dx * w / 2; 1643 wx := dx * w / 2; 1644 wy := dy * w / 2; 1645 1646 nbInter := (ceil(w) + 1) * 2; 1647 setlength(poly, 4 + nbInter * 2); 1648 poly[0] := pointf(x1 + hx, y1 + hy); 1649 poly[1] := pointf(x2 + hx, y2 + hy); 1650 1651 if closed then 1652 begin 1653 for i := 0 to nbInter - 1 do 1654 begin 1655 t := 1 - (i + 1) / (nbInter + 1) * 2; 1656 t2 := sqrt(1 - sqr(t)); 1657 poly[2 + i] := pointf(x2 + t * hx + t2 * wx, y2 + t * hy + t2 * wy); 1658 end; 1659 end 1660 else 1661 begin 1662 if c.alpha=255 then alphaFactor := 1 else 1663 begin 1664 alphaFactor := sqr(c.alpha / 255) / 2.5; 1665 if (c.alpha > 220) then 1666 begin 1667 t := sqr(sqr((c.alpha-220)/(255-220))); 1668 alphaFactor := alphaFactor*(1-t)+0.8*t; 1669 end; 1670 end; 1671 for i := 0 to nbInter - 1 do 1672 begin 1673 t := 1 - (i + 1) / (nbInter + 1) * 2; 1674 t2 := sqrt(1 - sqr(t)); 1675 t3 := (1 - t2) * 0.7; 1676 poly[2 + i] := pointf(x2 + t * hx - t2 * wx + dx * (alphaFactor + t3), 1677 y2 + t * hy - t2 * wy + dy * (alphaFactor + t3)); 1678 end; 1679 end; 1680 1681 poly[2 + nbinter] := pointf(x2 - hx, y2 - hy); 1682 poly[3 + nbinter] := pointf(x1 - hx, y1 - hy); 1683 1684 for i := 0 to nbInter - 1 do 1685 begin 1686 t := (i + 1) / (nbInter + 1) * 2 - 1; 1687 t2 := sqrt(1 - sqr(t)); 1688 poly[4 + nbinter + i] := pointf(x1 + t * hx - t2 * wx, y1 + t * hy - t2 * wy); 1689 end; 1690 1691 FillPolyAntialias(poly, c); 1692 end; 1693 1694 procedure TBGRADefaultBitmap.DrawPolyLineAntialias(points: array of TPointF; 1695 c: TBGRAPixel; w: single; Closed: boolean); 1696 var i: integer; 1697 begin 1698 if length(points) = 1 then 1699 begin 1700 if Closed then DrawLineAntialias(points[0].x,points[0].y,points[0].x,points[0].y,c,w,true); 1701 end 1702 else 1703 for i := 0 to high(points)-1 do 1704 DrawLineAntialias(points[i].x,points[i].Y,points[i+1].x,points[i+1].y,c,w,Closed and (i=high(points)-1)); 1705 end; 1706 1707 procedure TBGRADefaultBitmap.DrawPolygonAntialias(points: array of TPointF; 1708 c: TBGRAPixel; w: single); 1709 var i: integer; 1710 begin 1711 if length(points) = 1 then 1712 begin 1713 DrawLineAntialias(points[0].x,points[0].y,points[0].x,points[0].y,c,w,true); 1714 end 1715 else 1716 if length(points) > 1 then 1717 begin 1718 for i := 0 to high(points)-1 do 1719 DrawLineAntialias(points[i].x,points[i].Y,points[i+1].x,points[i+1].y,c,w,False); 1720 DrawLineAntialias(points[high(points)].x,points[high(points)].Y,points[0].x,points[0].y,c,w,False); 1721 end; 1722 end; 1723 1724 procedure TBGRADefaultBitmap.EraseLineAntialias(x1, y1, x2, y2: single; 1725 alpha: byte; w: single; Closed: boolean); 1726 begin 1727 FEraseMode := True; 1728 DrawLineAntialias(x1, y1, x2, y2, BGRA(0, 0, 0, alpha), w, Closed); 1729 FEraseMode := False; 1730 end; 1731 1732 procedure TBGRADefaultBitmap.FillPolyAntialias(points: array of TPointF; c: TBGRAPixel); 1733 begin 1734 BGRAPolygon.FillPolyAntialias(self, points, c, FEraseMode); 1735 end; 1736 1737 procedure TBGRADefaultBitmap.ErasePolyAntialias(points: array of TPointF; alpha: byte); 1738 begin 1739 FEraseMode := True; 1740 FillPolyAntialias(points, BGRA(0, 0, 0, alpha)); 1741 FEraseMode := False; 1742 end; 1743 1744 procedure TBGRADefaultBitmap.EllipseAntialias(x, y, rx, ry: single; 1745 c: TBGRAPixel; w: single); 1746 begin 1747 BGRAPolygon.BorderEllipseAntialias(self, x, y, rx, ry, w, c, FEraseMode); 1748 end; 1749 1750 procedure TBGRADefaultBitmap.FillEllipseAntialias(x, y, rx, ry: single; c: TBGRAPixel); 1751 begin 1752 BGRAPolygon.FillEllipseAntialias(self, x, y, rx, ry, c, FEraseMode); 1753 end; 1754 1755 procedure TBGRADefaultBitmap.EraseEllipseAntialias(x, y, rx, ry: single; alpha: byte); 1756 begin 1757 FEraseMode := True; 1758 FillEllipseAntialias(x, y, rx, ry, BGRA(0, 0, 0, alpha)); 1759 FEraseMode := False; 1760 end; 1761 1762 {------------------------ Shapes ----------------------------------------------} 1763 1764 procedure TBGRADefaultBitmap.Rectangle(x, y, x2, y2: integer; c: TColor); 1765 begin 1766 Rectangle(x, y, x2, y2, ColorToBGRA(c), dmSet); 1767 end; 1768 1769 procedure TBGRADefaultBitmap.Rectangle(r: TRect; c: TBGRAPixel; mode: TDrawMode); 1770 begin 1771 Rectangle(r.left, r.top, r.right, r.bottom, c, mode); 1772 end; 1773 1774 procedure TBGRADefaultBitmap.Rectangle(r: TRect; BorderColor, FillColor: TBGRAPixel; 1775 mode: TDrawMode); 1776 begin 1777 Rectangle(r.left, r.top, r.right, r.bottom, BorderColor, FillColor, mode); 1778 end; 1779 1780 procedure TBGRADefaultBitmap.Rectangle(r: TRect; c: TColor); 1781 begin 1782 Rectangle(r.left, r.top, r.right, r.bottom, c); 1783 end; 1784 1785 procedure TBGRADefaultBitmap.RectangleAntialias(x, y, x2, y2: single; 1786 c: TBGRAPixel; w: single); 1787 begin 1788 RectangleAntialias(x, y, x2, y2, c, w, BGRAPixelTransparent); 1789 end; 1790 1791 procedure TBGRADefaultBitmap.RectangleAntialias(x, y, x2, y2: single; 1792 c: TBGRAPixel; w: single; back: TBGRAPixel); 1793 var 1794 poly: array of TPointF; 1795 temp: single; 1796 begin 1797 if (x > x2) then 1798 begin 1799 temp := x; 1800 x := x2; 1801 x2 := temp; 1802 end; 1803 if (y > y2) then 1804 begin 1805 temp := y; 1806 y := y2; 1807 y2 := temp; 1808 end; 1809 1810 if (x2 - x <= w) or (y2 - y <= w) then 1811 begin 1812 FillRectAntialias(x - w / 2, y - w / 2, x2 + w / 2, y2 + w / 2, c); 1813 exit; 1814 end; 1815 w /= 2; 1816 1817 setlength(poly, 9); 1818 poly[0] := pointf(x - w, y - w); 1819 poly[1] := pointf(x2 + w, y - w); 1820 poly[2] := pointf(x2 + w, y2 + w); 1821 poly[3] := pointf(x - w, y2 + w); 1822 poly[4] := EmptyPointF; 1823 poly[5] := pointf(x + w, y + w); 1824 poly[6] := pointf(x2 - w, y + w); 1825 poly[7] := pointf(x2 - w, y2 - w); 1826 poly[8] := pointf(x + w, y2 - w); 1827 FillPolyAntialias(poly, c); 1828 1829 if back.alpha <> 0 then 1830 FillRectAntialias(x + w, y + w, x2 - w, y2 - w, back); 1831 end; 1832 1833 procedure TBGRADefaultBitmap.FillRect(r: TRect; c: TColor); 1834 begin 1835 FillRect(r.Left, r.top, r.right, r.bottom, c); 1836 end; 1837 1838 procedure TBGRADefaultBitmap.FillRect(r: TRect; c: TBGRAPixel; mode: TDrawMode); 1839 begin 1840 FillRect(r.Left, r.top, r.right, r.bottom, c, mode); 2524 end else 2525 result := true; 1841 2526 end; 1842 2527 1843 2528 procedure TBGRADefaultBitmap.Rectangle(x, y, x2, y2: integer; 1844 2529 c: TBGRAPixel; mode: TDrawMode); 1845 var 1846 temp: integer; 1847 begin 1848 if (x > x2) then 1849 begin 1850 temp := x; 1851 x := x2; 1852 x2 := temp; 1853 end; 1854 if (y > y2) then 1855 begin 1856 temp := y; 1857 y := y2; 1858 y2 := temp; 1859 end; 1860 if (x2 - x <= 1) or (y2 - y <= 1) then 1861 exit; 2530 begin 2531 if not CheckRectBounds(x,y,x2,y2,1) then exit; 1862 2532 case mode of 1863 2533 dmFastBlend: … … 1891 2561 end; 1892 2562 end; 2563 dmXor: 2564 begin 2565 XorHorizLine(x, y, x2 - 1, c); 2566 XorHorizLine(x, y2 - 1, x2 - 1, c); 2567 if y2 - y > 2 then 2568 begin 2569 XorVertLine(x, y + 1, y2 - 2, c); 2570 XorVertLine(x2 - 1, y + 1, y2 - 2, c); 2571 end; 2572 end; 1893 2573 dmSetExceptTransparent: if (c.alpha = 255) then 1894 2574 Rectangle(x, y, x2, y2, c, dmSet); … … 1898 2578 procedure TBGRADefaultBitmap.Rectangle(x, y, x2, y2: integer; 1899 2579 BorderColor, FillColor: TBGRAPixel; mode: TDrawMode); 2580 begin 2581 if not CheckRectBounds(x,y,x2,y2,1) then exit; 2582 Rectangle(x, y, x2, y2, BorderColor, mode); 2583 FillRect(x + 1, y + 1, x2 - 1, y2 - 1, FillColor, mode); 2584 end; 2585 2586 function TBGRADefaultBitmap.CheckClippedRectBounds(var x, y, x2, y2: integer): boolean; inline; 1900 2587 var 1901 2588 temp: integer; … … 1913 2600 y2 := temp; 1914 2601 end; 1915 if (x2 - x <= 1) or (y2 - y <= 1) then 2602 if (x >= FClipRect.Right) or (x2 <= FClipRect.Left) or (y >= FClipRect.Bottom) or (y2 <= FClipRect.Top) then 2603 begin 2604 result := false; 1916 2605 exit; 1917 1918 Rectangle(x, y, x2, y2, BorderColor, mode); 1919 FillRect(x + 1, y + 1, x2 - 1, y2 - 1, FillColor, mode); 1920 end; 1921 1922 procedure TBGRADefaultBitmap.FillRect(x, y, x2, y2: integer; c: TColor); 1923 begin 1924 FillRect(x, y, x2, y2, ColorToBGRA(c), dmSet); 2606 end; 2607 if x < FClipRect.Left then 2608 x := FClipRect.Left; 2609 if x2 > FClipRect.Right then 2610 x2 := FClipRect.Right; 2611 if y < FClipRect.Top then 2612 y := FClipRect.Top; 2613 if y2 > FClipRect.Bottom then 2614 y2 := FClipRect.Bottom; 2615 if (x2 - x <= 0) or (y2 - y <= 0) then 2616 begin 2617 result := false; 2618 exit; 2619 end else 2620 result := true; 1925 2621 end; 1926 2622 … … 1928 2624 mode: TDrawMode); 1929 2625 var 1930 temp,yb, tx, delta: integer;2626 yb, tx, delta: integer; 1931 2627 p: PBGRAPixel; 1932 2628 begin 1933 if (x > x2) then 1934 begin 1935 temp := x; 1936 x := x2; 1937 x2 := temp; 1938 end; 1939 if (y > y2) then 1940 begin 1941 temp := y; 1942 y := y2; 1943 y2 := temp; 1944 end; 1945 if (x >= Width) or (x2 <= 0) or (y >= Height) or (y2 <= 0) then 1946 exit; 1947 if x < 0 then 1948 x := 0; 1949 if x2 > Width then 1950 x2 := Width; 1951 if y < 0 then 1952 y := 0; 1953 if y2 > Height then 1954 y2 := Height; 1955 if (x2 - x <= 0) or (y2 - y <= 0) then 1956 exit; 2629 if not CheckClippedRectBounds(x,y,x2,y2) then exit; 1957 2630 tx := x2 - x; 1958 2631 Dec(x2); 1959 2632 Dec(y2); 1960 2633 1961 case mode of 1962 dmFastBlend: 1963 begin 1964 p := Scanline[y] + x; 1965 if FLineOrder = riloBottomToTop then 1966 delta := -Width 1967 else 1968 delta := Width; 1969 for yb := y2 - y downto 0 do 1970 begin 1971 FastBlendPixelsInline(p, c, tx); 1972 Inc(p, delta); 1973 end; 1974 InvalidateBitmap; 2634 if mode = dmSetExceptTransparent then 2635 begin 2636 if (c.alpha = 255) then 2637 FillRect(x, y, x2, y2, c, dmSet); 2638 end else 2639 begin 2640 if (mode <> dmSet) and (c.alpha = 0) then exit; 2641 2642 p := Scanline[y] + x; 2643 if FLineOrder = riloBottomToTop then 2644 delta := -Width 2645 else 2646 delta := Width; 2647 2648 case mode of 2649 dmFastBlend: 2650 for yb := y2 - y downto 0 do 2651 begin 2652 FastBlendPixelsInline(p, c, tx); 2653 Inc(p, delta); 2654 end; 2655 dmDrawWithTransparency: 2656 for yb := y2 - y downto 0 do 2657 begin 2658 DrawPixelsInline(p, c, tx); 2659 Inc(p, delta); 2660 end; 2661 dmSet: 2662 for yb := y2 - y downto 0 do 2663 begin 2664 FillInline(p, c, tx); 2665 Inc(p, delta); 2666 end; 2667 dmXor: 2668 for yb := y2 - y downto 0 do 2669 begin 2670 XorInline(p, c, tx); 2671 Inc(p, delta); 2672 end; 1975 2673 end; 1976 dmDrawWithTransparency: 1977 begin 1978 p := Scanline[y] + x; 1979 if FLineOrder = riloBottomToTop then 1980 delta := -Width 1981 else 1982 delta := Width; 1983 for yb := y2 - y downto 0 do 1984 begin 1985 DrawPixelsInline(p, c, tx); 1986 Inc(p, delta); 1987 end; 1988 InvalidateBitmap; 1989 end; 1990 dmSet: 1991 begin 1992 p := Scanline[y] + x; 1993 if FLineOrder = riloBottomToTop then 1994 delta := -Width 1995 else 1996 delta := Width; 1997 for yb := y2 - y downto 0 do 1998 begin 1999 FillInline(p, c, tx); 2000 Inc(p, delta); 2001 end; 2002 InvalidateBitmap; 2003 end; 2004 dmSetExceptTransparent: if (c.alpha = 255) then 2005 FillRect(x, y, x2, y2, c, dmSet); 2006 end; 2007 end; 2008 2009 procedure TBGRADefaultBitmap.FillRectAntialias(x, y, x2, y2: single; c: TBGRAPixel); 2010 var 2011 poly: array of TPointF; 2012 begin 2013 setlength(poly, 4); 2014 poly[0] := pointf(x, y); 2015 poly[1] := pointf(x2, y); 2016 poly[2] := pointf(x2, y2); 2017 poly[3] := pointf(x, y2); 2018 FillPolyAntialias(poly, c); 2674 2675 InvalidateBitmap; 2676 end; 2677 end; 2678 2679 procedure TBGRADefaultBitmap.FillRect(x, y, x2, y2: integer; 2680 texture: IBGRAScanner; mode: TDrawMode); 2681 var 2682 yb, tx, delta: integer; 2683 p: PBGRAPixel; 2684 begin 2685 if not CheckClippedRectBounds(x,y,x2,y2) then exit; 2686 tx := x2 - x; 2687 Dec(x2); 2688 Dec(y2); 2689 2690 p := Scanline[y] + x; 2691 if FLineOrder = riloBottomToTop then 2692 delta := -Width 2693 else 2694 delta := Width; 2695 2696 for yb := y to y2 do 2697 begin 2698 texture.ScanMoveTo(x,yb); 2699 ScannerPutPixels(texture, p, tx, mode); 2700 Inc(p, delta); 2701 end; 2702 2703 InvalidateBitmap; 2019 2704 end; 2020 2705 2021 2706 procedure TBGRADefaultBitmap.AlphaFillRect(x, y, x2, y2: integer; alpha: byte); 2022 2707 var 2023 temp,yb, tx, delta: integer;2708 yb, tx, delta: integer; 2024 2709 p: PBGRAPixel; 2025 2710 begin … … 2030 2715 end; 2031 2716 2032 if (x > x2) then 2033 begin 2034 temp := x; 2035 x := x2; 2036 x2 := temp; 2037 end; 2038 if (y > y2) then 2039 begin 2040 temp := y; 2041 y := y2; 2042 y2 := temp; 2043 end; 2044 if (x >= Width) or (x2 <= 0) or (y >= Height) or (y2 <= 0) then 2045 exit; 2046 if x < 0 then 2047 x := 0; 2048 if x2 > Width then 2049 x2 := Width; 2050 if y < 0 then 2051 y := 0; 2052 if y2 > Height then 2053 y2 := Height; 2054 if (x2 - x <= 0) or (y2 - y <= 0) then 2055 exit; 2717 if not CheckClippedRectBounds(x,y,x2,y2) then exit; 2056 2718 tx := x2 - x; 2057 2719 Dec(x2); … … 2071 2733 end; 2072 2734 2735 procedure TBGRADefaultBitmap.FillRectAntialias(x, y, x2, y2: single; c: TBGRAPixel); 2736 var tx,ty: single; 2737 begin 2738 tx := x2-x; 2739 ty := y2-y; 2740 if (tx=0) or (ty=0) then exit; 2741 if (abs(tx) > 2) and (abs(ty) > 2) then 2742 begin 2743 if (tx < 0) then 2744 begin 2745 tx := -tx; 2746 x := x2; 2747 x2 := x+tx; 2748 end; 2749 if (ty < 0) then 2750 begin 2751 ty := -ty; 2752 y := y2; 2753 y2 := y+ty; 2754 end; 2755 FillRectAntialias(x,y,x2,ceil(y)+0.5,c); 2756 FillRectAntialias(x,ceil(y)+0.5,ceil(x)+0.5,floor(y2)-0.5,c); 2757 FillRectAntialias(floor(x2)-0.5,ceil(y)+0.5,x2,floor(y2)-0.5,c); 2758 FillRectAntialias(x,floor(y2)-0.5,x2,y2,c); 2759 FillRect(ceil(x)+1,ceil(y)+1,floor(x2),floor(y2),c,dmDrawWithTransparency); 2760 end else 2761 FillPolyAntialias([pointf(x, y), pointf(x2, y), pointf(x2, y2), pointf(x, y2)], c); 2762 end; 2763 2764 procedure TBGRADefaultBitmap.EraseRectAntialias(x, y, x2, y2: single; 2765 alpha: byte); 2766 begin 2767 ErasePolyAntialias([pointf(x, y), pointf(x2, y), pointf(x2, y2), pointf(x, y2)], alpha); 2768 end; 2769 2770 procedure TBGRADefaultBitmap.FillRectAntialias(x, y, x2, y2: single; 2771 texture: IBGRAScanner); 2772 begin 2773 FillPolyAntialias([pointf(x, y), pointf(x2, y), pointf(x2, y2), pointf(x, y2)], texture); 2774 end; 2775 2776 procedure TBGRADefaultBitmap.FillRoundRectAntialias(x, y, x2, y2, rx,ry: single; 2777 c: TBGRAPixel; options: TRoundRectangleOptions); 2778 begin 2779 BGRAPolygon.FillRoundRectangleAntialias(self,x,y,x2,y2,rx,ry,options,c,False); 2780 end; 2781 2782 procedure TBGRADefaultBitmap.FillRoundRectAntialias(x, y, x2, y2, rx, 2783 ry: single; texture: IBGRAScanner; options: TRoundRectangleOptions); 2784 begin 2785 BGRAPolygon.FillRoundRectangleAntialiasWithTexture(self,x,y,x2,y2,rx,ry,options,texture); 2786 end; 2787 2788 procedure TBGRADefaultBitmap.EraseRoundRectAntialias(x, y, x2, y2, rx, 2789 ry: single; alpha: byte; options: TRoundRectangleOptions); 2790 begin 2791 BGRAPolygon.FillRoundRectangleAntialias(self,x,y,x2,y2,rx,ry,options,BGRA(0,0,0,alpha),True); 2792 end; 2793 2073 2794 procedure TBGRADefaultBitmap.RoundRect(X1, Y1, X2, Y2: integer; 2074 RX, RY: integer; BorderColor, FillColor: TBGRAPixel); 2075 var 2076 CX, CY, CX1, CY1, A, B, NX, NY: single; 2077 X, Y, EX, EY: integer; 2078 LX1, LY1: integer; 2079 LX2, LY2: integer; 2080 DivSqrA, DivSqrB: single; 2081 I, J, S: integer; 2082 EdgeList: array of TPoint; 2083 temp: integer; 2084 LX, LY: integer; 2085 2086 procedure AddEdge(X, Y: integer); 2087 begin 2088 if (EdgeList[Y].X = -1) or (X < EdgeList[Y].X) then 2089 EdgeList[Y].X := X; 2090 if (EdgeList[Y].Y = -1) or (X > EdgeList[Y].Y) then 2091 EdgeList[Y].Y := X; 2092 end; 2093 2094 begin 2095 if (x1 > x2) then 2096 begin 2097 temp := x1; 2098 x1 := x2; 2099 x2 := temp; 2100 end; 2101 if (y1 > y2) then 2102 begin 2103 temp := y1; 2104 y1 := y2; 2105 y2 := temp; 2106 end; 2107 if (x2 - x1 <= 0) or (y2 - y1 <= 0) then 2108 exit; 2109 LX := x2 - x1 - RX; 2110 LY := y2 - y1 - RY; 2111 Dec(x2); 2112 Dec(y2); 2113 2114 if (X1 = X2) and (Y1 = Y2) then 2115 begin 2116 DrawPixel(X1, Y1, BorderColor); 2117 Exit; 2118 end; 2119 2120 if (X2 - X1 = 1) or (Y2 - Y1 = 1) then 2121 begin 2122 FillRect(X1, Y1, X2 + 1, Y2 + 1, BorderColor, dmDrawWithTransparency); 2123 Exit; 2124 end; 2125 2126 if (LX > X2 - X1) or (LY > Y2 - Y1) then 2127 begin 2128 Rectangle(X1, Y1, X2 + 1, Y2 + 1, BorderColor, dmDrawWithTransparency); 2129 FillRect(X1 + 1, Y1 + 1, X2, Y2, FillColor, dmDrawWithTransparency); 2130 Exit; 2131 end; 2132 2133 SetLength(EdgeList, Ceil((Y2 - Y1 + 1) / 2)); 2134 for I := 0 to Pred(High(EdgeList)) do 2135 EdgeList[I] := Point(-1, -1); 2136 EdgeList[High(EdgeList)] := Point(0, 0); 2137 2138 A := (X2 - X1 + 1 - LX) / 2; 2139 B := (Y2 - Y1 + 1 - LY) / 2; 2140 CX := (X2 + X1 + 1) / 2; 2141 CY := (Y2 + Y1 + 1) / 2; 2142 2143 CX1 := X2 + 1 - A - Floor(CX); 2144 CY1 := Y2 + 1 - B - Floor(CY); 2145 2146 EX := Floor(Sqr(A) / Sqrt(Sqr(A) + Sqr(B)) + Frac(A)); 2147 EY := Floor(Sqr(B) / Sqrt(Sqr(A) + Sqr(B)) + Frac(B)); 2148 2149 DivSqrA := 1 / Sqr(A); 2150 DivSqrB := 1 / Sqr(B); 2151 2152 NY := B; 2153 AddEdge(Floor(CX1), Round(CY1 + B) - 1); 2154 for X := 1 to Pred(EX) do 2155 begin 2156 NY := B * Sqrt(1 - Sqr(X + 0.5 - Frac(A)) * DivSqrA); 2157 2158 AddEdge(Floor(CX1) + X, Round(CY1 + NY) - 1); 2159 end; 2160 2161 LX1 := Floor(CX1) + Pred(EX); 2162 LY1 := Round(CY1 + NY) - 1; 2163 2164 NX := A; 2165 AddEdge(Round(CX1 + A) - 1, Floor(CY1)); 2166 for Y := 1 to Pred(EY) do 2167 begin 2168 NX := A * Sqrt(1 - Sqr(Y + 0.5 - Frac(B)) * DivSqrB); 2169 2170 AddEdge(Round(CX1 + NX) - 1, Floor(CY1) + Y); 2171 end; 2172 2173 LX2 := Round(CX1 + NX) - 1; 2174 LY2 := Floor(CY1) + Pred(EY); 2175 2176 if Abs(LX1 - LX2) > 1 then 2177 begin 2178 if Abs(LY1 - LY2) > 1 then 2179 AddEdge(LX1 + 1, LY1 - 1) 2180 else 2181 AddEdge(LX1 + 1, LY1); 2182 end 2183 else 2184 if Abs(LY1 - LY2) > 1 then 2185 AddEdge(LX2, LY1 - 1); 2186 2187 for I := 0 to High(EdgeList) do 2188 begin 2189 if EdgeList[I].X = -1 then 2190 EdgeList[I] := Point(Round(CX1 + A) - 1, Round(CX1 + A) - 1) 2191 else 2192 Break; 2193 end; 2194 2195 for J := 0 to High(EdgeList) do 2196 begin 2197 if (J = 0) and (Frac(CY) > 0) then 2198 begin 2199 for I := EdgeList[J].X to EdgeList[J].Y do 2200 begin 2201 DrawPixel(Floor(CX) + I, Floor(CY) + J, BorderColor); 2202 DrawPixel(Ceil(CX) - Succ(I), Floor(CY) + J, BorderColor); 2203 end; 2204 2205 DrawHorizLine(Ceil(CX) - EdgeList[J].X, Floor(CY) + J, Floor(CX) + 2206 Pred(EdgeList[J].X), FillColor); 2207 end 2208 else 2209 if (J = High(EdgeList)) then 2210 begin 2211 if Frac(CX) > 0 then 2212 S := -EdgeList[J].Y 2213 else 2214 S := -Succ(EdgeList[J].Y); 2215 2216 for I := S to EdgeList[J].Y do 2217 begin 2218 DrawPixel(Floor(CX) + I, Floor(CY) + J, BorderColor); 2219 DrawPixel(Floor(CX) + I, Ceil(CY) - Succ(J), BorderColor); 2220 end; 2221 end 2222 else 2223 begin 2224 for I := EdgeList[J].X to EdgeList[J].Y do 2225 begin 2226 DrawPixel(Floor(CX) + I, Floor(CY) + J, BorderColor); 2227 DrawPixel(Floor(CX) + I, Ceil(CY) - Succ(J), BorderColor); 2228 if Floor(CX) + I <> Ceil(CX) - Succ(I) then 2229 begin 2230 DrawPixel(Ceil(CX) - Succ(I), Floor(CY) + J, BorderColor); 2231 DrawPixel(Ceil(CX) - Succ(I), Ceil(CY) - Succ(J), BorderColor); 2232 end; 2233 end; 2234 2235 DrawHorizLine(Ceil(CX) - EdgeList[J].X, Floor(CY) + J, 2236 Floor(CX) + Pred(EdgeList[J].X), FillColor); 2237 DrawHorizLine(Ceil(CX) - EdgeList[J].X, Ceil(CY) - Succ(J), 2238 Floor(CX) + Pred(EdgeList[J].X), FillColor); 2239 end; 2240 end; 2241 end; 2242 2243 procedure TBGRADefaultBitmap.TextOut(x, y: integer; s: string; c: TBGRAPixel); 2244 begin 2245 TextOut(x, y, s, c, taLeftJustify); 2246 end; 2247 2248 2249 {$HINTS OFF} 2795 DX, DY: integer; BorderColor, FillColor: TBGRAPixel); 2796 begin 2797 BGRARoundRectAliased(self,X1,Y1,X2,Y2,DX,DY,BorderColor,FillColor); 2798 end; 2799 2800 {------------------------- Text functions ---------------------------------------} 2801 2802 procedure TBGRADefaultBitmap.TextOutAngle(x, y, orientation: integer; 2803 s: string; c: TBGRAPixel; align: TAlignment); 2804 begin 2805 UpdateFont; 2806 BGRAText.BGRATextOutAngle(self,FFont,FontQuality,x,y,orientation,s,c,nil,align); 2807 end; 2808 2809 procedure TBGRADefaultBitmap.TextOutAngle(x, y, orientation: integer; 2810 s: string; texture: IBGRAScanner; align: TAlignment); 2811 begin 2812 UpdateFont; 2813 BGRAText.BGRATextOutAngle(self,FFont,FontQuality,x,y,orientation,s,BGRAPixelTransparent,texture,align); 2814 end; 2815 2816 procedure TBGRADefaultBitmap.TextOut(x, y: integer; s: string; 2817 texture: IBGRAScanner; align: TAlignment); 2818 begin 2819 UpdateFont; 2820 2821 if (FontQuality in[fqFineAntialiasing,fqFineClearTypeBGR,fqFineClearTypeRGB]) and (FFont.Orientation mod 3600 = 0) then 2822 BGRATextFX.BGRATextOutImproveReadability(self,FFont,x,y,s,BGRAPixelTransparent,texture,align, 2823 FontQuality in[fqFineClearTypeRGB,fqFineClearTypeBGR], FontQuality = fqFineClearTypeRGB) else 2824 2825 BGRAText.BGRATextOut(self,FFont,FontQuality,x,y,s,BGRAPixelTransparent,texture,align); 2826 end; 2827 2250 2828 procedure TBGRADefaultBitmap.TextOut(x, y: integer; s: string; 2251 2829 c: TBGRAPixel; align: TAlignment); 2252 var2253 size: TSize;2254 temp: TBGRADefaultBitmap;2255 P: PBGRAPixel;2256 n: integer;2257 alpha: integer;2258 2830 begin 2259 2831 UpdateFont; 2260 2832 2261 size := TextSize(s); 2262 if (size.cx = 0) or (size.cy = 0) then 2263 exit; 2264 2265 case align of 2266 taLeftJustify: ; 2267 taCenter: Dec(x, size.cx div 2); 2268 taRightJustify: Dec(x, size.cx); 2269 end; 2270 2271 temp := NewBitmap(size.cx, size.cy); 2272 temp.Fill(clBlack); 2273 temp.Canvas.Font := FFont; 2274 temp.Canvas.Font.Color := clWhite; 2275 temp.Canvas.Brush.Style := bsClear; 2276 temp.Canvas.TextOut(0, 0, s); 2277 p := temp.Data; 2278 for n := temp.NbPixels - 1 downto 0 do 2279 begin 2280 alpha := P^.green; 2281 p^.red := c.red; 2282 p^.green := c.green; 2283 p^.blue := c.blue; 2284 p^.alpha := (c.alpha * alpha) div 255; 2285 Inc(p); 2286 end; 2287 PutImage(x, y, temp, dmDrawWithTransparency); 2288 temp.Free; 2289 end; 2290 2291 {$HINTS ON} 2292 2293 procedure TBGRADefaultBitmap.TextOut(x, y: integer; s: string; c: TColor); 2294 begin 2295 TextOut(x, y, s, ColorToBGRA(c)); 2833 if (FontQuality in[fqFineAntialiasing,fqFineClearTypeBGR,fqFineClearTypeRGB]) and (FFont.Orientation mod 3600 = 0) then 2834 BGRATextFX.BGRATextOutImproveReadability(self,FFont,x,y,s,c,nil,align, 2835 FontQuality in[fqFineClearTypeRGB,fqFineClearTypeBGR], FontQuality = fqFineClearTypeRGB) else 2836 2837 BGRAText.BGRATextOut(self,FFont,FontQuality,x,y,s,c,nil,align); 2296 2838 end; 2297 2839 2298 2840 procedure TBGRADefaultBitmap.TextRect(ARect: TRect; x, y: integer; 2299 2841 s: string; style: TTextStyle; c: TBGRAPixel); 2300 var2301 tx, ty: integer;2302 temp: TBGRADefaultBitmap;2303 P: PBGRAPixel;2304 n: integer;2305 alpha: integer;2306 2842 begin 2307 2843 UpdateFont; 2308 2309 if ARect.Left < 0 then 2310 ARect.Left := 0; 2311 if ARect.Top < 0 then 2312 ARect.Top := 0; 2313 if ARect.Right > Width then 2314 ARect.Right := Width; 2315 if ARect.Bottom > Height then 2316 ARect.Bottom := Height; 2317 2318 tx := ARect.Right - ARect.Left; 2319 ty := ARect.Bottom - ARect.Top; 2320 if (tx <= 0) or (ty <= 0) then 2321 exit; 2322 temp := NewBitmap(tx, ty); 2323 temp.Fill(clBlack); 2324 temp.Canvas.Font := FFont; 2325 temp.Canvas.Font.Color := clWhite; 2326 temp.Canvas.Brush.Style := bsClear; 2327 temp.Canvas.TextRect(rect(0, 0, tx, ty), x - ARect.Left, y - ARect.Top, s, style); 2328 p := temp.Data; 2329 for n := tx * ty - 1 downto 0 do 2330 begin 2331 alpha := P^.green; 2332 p^.red := c.red; 2333 p^.green := c.green; 2334 p^.blue := c.blue; 2335 p^.alpha := (c.alpha * alpha) div 255; 2336 Inc(p); 2337 end; 2338 PutImage(ARect.Left, ARect.Top, temp, dmDrawWithTransparency); 2339 temp.Free; 2340 end; 2341 2342 {$hints off} 2844 BGRAText.BGRATextRect(self,FFont,FontQuality,ARect,x,y,s,style,c,nil); 2845 end; 2846 2847 procedure TBGRADefaultBitmap.TextRect(ARect: TRect; x, y: integer; s: string; 2848 style: TTextStyle; texture: IBGRAScanner); 2849 begin 2850 UpdateFont; 2851 BGRAText.BGRATextRect(self,FFont,FontQuality,ARect,x,y,s,style,BGRAPixelTransparent,texture); 2852 end; 2853 2343 2854 function TBGRADefaultBitmap.TextSize(s: string): TSize; 2344 var2345 temp: TBitmap;2346 2855 begin 2347 2856 UpdateFont; 2348 2349 temp := TBitmap.Create; 2350 temp.Canvas.Font := FFont; 2351 temp.Canvas.Font.GetTextSize(s, Result.cx, Result.cy); 2352 temp.Free; 2353 end; 2354 2355 {$hints on} 2356 2357 {----------------------- Spline ------------------} 2358 2359 function TBGRADefaultBitmap.Spline(y0, y1, y2, y3: single; t: single): single; 2360 var 2361 a0, a1, a2, a3: single; 2362 t2: single; 2363 begin 2364 t2 := t * t; 2365 a0 := y3 - y2 - y0 + y1; 2366 a1 := y0 - y1 - a0; 2367 a2 := y2 - y0; 2368 a3 := y1; 2369 Result := a0 * t * t2 + a1 * t2 + a2 * t + a3; 2370 end; 2371 2372 function TBGRADefaultBitmap.ComputeClosedSpline(points: array of TPointF): 2373 ArrayOfTPointF; 2374 2375 function computePrecision(pt1, pt2, pt3, pt4: TPointF): integer; 2376 var 2377 len: single; 2378 begin 2379 len := sqrt(sqr(pt1.x - pt2.x) + sqr(pt1.y - pt2.y)); 2380 len := max(len, sqrt(sqr(pt3.x - pt2.x) + sqr(pt3.y - pt2.y))); 2381 len := max(len, sqrt(sqr(pt3.x - pt4.x) + sqr(pt3.y - pt4.y))); 2382 Result := round(sqrt(len) * 2); 2383 end; 2384 2385 var 2386 i, j, nb, idx, pre: integer; 2387 ptPrev, ptPrev2, ptNext, ptNext2: TPointF; 2388 2389 begin 2390 if length(points) = 2 then 2391 begin 2392 setlength(Result, 2); 2393 Result[0] := points[0]; 2394 Result[1] := points[1]; 2395 exit; 2396 end; 2397 2398 nb := 1; 2399 for i := 0 to high(points) do 2400 begin 2401 ptPrev2 := points[(i + length(points) - 1) mod length(points)]; 2402 ptPrev := points[i]; 2403 ptNext := points[(i + 1) mod length(points)]; 2404 ptNext2 := points[(i + 2) mod length(points)]; 2405 nb += computePrecision(ptPrev2, ptPrev, ptNext, ptNext2); 2406 end; 2407 2408 setlength(Result, nb); 2409 Result[0] := points[0]; 2410 idx := 1; 2411 for i := 0 to high(points) do 2412 begin 2413 ptPrev2 := points[(i + length(points) - 1) mod length(points)]; 2414 ptPrev := points[i]; 2415 ptNext := points[(i + 1) mod length(points)]; 2416 ptNext2 := points[(i + 2) mod length(points)]; 2417 pre := computePrecision(ptPrev2, ptPrev, ptNext, ptNext2); 2418 for j := 1 to pre - 1 do 2419 begin 2420 Result[idx] := pointF(spline(ptPrev2.x, ptPrev.X, ptNext.X, ptNext2.X, j / pre), 2421 spline(ptPrev2.y, ptPrev.y, ptNext.y, ptNext2.y, j / pre)); 2422 Inc(idx); 2423 end; 2424 if pre <> 0 then 2425 begin 2426 Result[idx] := ptNext; 2427 Inc(idx); 2428 end; 2429 end; 2430 end; 2431 2432 function TBGRADefaultBitmap.ComputeOpenedSpline(points: array of TPointF): 2433 ArrayOfTPointF; 2434 2435 function computePrecision(pt1, pt2, pt3, pt4: TPointF): integer; 2436 var 2437 len: single; 2438 begin 2439 len := sqrt(sqr(pt1.x - pt2.x) + sqr(pt1.y - pt2.y)); 2440 len := max(len, sqrt(sqr(pt3.x - pt2.x) + sqr(pt3.y - pt2.y))); 2441 len := max(len, sqrt(sqr(pt3.x - pt4.x) + sqr(pt3.y - pt4.y))); 2442 Result := round(sqrt(len) * 2); 2443 end; 2444 2445 var 2446 i, j, nb, idx, pre: integer; 2447 ptPrev, ptPrev2, ptNext, ptNext2: TPointF; 2448 2449 begin 2450 if length(points) = 2 then 2451 begin 2452 setlength(Result, 2); 2453 Result[0] := points[0]; 2454 Result[1] := points[1]; 2455 exit; 2456 end; 2457 2458 nb := 1; 2459 for i := 0 to high(points) - 1 do 2460 begin 2461 ptPrev2 := points[max(0, i - 1)]; 2462 ptPrev := points[i]; 2463 ptNext := points[i + 1]; 2464 ptNext2 := points[min(high(points), i + 2)]; 2465 nb += computePrecision(ptPrev2, ptPrev, ptNext, ptNext2); 2466 end; 2467 2468 setlength(Result, nb); 2469 Result[0] := points[0]; 2470 idx := 1; 2471 for i := 0 to high(points) - 1 do 2472 begin 2473 ptPrev2 := points[max(0, i - 1)]; 2474 ptPrev := points[i]; 2475 ptNext := points[i + 1]; 2476 ptNext2 := points[min(high(points), i + 2)]; 2477 pre := computePrecision(ptPrev2, ptPrev, ptNext, ptNext2); 2478 for j := 1 to pre - 1 do 2479 begin 2480 Result[idx] := pointF(spline(ptPrev2.x, ptPrev.X, ptNext.X, ptNext2.X, j / pre), 2481 spline(ptPrev2.y, ptPrev.y, ptNext.y, ptNext2.y, j / pre)); 2482 Inc(idx); 2483 end; 2484 if pre <> 0 then 2485 begin 2486 Result[idx] := ptNext; 2487 Inc(idx); 2488 end; 2489 end; 2857 result := BGRAText.BGRATextSize(FFont,FontQuality,s,FontAntialiasingLevel); 2858 if (result.cy >= 24) and FontAntialias then 2859 result := BGRAText.BGRATextSize(FFont,FontQuality,s,4); 2860 end; 2861 2862 {---------------------------- Curves ----------------------------------------} 2863 2864 function TBGRADefaultBitmap.ComputeClosedSpline(const APoints: array of TPointF; AStyle: TSplineStyle): ArrayOfTPointF; 2865 begin 2866 result := BGRAPath.ComputeClosedSpline(APoints, AStyle); 2867 end; 2868 2869 function TBGRADefaultBitmap.ComputeOpenedSpline(const APoints: array of TPointF; AStyle: TSplineStyle): ArrayOfTPointF; 2870 begin 2871 result := BGRAPath.ComputeOpenedSpline(APoints, AStyle); 2872 end; 2873 2874 function TBGRADefaultBitmap.ComputeBezierCurve(const ACurve: TCubicBezierCurve 2875 ): ArrayOfTPointF; 2876 begin 2877 Result:= BGRAPath.ComputeBezierCurve(ACurve); 2878 end; 2879 2880 function TBGRADefaultBitmap.ComputeBezierCurve( 2881 const ACurve: TQuadraticBezierCurve): ArrayOfTPointF; 2882 begin 2883 Result:= BGRAPath.ComputeBezierCurve(ACurve); 2884 end; 2885 2886 function TBGRADefaultBitmap.ComputeBezierSpline( 2887 const ASpline: array of TCubicBezierCurve): ArrayOfTPointF; 2888 begin 2889 Result:= BGRAPath.ComputeBezierSpline(ASpline); 2890 end; 2891 2892 function TBGRADefaultBitmap.ComputeBezierSpline( 2893 const ASpline: array of TQuadraticBezierCurve): ArrayOfTPointF; 2894 begin 2895 Result:= BGRAPath.ComputeBezierSpline(ASpline); 2896 end; 2897 2898 function TBGRADefaultBitmap.ComputeWidePolyline(const points: array of TPointF; 2899 w: single): ArrayOfTPointF; 2900 begin 2901 Result:= BGRAPen.ComputeWidePolylinePoints(points,w,BGRAWhite,LineCap,JoinStyle,FCustomPenStyle,[],JoinMiterLimit); 2902 end; 2903 2904 function TBGRADefaultBitmap.ComputeWidePolyline(const points: array of TPointF; 2905 w: single; Closed: boolean): ArrayOfTPointF; 2906 var 2907 options: TBGRAPolyLineOptions; 2908 begin 2909 if not closed then options := [plRoundCapOpen] else options := []; 2910 Result:= BGRAPen.ComputeWidePolylinePoints(points,w,BGRAWhite,pecRound,pjsRound,FCustomPenStyle,options,JoinMiterLimit); 2911 end; 2912 2913 function TBGRADefaultBitmap.ComputeWidePolygon(const points: array of TPointF; 2914 w: single): ArrayOfTPointF; 2915 begin 2916 Result:= BGRAPen.ComputeWidePolylinePoints(points,w,BGRAWhite,LineCap,JoinStyle,FCustomPenStyle,[plCycle],JoinMiterLimit); 2917 end; 2918 2919 function TBGRADefaultBitmap.ComputeEllipse(x, y, rx, ry: single 2920 ): ArrayOfTPointF; 2921 begin 2922 result := BGRAPath.ComputeEllipse(x,y,rx,ry); 2923 end; 2924 2925 function TBGRADefaultBitmap.ComputeEllipse(x, y, rx, ry, w: single 2926 ): ArrayOfTPointF; 2927 begin 2928 result := ComputeWidePolygon(ComputeEllipse(x,y,rx,ry),w); 2929 end; 2930 2931 function TBGRADefaultBitmap.ComputeArc65536(x, y, rx, ry: single; start65536, 2932 end65536: word): ArrayOfTPointF; 2933 begin 2934 result := BGRAPath.ComputeArc65536(x,y,rx,ry,start65536,end65536); 2935 end; 2936 2937 function TBGRADefaultBitmap.ComputeArcRad(x, y, rx, ry: single; startRad, 2938 endRad: single): ArrayOfTPointF; 2939 begin 2940 result := BGRAPath.ComputeArc65536(x,y,rx,ry,round(startRad*32768/Pi),round(endRad*32768/Pi)); 2941 end; 2942 2943 function TBGRADefaultBitmap.ComputeRoundRect(x1, y1, x2, y2, rx, ry: single 2944 ): ArrayOfTPointF; 2945 begin 2946 result := BGRAPath.ComputeRoundRect(x1,y1,x2,y2,rx,ry); 2947 end; 2948 2949 function TBGRADefaultBitmap.ComputeRoundRect(x1, y1, x2, y2, rx, ry: single; 2950 options: TRoundRectangleOptions): ArrayOfTPointF; 2951 begin 2952 Result:= BGRAPath.ComputeRoundRect(x1,y1,x2,y2,rx,ry,options); 2953 end; 2954 2955 function TBGRADefaultBitmap.ComputePie65536(x, y, rx, ry: single; start65536, 2956 end65536: word): ArrayOfTPointF; 2957 begin 2958 result := BGRAPath.ComputeArc65536(x,y,rx,ry,start65536,end65536); 2959 if (start65536 <> end65536) then 2960 begin 2961 setlength(result,length(result)+1); 2962 result[high(result)] := PointF(x,y); 2963 end; 2964 end; 2965 2966 function TBGRADefaultBitmap.ComputePieRad(x, y, rx, ry: single; startRad, 2967 endRad: single): ArrayOfTPointF; 2968 begin 2969 result := self.ComputePie65536(x,y,rx,ry,round(startRad*32768/Pi),round(endRad*32768/Pi)); 2490 2970 end; 2491 2971 2492 2972 {---------------------------------- Fill ---------------------------------} 2493 2973 2494 procedure TBGRADefaultBitmap.FillTransparent; 2495 begin 2496 Fill(BGRAPixelTransparent); 2497 end; 2498 2499 procedure TBGRADefaultBitmap.ApplyGlobalOpacity(alpha: byte); 2500 var 2501 p: PBGRAPixel; 2502 i: integer; 2503 begin 2504 if alpha = 0 then 2505 FillTransparent 2506 else 2507 if alpha <> 255 then 2508 begin 2509 p := Data; 2510 for i := NbPixels - 1 downto 0 do 2511 begin 2512 p^.alpha := (p^.alpha * alpha + 128) shr 8; 2513 Inc(p); 2514 end; 2515 end; 2516 end; 2517 2518 procedure TBGRADefaultBitmap.Fill(c: TColor); 2519 begin 2520 Fill(ColorToBGRA(c)); 2521 end; 2522 2523 procedure TBGRADefaultBitmap.Fill(c: TBGRAPixel); 2524 begin 2525 Fill(c, 0, Width * Height); 2974 procedure TBGRADefaultBitmap.Fill(texture: IBGRAScanner); 2975 begin 2976 FillRect(FClipRect.Left,FClipRect.Top,FClipRect.Right,FClipRect.Bottom,texture,dmSet); 2526 2977 end; 2527 2978 … … 2542 2993 end; 2543 2994 2544 procedure TBGRADefaultBitmap.AlphaFill(alpha: byte);2545 begin2546 AlphaFill(alpha, 0, NbPixels);2547 end;2548 2549 2995 procedure TBGRADefaultBitmap.AlphaFill(alpha: byte; start, Count: integer); 2550 2996 begin … … 2565 3011 end; 2566 3012 3013 procedure TBGRADefaultBitmap.FillMask(x, y: integer; AMask: TBGRACustomBitmap; 3014 color: TBGRAPixel); 3015 var 3016 scan: TBGRACustomScanner; 3017 begin 3018 if (AMask = nil) or (color.alpha = 0) then exit; 3019 scan := TBGRASolidColorMaskScanner.Create(AMask,Point(-X,-Y),color); 3020 self.FillRect(X,Y,X+AMask.Width,Y+AMask.Height,scan,dmDrawWithTransparency); 3021 scan.Free; 3022 end; 3023 3024 procedure TBGRADefaultBitmap.FillMask(x, y: integer; AMask: TBGRACustomBitmap; 3025 texture: IBGRAScanner); 3026 var 3027 scan: TBGRACustomScanner; 3028 begin 3029 if AMask = nil then exit; 3030 scan := TBGRATextureMaskScanner.Create(AMask,Point(-X,-Y),texture); 3031 self.FillRect(X,Y,X+AMask.Width,Y+AMask.Height,scan,dmDrawWithTransparency); 3032 scan.Free; 3033 end; 3034 3035 procedure TBGRADefaultBitmap.FillClearTypeMask(x, y: integer; xThird: integer; 3036 AMask: TBGRACustomBitmap; color: TBGRAPixel; ARGBOrder: boolean); 3037 begin 3038 BGRAFillClearTypeMask(self,x, y, xThird, AMask, color, nil, ARGBOrder); 3039 end; 3040 3041 procedure TBGRADefaultBitmap.FillClearTypeMask(x, y: integer; xThird: integer; 3042 AMask: TBGRACustomBitmap; texture: IBGRAScanner; ARGBOrder: boolean); 3043 begin 3044 BGRAFillClearTypeMask(self,x, y, xThird, AMask, BGRAPixelTransparent, texture, ARGBOrder); 3045 end; 3046 3047 { Replace color without taking alpha channel into account } 2567 3048 procedure TBGRADefaultBitmap.ReplaceColor(before, after: TColor); 2568 3049 const … … 2573 3054 beforeBGR, afterBGR: longword; 2574 3055 begin 2575 beforeBGR := (before and $FF shl 16) + (before and $FF00) + (before shr 16 and $FF);2576 afterBGR := (after and $FF shl 16) + (after and $FF00) + (after shr 16 and $FF);3056 beforeBGR := NtoLE((before and $FF shl 16) + (before and $FF00) + (before shr 16 and $FF)); 3057 afterBGR := NtoLE((after and $FF shl 16) + (after and $FF00) + (after shr 16 and $FF)); 2577 3058 2578 3059 p := PLongWord(Data); … … 2606 3087 end; 2607 3088 3089 { Replace transparent pixels by the specified color } 2608 3090 procedure TBGRADefaultBitmap.ReplaceTransparent(after: TBGRAPixel); 2609 3091 var … … 2621 3103 end; 2622 3104 2623 procedure TBGRADefaultBitmap.FloodFill(X, Y: integer; Color: TBGRAPixel; 2624 mode: TFloodfillMode; Tolerance: byte = 0); 2625 begin 2626 ParallelFloodFill(X,Y,Self,Color,mode,Tolerance); 2627 end; 2628 3105 { General purpose FloodFill. It can be used to fill inplace or to 3106 fill a destination bitmap according to the content of the current bitmap. 3107 3108 The first pixel encountered is taken as a reference, further pixels 3109 are compared to this pixel. If the distance between next colors and 3110 the first color is lower than the tolerance, then the floodfill continues. 3111 3112 It uses an array of bits to store visited places to avoid filling twice 3113 the same area. It also uses a stack of positions to remember where 3114 to continue after a place is completely filled. 3115 3116 The first direction to be checked is horizontal, then 3117 it checks pixels on the line above and on the line below. } 2629 3118 procedure TBGRADefaultBitmap.ParallelFloodFill(X, Y: integer; 2630 Dest: TBGRA DefaultBitmap; Color: TBGRAPixel; mode: TFloodfillMode;3119 Dest: TBGRACustomBitmap; Color: TBGRAPixel; mode: TFloodfillMode; 2631 3120 Tolerance: byte); 2632 3121 var … … 2699 3188 2700 3189 begin 2701 if (X >= 0) and (X < Width) and (Y >= 0) and (Y < Height) then3190 if PtInClipRect(X,Y) then 2702 3191 begin 2703 3192 S := GetPixel(X, Y); … … 2717 3206 2718 3207 SX := X; 2719 while (SX > 0) and CheckPixel(Pred(SX), Y) do3208 while (SX > FClipRect.Left) and CheckPixel(Pred(SX), Y) do 2720 3209 Dec(SX); 2721 3210 EX := X; 2722 while (EX < Pred( Width)) and CheckPixel(Succ(EX), Y) do3211 while (EX < Pred(FClipRect.Right)) and CheckPixel(Succ(EX), Y) do 2723 3212 Inc(EX); 2724 3213 … … 2733 3222 2734 3223 Added := False; 2735 if Y > 0then3224 if Y > FClipRect.Top then 2736 3225 for I := SX to EX do 2737 3226 if CheckPixel(I, Pred(Y)) then 2738 3227 begin 2739 if Added then 3228 if Added then //do not add twice the same segment 2740 3229 Continue; 2741 3230 Push(I, Pred(Y)); … … 2746 3235 2747 3236 Added := False; 2748 if Y < Pred( Height) then3237 if Y < Pred(FClipRect.Bottom) then 2749 3238 for I := SX to EX do 2750 3239 if CheckPixel(I, Succ(Y)) then 2751 3240 begin 2752 if Added then 3241 if Added then //do not add twice the same segment 2753 3242 Continue; 2754 3243 Push(I, Succ(Y)); … … 2764 3253 c1, c2: TBGRAPixel; gtype: TGradientType; o1, o2: TPointF; mode: TDrawMode; 2765 3254 gammaColorCorrection: boolean = True; Sinus: Boolean=False); 2766 var 2767 u, p: TPointF; 2768 len, a: single; 2769 xb, yb, temp: integer; 2770 b: integer; 2771 c: TBGRAPixel; 2772 ec, ec1, ec2: TExpandedPixel; 2773 pixelProc: procedure(x, y: integer; col: TBGRAPixel) of object; 2774 begin 2775 if (x > x2) then 2776 begin 2777 temp := x; 2778 x := x2; 2779 x2 := temp; 2780 end; 2781 if (y > y2) then 2782 begin 2783 temp := y; 2784 y := y2; 2785 y2 := temp; 2786 end; 2787 if x < 0 then x := 0; 2788 if x2 > width then x2 := width; 2789 if y < 0 then y := 0; 2790 if y2 > height then y2 := height; 2791 if (x2 <= x) or (y2 <= y) then exit; 2792 3255 begin 3256 BGRAGradientFill(self, x, y, x2, y2, c1, c2, gtype, o1, o2, mode, gammaColorCorrection, Sinus); 3257 end; 3258 3259 procedure TBGRADefaultBitmap.GradientFill(x, y, x2, y2: integer; 3260 gradient: TBGRACustomGradient; gtype: TGradientType; o1, o2: TPointF; 3261 mode: TDrawMode; Sinus: Boolean); 3262 var 3263 scanner: TBGRAGradientScanner; 3264 begin 3265 scanner := TBGRAGradientScanner.Create(gradient,gtype,o1,o2,sinus); 3266 FillRect(x,y,x2,y2,scanner,mode); 3267 scanner.Free; 3268 end; 3269 3270 function TBGRADefaultBitmap.CreateBrushTexture(ABrushStyle: TBrushStyle; APatternColor, ABackgroundColor: TBGRAPixel; 3271 AWidth: integer = 8; AHeight: integer = 8; APenWidth: single = 1): TBGRACustomBitmap; 3272 begin 3273 result := BGRAPen.CreateBrushTexture(self,ABrushStyle,APatternColor,ABackgroundColor,AWidth,AHeight,APenWidth); 3274 end; 3275 3276 { Scanning procedures for IBGRAScanner interface } 3277 procedure TBGRADefaultBitmap.ScanMoveTo(X, Y: Integer); 3278 begin 3279 LoadFromBitmapIfNeeded; 3280 FScanCurX := PositiveMod(X+ScanOffset.X, FWidth); 3281 FScanCurY := PositiveMod(Y+ScanOffset.Y, FHeight); 3282 FScanPtr := ScanLine[FScanCurY]; 3283 end; 3284 3285 function TBGRADefaultBitmap.ScanNextPixel: TBGRAPixel; 3286 begin 3287 result := (FScanPtr+FScanCurX)^; 3288 inc(FScanCurX); 3289 if FScanCurX = FWidth then //cycle 3290 FScanCurX := 0; 3291 end; 3292 3293 function TBGRADefaultBitmap.ScanAt(X, Y: Single): TBGRAPixel; 3294 begin 3295 Result:= GetPixelCycle(x+ScanOffset.X,y+ScanOffset.Y,ScanInterpolationFilter); 3296 end; 3297 3298 function TBGRADefaultBitmap.IsScanPutPixelsDefined: boolean; 3299 begin 3300 Result:= true; 3301 end; 3302 3303 procedure TBGRADefaultBitmap.ScanPutPixels(pdest: PBGRAPixel; count: integer; 3304 mode: TDrawMode); 3305 var 3306 i,nbCopy: Integer; 3307 c: TBGRAPixel; 3308 begin 2793 3309 case mode of 2794 dmSet, dmSetExceptTransparent: pixelProc := @SetPixel; 2795 dmDrawWithTransparency: pixelProc := @DrawPixel; 2796 dmFastBlend: pixelProc := @FastBlendPixel; 2797 end; 2798 //handles transparency 2799 if (c1.alpha = 0) and (c2.alpha = 0) then 2800 begin 2801 FillRect(x, y, x2, y2, BGRAPixelTransparent, mode); 2802 exit; 2803 end; 2804 if c1.alpha = 0 then 2805 begin 2806 c1.red := c2.red; 2807 c1.green := c2.green; 2808 c1.blue := c2.blue; 2809 end 2810 else 2811 if c2.alpha = 0 then 2812 begin 2813 c2.red := c1.red; 2814 c2.green := c1.green; 2815 c2.blue := c1.blue; 2816 end; 2817 2818 //compute vector 2819 u.x := o2.x - o1.x; 2820 u.y := o2.y - o1.y; 2821 len := sqrt(sqr(u.x) + sqr(u.y)); 2822 if len = 0 then 2823 begin 2824 FillRect(x, y, x2, y2, MergeBGRA(c1, c2), mode); 2825 exit; 2826 end; 2827 u.x /= len; 2828 u.y /= len; 2829 2830 ec1 := GammaExpansion(c1); 2831 ec2 := GammaExpansion(c2); 2832 if gammaColorCorrection then 2833 begin 2834 //render with gamma correction 2835 case gtype of 2836 gtLinear: 2837 for yb := y to y2 - 1 do 2838 for xb := x to x2 - 1 do 2839 begin 2840 p.x := xb - o1.x; 2841 p.y := yb - o1.y; 2842 a := p.x * u.x + p.y * u.y; 2843 if Sinus then a := (sin(a*2*Pi/len)+1)*len/2; 2844 if a < 0 then 2845 c := c1 2846 else 2847 if a > len then 2848 c := c2 2849 else 2850 begin 2851 b := round(a / len * 256); 2852 ec.red := (ec1.red * (256 - b) + ec2.red * b + 127) shr 8; 2853 ec.green := (ec1.green * (256 - b) + ec2.green * b + 127) shr 8; 2854 ec.blue := (ec1.blue * (256 - b) + ec2.blue * b + 127) shr 8; 2855 ec.alpha := (ec1.alpha * (256 - b) + ec2.alpha * b + 127) shr 8; 2856 c := GammaCompression(ec); 2857 end; 2858 pixelProc(xb, yb, c); 2859 end; 2860 2861 gtReflected: 2862 for yb := y to y2 - 1 do 2863 for xb := x to x2 - 1 do 2864 begin 2865 p.x := xb - o1.x; 2866 p.y := yb - o1.y; 2867 a := abs(p.x * u.x + p.y * u.y); 2868 if Sinus then a := (sin(a*2*Pi/len)+1)*len/2; 2869 if a < 0 then 2870 c := c1 2871 else 2872 if a > len then 2873 c := c2 2874 else 2875 begin 2876 b := round(a / len * 256); 2877 ec.red := (ec1.red * (256 - b) + ec2.red * b + 127) shr 8; 2878 ec.green := (ec1.green * (256 - b) + ec2.green * b + 127) shr 8; 2879 ec.blue := (ec1.blue * (256 - b) + ec2.blue * b + 127) shr 8; 2880 ec.alpha := (ec1.alpha * (256 - b) + ec2.alpha * b + 127) shr 8; 2881 c := GammaCompression(ec); 2882 end; 2883 pixelProc(xb, yb, c); 2884 end; 2885 2886 gtDiamond: 2887 for yb := y to y2 - 1 do 2888 for xb := x to x2 - 1 do 2889 begin 2890 p.x := xb - o1.x; 2891 p.y := yb - o1.y; 2892 a := max(abs(p.x * u.x + p.y * u.y), abs(p.x * u.y - p.y * u.x)); 2893 if Sinus then a := (sin(a*2*Pi/len)+1)*len/2; 2894 if a < 0 then 2895 c := c1 2896 else 2897 if a > len then 2898 c := c2 2899 else 2900 begin 2901 b := round(a / len * 256); 2902 ec.red := (ec1.red * (256 - b) + ec2.red * b + 127) shr 8; 2903 ec.green := (ec1.green * (256 - b) + ec2.green * b + 127) shr 8; 2904 ec.blue := (ec1.blue * (256 - b) + ec2.blue * b + 127) shr 8; 2905 ec.alpha := (ec1.alpha * (256 - b) + ec2.alpha * b + 127) shr 8; 2906 c := GammaCompression(ec); 2907 end; 2908 pixelProc(xb, yb, c); 2909 end; 2910 2911 gtRadial: 2912 for yb := y to y2 - 1 do 2913 for xb := x to x2 - 1 do 2914 begin 2915 p.x := xb - o1.x; 2916 p.y := yb - o1.y; 2917 a := sqrt(sqr(p.x * u.x + p.y * u.y) + sqr(p.x * u.y - p.y * u.x)); 2918 if Sinus then a := (sin(a*2*Pi/len)+1)*len/2; 2919 if a < 0 then 2920 c := c1 2921 else 2922 if a > len then 2923 c := c2 2924 else 2925 begin 2926 b := round(a / len * 256); 2927 ec.red := (ec1.red * (256 - b) + ec2.red * b + 127) shr 8; 2928 ec.green := (ec1.green * (256 - b) + ec2.green * b + 127) shr 8; 2929 ec.blue := (ec1.blue * (256 - b) + ec2.blue * b + 127) shr 8; 2930 ec.alpha := (ec1.alpha * (256 - b) + ec2.alpha * b + 127) shr 8; 2931 c := GammaCompression(ec); 2932 end; 2933 pixelProc(xb, yb, c); 2934 end; 2935 end; 2936 end 2937 else 2938 begin 2939 //render without gamma correction 2940 case gtype of 2941 gtLinear: 2942 for yb := y to y2 - 1 do 2943 for xb := x to x2 - 1 do 2944 begin 2945 p.x := xb - o1.x; 2946 p.y := yb - o1.y; 2947 a := p.x * u.x + p.y * u.y; 2948 if Sinus then a := (sin(a*2*Pi/len)+1)*len/2; 2949 if a < 0 then 2950 c := c1 2951 else 2952 if a > len then 2953 c := c2 2954 else 2955 begin 2956 b := round(a / len * 256); 2957 c.red := (c1.red * (256 - b) + c2.red * b + 127) shr 8; 2958 c.green := (c1.green * (256 - b) + c2.green * b + 127) shr 8; 2959 c.blue := (c1.blue * (256 - b) + c2.blue * b + 127) shr 8; 2960 c.alpha := (c1.alpha * (256 - b) + c2.alpha * b + 127) shr 8; 2961 end; 2962 pixelProc(xb, yb, c); 2963 end; 2964 2965 gtReflected: 2966 for yb := y to y2 - 1 do 2967 for xb := x to x2 - 1 do 2968 begin 2969 p.x := xb - o1.x; 2970 p.y := yb - o1.y; 2971 a := abs(p.x * u.x + p.y * u.y); 2972 if Sinus then a := (sin(a*2*Pi/len)+1)*len/2; 2973 if a < 0 then 2974 c := c1 2975 else 2976 if a > len then 2977 c := c2 2978 else 2979 begin 2980 b := round(a / len * 256); 2981 c.red := (c1.red * (256 - b) + c2.red * b + 127) shr 8; 2982 c.green := (c1.green * (256 - b) + c2.green * b + 127) shr 8; 2983 c.blue := (c1.blue * (256 - b) + c2.blue * b + 127) shr 8; 2984 c.alpha := (c1.alpha * (256 - b) + c2.alpha * b + 127) shr 8; 2985 end; 2986 pixelProc(xb, yb, c); 2987 end; 2988 2989 gtDiamond: 2990 for yb := y to y2 - 1 do 2991 for xb := x to x2 - 1 do 2992 begin 2993 p.x := xb - o1.x; 2994 p.y := yb - o1.y; 2995 a := max(abs(p.x * u.x + p.y * u.y), abs(p.x * u.y - p.y * u.x)); 2996 if Sinus then a := (sin(a*2*Pi/len)+1)*len/2; 2997 if a < 0 then 2998 c := c1 2999 else 3000 if a > len then 3001 c := c2 3002 else 3003 begin 3004 b := round(a / len * 256); 3005 c.red := (c1.red * (256 - b) + c2.red * b + 127) shr 8; 3006 c.green := (c1.green * (256 - b) + c2.green * b + 127) shr 8; 3007 c.blue := (c1.blue * (256 - b) + c2.blue * b + 127) shr 8; 3008 c.alpha := (c1.alpha * (256 - b) + c2.alpha * b + 127) shr 8; 3009 end; 3010 pixelProc(xb, yb, c); 3011 end; 3012 3013 gtRadial: 3014 for yb := y to y2 - 1 do 3015 for xb := x to x2 - 1 do 3016 begin 3017 p.x := xb - o1.x; 3018 p.y := yb - o1.y; 3019 a := sqrt(sqr(p.x * u.x + p.y * u.y) + sqr(p.x * u.y - p.y * u.x)); 3020 if Sinus then a := (sin(a*2*Pi/len)+1)*len/2; 3021 if a < 0 then 3022 c := c1 3023 else 3024 if a > len then 3025 c := c2 3026 else 3027 begin 3028 b := round(a / len * 256); 3029 c.red := (c1.red * (256 - b) + c2.red * b + 127) shr 8; 3030 c.green := (c1.green * (256 - b) + c2.green * b + 127) shr 8; 3031 c.blue := (c1.blue * (256 - b) + c2.blue * b + 127) shr 8; 3032 c.alpha := (c1.alpha * (256 - b) + c2.alpha * b + 127) shr 8; 3033 end; 3034 pixelProc(xb, yb, c); 3035 end; 3036 end; 3037 end; 3038 end; 3039 3310 dmLinearBlend: 3311 for i := 0 to count-1 do 3312 begin 3313 FastBlendPixelInline(pdest, ScanNextPixel); 3314 inc(pdest); 3315 end; 3316 dmDrawWithTransparency: 3317 for i := 0 to count-1 do 3318 begin 3319 DrawPixelInlineWithAlphaCheck(pdest, ScanNextPixel); 3320 inc(pdest); 3321 end; 3322 dmSet: 3323 while count > 0 do 3324 begin 3325 nbCopy := FWidth-FScanCurX; 3326 if count < nbCopy then nbCopy := count; 3327 move((FScanPtr+FScanCurX)^,pdest^,nbCopy*sizeof(TBGRAPixel)); 3328 inc(pdest,nbCopy); 3329 inc(FScanCurX,nbCopy); 3330 if FScanCurX = FWidth then FScanCurX := 0; 3331 dec(count,nbCopy); 3332 end; 3333 dmSetExceptTransparent: 3334 for i := 0 to count-1 do 3335 begin 3336 c := ScanNextPixel; 3337 if c.alpha = 255 then pdest^ := c; 3338 inc(pdest); 3339 end; 3340 dmXor: 3341 for i := 0 to count-1 do 3342 begin 3343 PDWord(pdest)^ := PDWord(pdest)^ xor DWord(ScanNextPixel); 3344 inc(pdest); 3345 end; 3346 end; 3347 end; 3348 3349 { General purpose pixel drawing function } 3040 3350 procedure TBGRADefaultBitmap.DrawPixels(c: TBGRAPixel; start, Count: integer); 3041 3351 var … … 3044 3354 if c.alpha = 0 then 3045 3355 exit; 3356 if c.alpha = 255 then 3357 begin 3358 Fill(c,start,Count); 3359 exit; 3360 end; 3046 3361 3047 3362 if start < 0 then … … 3056 3371 3057 3372 p := Data + start; 3058 while Count > 0 do 3059 begin 3060 DrawPixelInline(p, c); 3061 Inc(p); 3062 Dec(Count); 3063 end; 3373 DrawPixelsInline(p,c,Count); 3064 3374 InvalidateBitmap; 3065 3375 end; … … 3086 3396 end; 3087 3397 3398 { Ensure that transparent pixels have all channels to zero } 3088 3399 procedure TBGRADefaultBitmap.ClearTransparentPixels; 3089 3400 var … … 3101 3412 end; 3102 3413 3103 procedure TBGRADefaultBitmap.PutImage(x, y: integer; Source: TBGRADefaultBitmap; 3104 mode: TDrawMode); 3105 var 3106 x2, y2, yb, minxb, minyb, maxxb, ignoreleft, copycount, sourcewidth, 3414 function TBGRADefaultBitmap.CheckPutImageBounds(x,y,tx,ty: integer; out minxb,minyb,maxxb,maxyb,ignoreleft: integer): boolean inline; 3415 var x2,y2: integer; 3416 begin 3417 if (x >= FClipRect.Right) or (y >= FClipRect.Bottom) or (x <= FClipRect.Left-tx) or 3418 (y <= FClipRect.Top-ty) or (Height = 0) or (ty = 0) or (tx = 0) then 3419 begin 3420 result := false; 3421 exit; 3422 end; 3423 3424 x2 := x + tx - 1; 3425 y2 := y + ty - 1; 3426 3427 if y < FClipRect.Top then 3428 minyb := FClipRect.Top 3429 else 3430 minyb := y; 3431 if y2 >= FClipRect.Bottom then 3432 maxyb := FClipRect.Bottom - 1 3433 else 3434 maxyb := y2; 3435 3436 if x < FClipRect.Left then 3437 begin 3438 ignoreleft := FClipRect.Left-x; 3439 minxb := FClipRect.Left; 3440 end 3441 else 3442 begin 3443 ignoreleft := 0; 3444 minxb := x; 3445 end; 3446 if x2 >= FClipRect.Right then 3447 maxxb := FClipRect.Right - 1 3448 else 3449 maxxb := x2; 3450 3451 result := true; 3452 end; 3453 3454 function TBGRADefaultBitmap.CheckAntialiasRectBounds(var x, y, x2, y2: single; 3455 w: single): boolean; 3456 var 3457 temp: Single; 3458 begin 3459 if (x > x2) then 3460 begin 3461 temp := x; 3462 x := x2; 3463 x2 := temp; 3464 end; 3465 if (y > y2) then 3466 begin 3467 temp := y; 3468 y := y2; 3469 y2 := temp; 3470 end; 3471 3472 result := (x2 - x > w) and (y2 - y > w); 3473 end; 3474 3475 function TBGRADefaultBitmap.GetCanvasBGRA: TBGRACanvas; 3476 begin 3477 if FCanvasBGRA = nil then 3478 FCanvasBGRA := TBGRACanvas.Create(self); 3479 result := FCanvasBGRA; 3480 end; 3481 3482 function TBGRADefaultBitmap.GetCanvas2D: TBGRACanvas2D; 3483 begin 3484 if FCanvas2D = nil then 3485 FCanvas2D := TBGRACanvas2D.Create(self); 3486 result := FCanvas2D; 3487 end; 3488 3489 procedure TBGRADefaultBitmap.PutImage(x, y: integer; Source: TBGRACustomBitmap; 3490 mode: TDrawMode; AOpacity: byte); 3491 var 3492 yb, minxb, minyb, maxxb, maxyb, ignoreleft, copycount, sourcewidth, 3107 3493 i, delta_source, delta_dest: integer; 3108 3494 psource, pdest: PBGRAPixel; 3109 begin 3495 tempPixel: TBGRAPixel; 3496 3497 begin 3498 if (source = nil) or (AOpacity = 0) then exit; 3110 3499 sourcewidth := Source.Width; 3111 3500 3112 if (x >= Width) or (y >= Height) or (x <= -sourcewidth) or 3113 (y <= -Source.Height) or (Height = 0) or (Source.Height = 0) then 3114 exit; 3115 3116 x2 := x + sourcewidth - 1; 3117 y2 := y + Source.Height - 1; 3118 3119 if y < 0 then 3120 minyb := 0 3121 else 3122 minyb := y; 3123 if y2 >= Height then 3124 y2 := Height - 1; 3125 3126 if x < 0 then 3127 begin 3128 ignoreleft := -x; 3129 minxb := 0; 3130 end 3131 else 3132 begin 3133 ignoreleft := 0; 3134 minxb := x; 3135 end; 3136 if x2 >= Width then 3137 maxxb := Width - 1 3138 else 3139 maxxb := x2; 3501 if not CheckPutImageBounds(x,y,sourcewidth,source.height,minxb,minyb,maxxb,maxyb,ignoreleft) then exit; 3140 3502 3141 3503 copycount := maxxb - minxb + 1; 3142 3504 3143 3505 psource := Source.ScanLine[minyb - y] + ignoreleft; 3144 if Source. FLineOrder = riloBottomToTop then3506 if Source.LineOrder = riloBottomToTop then 3145 3507 delta_source := -sourcewidth 3146 3508 else … … 3156 3518 dmSet: 3157 3519 begin 3158 copycount *= sizeof(TBGRAPixel); 3159 for yb := minyb to y2 do 3520 if AOpacity <> 255 then 3160 3521 begin 3161 move(psource^, pdest^, copycount); 3162 Inc(psource, delta_source); 3163 Inc(pdest, delta_dest); 3522 for yb := minyb to maxyb do 3523 begin 3524 CopyPixelsWithOpacity(pdest, psource, AOpacity, copycount); 3525 Inc(psource, delta_source); 3526 Inc(pdest, delta_dest); 3527 end; 3528 end 3529 else 3530 begin 3531 copycount *= sizeof(TBGRAPixel); 3532 for yb := minyb to maxyb do 3533 begin 3534 move(psource^, pdest^, copycount); 3535 Inc(psource, delta_source); 3536 Inc(pdest, delta_dest); 3537 end; 3164 3538 end; 3165 3539 InvalidateBitmap; … … 3169 3543 Dec(delta_source, copycount); 3170 3544 Dec(delta_dest, copycount); 3171 for yb := minyb to y2do3545 for yb := minyb to maxyb do 3172 3546 begin 3173 for i := copycount - 1 downto 0 do3547 if AOpacity <> 255 then 3174 3548 begin 3175 if psource^.alpha = 255 then 3176 pdest^ := psource^; 3177 Inc(pdest); 3178 Inc(psource); 3179 end; 3549 for i := copycount - 1 downto 0 do 3550 begin 3551 if psource^.alpha = 255 then 3552 begin 3553 tempPixel := psource^; 3554 tempPixel.alpha := ApplyOpacity(tempPixel.alpha,AOpacity); 3555 FastBlendPixelInline(pdest,tempPixel); 3556 end; 3557 Inc(pdest); 3558 Inc(psource); 3559 end; 3560 end else 3561 for i := copycount - 1 downto 0 do 3562 begin 3563 if psource^.alpha = 255 then 3564 pdest^ := psource^; 3565 Inc(pdest); 3566 Inc(psource); 3567 end; 3180 3568 Inc(psource, delta_source); 3181 3569 Inc(pdest, delta_dest); … … 3187 3575 Dec(delta_source, copycount); 3188 3576 Dec(delta_dest, copycount); 3189 for yb := minyb to y2do3577 for yb := minyb to maxyb do 3190 3578 begin 3191 for i := copycount - 1 downto 0 do3579 if AOpacity <> 255 then 3192 3580 begin 3193 DrawPixelInline(pdest, psource^); 3194 Inc(pdest); 3195 Inc(psource); 3196 end; 3581 for i := copycount - 1 downto 0 do 3582 begin 3583 DrawPixelInlineWithAlphaCheck(pdest, psource^, AOpacity); 3584 Inc(pdest); 3585 Inc(psource); 3586 end; 3587 end 3588 else 3589 for i := copycount - 1 downto 0 do 3590 begin 3591 DrawPixelInlineWithAlphaCheck(pdest, psource^); 3592 Inc(pdest); 3593 Inc(psource); 3594 end; 3197 3595 Inc(psource, delta_source); 3198 3596 Inc(pdest, delta_dest); … … 3204 3602 Dec(delta_source, copycount); 3205 3603 Dec(delta_dest, copycount); 3206 for yb := minyb to y2do3604 for yb := minyb to maxyb do 3207 3605 begin 3208 for i := copycount - 1 downto 0 do3606 if AOpacity <> 255 then 3209 3607 begin 3210 FastBlendPixelInline(pdest, psource^); 3211 Inc(pdest); 3212 Inc(psource); 3213 end; 3608 for i := copycount - 1 downto 0 do 3609 begin 3610 FastBlendPixelInline(pdest, psource^, AOpacity); 3611 Inc(pdest); 3612 Inc(psource); 3613 end; 3614 end else 3615 for i := copycount - 1 downto 0 do 3616 begin 3617 FastBlendPixelInline(pdest, psource^); 3618 Inc(pdest); 3619 Inc(psource); 3620 end; 3214 3621 Inc(psource, delta_source); 3215 3622 Inc(pdest, delta_dest); … … 3217 3624 InvalidateBitmap; 3218 3625 end; 3219 end; 3220 end; 3221 3222 procedure TBGRADefaultBitmap.BlendImage(x, y: integer; Source: TBGRADefaultBitmap; 3626 dmXor: 3627 begin 3628 if AOpacity <> 255 then 3629 begin 3630 Dec(delta_source, copycount); 3631 Dec(delta_dest, copycount); 3632 for yb := minyb to maxyb do 3633 begin 3634 for i := copycount - 1 downto 0 do 3635 begin 3636 FastBlendPixelInline(pdest, TBGRAPixel(PDWord(pdest)^ xor PDword(psource)^), AOpacity); 3637 Inc(pdest); 3638 Inc(psource); 3639 end; 3640 Inc(psource, delta_source); 3641 Inc(pdest, delta_dest); 3642 end; 3643 end else 3644 begin 3645 for yb := minyb to maxyb do 3646 begin 3647 XorPixels(pdest, psource, copycount); 3648 Inc(psource, delta_source); 3649 Inc(pdest, delta_dest); 3650 end; 3651 end; 3652 InvalidateBitmap; 3653 end; 3654 end; 3655 end; 3656 3657 procedure TBGRADefaultBitmap.BlendImage(x, y: integer; Source: TBGRACustomBitmap; 3223 3658 operation: TBlendOperation); 3224 3659 var 3225 x2, y2, yb, minxb, minyb, maxxb, ignoreleft, copycount, sourcewidth,3660 yb, minxb, minyb, maxxb, maxyb, ignoreleft, copycount, sourcewidth, 3226 3661 delta_source, delta_dest: integer; 3227 3662 psource, pdest: PBGRAPixel; … … 3229 3664 sourcewidth := Source.Width; 3230 3665 3231 if (x >= Width) or (y >= Height) or (x <= -sourcewidth) or 3232 (y <= -Source.Height) or (Height = 0) or (Source.Height = 0) then 3233 exit; 3234 3235 x2 := x + sourcewidth - 1; 3236 y2 := y + Source.Height - 1; 3237 3238 if y < 0 then 3239 minyb := 0 3240 else 3241 minyb := y; 3242 if y2 >= Height then 3243 y2 := Height - 1; 3244 3245 if x < 0 then 3246 begin 3247 ignoreleft := -x; 3248 minxb := 0; 3249 end 3250 else 3251 begin 3252 ignoreleft := 0; 3253 minxb := x; 3254 end; 3255 if x2 >= Width then 3256 maxxb := Width - 1 3257 else 3258 maxxb := x2; 3666 if not CheckPutImageBounds(x,y,sourcewidth,source.height,minxb,minyb,maxxb,maxyb,ignoreleft) then exit; 3259 3667 3260 3668 copycount := maxxb - minxb + 1; 3261 3669 3262 3670 psource := Source.ScanLine[minyb - y] + ignoreleft; 3263 if Source. FLineOrder = riloBottomToTop then3671 if Source.LineOrder = riloBottomToTop then 3264 3672 delta_source := -sourcewidth 3265 3673 else … … 3272 3680 delta_dest := Width; 3273 3681 3274 for yb := minyb to y2do3682 for yb := minyb to maxyb do 3275 3683 begin 3276 3684 BlendPixels(pdest, psource, operation, copycount); … … 3281 3689 end; 3282 3690 3283 function TBGRADefaultBitmap.Duplicate: TBGRADefaultBitmap; 3691 { Draw an image wih an angle. Use an affine transformation to do this. } 3692 procedure TBGRADefaultBitmap.PutImageAngle(x, y: single; 3693 Source: TBGRACustomBitmap; angle: single; imageCenterX: single; 3694 imageCenterY: single; AOpacity: Byte); 3695 var 3696 cosa,sina: single; 3697 3698 { Compute rotated coordinates } 3699 function Coord(relX,relY: single): TPointF; 3700 begin 3701 relX -= imageCenterX; 3702 relY -= imageCenterY; 3703 result.x := relX*cosa-relY*sina+x; 3704 result.y := relY*cosa+relX*sina+y; 3705 end; 3706 3707 begin 3708 cosa := cos(-angle*Pi/180); 3709 sina := -sin(-angle*Pi/180); 3710 PutImageAffine(Coord(0,0),Coord(source.Width,0),Coord(0,source.Height),source,AOpacity); 3711 end; 3712 3713 { Draw an image with an affine transformation (rotation, scale, translate). 3714 Parameters are the bitmap origin, the end of the horizontal axis and the end of the vertical axis. } 3715 procedure TBGRADefaultBitmap.PutImageAffine(Origin,HAxis,VAxis: TPointF; Source: TBGRACustomBitmap; AOpacity: Byte); 3716 var affine: TBGRAAffineBitmapTransform; 3717 minx,miny,maxx,maxy: integer; 3718 pt4: TPointF; 3719 3720 //include specified point in the bounds 3721 procedure Include(pt: TPointF); 3722 begin 3723 if floor(pt.X) < minx then minx := floor(pt.X); 3724 if floor(pt.Y) < miny then miny := floor(pt.Y); 3725 if ceil(pt.X) > maxx then maxx := ceil(pt.X); 3726 if ceil(pt.Y) > maxy then maxy := ceil(pt.Y); 3727 end; 3728 3729 begin 3730 if (abs(Origin.x-round(Origin.x))<1e-6) and (abs(Origin.y-round(Origin.Y))<1e-6) and 3731 (abs(HAxis.x-(Origin.x+Source.Width))<1e-6) and (abs(HAxis.y-origin.y)<1e-6) and 3732 (abs(VAxis.x-Origin.x)<1e-6) and (abs(VAxis.y-(Origin.y+Source.Height))<1e-6) then 3733 begin 3734 PutImage(round(origin.x),round(origin.y),Source,dmDrawWithTransparency,AOpacity); 3735 exit; 3736 end; 3737 3738 { Create affine transformation } 3739 affine := TBGRAAffineBitmapTransform.Create(Source); 3740 affine.GlobalOpacity := AOpacity; 3741 affine.Fit(Origin,HAxis,VAxis); 3742 3743 { Compute bounds } 3744 pt4.x := VAxis.x+HAxis.x-Origin.x; 3745 pt4.y := VAxis.y+HAxis.y-Origin.y; 3746 minx := floor(Origin.X); 3747 miny := floor(Origin.Y); 3748 maxx := ceil(Origin.X); 3749 maxy := ceil(Origin.Y); 3750 Include(HAxis); 3751 Include(VAxis); 3752 Include(pt4); 3753 3754 { Use the affine transformation as a scanner } 3755 FillRect(minx,miny,maxx+1,maxy+1,affine,dmDrawWithTransparency); 3756 affine.Free; 3757 end; 3758 3759 { Duplicate bitmap content. Optionally, bitmap properties can be also duplicated } 3760 function TBGRADefaultBitmap.Duplicate(DuplicateProperties: Boolean = False): TBGRACustomBitmap; 3761 var Temp: TBGRADefaultBitmap; 3284 3762 begin 3285 3763 LoadFromBitmapIfNeeded; 3286 Result := NewBitmap(Width, Height); 3287 Result.PutImage(0, 0, self, dmSet); 3288 Result.Caption := self.Caption; 3289 end; 3290 3291 function TBGRADefaultBitmap.Equals(comp: TBGRADefaultBitmap): boolean; 3764 Temp := NewBitmap(Width, Height) as TBGRADefaultBitmap; 3765 Temp.PutImage(0, 0, self, dmSet); 3766 Temp.Caption := self.Caption; 3767 if DuplicateProperties then 3768 CopyPropertiesTo(Temp); 3769 Result := Temp; 3770 end; 3771 3772 { Copy properties only } 3773 procedure TBGRADefaultBitmap.CopyPropertiesTo(ABitmap: TBGRADefaultBitmap); 3774 begin 3775 ABitmap.CanvasOpacity := CanvasOpacity; 3776 ABitmap.CanvasDrawModeFP := CanvasDrawModeFP; 3777 ABitmap.PenStyle := PenStyle; 3778 ABitmap.CustomPenStyle := CustomPenStyle; 3779 ABitmap.FontHeight := FontHeight; 3780 ABitmap.FontName := FontName; 3781 ABitmap.FontStyle := FontStyle; 3782 ABitmap.FontAntialias := FontAntialias; 3783 ABitmap.FontOrientation := FontOrientation; 3784 ABitmap.LineCap := LineCap; 3785 ABitmap.JoinStyle := JoinStyle; 3786 ABitmap.FillMode := FillMode; 3787 ABitmap.ClipRect := ClipRect; 3788 end; 3789 3790 { Check if two bitmaps have the same content } 3791 function TBGRADefaultBitmap.Equals(comp: TBGRACustomBitmap): boolean; 3292 3792 var 3293 3793 yb, xb: integer; … … 3320 3820 end; 3321 3821 3822 { Check if a bitmap is filled wih the specified color } 3322 3823 function TBGRADefaultBitmap.Equals(comp: TBGRAPixel): boolean; 3323 3824 var … … 3338 3839 end; 3339 3840 3340 function TBGRADefaultBitmap.FilterSmartZoom3(Option: TMedianOption): TBGRADefaultBitmap; 3841 {----------------------------- Filters -----------------------------------------} 3842 { Call the appropriate function } 3843 3844 function TBGRADefaultBitmap.FilterSmartZoom3(Option: TMedianOption): TBGRACustomBitmap; 3341 3845 begin 3342 3846 Result := BGRAFilters.FilterSmartZoom3(self, Option); 3343 3847 end; 3344 3848 3345 function TBGRADefaultBitmap.FilterMedian(Option: TMedianOption): TBGRA DefaultBitmap;3849 function TBGRADefaultBitmap.FilterMedian(Option: TMedianOption): TBGRACustomBitmap; 3346 3850 begin 3347 3851 Result := BGRAFilters.FilterMedian(self, option); 3348 3852 end; 3349 3853 3350 function TBGRADefaultBitmap.FilterSmooth: TBGRA DefaultBitmap;3854 function TBGRADefaultBitmap.FilterSmooth: TBGRACustomBitmap; 3351 3855 begin 3352 3856 Result := BGRAFilters.FilterBlurRadialPrecise(self, 0.3); 3353 3857 end; 3354 3858 3355 function TBGRADefaultBitmap.FilterSphere: TBGRA DefaultBitmap;3859 function TBGRADefaultBitmap.FilterSphere: TBGRACustomBitmap; 3356 3860 begin 3357 3861 Result := BGRAFilters.FilterSphere(self); 3358 3862 end; 3359 3863 3360 function TBGRADefaultBitmap.FilterCylinder: TBGRADefaultBitmap; 3864 function TBGRADefaultBitmap.FilterTwirl(ACenter: TPoint; ARadius: Single; ATurn: Single=1; AExponent: Single=3): TBGRACustomBitmap; 3865 begin 3866 Result := BGRAFilters.FilterTwirl(self, ACenter, ARadius, ATurn, AExponent); 3867 end; 3868 3869 function TBGRADefaultBitmap.FilterCylinder: TBGRACustomBitmap; 3361 3870 begin 3362 3871 Result := BGRAFilters.FilterCylinder(self); 3363 3872 end; 3364 3873 3365 function TBGRADefaultBitmap.FilterPlane: TBGRA DefaultBitmap;3874 function TBGRADefaultBitmap.FilterPlane: TBGRACustomBitmap; 3366 3875 begin 3367 3876 Result := BGRAFilters.FilterPlane(self); 3368 3877 end; 3369 3878 3370 function TBGRADefaultBitmap.FilterSharpen: TBGRA DefaultBitmap;3879 function TBGRADefaultBitmap.FilterSharpen: TBGRACustomBitmap; 3371 3880 begin 3372 3881 Result := BGRAFilters.FilterSharpen(self); 3373 3882 end; 3374 3883 3375 function TBGRADefaultBitmap.FilterContour: TBGRA DefaultBitmap;3884 function TBGRADefaultBitmap.FilterContour: TBGRACustomBitmap; 3376 3885 begin 3377 3886 Result := BGRAFilters.FilterContour(self); … … 3379 3888 3380 3889 function TBGRADefaultBitmap.FilterBlurRadial(radius: integer; 3381 blurType: TRadialBlurType): TBGRA DefaultBitmap;3890 blurType: TRadialBlurType): TBGRACustomBitmap; 3382 3891 begin 3383 3892 Result := BGRAFilters.FilterBlurRadial(self, radius, blurType); 3384 3893 end; 3385 3894 3895 function TBGRADefaultBitmap.FilterPixelate(pixelSize: integer; 3896 useResample: boolean; filter: TResampleFilter): TBGRACustomBitmap; 3897 begin 3898 Result:= BGRAFilters.FilterPixelate(self, pixelSize, useResample, filter); 3899 end; 3900 3386 3901 function TBGRADefaultBitmap.FilterBlurMotion(distance: integer; 3387 angle: single; oriented: boolean): TBGRA DefaultBitmap;3902 angle: single; oriented: boolean): TBGRACustomBitmap; 3388 3903 begin 3389 3904 Result := BGRAFilters.FilterBlurMotion(self, distance, angle, oriented); 3390 3905 end; 3391 3906 3392 function TBGRADefaultBitmap.FilterCustomBlur(mask: TBGRA DefaultBitmap):3393 TBGRA DefaultBitmap;3907 function TBGRADefaultBitmap.FilterCustomBlur(mask: TBGRACustomBitmap): 3908 TBGRACustomBitmap; 3394 3909 begin 3395 3910 Result := BGRAFilters.FilterBlur(self, mask); 3396 3911 end; 3397 3912 3398 function TBGRADefaultBitmap.FilterEmboss(angle: single): TBGRA DefaultBitmap;3913 function TBGRADefaultBitmap.FilterEmboss(angle: single): TBGRACustomBitmap; 3399 3914 begin 3400 3915 Result := BGRAFilters.FilterEmboss(self, angle); … … 3402 3917 3403 3918 function TBGRADefaultBitmap.FilterEmbossHighlight(FillSelection: boolean): 3404 TBGRA DefaultBitmap;3919 TBGRACustomBitmap; 3405 3920 begin 3406 3921 Result := BGRAFilters.FilterEmbossHighlight(self, FillSelection); 3407 3922 end; 3408 3923 3409 function TBGRADefaultBitmap.FilterGrayscale: TBGRA DefaultBitmap;3924 function TBGRADefaultBitmap.FilterGrayscale: TBGRACustomBitmap; 3410 3925 begin 3411 3926 Result := BGRAFilters.FilterGrayscale(self); … … 3413 3928 3414 3929 function TBGRADefaultBitmap.FilterNormalize(eachChannel: boolean = True): 3415 TBGRA DefaultBitmap;3930 TBGRACustomBitmap; 3416 3931 begin 3417 3932 Result := BGRAFilters.FilterNormalize(self, eachChannel); … … 3419 3934 3420 3935 function TBGRADefaultBitmap.FilterRotate(origin: TPointF; 3421 angle: single): TBGRA DefaultBitmap;3936 angle: single): TBGRACustomBitmap; 3422 3937 begin 3423 3938 Result := BGRAFilters.FilterRotate(self, origin, angle); … … 3481 3996 end; 3482 3997 3998 function TBGRADefaultBitmap.CreateAdaptedPngWriter: TFPWriterPNG; 3999 begin 4000 result := TFPWriterPNG.Create; 4001 result.Indexed := False; 4002 result.UseAlpha := HasTransparentPixels; 4003 result.WordSized := false; 4004 end; 4005 4006 {$hints off} 4007 function TBGRADefaultBitmap.LoadAsBmp32(Str: TStream): boolean; 4008 var OldPos: int64; 4009 fileHeader: TBitmapFileHeader; 4010 infoHeader: TBitmapInfoHeader; 4011 dataSize: integer; 4012 begin 4013 OldPos := Str.Position; 4014 result := false; 4015 try 4016 if Str.Read(fileHeader,sizeof(fileHeader)) <> sizeof(fileHeader) then 4017 raise exception.Create('Inuable to read file header'); 4018 if fileHeader.bfType = $4D42 then 4019 begin 4020 if Str.Read(infoHeader,sizeof(infoHeader)) <> sizeof(infoHeader) then 4021 raise exception.Create('Inuable to read info header'); 4022 4023 if (infoHeader.biPlanes = 1) and (infoHeader.biBitCount = 32) and (infoHeader.biCompression = 0) then 4024 begin 4025 SetSize(infoHeader.biWidth,infoHeader.biHeight); 4026 Str.Position := OldPos+fileHeader.bfOffBits; 4027 dataSize := NbPixels*sizeof(TBGRAPixel); 4028 if Str.Read(Data^, dataSize) <> dataSize then 4029 Begin 4030 SetSize(0,0); 4031 raise exception.Create('Unable to read data'); 4032 end; 4033 result := true; 4034 end; 4035 end; 4036 4037 except 4038 on ex:exception do 4039 begin 4040 4041 end; 4042 end; 4043 Str.Position := OldPos; 4044 4045 end; 4046 {$hints on} 4047 3483 4048 procedure TBGRADefaultBitmap.SetCanvasOpacity(AValue: byte); 3484 4049 begin … … 3496 4061 3497 4062 function TBGRADefaultBitmap.FineResample(NewWidth, NewHeight: integer): 3498 TBGRA DefaultBitmap;3499 begin 3500 Result := BGRAResample.FineResample(self, NewWidth, NewHeight );4063 TBGRACustomBitmap; 4064 begin 4065 Result := BGRAResample.FineResample(self, NewWidth, NewHeight, ResampleFilter); 3501 4066 end; 3502 4067 3503 4068 function TBGRADefaultBitmap.SimpleStretch(NewWidth, NewHeight: integer): 3504 TBGRA DefaultBitmap;4069 TBGRACustomBitmap; 3505 4070 begin 3506 4071 Result := BGRAResample.SimpleStretch(self, NewWidth, NewHeight); … … 3508 4073 3509 4074 function TBGRADefaultBitmap.Resample(newWidth, newHeight: integer; 3510 mode: TResampleMode): TBGRA DefaultBitmap;4075 mode: TResampleMode): TBGRACustomBitmap; 3511 4076 begin 3512 4077 case mode of … … 3520 4085 {-------------------------------- Data functions ------------------------} 3521 4086 4087 { Flip vertically the bitmap. Use a temporary line to store top line, 4088 assign bottom line to top line, then assign temporary line to bottom line. 4089 4090 It is an involution, i.e it does nothing when applied twice } 3522 4091 procedure TBGRADefaultBitmap.VerticalFlip; 3523 4092 var … … 3531 4100 exit; 3532 4101 4102 LoadFromBitmapIfNeeded; 3533 4103 linesize := Width * sizeof(TBGRAPixel); 3534 4104 line := nil; … … 3548 4118 end; 3549 4119 4120 { Flip horizontally. Swap left pixels with right pixels on each line. 4121 4122 It is an involution, i.e it does nothing when applied twice} 3550 4123 procedure TBGRADefaultBitmap.HorizontalFlip; 3551 4124 var … … 3558 4131 exit; 3559 4132 4133 LoadFromBitmapIfNeeded; 3560 4134 for yb := 0 to Height - 1 do 3561 4135 begin … … 3574 4148 end; 3575 4149 3576 function TBGRADefaultBitmap.RotateCW: TBGRADefaultBitmap; 4150 { Return a new bitmap rotated in a clock wise direction. } 4151 function TBGRADefaultBitmap.RotateCW: TBGRACustomBitmap; 3577 4152 var 3578 4153 psrc, pdest: PBGRAPixel; … … 3580 4155 delta: integer; 3581 4156 begin 4157 LoadFromBitmapIfNeeded; 3582 4158 Result := NewBitmap(Height, Width); 3583 4159 if Result.LineOrder = riloTopToBottom then … … 3598 4174 end; 3599 4175 3600 function TBGRADefaultBitmap.RotateCCW: TBGRADefaultBitmap; 4176 { Return a new bitmap rotated in a counter clock wise direction. } 4177 function TBGRADefaultBitmap.RotateCCW: TBGRACustomBitmap; 3601 4178 var 3602 4179 psrc, pdest: PBGRAPixel; … … 3604 4181 delta: integer; 3605 4182 begin 4183 LoadFromBitmapIfNeeded; 3606 4184 Result := NewBitmap(Height, Width); 3607 4185 if Result.LineOrder = riloTopToBottom then … … 3622 4200 end; 3623 4201 4202 { Compute negative with gamma correction. A negative contains 4203 complentary colors (black becomes white etc.). 4204 4205 It is an involution, i.e it does nothing when applied twice } 3624 4206 procedure TBGRADefaultBitmap.Negative; 3625 4207 var … … 3627 4209 n: integer; 3628 4210 begin 4211 LoadFromBitmapIfNeeded; 3629 4212 p := Data; 3630 4213 for n := NbPixels - 1 downto 0 do … … 3641 4224 end; 3642 4225 4226 { Compute negative without gamma correction. 4227 4228 It is an involution, i.e it does nothing when applied twice } 3643 4229 procedure TBGRADefaultBitmap.LinearNegative; 3644 4230 var … … 3646 4232 n: integer; 3647 4233 begin 4234 LoadFromBitmapIfNeeded; 3648 4235 p := Data; 3649 4236 for n := NbPixels - 1 downto 0 do … … 3660 4247 end; 3661 4248 4249 { Swap red and blue channels. Useful when RGB order is swapped. 4250 4251 It is an involution, i.e it does nothing when applied twice } 3662 4252 procedure TBGRADefaultBitmap.SwapRedBlue; 3663 4253 var … … 3666 4256 p: PLongword; 3667 4257 begin 4258 LoadFromBitmapIfNeeded; 3668 4259 p := PLongword(Data); 3669 4260 n := NbPixels; … … 3671 4262 exit; 3672 4263 repeat 3673 temp := p^;3674 p^ := ((temp and $FF) shl 16) or ((temp and $FF0000) shr 16) or3675 temp and $FF00FF00 ;4264 temp := LEtoN(p^); 4265 p^ := NtoLE(((temp and $FF) shl 16) or ((temp and $FF0000) shr 16) or 4266 temp and $FF00FF00); 3676 4267 Inc(p); 3677 4268 Dec(n); … … 3680 4271 end; 3681 4272 4273 { Convert a grayscale image into a black image with alpha value } 3682 4274 procedure TBGRADefaultBitmap.GrayscaleToAlpha; 3683 4275 var … … 3686 4278 p: PLongword; 3687 4279 begin 4280 LoadFromBitmapIfNeeded; 3688 4281 p := PLongword(Data); 3689 4282 n := NbPixels; … … 3691 4284 exit; 3692 4285 repeat 3693 temp := p^;3694 p^ := (temp and $FF) shl 24;4286 temp := LEtoN(p^); 4287 p^ := NtoLE((temp and $FF) shl 24); 3695 4288 Inc(p); 3696 4289 Dec(n); … … 3705 4298 p: PLongword; 3706 4299 begin 4300 LoadFromBitmapIfNeeded; 3707 4301 p := PLongword(Data); 3708 4302 n := NbPixels; … … 3710 4304 exit; 3711 4305 repeat 3712 temp := p^ shr 24;3713 p^ := temp or (temp shl 8) or (temp shl 16) or $FF000000;4306 temp := LEtoN(p^ shr 24); 4307 p^ := NtoLE(temp or (temp shl 8) or (temp shl 16) or $FF000000); 3714 4308 Inc(p); 3715 4309 Dec(n); … … 3718 4312 end; 3719 4313 3720 procedure TBGRADefaultBitmap.ApplyMask(mask: TBGRADefaultBitmap); 4314 { Apply a mask to the bitmap. It means that alpha channel is 4315 changed according to grayscale values of the mask. 4316 4317 See : http://wiki.lazarus.freepascal.org/BGRABitmap_tutorial_5 } 4318 procedure TBGRADefaultBitmap.ApplyMask(mask: TBGRACustomBitmap); 3721 4319 var 3722 4320 p, pmask: PBGRAPixel; … … 3726 4324 exit; 3727 4325 4326 LoadFromBitmapIfNeeded; 3728 4327 for yb := 0 to Height - 1 do 3729 4328 begin … … 3732 4331 for xb := Width - 1 downto 0 do 3733 4332 begin 3734 p^.alpha := (p^.alpha * pmask^.red + 128) div 255;4333 p^.alpha := ApplyOpacity(p^.alpha, pmask^.red); 3735 4334 Inc(p); 3736 4335 Inc(pmask); … … 3740 4339 end; 3741 4340 4341 procedure TBGRADefaultBitmap.ApplyGlobalOpacity(alpha: byte); 4342 var 4343 p: PBGRAPixel; 4344 i: integer; 4345 begin 4346 if alpha = 0 then 4347 FillTransparent 4348 else 4349 if alpha <> 255 then 4350 begin 4351 p := Data; 4352 for i := NbPixels - 1 downto 0 do 4353 begin 4354 p^.alpha := ApplyOpacity(p^.alpha, alpha); 4355 Inc(p); 4356 end; 4357 end; 4358 end; 4359 4360 { Get bounds of non zero values of specified channel } 3742 4361 function TBGRADefaultBitmap.GetImageBounds(Channel: TChannel = cAlpha): TRect; 3743 4362 var … … 3793 4412 end; 3794 4413 4414 function TBGRADefaultBitmap.GetImageBounds(Channels: TChannels): TRect; 4415 var c: TChannel; 4416 begin 4417 result := rect(0,0,0,0); 4418 for c := low(TChannel) to high(TChannel) do 4419 if c in Channels then 4420 UnionRect(result,result,GetImageBounds(c)); 4421 end; 4422 4423 { Make a copy of the transparent bitmap to a TBitmap with a background color 4424 instead of transparency } 3795 4425 function TBGRADefaultBitmap.MakeBitmapCopy(BackgroundColor: TColor): TBitmap; 3796 4426 var 3797 opaqueCopy: TBGRA DefaultBitmap;4427 opaqueCopy: TBGRACustomBitmap; 3798 4428 begin 3799 4429 Result := TBitmap.Create; … … 3807 4437 end; 3808 4438 3809 procedure TBGRADefaultBitmap.DrawPart(Arect: TRect; Canvas: TCanvas; 3810 x, y: integer; Opaque: boolean); 3811 var 3812 partial: TBGRADefaultBitmap; 3813 begin 3814 partial := GetPart(ARect); 3815 if partial <> nil then 3816 begin 3817 partial.Draw(Canvas, x, y, Opaque); 3818 partial.Free; 3819 end; 3820 end; 3821 3822 function TBGRADefaultBitmap.GetPart(ARect: TRect): TBGRADefaultBitmap; 4439 { Get a part of the image with repetition in both directions. It means 4440 that if the bounds are within the image, the result is just that part 4441 of the image, but if the bounds are bigger than the image, the image 4442 is tiled. } 4443 function TBGRADefaultBitmap.GetPart(ARect: TRect): TBGRACustomBitmap; 3823 4444 var 3824 4445 copywidth, copyheight, widthleft, heightleft, curxin, curyin, xdest, … … 3890 4511 end; 3891 4512 4513 function TBGRADefaultBitmap.GetPtrBitmap(Top, Bottom: Integer 4514 ): TBGRACustomBitmap; 4515 var temp: integer; 4516 ptrbmp: TBGRAPtrBitmap; 4517 begin 4518 if Top > Bottom then 4519 begin 4520 temp := Top; 4521 Top := Bottom; 4522 Bottom := Temp; 4523 end; 4524 if Top < 0 then Top := 0; 4525 if Bottom > Height then Bottom := Height; 4526 if Top >= Bottom then 4527 result := nil 4528 else 4529 begin 4530 if LineOrder = riloTopToBottom then 4531 ptrbmp := TBGRAPtrBitmap.Create(Width,Bottom-Top,ScanLine[Top]) else 4532 ptrbmp := TBGRAPtrBitmap.Create(Width,Bottom-Top,ScanLine[Bottom-1]); 4533 ptrbmp.LineOrder := LineOrder; 4534 result := ptrbmp; 4535 end; 4536 end; 4537 4538 { Draw BGRA data to a canvas with transparency } 3892 4539 procedure TBGRADefaultBitmap.DataDrawTransparent(ACanvas: TCanvas; 3893 4540 Rect: TRect; AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); … … 3911 4558 end; 3912 4559 4560 { Draw BGRA data to a canvas without transparency } 3913 4561 procedure TBGRADefaultBitmap.DataDrawOpaque(ACanvas: TCanvas; 3914 4562 Rect: TRect; AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); … … 3924 4572 ALineEndMargin: integer; 3925 4573 CreateResult: boolean; 3926 {$IFDEF DARWIN}3927 TempShift: byte;3928 {$ENDIF}4574 {$IFDEF DARWIN} 4575 TempShift: Byte; 4576 {$ENDIF} 3929 4577 begin 3930 4578 if (AHeight = 0) or (AWidth = 0) then … … 3939 4587 PTempData := TempData; 3940 4588 PSource := AData; 3941 {$IFDEF DARWIN} 3942 SwapRedBlue; //swap red and blue values 3943 {$ENDIF} 4589 4590 {$IFDEF DARWIN} //swap red and blue values 3944 4591 for y := 0 to AHeight - 1 do 3945 4592 begin 3946 4593 for x := 0 to AWidth - 1 do 3947 4594 begin 3948 PWord(PTempData)^ := PWord(PSource)^; 3949 Inc(PTempData, 2); 3950 Inc(PSource, 2); 3951 PTempData^ := PSource^; 3952 Inc(PTempData); 3953 Inc(PSource, 2); 4595 PTempData^ := (PSource+2)^; 4596 (PTempData+1)^ := (PSource+1)^; 4597 (PTempData+2)^ := PSource^; 4598 inc(PTempData,3); 4599 inc(PSource,4); 3954 4600 end; 3955 4601 Inc(PTempData, ALineEndMargin); 3956 4602 end; 3957 {$IFDEF DARWIN} 3958 SwapRedBlue; //swap red and blue values 3959 {$ENDIF} 4603 {$ELSE} 4604 for y := 0 to AHeight - 1 do 4605 begin 4606 for x := 0 to AWidth - 1 do 4607 begin 4608 PWord(PTempData)^ := PWord(PSource)^; 4609 (PTempData+2)^ := (PSource+2)^; 4610 Inc(PTempData,3); 4611 Inc(PSource, 4); 4612 end; 4613 Inc(PTempData, ALineEndMargin); 4614 end; 4615 {$ENDIF} 3960 4616 3961 4617 RawImage.Init; 3962 4618 RawImage.Description.Init_BPP24_B8G8R8_BIO_TTB(AWidth, AHeight); 3963 {$IFDEF DARWIN} 3964 //swap red and blue positions 4619 {$IFDEF DARWIN} 3965 4620 TempShift := RawImage.Description.RedShift; 3966 4621 RawImage.Description.RedShift := RawImage.Description.BlueShift; 3967 4622 RawImage.Description.BlueShift := TempShift; 3968 {$ENDIF} 4623 {$ENDIF} 4624 3969 4625 RawImage.Description.LineOrder := ALineOrder; 3970 4626 RawImage.Description.LineEnd := rileDWordBoundary; 4627 3971 4628 if integer(RawImage.Description.BytesPerLine) <> AWidth * 3 + ALineEndMargin then 3972 4629 begin … … 3999 4656 raise EOutOfMemory.Create('TBGRADefaultBitmap: Not enough memory'); 4000 4657 InvalidateBitmap; 4658 FScanPtr := nil; 4001 4659 end; 4002 4660 … … 4042 4700 var 4043 4701 bmp: TBitmap; 4044 subBmp: TBGRA DefaultBitmap;4702 subBmp: TBGRACustomBitmap; 4045 4703 subRect: TRect; 4046 4704 cw,ch: integer; … … 4081 4739 end; 4082 4740 4741 function TBGRADefaultBitmap.GetNbPixels: integer; 4742 begin 4743 result := FNbPixels; 4744 end; 4745 4746 function TBGRADefaultBitmap.GetWidth: integer; 4747 begin 4748 Result := FWidth; 4749 end; 4750 4751 function TBGRADefaultBitmap.GetHeight: integer; 4752 begin 4753 Result:= FHeight; 4754 end; 4755 4756 function TBGRADefaultBitmap.GetRefCount: integer; 4757 begin 4758 result := FRefCount; 4759 end; 4760 4761 function TBGRADefaultBitmap.GetLineOrder: TRawImageLineOrder; 4762 begin 4763 result := FLineOrder; 4764 end; 4765 4766 function TBGRADefaultBitmap.GetCanvasOpacity: byte; 4767 begin 4768 result:= FCanvasOpacity; 4769 end; 4770 4771 function TBGRADefaultBitmap.GetFontHeight: integer; 4772 begin 4773 result := FFontHeight; 4774 end; 4775 4083 4776 { TBGRAPtrBitmap } 4084 4777 … … 4099 4792 end; 4100 4793 4101 function TBGRAPtrBitmap.Duplicate : TBGRADefaultBitmap;4794 function TBGRAPtrBitmap.Duplicate(DuplicateProperties: Boolean = False): TBGRACustomBitmap; 4102 4795 begin 4103 4796 Result := NewBitmap(Width, Height); 4104 TBGRAPtrBitmap(Result).SetDataPtr(FData);4797 if DuplicateProperties then CopyPropertiesTo(TBGRADefaultBitmap(Result)); 4105 4798 end; 4106 4799 … … 4108 4801 begin 4109 4802 FData := AData; 4803 end; 4804 4805 procedure BGRAGradientFill(bmp: TBGRACustomBitmap; x, y, x2, y2: integer; 4806 c1, c2: TBGRAPixel; gtype: TGradientType; o1, o2: TPointF; mode: TDrawMode; 4807 gammaColorCorrection: boolean = True; Sinus: Boolean=False); 4808 var 4809 gradScan : TBGRAGradientScanner; 4810 begin 4811 //handles transparency 4812 if (c1.alpha = 0) and (c2.alpha = 0) then 4813 begin 4814 bmp.FillRect(x, y, x2, y2, BGRAPixelTransparent, mode); 4815 exit; 4816 end; 4817 4818 gradScan := TBGRAGradientScanner.Create(c1,c2,gtype,o1,o2,gammaColorCorrection,Sinus); 4819 bmp.FillRect(x,y,x2,y2,gradScan,mode); 4820 gradScan.Free; 4110 4821 end; 4111 4822 -
GraphicTest/BGRABitmap/bgradnetdeserial.pas
r210 r317 4 4 5 5 interface 6 7 { This unit allow to read .Net serialized classes with BinaryFormatter of 8 namespace System.Runtime.Serialization.Formatters.Binary. 9 10 Serialization is a process by which objects in memory are saved according 11 to their structure. 12 13 This unit is used by BGRAPaintNet to read Paint.NET images. } 6 14 7 15 uses … … 9 17 10 18 type 19 arrayOfLongword = array of longword; 20 11 21 TTypeCategory = (ftPrimitiveType = 0, ftString = 1, ftObjectType = 12 22 2, ftRuntimeType = 3, … … 17 27 ptDouble = 6, ptInt16 = 7, ptInt32 = 8, ptInt64 = 9, ptSByte = 10, ptSingle = 11, 18 28 ptDateTime = 13, ptUInt16 = 14, ptUInt32 = 15, ptUInt64 = 16, ptString = 18); 29 30 TGenericArrayType = (gatSingleDimension, gatJagged, gatMultidimensional); 31 32 TDotNetDeserialization = class; 19 33 20 34 ArrayOfNameValue = array of record … … 43 57 end; 44 58 45 PSerializedObject = ^TSerializedObject; 46 47 TSerializedObject = record 59 { TCustomSerializedObject } 60 61 TCustomSerializedObject = class 62 protected 63 FContainer: TDotNetDeserialization; 64 function GetTypeAsString: string; virtual; abstract; 65 function GetFieldAsString(Index: longword): string; virtual; abstract; 66 function GetFieldAsString(Name: string): string; 67 function GetFieldCount: longword; virtual; abstract; 68 function GetFieldName(Index: longword): string; virtual; abstract; 69 function GetFieldTypeAsString(Index: longword): string; virtual; abstract; 70 function IsReferenceType(index: longword): boolean; virtual; abstract; 71 public 48 72 idObject: longword; 49 numType: integer;50 fields: ArrayOfNameValue;51 73 refCount: integer; 52 74 inToString: boolean; 75 constructor Create(container: TDotNetDeserialization); virtual; 76 property FieldCount: longword read GetFieldCount; 77 property FieldName[Index: longword]:string read GetFieldName; 78 property FieldAsString[Index: longword]: string read GetFieldAsString; 79 property FieldByNameAsString[Name: string]: string read GetFieldAsString; 80 property FieldTypeAsString[Index: longword]: string read GetFieldTypeAsString; 81 property TypeAsString: string read GetTypeAsString; 82 function GetFieldIndex(Name: string): integer; 83 end; 84 85 { TSerializedClass } 86 87 TSerializedClass = class(TCustomSerializedObject) 88 protected 89 function GetFieldAsString(Index: longword): string; override; 90 function GetFieldCount: longword; override; 91 function GetFieldName(Index: longword): string; override; 92 function GetFieldTypeAsString(Index: longword): string; override; 93 function IsReferenceType(index: longword): boolean; override; 94 function GetTypeAsString: string; override; 95 public 96 numType: integer; 97 fields: ArrayOfNameValue; 98 end; 99 100 { TSerializedArray } 101 102 TSerializedArray = class(TCustomSerializedObject) 103 private 104 data: pointer; 105 FItemSize: longword; 106 function GetItemPtr(Index: longword): pointer; 107 procedure InitData; 108 protected 109 FArrayType: TGenericArrayType; 110 function GetFieldAsString(Index: longword): string; override; 111 function GetFieldCount: longword; override; 112 function GetFieldName(Index: longword): string; override; 113 function GetFieldTypeAsString(Index: longword): string; override; 114 function IsReferenceType(index: longword): boolean; override; 115 function GetTypeAsString: string; override; 116 public 117 dimensions: array of longword; 118 itemType: TFieldType; 119 nbItems: longword; 120 constructor Create(AContainer: TDotNetDeserialization; AItemType: TFieldType; ALength: longword); overload; 121 constructor Create(AContainer: TDotNetDeserialization; AArrayType: TGenericArrayType; AItemType: TFieldType; ADimensions: arrayOfLongword); overload; 122 destructor Destroy; override; 123 property ItemPtr[Index:longword]: pointer read GetItemPtr; 124 property ItemSize: longword read FItemSize; 125 end; 126 127 { TSerializedValue } 128 129 TSerializedValue = class(TSerializedArray) 130 protected 131 function GetIsReferenceType: boolean; 132 function GetValueAsString: string; 133 function GetTypeAsString: string; override; 134 public 135 constructor Create(AContainer: TDotNetDeserialization; AItemType: TFieldType); overload; 136 property ValueAsString: string read GetValueAsString; 137 property IsReferenceType: boolean read GetIsReferenceType; 53 138 end; 54 139 … … 57 142 objectTypes: array of TSerializedType; 58 143 assemblies: array of TAssemblyReference; 59 objects: array of TSerializedObject; 60 61 function FindObject(typeName: string): PSerializedObject; 62 function GetSimpleField(obj: TSerializedObject; Name: string): string; 63 function FieldIndex(obj: TSerializedObject; Name: string): integer; 64 function GetObjectField(obj: TSerializedObject; Name: string): PSerializedObject; 65 function GetObject(id: string): PSerializedObject; 66 function GetObject(id: longword): PSerializedObject; 67 function GetObjectType(obj: PSerializedObject): string; 68 function PrimitiveTypeName(pt: TPrimitiveType): string; 69 function IsBoxedValue(obj: TSerializedObject; index: integer): boolean; 70 function GetBoxedValue(obj: TSerializedObject; index: integer): string; 71 function IsReferenceType(numType: integer; index: integer): boolean; 144 objects: array of TCustomSerializedObject; 145 146 function FindClass(typeName: string): TSerializedClass; 147 function FindObject(typeName: string): TCustomSerializedObject; 148 function GetSimpleField(obj: TCustomSerializedObject; Name: string): string; 149 function GetObjectField(obj: TCustomSerializedObject; Name: string): TCustomSerializedObject; 150 function GetObjectField(obj: TCustomSerializedObject; index: integer): TCustomSerializedObject; 151 function GetObject(id: string): TCustomSerializedObject; 152 function GetObject(id: longword): TCustomSerializedObject; 153 function IsBoxedValue(obj: TCustomSerializedObject; index: integer): boolean; 154 function GetBoxedValue(obj: TCustomSerializedObject; index: integer): string; 72 155 procedure LoadFromStream(Stream: TStream); 73 156 procedure LoadFromFile(filename: string); 74 157 function ToString: string; 75 158 constructor Create; 159 destructor Destroy; override; 160 function GetTypeOfClassObject(idObject: longword): integer; 76 161 private 77 162 EndOfStream: boolean; 78 ArrayFillerCount: integer;163 ArrayFillerCount: Longword; 79 164 currentAutoObjectValue: longword; 80 165 function nextAutoObjectId: longword; 81 166 function LoadNextFromStream(Stream: TStream): longword; 82 167 function LoadStringFromStream(Stream: TStream): string; 168 function LoadDotNetCharFromStream(Stream: TStream): string; 83 169 function LoadTypeFromStream(Stream: TStream; IsRuntimeType: boolean): integer; 84 170 function LoadValuesFromStream(Stream: TStream; numType: integer): ArrayOfNameValue; 85 function LoadValueFromStream(Stream: TStream; fieldType: TFieldType): string; 86 function GetTypeOfObject(idObject: longword): integer; 87 end; 88 171 function LoadValueFromStream(Stream: TStream; const fieldType: TFieldType): string; 172 function LoadFieldType(Stream: TStream; category: TTypeCategory): TFieldType; 173 end; 174 175 function WinReadByte(stream: TStream): byte; 89 176 function WinReadWord(Stream: TStream): word; 90 177 function WinReadSmallInt(Stream: TStream): smallint; … … 119 206 120 207 {$hints off} 208 209 function WinReadByte(stream: TStream): byte; 210 begin 211 stream.Read(Result, sizeof(Result)); 212 end; 213 121 214 function WinReadWord(Stream: TStream): word; 122 215 begin … … 155 248 end; 156 249 157 {$hints on} 158 159 { TDotNetDeserialization } 160 161 function TDotNetDeserialization.FindObject(typeName: string): PSerializedObject; 162 var 163 i, numType: integer; 164 comparedType: string; 165 begin 166 for i := 0 to high(objects) do 250 function GetFieldTypeSize(const fieldType: TFieldType): longword; 251 begin 252 case fieldType.category of 253 ftPrimitiveType: 254 case fieldType.primitiveType of 255 ptBoolean, ptByte,ptSByte: result := 1; 256 ptChar,ptString, ptDecimal: Result := sizeof(string); 257 ptSingle: result := sizeof(single); 258 ptDouble: result := sizeof(double); 259 ptInt16,ptUInt16: result := 2; 260 ptInt32,ptUInt32: result := 4; 261 ptInt64,ptUInt64,ptDateTime: result := 8; 262 else 263 raise Exception.Create('Unknown primitive type (' + IntToStr( 264 byte(fieldType.primitiveType)) + ')'); 265 end; 266 ftString, ftObjectType, ftRuntimeType, ftGenericType, ftArrayOfObject, 267 ftArrayOfString, ftArrayOfPrimitiveType: result := 4; 268 else 269 raise Exception.Create('Unknown field type (' + IntToStr( 270 byte(fieldType.category)) + ')'); 271 end; 272 end; 273 274 function IsDotNetTypeStoredAsString(const fieldType: TFieldType): boolean; 275 begin 276 result := (fieldType.category = ftPrimitiveType) and 277 (fieldType.primitiveType in [ptChar,ptString,ptDecimal]); 278 end; 279 280 function DotNetValueToString(var value; const fieldType: TFieldType): string; 281 var 282 tempByte: byte; 283 value2bytes: record 284 case byte of 285 2: (tempWord: word); 286 3: (tempInt16: smallint); 287 end; 288 value4bytes: record 289 case byte of 290 1: (tempSingle: single); 291 2: (tempLongWord: longword); 292 3: (tempLongInt: longint); 293 end; 294 value8bytes: record 295 case byte of 296 1: (tempDouble: double); 297 2: (tempInt64: Int64); 298 2: (tempUInt64: QWord); 299 end; 300 tempIdObject: longword; 301 302 begin 303 if IsDotNetTypeStoredAsString(fieldType) then 167 304 begin 168 numType := objects[i].numType; 169 if numType >= 0 then 170 begin 171 comparedType := objectTypes[numType].ClassName; 172 if (comparedType = typeName) or (length(typeName) < 173 length(comparedType)) and 174 (copy(comparedType, length(comparedType) - length(typeName), 175 length(typeName) + 1) = '.' + typeName) then 176 begin 177 Result := @objects[i]; 178 exit; 179 end; 180 end; 181 end; 182 Result := nil; 183 end; 184 185 function TDotNetDeserialization.GetSimpleField(obj: TSerializedObject; 186 Name: string): string; 187 var 188 i: integer; 189 begin 190 i := FieldIndex(obj, Name); 191 if i = -1 then 192 Result := '' 193 else 194 begin 195 if IsBoxedValue(obj, i) then 196 Result := GetBoxedValue(obj, i) 305 Result := pstring(@value)^; 306 exit; 307 end; 308 case fieldType.category of 309 ftPrimitiveType: case fieldType.primitiveType of 310 ptBoolean: 311 begin 312 {$hints off} 313 move(value,tempByte,sizeof(tempByte)); 314 {$hints on} 315 if tempByte = 0 then 316 Result := 'False' 317 else 318 if tempByte = 1 then 319 Result := 'True' 320 else 321 raise Exception.Create('Invalid boolean value (' + 322 IntToStr(tempByte) + ')'); 323 end; 324 ptByte: Result := inttostr(pbyte(@value)^); 325 ptSByte: Result := inttostr(pshortint(@value)^); 326 ptInt16,ptUInt16: 327 begin 328 {$hints off} 329 move(value, value2bytes.tempWord,sizeof(word)); 330 {$hints on} 331 value2bytes.tempWord := LEtoN(value2bytes.tempWord); 332 if fieldType.primitiveType = ptInt16 then 333 Result := IntToStr(value2bytes.tempInt16) 334 else 335 Result := IntToStr(value2bytes.tempWord); 336 end; 337 ptInt32,ptUInt32,ptSingle: 338 begin 339 {$hints off} 340 move(value, value4bytes.tempLongWord,sizeof(longword)); 341 {$hints on} 342 value4bytes.tempLongWord := LEtoN(value4bytes.tempLongWord); 343 if fieldType.primitiveType = ptInt32 then 344 Result := IntToStr(value4bytes.tempLongInt) 345 else if fieldType.primitiveType = ptUInt32 then 346 Result := IntToStr(value4bytes.tempLongWord) 347 else 348 result := FloatToStr(value4bytes.tempSingle); 349 end; 350 351 ptInt64,ptUInt64,ptDouble,ptDateTime: 352 begin 353 {$hints off} 354 move(value, value8bytes.tempUInt64,8); 355 {$hints on} 356 value8bytes.tempUInt64 := LEtoN(value8bytes.tempUInt64); 357 if fieldType.primitiveType = ptInt64 then 358 Result := IntToStr(value8bytes.tempInt64) 359 else if fieldType.primitiveType = ptUInt64 then 360 Result := IntToStr(value8bytes.tempUInt64) 361 else if fieldType.primitiveType = ptDouble then 362 result := FloatToStr(value8bytes.tempDouble) 363 else 364 Result := DateTimeToStr( 365 (value8bytes.tempUInt64 and $7FFFFFFFFFFFFFFF - 599264352000000000) / 864000000000); 366 end; 367 else 368 raise Exception.Create('Unknown primitive type (' + IntToStr( 369 byte(fieldType.primitiveType)) + ')'); 370 end; 371 ftString, ftObjectType, ftRuntimeType, ftGenericType, ftArrayOfObject, 372 ftArrayOfString, ftArrayOfPrimitiveType: 373 begin 374 {$hints off} 375 move(value,tempIdObject,sizeof(tempIdObject)); 376 {$hints on} 377 result := '#' + IntToStr(tempIdObject); 378 end; 197 379 else 198 Result := obj.fields[i].Value; 199 end; 200 end; 201 202 function TDotNetDeserialization.FieldIndex(obj: TSerializedObject; 203 Name: string): integer; 204 var 205 i: integer; 206 begin 207 //case sensitive 208 for i := 0 to high(obj.fields) do 209 if obj.fields[i].Name = Name then 210 begin 211 Result := i; 212 exit; 213 end; 214 //case insensitive 215 for i := 0 to high(obj.fields) do 216 if compareText(obj.fields[i].Name, Name) = 0 then 217 begin 218 Result := i; 219 exit; 220 end; 221 //case sensitive inner member 222 for i := 0 to high(obj.fields) do 223 if (length(Name) < length(obj.fields[i].Name)) and 224 (copy(obj.fields[i].Name, length(obj.fields[i].Name) - length(Name), 225 length(Name) + 1) = '+' + Name) then 226 begin 227 Result := i; 228 exit; 229 end; 230 //case insensitive inner member 231 for i := 0 to high(obj.fields) do 232 if (length(Name) < length(obj.fields[i].Name)) and 233 (compareText(copy(obj.fields[i].Name, length(obj.fields[i].Name) - 234 length(Name), length(Name) + 1), '+' + Name) = 0) then 235 begin 236 Result := i; 237 exit; 238 end; 239 Result := -1; 240 end; 241 242 function TDotNetDeserialization.GetObjectField(obj: TSerializedObject; 243 Name: string): PSerializedObject; 244 var 245 i: integer; 246 begin 247 i := FieldIndex(obj, Name); 248 if i = -1 then 249 Result := nil 250 else 251 begin 252 if not IsReferenceType(obj.numType, i) then 253 raise Exception.Create('GetObjectMember: Not a reference type'); 254 Result := GetObject(obj.fields[i].Value); 255 end; 256 end; 257 258 function TDotNetDeserialization.GetObject(id: string): PSerializedObject; 259 var 260 idObj: longword; 261 begin 262 if copy(id, 1, 1) = '#' then 263 Delete(id, 1, 1); 264 idObj := StrToInt(id); 265 Result := GetObject(idObj); 266 end; 267 268 function TDotNetDeserialization.GetObject(id: longword): PSerializedObject; 269 var 270 i: integer; 271 begin 272 for i := 0 to high(objects) do 273 if objects[i].idObject = id then 274 begin 275 Result := @objects[i]; 276 exit; 277 end; 278 Result := nil; 279 end; 280 281 function TDotNetDeserialization.GetObjectType(obj: PSerializedObject): string; 282 begin 283 if (obj^.numType = -btString) then 284 Result := 'String' 285 else 286 if (obj^.numType = -btArrayOfObject) then 287 Result := 'Object[]' 288 else 289 if (obj^.numType = -btArrayOfString) then 290 Result := 'String[]' 291 else 292 if (obj^.numType < 0) or (obj^.numType > high(objectTypes)) then 293 Result := '' 294 else 295 begin 296 Result := objectTypes[obj^.numType].ClassName; 297 end; 298 end; 299 300 function TDotNetDeserialization.PrimitiveTypeName(pt: TPrimitiveType): string; 380 raise Exception.Create('Unknown field type (' + IntToStr( 381 byte(fieldType.category)) + ')'); 382 end; 383 end; 384 385 function PrimitiveTypeName(pt: TPrimitiveType): string; 301 386 begin 302 387 case pt of … … 317 402 ptString: Result := 'String'; 318 403 else 319 raise Exception.Create('Unknown primitive type (' + IntToStr(byte(pt)) + ')'); 320 end; 321 end; 322 323 function TDotNetDeserialization.IsBoxedValue(obj: TSerializedObject; 404 raise Exception.Create('Unknown primitive type (' + IntToStr(integer(pt)) + ')'); 405 end; 406 end; 407 408 Function DotNetTypeToString(ft: TFieldType): string; 409 begin 410 if ft.category = ftPrimitiveType then 411 result := PrimitiveTypeName(ft.primitiveType) 412 else 413 case ft.category of 414 ftString: result := 'String'; 415 ftObjectType: result := 'Object'; 416 ftRuntimeType: result := 'RuntimeType'; 417 ftGenericType: result := 'GenericType'; 418 ftArrayOfObject: result := 'Object[]'; 419 ftArrayOfString: result := 'String[]'; 420 ftArrayOfPrimitiveType: result := 'PrimitiveType[]'; 421 else 422 raise Exception.Create('Unknown field type (' + IntToStr( 423 byte(ft.category)) + ')'); 424 end; 425 end; 426 427 { TCustomSerializedObject } 428 429 function TCustomSerializedObject.GetFieldAsString(Name: string): string; 430 begin 431 result := GetFieldAsString(GetFieldIndex(Name)); 432 end; 433 434 constructor TCustomSerializedObject.Create(container: TDotNetDeserialization); 435 begin 436 FContainer := container; 437 refCount := 0; 438 end; 439 440 function TCustomSerializedObject.GetFieldIndex(Name: string): integer; 441 var 442 i: integer; 443 fn: string; 444 begin 445 if FieldCount = 0 then 446 begin 447 result := -1; 448 exit; 449 end; 450 //case sensitive 451 for i := 0 to FieldCount-1 do 452 if FieldName[i] = Name then 453 begin 454 Result := i; 455 exit; 456 end; 457 //case insensitive 458 for i := 0 to FieldCount-1 do 459 if compareText(FieldName[i], Name) = 0 then 460 begin 461 Result := i; 462 exit; 463 end; 464 //case sensitive inner member 465 for i := 0 to FieldCount-1 do 466 begin 467 fn := FieldName[i]; 468 if (length(Name) < length(fn)) and 469 (copy(fn, length(fn) - length(Name), 470 length(Name) + 1) = '+' + Name) then 471 begin 472 Result := i; 473 exit; 474 end; 475 end; 476 //case insensitive inner member 477 for i := 0 to FieldCount-1 do 478 begin 479 fn := FieldName[i]; 480 if (length(Name) < length(fn)) and 481 (compareText(copy(fn, length(fn) - 482 length(Name), length(Name) + 1), '+' + Name) = 0) then 483 begin 484 Result := i; 485 exit; 486 end; 487 end; 488 Result := -1; 489 end; 490 491 { TSerializedClass } 492 493 function TSerializedClass.GetFieldAsString(Index: longword): string; 494 begin 495 result := fields[Index].Value; 496 end; 497 498 function TSerializedClass.GetFieldCount: longword; 499 begin 500 Result:= length(fields); 501 end; 502 503 function TSerializedClass.GetFieldName(Index: longword): string; 504 begin 505 result := fields[Index].Name; 506 end; 507 508 function TSerializedClass.GetFieldTypeAsString(Index: longword): string; 509 begin 510 result := fields[Index].valueType; 511 end; 512 513 function TSerializedClass.IsReferenceType(index: longword): boolean; 514 begin 515 Result:= FContainer.objectTypes[numType].fieldTypes[index].category <> ftPrimitiveType; 516 end; 517 518 function TSerializedClass.GetTypeAsString: string; 519 begin 520 Result:= FContainer.objectTypes[numType].ClassName; 521 end; 522 523 { TSerializedArray } 524 525 procedure TSerializedArray.InitData; 526 begin 527 FItemSize := GetFieldTypeSize(itemType); 528 getmem(data, itemSize*nbItems); 529 fillchar(data^, itemSize*nbItems, 0); 530 end; 531 532 function TSerializedArray.GetItemPtr(Index: longword): pointer; 533 begin 534 if index >= nbItems then 535 raise exception.Create('Index out of bounds'); 536 result := pointer(pbyte(data)+Index*itemsize); 537 end; 538 539 function TSerializedArray.GetFieldAsString(Index: longword): string; 540 begin 541 if data = nil then 542 result := '' 543 else 544 result := DotNetValueToString(ItemPtr[index]^, itemType); 545 end; 546 547 function TSerializedArray.GetFieldCount: longword; 548 begin 549 Result:= nbItems; 550 end; 551 552 function TSerializedArray.GetFieldName(Index: longword): string; 553 var 554 r: longword; 555 begin 556 result := '['; 557 for r := 1 to length(dimensions) do 558 begin 559 if r <> 1 then result+=','; 560 result += inttostr(index mod dimensions[r-1]); 561 index := index div dimensions[r-1]; 562 end; 563 result += ']'; 564 end; 565 566 {$hints off} 567 function TSerializedArray.GetFieldTypeAsString(Index: longword): string; 568 begin 569 Result:= DotNetTypeToString(itemType); 570 end; 571 {$hints on} 572 573 {$hints off} 574 function TSerializedArray.IsReferenceType(index: longword): boolean; 575 begin 576 Result:= itemType.category <> ftPrimitiveType; 577 end; 578 {$hints on} 579 580 function TSerializedArray.GetTypeAsString: string; 581 var 582 i: Integer; 583 begin 584 Result:= DotNetTypeToString(itemType)+'['; 585 for i := 2 to length(dimensions) do 586 result += ','; 587 result += ']'; 588 end; 589 590 constructor TSerializedArray.Create(AContainer: TDotNetDeserialization; AItemType: TFieldType; ALength: longword); 591 begin 592 inherited Create(AContainer); 593 setlength(dimensions,1); 594 dimensions[0] := ALength; 595 nbItems := ALength; 596 FArrayType := gatSingleDimension; 597 itemType := AItemType; 598 InitData; 599 end; 600 601 constructor TSerializedArray.Create(AContainer: TDotNetDeserialization; AArrayType: TGenericArrayType; AItemType: TFieldType; 602 ADimensions: arrayOfLongword); 603 var n: longword; 604 begin 605 inherited Create(AContainer); 606 setlength(dimensions, length(ADimensions)); 607 nbItems := 1; 608 if length(ADimensions) <> 0 then 609 for n := 0 to length(ADimensions)-1 do 610 begin 611 dimensions[n] := ADimensions[n]; 612 nbItems *= ADimensions[n]; 613 end; 614 FArrayType := AArrayType; 615 itemType := AItemType; 616 InitData; 617 end; 618 619 destructor TSerializedArray.Destroy; 620 var ps: PString; 621 n: longword; 622 begin 623 if IsDotNetTypeStoredAsString(itemType) and (nbItems <> 0) then 624 begin 625 ps := PString(data); 626 for n := 1 to nbItems do 627 begin 628 ps^ := ''; 629 inc(ps); 630 end; 631 end; 632 freemem(data); 633 inherited Destroy; 634 end; 635 636 { TSerializedValue } 637 638 function TSerializedValue.GetIsReferenceType: boolean; 639 begin 640 result := inherited IsReferenceType(0); 641 end; 642 643 function TSerializedValue.GetValueAsString: string; 644 begin 645 result := GetFieldAsString(0); 646 end; 647 648 function TSerializedValue.GetTypeAsString: string; 649 begin 650 Result:= GetFieldTypeAsString(0); 651 end; 652 653 constructor TSerializedValue.Create(AContainer: TDotNetDeserialization; 654 AItemType: TFieldType); 655 begin 656 inherited Create(AContainer,AItemType,1); 657 end; 658 659 {$hints on} 660 661 { TDotNetDeserialization } 662 663 function TDotNetDeserialization.FindClass(typeName: string): TSerializedClass; 664 var obj: TCustomSerializedObject; 665 begin 666 obj := FindObject(typeName); 667 if obj is TSerializedClass then 668 result := obj as TSerializedClass 669 else 670 raise exception.Create('FindClass: found object is not a class'); 671 end; 672 673 function TDotNetDeserialization.FindObject(typeName: string): TCustomSerializedObject; 674 var 675 i: integer; 676 comparedType: string; 677 begin 678 for i := 0 to high(objects) do 679 begin 680 comparedType := objects[i].TypeAsString; 681 if (comparedType = typeName) or 682 ( (length(typeName) < length(comparedType) ) and 683 (copy(comparedType, length(comparedType) - length(typeName), 684 length(typeName) + 1) = '.' + typeName) ) then 685 begin 686 Result := objects[i]; 687 exit; 688 end; 689 end; 690 Result := nil; 691 end; 692 693 function TDotNetDeserialization.GetSimpleField(obj: TCustomSerializedObject; 694 Name: string): string; 695 var 696 i,idxSlash: integer; 697 tempSub: TCustomSerializedObject; 698 begin 699 i := obj.GetFieldIndex(Name); 700 if i = -1 then 701 begin 702 idxSlash := pos('\',name); 703 if idxSlash <> 0 then 704 begin 705 tempSub := GetObjectField(obj,copy(name,1,idxSlash-1)); 706 if tempSub <> nil then 707 begin 708 result := GetSimpleField(tempSub,copy(name,idxSlash+1,length(name)-idxSlash)); 709 exit; 710 end; 711 end; 712 Result := '' 713 end 714 else 715 begin 716 if IsBoxedValue(obj, i) then 717 Result := GetBoxedValue(obj, i) 718 else 719 Result := obj.FieldAsString[i]; 720 end; 721 end; 722 723 function TDotNetDeserialization.GetObjectField(obj: TCustomSerializedObject; 724 Name: string): TCustomSerializedObject; 725 var 726 i: integer; 727 idxSlash: LongInt; 728 tempSub: TCustomSerializedObject; 729 begin 730 i := obj.GetFieldIndex(Name); 731 if i = -1 then 732 begin 733 idxSlash := pos('\',name); 734 if idxSlash <> 0 then 735 begin 736 tempSub := GetObjectField(obj,copy(name,1,idxSlash-1)); 737 if tempSub <> nil then 738 begin 739 result := GetObjectField(tempSub,copy(name,idxSlash+1,length(name)-idxSlash)); 740 exit; 741 end; 742 end; 743 Result := nil 744 end 745 else 746 begin 747 if not obj.IsReferenceType(i) then 748 raise Exception.Create('GetObjectField: Not a reference type'); 749 Result := GetObject(obj.FieldAsString[i]); 750 end; 751 end; 752 753 function TDotNetDeserialization.GetObjectField(obj: TCustomSerializedObject; 754 index: integer): TCustomSerializedObject; 755 begin 756 if not obj.IsReferenceType(index) then 757 raise Exception.Create('GetObjectField: Not a reference type'); 758 Result := GetObject(obj.FieldAsString[index]); 759 end; 760 761 function TDotNetDeserialization.GetObject(id: string): TCustomSerializedObject; 762 var 763 idObj: longword; 764 begin 765 if copy(id, 1, 1) = '#' then 766 Delete(id, 1, 1); 767 idObj := StrToInt64(id); 768 Result := GetObject(idObj); 769 end; 770 771 function TDotNetDeserialization.GetObject(id: longword): TCustomSerializedObject; 772 var 773 i: integer; 774 begin 775 for i := 0 to high(objects) do 776 if objects[i].idObject = id then 777 begin 778 Result := objects[i]; 779 exit; 780 end; 781 Result := nil; 782 end; 783 784 function TDotNetDeserialization.IsBoxedValue(obj: TCustomSerializedObject; 324 785 index: integer): boolean; 325 786 var 326 subObj: PSerializedObject;327 begin 328 if not IsReferenceType(obj.numType,index) then787 subObj: TCustomSerializedObject; 788 begin 789 if not obj.IsReferenceType(index) then 329 790 begin 330 791 Result := False; 331 792 exit; 332 793 end; 333 subObj := GetObject(obj. fields[index].Value);334 if subObj = nil then 794 subObj := GetObject(obj.FieldAsString[index]); 795 if subObj = nil then //suppose Nothing is a boxed value 335 796 begin 336 797 Result := True; 337 798 exit; 338 799 end; 339 Result := (length(subObj^.fields) = 1) and (subObj^.fields[0].Name = '');340 end; 341 342 function TDotNetDeserialization.GetBoxedValue(obj: T SerializedObject;800 Result := subObj is TSerializedValue; 801 end; 802 803 function TDotNetDeserialization.GetBoxedValue(obj: TCustomSerializedObject; 343 804 index: integer): string; 344 805 var 345 subObj: PSerializedObject;346 begin 347 if not IsReferenceType(obj.numType,index) then806 subObj: TCustomSerializedObject; 807 begin 808 if not obj.IsReferenceType(index) then 348 809 raise Exception.Create('GetBoxedValue: Not a reference type'); 349 subObj := GetObject(obj. fields[index].Value);810 subObj := GetObject(obj.FieldAsString[index]); 350 811 if subObj = nil then 351 812 begin … … 353 814 exit; 354 815 end; 355 if ( length(subObj^.fields) = 1) and (subObj^.fields[0].Name = '')then356 Result := subObj^.fields[0].Value816 if (subObj is TSerializedValue) and not (subObj as TSerializedValue).IsReferenceType then 817 Result := (subObj as TSerializedValue).ValueAsString 357 818 else 358 819 raise Exception.Create('GetBoxedValue: Not a primitive type'); 359 end;360 361 function TDotNetDeserialization.IsReferenceType(numType: integer;362 index: integer): boolean;363 begin364 if numType >= length(objectTypes) then365 raise Exception.Create('IsReferenceType: Type number out of bounds');366 367 if (numType < 0) then368 begin369 Result := (numType = -btArrayOfObject) or (numtype = -btArrayOfString);370 end371 else372 begin373 if (index < 0) or (index >= objecttypes[numType].nbFields) then374 raise Exception.Create('IsReferenceType: Index out of bounds');375 376 Result := (objecttypes[numType].fieldTypes[index].category <> ftPrimitiveType);377 end;378 820 end; 379 821 … … 433 875 subNum: integer; 434 876 objType, subExpectedType: string; 877 fieldTypeStr: string; 435 878 begin 436 879 Result := ''; … … 448 891 end; 449 892 inToString := True; 893 objType := TypeAsString; 450 894 if main then 451 895 begin 452 if numType < 0 then453 objType := ''454 else455 objType := objectTypes[numType].ClassName;456 896 Result += tab + 'Object'; 457 if refCount > 0 then 458 Result += ' #' + IntToStr(idObject); 897 Result += ' #' + IntToStr(idObject); 459 898 if (objType = '') or (objType = expectedType) then 460 899 Result += ' = ' … … 464 903 else 465 904 begin 466 objType := GetObjectType(@objects[num]);467 905 if (objType = '') or (objType = expectedType) then 468 906 Result := '' … … 477 915 subExpectedType := ''; 478 916 479 if not main and ( length(fields) = 1) and (fields[0].Name = '') then917 if not main and (objects[num] is TSerializedValue) then 480 918 begin 481 Result += fields[0].Value+ LineEnding;919 Result += (objects[num] as TSerializedValue).ValueAsString + LineEnding; 482 920 end 483 921 else 484 if ( length(fields)= 0) then922 if (FieldCount = 0) then 485 923 begin 486 924 Result += '{}' + LineEnding; … … 489 927 begin 490 928 Result += '{' + LineEnding; 491 for j := 0 to High(fields)do929 for j := 0 to FieldCount-1 do 492 930 begin 493 Result += tab + ' ' + fields[j].Name; 494 if (fields[j].valueType <> '') and (fields[j].valueType <> subExpectedType) and 495 not ((subExpectedType = '') and ((fields[j].valueType = 'Int32') or 496 (fields[j].valueType = 'Boolean'))) then 497 Result += ' As ' + fields[j].valueType; 931 Result += tab + ' ' + FieldName[j]; 932 fieldTypeStr := FieldTypeAsString[j]; 933 if (fieldTypeStr <> '') and (fieldTypeStr <> subExpectedType) and 934 not ((subExpectedType = '') and ((fieldTypeStr = 'Int32') or 935 (fieldTypeStr = 'Boolean') or (fieldTypeStr = 'Double'))) then 936 Result += ' As ' + fieldTypeStr; 498 937 Result += ' = '; 499 if not IsReferenceType(numType, j) or (copy(fields[j].Value, 1, 1) <> '#') or 500 (fields[j].Value = '#0') then 501 Result += fields[j].Value + lineending 938 if not IsReferenceType(j) then 939 Result += FieldAsString[j] + lineending 502 940 else 503 941 begin 504 subId := StrToInt(copy(fields[j].Value, 2, length(fields[j].Value) - 1)); 505 subNum := -1; 506 for k := 0 to high(objects) do 507 if (objects[k].idObject = subId) then 942 try 943 subId := StrToInt64(copy(fieldAsString[j], 2, length(fieldAsString[j]) - 1)); 944 if subId = 0 then result += 'null'+LineEnding else 508 945 begin 509 subNum := k; 510 break; 946 begin 947 subNum := -1; 948 for k := 0 to high(objects) do 949 if (objects[k].idObject = subId) then 950 begin 951 subNum := k; 952 break; 953 end; 954 end; 955 if subNum = -1 then 956 Result += '(Not found) #' + IntToStr(subId)+LineEnding 957 else 958 Result += objectToString(subNum, fieldTypeStr, tab + ' ', False); 511 959 end; 512 if subNum = -1 then 513 Result += '#' + IntToStr(subId) + '!' + LineEnding 514 else 515 Result += objectToString(subNum, fields[j].valueType, tab + ' ', False); 960 except 961 result += '!' + fieldAsString[j]+'!' +LineEnding 962 end; 516 963 end; 517 964 end; … … 541 988 end; 542 989 990 destructor TDotNetDeserialization.Destroy; 991 var 992 i: Integer; 993 begin 994 for i := 0 to high(objects) do 995 objects[i].Free; 996 inherited Destroy; 997 end; 998 999 function TDotNetDeserialization.GetTypeOfClassObject(idObject: longword 1000 ): integer; 1001 var 1002 i: Integer; 1003 begin 1004 for i := 0 to high(objects) do 1005 if objects[i].idObject = idObject then 1006 begin 1007 if objects[i] is TSerializedClass then 1008 begin 1009 result := (objects[i] as TSerializedClass).numType; 1010 exit; 1011 end 1012 else 1013 raise exception.Create('GetTypeOfClassObject: Specified object is not of class type'); 1014 end; 1015 raise exception.Create('GetTypeOfClassObject: Object not found'); 1016 end; 1017 543 1018 function TDotNetDeserialization.nextAutoObjectId: longword; 544 1019 begin … … 552 1027 idRefObject, tempIdObject: longword; 553 1028 tempType: TFieldType; 554 arrayCount, i, idx, FillZeroCount: integer; 555 tempObj: TSerializedObject; 556 tempTypeName: string; 557 tempPObj: PSerializedObject; 1029 arrayCount, arrayIndex,FillZeroCount : longword; 1030 tempAnyObj: TCustomSerializedObject; 1031 newClassObj: TSerializedClass; 1032 newValueObj: TSerializedValue; 1033 newArrayObj: TSerializedArray; 1034 genericArrayType: TGenericArrayType; 1035 genericArrayRank: longword; 1036 genericArrayDims: array of longword; 1037 genericArrayItemType: TFieldType; 1038 1039 function GetArrayCellNumber(index: longword): string; 1040 var r: longword; 1041 begin 1042 result := ''; 1043 for r := 1 to genericArrayRank do 1044 begin 1045 if r <> 1 then result+=','; 1046 result += inttostr(index mod genericArrayDims[r-1]); 1047 index := index div genericArrayDims[r-1]; 1048 end; 1049 end; 1050 558 1051 begin 559 1052 Result := 0; //idObject or zero 560 {$hints off} 561 Stream.Read(blockType, sizeof(blockType)); 562 {$hints on} 1053 blockType := WinReadByte(Stream); 563 1054 case blockType of 564 1055 … … 568 1059 with assemblies[high(assemblies)] do 569 1060 begin 570 Stream.Read(idAssembly, 4);1061 idAssembly := WinReadLongword(Stream); 571 1062 Name := LoadStringFromStream(Stream); 572 1063 end; … … 575 1066 btRuntimeObject, btExternalObject: 576 1067 begin 1068 newClassObj := TSerializedClass.Create(self); 577 1069 setlength(objects, length(objects) + 1); 578 idx := high(objects);579 with tempObj do //use temp because array address may change1070 objects[high(objects)] := newClassObj; 1071 with newClassObj do 580 1072 begin 581 refCount := 0; 582 Stream.Read(idObject, 4); 583 Result := idObject; 584 numType := LoadTypeFromStream(Stream, blockType = btRuntimeObject); 585 end; 586 objects[idx] := tempObj; 587 tempObj.fields := LoadValuesFromStream(Stream, objects[idx].numType); 588 objects[idx].fields := tempObj.fields; 1073 idObject := WinReadLongword(Stream); 1074 Result := idObject; 1075 numType := LoadTypeFromStream(Stream, blockType = btRuntimeObject); 1076 fields := LoadValuesFromStream(Stream, numType); 1077 end; 589 1078 end; 590 1079 591 1080 btRefTypeObject: 592 1081 begin 1082 newClassObj := TSerializedClass.Create(self); 593 1083 setlength(objects, length(objects) + 1); 594 idx := high(objects);595 with tempObj do //use temp because array address may change1084 objects[high(objects)] := newClassObj; 1085 with newClassObj do 596 1086 begin 597 refCount := 0;598 1087 idObject := WinReadLongword(Stream); 599 1088 Result := idObject; 600 1089 idRefObject := WinReadLongword(Stream); 601 numType := GetTypeOfObject(idRefObject); 602 end; 603 objects[idx] := tempObj; 604 tempObj.fields := LoadValuesFromStream(Stream, objects[idx].numType); 605 objects[idx].fields := tempObj.fields; 1090 numType := GetTypeOfClassObject(idRefObject); 1091 fields := LoadValuesFromStream(Stream, numType); 1092 end; 606 1093 end; 607 1094 608 1095 btString: 609 1096 begin 1097 tempType.primitiveType := ptString; 1098 tempType.category := ftPrimitiveType; 1099 tempType.Name := PrimitiveTypeName(ptString); 1100 tempType.refAssembly := 0; 1101 1102 newValueObj := TSerializedValue.Create(self,tempType); 610 1103 setlength(objects, length(objects) + 1); 611 idx := high(objects);612 with tempObj do //use temp because array address may change1104 objects[high(objects)] := newValueObj; 1105 with newValueObj do 613 1106 begin 614 refCount := 0; 615 Stream.Read(idObject, 4); 1107 idObject := WinReadLongword(Stream); 616 1108 Result := idObject; 617 numType := -blockType; 618 setlength(fields, 1); 619 fields[0].Name := ''; 620 fields[0].valueType := 'String'; 621 fields[0].Value := LoadStringFromStream(Stream); 622 end; 623 objects[idx] := tempObj; 1109 pstring(data)^ := LoadStringFromStream(Stream); 1110 end; 624 1111 end; 625 1112 … … 627 1114 begin 628 1115 try 1116 tempType.category := ftPrimitiveType; 1117 tempType.refAssembly := 0; 1118 tempType.primitiveType := TPrimitiveType(WinReadByte(stream)); 1119 tempType.Name := PrimitiveTypeName(tempType.primitiveType); 1120 1121 newValueObj := TSerializedValue.Create(self,tempType); 629 1122 setlength(objects, length(objects) + 1); 630 idx := high(objects); 631 with tempObj do //use temp because array address may change 1123 objects[high(objects)] := newValueObj; 1124 1125 with newValueObj do 632 1126 begin 633 refCount := 0;634 1127 idObject := nextAutoObjectId; 635 1128 Result := idObject; 636 numType := -blockType; 637 638 tempType.category := ftPrimitiveType; 639 tempType.refAssembly := 0; 640 Stream.Read(tempType.primitiveType, 1); 641 tempType.Name := PrimitiveTypeName(tempType.primitiveType); 642 643 setlength(fields, 1); 644 fields[0].Name := ''; 645 fields[0].Value := LoadValueFromStream(Stream, tempType); 646 fields[0].valueType := tempType.Name; 1129 1130 if IsDotNetTypeStoredAsString(tempType) then 1131 pstring(data)^ := LoadValueFromStream(Stream, tempType) 1132 else 1133 Stream.Read(data^, itemSize); 647 1134 end; 648 objects[idx] := tempObj;649 1135 except 650 1136 on ex: Exception do … … 656 1142 btObjectReference: 657 1143 begin 658 Stream.Read(Result, 4);659 temp PObj := GetObject(Result);660 if temp PObj <> nil then661 Inc(temp PObj^.refCount);1144 result := WinReadLongword(Stream); 1145 tempAnyObj := GetObject(Result); 1146 if tempAnyObj <> nil then 1147 Inc(tempAnyObj.refCount); 662 1148 end; 663 1149 … … 667 1153 begin 668 1154 try 1155 result := WinReadLongword(Stream); 1156 arrayCount := WinReadLongword(Stream); 1157 1158 tempType.category := ftPrimitiveType; 1159 tempType.refAssembly := 0; 1160 tempType.primitiveType := TPrimitiveType(WinReadByte(stream)); 1161 tempType.Name := PrimitiveTypeName(tempType.primitiveType); 1162 1163 newArrayObj := TSerializedArray.Create(self,tempType,arrayCount); 669 1164 setlength(objects, length(objects) + 1); 670 idx := high(objects);671 with tempObj do //use temp because array address may change1165 objects[high(objects)] := newArrayObj; 1166 with newArrayObj do 672 1167 begin 673 refCount := 0; 674 Stream.Read(idObject, 4); 675 Result := idObject; 676 arrayCount := WinReadLongint(Stream); 677 678 tempType.category := ftPrimitiveType; 679 tempType.refAssembly := 0; 680 Stream.Read(tempType.primitiveType, 1); 681 tempType.Name := PrimitiveTypeName(tempType.primitiveType); 682 683 setlength(fields, arrayCount); 684 for i := 0 to arrayCount - 1 do 1168 idObject := result; 1169 1170 if arrayCount <> 0 then 685 1171 begin 686 fields[i].Name := '[' + IntToStr(i) + ']'; 687 fields[i].Value := LoadValueFromStream(Stream, tempType); 688 fields[i].valueType := tempType.Name; 689 end; 690 691 setlength(objectTypes, length(objecttypes) + 1); 692 numType := high(objectTypes); 693 with objectTypes[numType] do 694 begin 695 ClassName := tempType.Name + '[]'; 696 nbFields := arrayCount; 697 setlength(fieldNames, nbFields); 698 setlength(fieldTypes, nbFields); 699 for i := 0 to arrayCount - 1 do 1172 if IsDotNetTypeStoredAsString(tempType) then 700 1173 begin 701 fieldNames[i] := fields[i].Name; 702 fieldTypes[i] := tempType; 1174 for arrayIndex := 0 to arrayCount - 1 do 1175 pstring(ItemPtr[arrayIndex])^ := LoadValueFromStream(Stream, tempType); 1176 end else 1177 begin 1178 for arrayIndex := 0 to arrayCount - 1 do 1179 stream.Read(ItemPtr[arrayIndex]^, itemSize); 703 1180 end; 704 refAssembly := 0;705 1181 end; 706 1182 end; 707 objects[idx] := tempObj;708 1183 except 709 1184 on ex: Exception do … … 713 1188 end; 714 1189 715 btArrayOfObject, 1190 btArrayOfObject,btArrayOfString: 716 1191 begin 717 1192 try 1193 result := WinReadLongword(Stream); 1194 arrayCount := WinReadLongword(Stream); 1195 1196 if blockType = btArrayOfObject then 1197 tempType.category := ftObjectType 1198 else 1199 tempType.category := ftString; 1200 1201 tempType.refAssembly := 0; 1202 tempType.primitiveType := ptNone; 1203 tempType.Name := DotNetTypeToString(tempType); 1204 1205 newArrayObj := TSerializedArray.Create(self,tempType,arrayCount); 718 1206 setlength(objects, length(objects) + 1); 719 idx := high(objects); 720 with tempObj do //use temp because array address may change 1207 objects[high(objects)] := newArrayObj; 1208 1209 with newArrayObj do 721 1210 begin 722 refCount := 0; 723 Stream.Read(idObject, 4); 724 Result := idObject; 725 numType := -blockType; 726 Stream.Read(arrayCount, 4); 727 end; 728 objects[idx] := tempObj; 729 with tempObj do 730 begin 731 setlength(fields, arrayCount); 1211 idObject:= result; 732 1212 FillZeroCount := 0; 733 if blockType = btArrayOfObject then 734 tempTypeName := 'Object' 735 else 736 tempTypeName := 'String'; 737 for i := 0 to arrayCount - 1 do 738 begin 739 fields[i].Name := '[' + IntToStr(i) + ']'; 740 fields[i].valueType := tempTypeName; 741 if FillZeroCount > 0 then 1213 if arrayCount <> 0 then 1214 for arrayIndex := 0 to arrayCount - 1 do 742 1215 begin 743 fields[i].Value := '#0';744 Dec(FillZeroCount);745 end746 else747 begin748 tempIdObject := LoadNextFromStream(Stream);749 if tempIdObject = idArrayFiller then750 begin751 tempIdObject := 0;752 FillZeroCount := ArrayFillerCount;753 ArrayFillerCount := 0;754 end;755 1216 if FillZeroCount > 0 then 756 begin 757 fields[i].Value := '#0'; 758 Dec(FillZeroCount); 759 end 1217 Dec(FillZeroCount) 760 1218 else 761 1219 begin 762 fields[i].Value := '#' + IntToStr(tempIdObject); 1220 tempIdObject := LoadNextFromStream(Stream); 1221 if tempIdObject = idArrayFiller then 1222 begin 1223 tempIdObject := 0; 1224 FillZeroCount := ArrayFillerCount; 1225 ArrayFillerCount := 0; 1226 end; 1227 if FillZeroCount > 0 then 1228 Dec(FillZeroCount) 1229 else 1230 plongword(ItemPtr[arrayIndex])^ := tempIdObject; 763 1231 end; 764 1232 end; 765 end;766 1233 end; 767 objects[idx].fields := tempObj.fields;768 1234 except 769 1235 on ex: Exception do … … 777 1243 arrayCount := 0; 778 1244 if blockType = btArrayFiller8b then 779 begin 780 Stream.Read(arrayCount, 1); 781 end 1245 arrayCount := WinReadByte(Stream) 782 1246 else 783 Stream.Read(arrayCount, 3); 784 arrayCount := LEtoN(arrayCount); 1247 arrayCount := WinReadLongWord(Stream); 785 1248 ArrayFillerCount := arraycount; 786 1249 end; 787 1250 788 1251 btGenericArray: 789 raise Exception.Create('Generic array not supported'); 1252 begin 1253 try 1254 result := WinReadLongword(Stream); 1255 genericArrayType := TGenericArrayType( WinReadByte(Stream) ); 1256 genericArrayRank := WinReadLongword(Stream); 1257 setlength(genericArrayDims,genericArrayRank); 1258 arrayCount := 0; 1259 if genericArrayRank <> 0 then 1260 for arrayIndex := 0 to genericArrayRank-1 do 1261 begin 1262 genericArrayDims[arrayIndex] := WinReadLongword(Stream); 1263 if arrayIndex=0 then 1264 arrayCount := genericArrayDims[arrayIndex] 1265 else 1266 arrayCount *= genericArrayDims[arrayIndex]; 1267 end; 1268 genericArrayItemType.category := TTypeCategory(WinReadByte(Stream)); 1269 genericArrayItemType := LoadFieldType(stream,genericArrayItemType.category); 1270 1271 newArrayObj := TSerializedArray.Create(self,genericArrayType,genericArrayItemType,genericArrayDims); 1272 setlength(objects, length(objects) + 1); 1273 objects[high(objects)] := newArrayObj; 1274 newArrayObj.idObject := result; 1275 1276 FillZeroCount := 0; 1277 if arrayCount <> 0 then 1278 for arrayIndex := 0 to arrayCount - 1 do 1279 begin 1280 if IsDotNetTypeStoredAsString(genericArrayItemType) then 1281 PString(newArrayObj.ItemPtr[arrayIndex])^ := LoadValueFromStream(Stream,genericArrayItemType) 1282 else 1283 if genericArrayItemType.category = ftPrimitiveType then 1284 Stream.Read(newArrayObj.ItemPtr[arrayIndex]^, newArrayObj.ItemSize) 1285 else 1286 begin 1287 if FillZeroCount > 0 then 1288 Dec(FillZeroCount) 1289 else 1290 begin 1291 tempIdObject := LoadNextFromStream(Stream); 1292 if tempIdObject = idArrayFiller then 1293 begin 1294 tempIdObject := 0; 1295 FillZeroCount := ArrayFillerCount; 1296 ArrayFillerCount := 0; 1297 end; 1298 if FillZeroCount > 0 then 1299 Dec(FillZeroCount) 1300 else 1301 plongword(newArrayObj.ItemPtr[arrayIndex])^ := tempIdObject; 1302 end; 1303 end; 1304 end; 1305 except 1306 on ex: Exception do 1307 raise Exception.Create('Error while reading array of object. ' + ex.Message); 1308 end; 1309 end; 790 1310 791 1311 btMethodCall, btMethodResponse: 792 raise Exception.Create('Method or not supported');1312 raise Exception.Create('Method or method response not supported'); 793 1313 794 1314 btEndOfStream: EndOfStream := True; … … 802 1322 var 803 1323 byteLength, shift: byte; 804 fullLength: longword;1324 fullLength: integer; 805 1325 utf8value: string; 806 1326 begin … … 817 1337 if Stream.Read(utf8value[1], fullLength) <> fullLength then 818 1338 raise Exception.Create('String length error'); 819 Result := Utf8ToAnsi(utf8value); 1339 Result := utf8value; 1340 end; 1341 1342 function TDotNetDeserialization.LoadDotNetCharFromStream(Stream: TStream 1343 ): string; 1344 var 1345 tempByte: byte; 1346 dataLen: Byte; 1347 utf8value: string; 1348 begin 1349 tempByte:= WinReadByte(Stream); 1350 1351 if tempByte and $80 = 0 then 1352 dataLen := 1 1353 else 1354 if tempByte and $E0 = $C0 then 1355 dataLen := 2 1356 else 1357 if tempByte and $F0 = $E0 then 1358 dataLen := 3 1359 else 1360 if tempByte and $F8 = $F0 then 1361 dataLen := 4 1362 else 1363 raise Exception.Create('Invalid UTF8 char'); 1364 1365 setlength(utf8value, dataLen); 1366 utf8value[1] := char(tempByte); 1367 Stream.Read(utf8value[2], dataLen - 1); 1368 Result := utf8value; 820 1369 end; 821 1370 … … 831 1380 begin 832 1381 ClassName := LoadStringFromStream(Stream); 833 Stream.Read(nbFields, 4);1382 nbFields := WinReadLongword(Stream); 834 1383 setlength(fieldNames, nbFields); 835 1384 setlength(fieldTypes, nbFields); … … 837 1386 fieldNames[i] := LoadStringFromStream(Stream); 838 1387 for i := 0 to nbFields - 1 do 839 Stream.Read(fieldTypes[i].category, 1);1388 fieldTypes[i].category := TTypeCategory(WinReadByte(Stream)); 840 1389 for i := 0 to nbFields - 1 do 841 begin 842 fieldTypes[i].Name := ''; 843 fieldTypes[i].refAssembly := 0; 844 fieldTypes[i].primitiveType := ptNone; 845 case fieldTypes[i].category of 846 ftPrimitiveType, ftArrayOfPrimitiveType: 847 begin 848 Stream.Read(fieldTypes[i].primitiveType, 1); 849 fieldTypes[i].Name := PrimitiveTypeName(fieldTypes[i].primitiveType); 850 if fieldTypes[i].category = ftArrayOfPrimitiveType then 851 fieldTypes[i].Name += '[]'; 852 end; 853 ftString: fieldTypes[i].Name := 'String'; 854 ftObjectType: fieldTypes[i].Name := 'Object'; 855 ftRuntimeType: fieldTypes[i].Name := LoadStringFromStream(Stream); 856 ftGenericType: 857 begin 858 fieldTypes[i].Name := LoadStringFromStream(Stream); 859 Stream.Read(fieldTypes[i].refAssembly, 4); 860 end; 861 ftArrayOfObject: fieldTypes[i].Name := 'Object[]'; 862 ftArrayOfString: fieldTypes[i].Name := 'String[]'; 863 else 864 raise Exception.Create('Unknown field type tag (' + IntToStr( 865 byte(fieldTypes[i].category)) + ')'); 866 end; 867 end; 1390 fieldTypes[i] := LoadFieldType(Stream,fieldTypes[i].category); 868 1391 if isRuntimeType then 869 1392 refAssembly := 0 870 1393 else 871 Stream.Read(refAssembly, 4);1394 refAssembly := WinReadLongword(Stream); 872 1395 end; 873 1396 except … … 906 1429 907 1430 function TDotNetDeserialization.LoadValueFromStream(Stream: TStream; 908 fieldType: TFieldType): string; 909 var 910 utf8value: string; 911 utf8len: byte; 912 tempByte: byte; 913 tempDouble: double; 914 tempSingle: single; 915 tempSByte: shortint; 916 tempUInt64: QWord; 1431 const fieldType: TFieldType): string; 1432 var 1433 data : record 1434 case byte of 1435 1: (ptr: pointer); 1436 2: (bytes: array[0..7] of byte); 1437 end; 1438 dataLen: longword; 917 1439 tempIdObject: longword; 918 1440 begin 919 1441 try 920 case fieldType.category of 921 ftPrimitiveType: case fieldType.primitiveType of 922 ptBoolean: 923 begin 924 {$hints off} 925 Stream.Read(tempByte, 1); 926 {$hints on} 927 if tempByte = 0 then 928 Result := 'False' 929 else 930 if tempByte = 1 then 931 Result := 'True' 932 else 933 raise Exception.Create('Invalid boolean value (' + 934 IntToStr(tempByte) + ')'); 935 end; 936 ptByte: 937 begin 938 {$hints off} 939 Stream.Read(tempByte, 1); 940 {$hints on} 941 Result := IntToStr(tempByte); 942 end; 943 ptChar: 944 begin 945 {$hints off} 946 Stream.Read(tempByte, 1); 947 {$hints on} 948 if tempByte and $80 = 0 then 949 utf8len := 1 950 else 951 if tempByte and $E0 = $C0 then 952 utf8len := 2 953 else 954 if tempByte and $F0 = $E0 then 955 utf8len := 3 956 else 957 if tempByte and $F8 = $F0 then 958 utf8len := 4 959 else 960 raise Exception.Create('Invalid UTF8 char'); 961 setlength(utf8value, utf8len); 962 utf8value[1] := char(tempByte); 963 Stream.Read(utf8value[2], utf8len - 1); 964 Result := Utf8ToAnsi(utf8value); 965 end; 966 ptString, ptDecimal: Result := LoadStringFromStream(Stream); 967 ptDouble: 968 begin 969 {$hints off} 970 stream.Read(tempDouble, sizeof(tempDouble)); 971 {$hints on} 972 Result := FloatToStr(tempDouble); 973 end; 974 ptInt16: 975 begin 976 Result := IntToStr(WinReadSmallInt(stream)); 977 end; 978 ptInt32: 979 begin 980 Result := IntToStr(WinReadLongInt(stream)); 981 end; 982 ptInt64: 983 begin 984 Result := IntToStr(WinReadInt64(stream)); 985 end; 986 ptSByte: 987 begin 988 {$hints off} 989 stream.Read(tempSByte, sizeof(tempSByte)); 990 {$hints on} 991 Result := IntToStr(tempSByte); 992 end; 993 ptSingle: 994 begin 995 {$hints off} 996 stream.Read(tempSingle, sizeof(tempSingle)); 997 {$hints on} 998 Result := FloatToStr(tempSingle); 999 end; 1000 ptUInt16: 1001 begin 1002 Result := IntToStr(WinReadWord(stream)); 1003 end; 1004 ptUInt32: 1005 begin 1006 Result := IntToStr(WinReadLongword(stream)); 1007 end; 1008 ptUInt64: 1009 begin 1010 Result := IntToStr(WinReadQWord(stream)); 1011 end; 1012 ptDateTime: 1013 begin 1014 tempUInt64 := WinReadQWord(stream); 1015 Result := DateTimeToStr( 1016 (tempUInt64 and $7FFFFFFFFFFFFFFF - 599264352000000000) / 864000000000); 1017 end; 1018 else 1019 raise Exception.Create('Unknown primitive type (' + IntToStr( 1020 byte(fieldType.primitiveType)) + ')'); 1442 if fieldType.Category = ftPrimitiveType then 1443 begin 1444 case fieldType.primitiveType of 1445 ptChar: Result := LoadDotNetCharFromStream(Stream); 1446 ptString, ptDecimal: Result := LoadStringFromStream(Stream); 1447 else 1448 begin 1449 dataLen := GetFieldTypeSize(fieldType); 1450 {$hints off} 1451 stream.read(data,dataLen); 1452 {$hints on} 1453 result := DotNetValueToString(data,fieldType); 1021 1454 end; 1022 ftString, ftObjectType, ftRuntimeType, ftGenericType, ftArrayOfObject, 1023 ftArrayOfString, ftArrayOfPrimitiveType: 1024 begin 1025 tempIdObject := LoadNextFromStream(stream); 1026 Result := '#' + IntToStr(tempIdObject); 1027 1028 end; 1029 else 1030 raise Exception.Create('Unknown field type (' + IntToStr( 1031 byte(fieldType.category)) + ')'); 1032 end; 1455 end; 1456 end else 1457 if fieldType.Category in [ftString, ftObjectType, ftRuntimeType, ftGenericType, ftArrayOfObject, 1458 ftArrayOfString, ftArrayOfPrimitiveType] then 1459 begin 1460 tempIdObject := LoadNextFromStream(stream); 1461 Result := '#' + IntToStr(tempIdObject); 1462 end else 1463 raise Exception.Create('Unknown field type (' + IntToStr( 1464 byte(fieldType.category)) + ')'); 1033 1465 except 1034 1466 on ex: Exception do … … 1037 1469 end; 1038 1470 1039 function TDotNetDeserialization.GetTypeOfObject(idObject: longword): integer; 1040 var 1041 i: integer; 1042 begin 1043 for i := 0 to high(objects) do 1044 if objects[i].idObject = idObject then 1045 begin 1046 Result := objects[i].numType; 1047 exit; 1048 end; 1049 raise Exception.Create('Object not found (' + IntToStr(idObject) + ')'); 1471 function TDotNetDeserialization.LoadFieldType(Stream: TStream; category: TTypeCategory 1472 ): TFieldType; 1473 begin 1474 result.category := category; 1475 result.Name := ''; 1476 result.refAssembly := 0; 1477 result.primitiveType := ptNone; 1478 case category of 1479 ftPrimitiveType, ftArrayOfPrimitiveType: 1480 begin 1481 result.primitiveType := TPrimitiveType(WinReadByte(stream)); 1482 result.Name := PrimitiveTypeName(result.primitiveType); 1483 if result.category = ftArrayOfPrimitiveType then 1484 result.Name += '[]'; 1485 end; 1486 ftString: result.Name := 'String'; 1487 ftObjectType: result.Name := 'Object'; 1488 ftRuntimeType: result.Name := LoadStringFromStream(Stream); 1489 ftGenericType: 1490 begin 1491 result.Name := LoadStringFromStream(Stream); 1492 result.refAssembly := WinReadLongword(Stream); 1493 end; 1494 ftArrayOfObject: result.Name := 'Object[]'; 1495 ftArrayOfString: result.Name := 'String[]'; 1496 else 1497 raise Exception.Create('Unknown field type tag (' + IntToStr( 1498 byte(result.category)) + ')'); 1499 end; 1050 1500 end; 1051 1501 -
GraphicTest/BGRABitmap/bgrafilters.pas
r210 r317 5 5 interface 6 6 7 { Here are some filters that can be applied to a bitmap. The filters 8 take a source image as a parameter and gives a filtered image as 9 a result. } 10 7 11 uses 8 Classes, SysUtils, BGRADefaultBitmap, BGRABitmapTypes; 9 10 function FilterMedian(bmp: TBGRADefaultBitmap; 11 Option: TMedianOption): TBGRADefaultBitmap; 12 function FilterSmartZoom3(bmp: TBGRADefaultBitmap; 13 Option: TMedianOption): TBGRADefaultBitmap; 14 function FilterSharpen(bmp: TBGRADefaultBitmap): TBGRADefaultBitmap; 15 function FilterBlurRadialPrecise(bmp: TBGRADefaultBitmap; 16 radius: single): TBGRADefaultBitmap; 17 function FilterBlurRadial(bmp: TBGRADefaultBitmap; radius: integer; 18 blurType: TRadialBlurType): TBGRADefaultBitmap; 19 function FilterBlurMotion(bmp: TBGRADefaultBitmap; distance: single; 20 angle: single; oriented: boolean): TBGRADefaultBitmap; 21 function FilterBlur(bmp: TBGRADefaultBitmap; 22 blurMask: TBGRADefaultBitmap): TBGRADefaultBitmap; 23 function FilterEmboss(bmp: TBGRADefaultBitmap; angle: single): TBGRADefaultBitmap; 24 function FilterEmbossHighlight(bmp: TBGRADefaultBitmap; 25 FillSelection: boolean): TBGRADefaultBitmap; 26 function FilterNormalize(bmp: TBGRADefaultBitmap; 27 eachChannel: boolean = True): TBGRADefaultBitmap; 28 function FilterRotate(bmp: TBGRADefaultBitmap; origin: TPointF; 29 angle: single): TBGRADefaultBitmap; 30 function FilterGrayscale(bmp: TBGRADefaultBitmap): TBGRADefaultBitmap; 31 function FilterContour(bmp: TBGRADefaultBitmap): TBGRADefaultBitmap; 32 function FilterSphere(bmp: TBGRADefaultBitmap): TBGRADefaultBitmap; 33 function FilterCylinder(bmp: TBGRADefaultBitmap): TBGRADefaultBitmap; 34 function FilterPlane(bmp: TBGRADefaultBitmap): TBGRADefaultBitmap; 12 Classes, SysUtils, BGRABitmapTypes; 13 14 { The median filter consist in calculating the median value of pixels. Here 15 a square of 9x9 pixel is considered. The median allow to select the most 16 representative colors. The option parameter allow to choose to smooth the 17 result or not. } 18 function FilterMedian(bmp: TBGRACustomBitmap; 19 Option: TMedianOption): TBGRACustomBitmap; 20 21 { SmartZoom x3 is a filter that upsizes 3 times the picture and add 22 pixels that could be logically expected (horizontal, vertical, diagonal lines) } 23 function FilterSmartZoom3(bmp: TBGRACustomBitmap; 24 Option: TMedianOption): TBGRACustomBitmap; 25 26 { Sharpen filter add more contrast between pixels } 27 function FilterSharpen(bmp: TBGRACustomBitmap): TBGRACustomBitmap; 28 29 { A radial blur applies a blur with a circular influence, i.e, each pixel 30 is merged with pixels within the specified radius. There is an exception 31 with rbFast blur, the optimization entails an hyperbolic shape. } 32 function FilterBlurRadial(bmp: TBGRACustomBitmap; radius: integer; 33 blurType: TRadialBlurType): TBGRACustomBitmap; 34 35 { The precise blur allow to specify the blur radius with subpixel accuracy } 36 function FilterBlurRadialPrecise(bmp: TBGRACustomBitmap; 37 radius: single): TBGRACustomBitmap; 38 39 { Motion blur merge pixels in a direction. The oriented parameter specifies 40 if the weights of the pixels are the same along the line or not. } 41 function FilterBlurMotion(bmp: TBGRACustomBitmap; distance: single; 42 angle: single; oriented: boolean): TBGRACustomBitmap; 43 44 function FilterPixelate(bmp: TBGRACustomBitmap; pixelSize: integer; useResample: boolean; filter: TResampleFilter = rfLinear): TBGRACustomBitmap; 45 46 { General purpose blur filter, with a blur mask as parameter to describe 47 how pixels influence each other } 48 function FilterBlur(bmp: TBGRACustomBitmap; 49 blurMask: TBGRACustomBitmap): TBGRACustomBitmap; 50 51 { Emboss filter compute a color difference in the angle direction } 52 function FilterEmboss(bmp: TBGRACustomBitmap; angle: single): TBGRACustomBitmap; 53 54 { Emboss highlight computes a sort of emboss with 45 degrees angle and 55 with standard selection color (white/black and filled with blue) } 56 function FilterEmbossHighlight(bmp: TBGRACustomBitmap; 57 FillSelection: boolean): TBGRACustomBitmap; 58 59 { Normalize use the whole available range of values, making dark colors darkest possible 60 and light colors lightest possible } 61 function FilterNormalize(bmp: TBGRACustomBitmap; 62 eachChannel: boolean = True): TBGRACustomBitmap; 63 64 { Rotate filter rotate the image and clip it in the bounding rectangle } 65 function FilterRotate(bmp: TBGRACustomBitmap; origin: TPointF; 66 angle: single): TBGRACustomBitmap; 67 68 { Grayscale converts colored pixel into grayscale with same luminosity } 69 function FilterGrayscale(bmp: TBGRACustomBitmap): TBGRACustomBitmap; 70 71 { Compute a contour, as if the image was drawn with a 2 pixels-wide black pencil } 72 function FilterContour(bmp: TBGRACustomBitmap): TBGRACustomBitmap; 73 74 { Distort the image as if it were on a sphere } 75 function FilterSphere(bmp: TBGRACustomBitmap): TBGRACustomBitmap; 76 77 { Twirl distortion, i.e. a progressive rotation } 78 function FilterTwirl(bmp: TBGRACustomBitmap; ACenter: TPoint; ARadius: Single; ATurn: Single=1; AExponent: Single=3): TBGRACustomBitmap; 79 80 { Distort the image as if it were on a vertical cylinder } 81 function FilterCylinder(bmp: TBGRACustomBitmap): TBGRACustomBitmap; 82 83 { Compute a plane projection towards infinity (SLOW) } 84 function FilterPlane(bmp: TBGRACustomBitmap): TBGRACustomBitmap; 35 85 36 86 implementation 37 87 38 uses Math ;39 40 function FilterSmartZoom3(bmp: TBGRA DefaultBitmap;41 Option: TMedianOption): TBGRA DefaultBitmap;88 uses Math, GraphType, Dialogs, BGRATransform; 89 90 function FilterSmartZoom3(bmp: TBGRACustomBitmap; 91 Option: TMedianOption): TBGRACustomBitmap; 42 92 type 43 93 TSmartDiff = record … … 48 98 xb, yb: integer; 49 99 diag1, diag2, h1, h2, v1, v2: TSmartDiff; 50 c : TBGRAPixel;51 temp, median: TBGRA DefaultBitmap;100 c,c1,c2: TBGRAPixel; 101 temp, median: TBGRACustomBitmap; 52 102 53 103 function ColorDiff(c1, c2: TBGRAPixel): single; … … 156 206 if diag1.cd < 0.3 then 157 207 begin 158 c := MergeBGRA(bmp.GetPixel(xb, yb), bmp.GetPixel(xb + 1, yb + 1)); 208 c1 := bmp.GetPixel(xb, yb); 209 c2 := bmp.GetPixel(integer(xb + 1), integer(yb + 1)); 210 c := MergeBGRA(c1, c2); 159 211 //restore 160 212 Result.SetPixel(xb * 3 + 2, yb * 3 + 2, bmp.GetPixel(xb, yb)); 161 Result.SetPixel(xb * 3 + 3, yb * 3 + 3, bmp.GetPixel( xb + 1, yb + 1));213 Result.SetPixel(xb * 3 + 3, yb * 3 + 3, bmp.GetPixel(integer(xb + 1), integer(yb + 1))); 162 214 163 215 if (diag1.sd < h1.sd) and (diag1.sd < v2.sd) then … … 173 225 if diag2.cd < 0.3 then 174 226 begin 175 c := MergeBGRA(bmp.GetPixel(xb, yb + 1), bmp.GetPixel(xb + 1, yb)); 227 c1 := bmp.GetPixel(xb, yb + 1); 228 c2 := bmp.GetPixel(xb + 1, yb); 229 c := MergeBGRA(c1, c2); 176 230 //restore 177 231 Result.SetPixel(xb * 3 + 3, yb * 3 + 2, bmp.GetPixel(xb + 1, yb)); … … 190 244 end; 191 245 192 function FilterSharpen(bmp: TBGRADefaultBitmap): TBGRADefaultBitmap; 246 { This filter compute for each pixel the mean of the eight surrounding pixels, 247 then the difference between this average pixel and the pixel at the center 248 of the square. Finally the difference is added to the new pixel, exagerating 249 its difference with its neighbours. } 250 function FilterSharpen(bmp: TBGRACustomBitmap): TBGRACustomBitmap; 193 251 const 194 252 nbpix = 8; … … 204 262 Result := bmp.NewBitmap(bmp.Width, bmp.Height); 205 263 264 //determine where pixels are in the bitmap 206 265 bounds := bmp.GetImageBounds; 207 266 if (bounds.Right <= bounds.Left) or (bounds.Bottom <= Bounds.Top) then … … 212 271 bounds.Bottom := min(bmp.Height, bounds.Bottom + 1); 213 272 273 //loop through the destination bitmap 214 274 for yb := bounds.Top to bounds.Bottom - 1 do 215 275 begin … … 217 277 for xb := bounds.Left to bounds.Right - 1 do 218 278 begin 279 //for each pixel, read eight surrounding pixels in the source bitmap 219 280 n := 0; 220 281 for dy := -1 to 1 do … … 222 283 if (dx <> 0) or (dy <> 0) then 223 284 begin 224 a_pixels[n] := bmp.GetPixel( xb + dx, yb + dy);285 a_pixels[n] := bmp.GetPixel(integer(xb + dx), integer(yb + dy)); 225 286 Inc(n); 226 287 end; 227 288 289 //compute sum 228 290 sumR := 0; 229 291 sumG := 0; … … 246 308 {$hints on} 247 309 310 //we finally have an average pixel 248 311 if (RGBdiv = 0) then 249 312 refPixel := BGRAPixelTransparent … … 256 319 end; 257 320 321 //read the pixel at the center of the square 258 322 tempPixel := bmp.GetPixel(xb, yb); 259 323 if refPixel <> BGRAPixelTransparent then 260 324 begin 325 //compute sharpened pixel by adding the difference 261 326 tempPixel.red := max(0, min(255, tempPixel.red + 262 327 integer(tempPixel.red - refPixel.red))); … … 275 340 end; 276 341 277 function FilterBlurRadialPrecise(bmp: TBGRADefaultBitmap; 278 radius: single): TBGRADefaultBitmap; 279 var 280 blurShape: TBGRADefaultBitmap; 342 { Precise blur builds a blur mask with a gradient fill and use 343 general purpose blur } 344 function FilterBlurRadialPrecise(bmp: TBGRACustomBitmap; 345 radius: single): TBGRACustomBitmap; 346 var 347 blurShape: TBGRACustomBitmap; 281 348 intRadius: integer; 282 349 begin 350 if radius = 0 then 351 begin 352 result := bmp.Duplicate; 353 exit; 354 end; 283 355 intRadius := ceil(radius); 284 blurShape := TBGRADefaultBitmap.Create(2 * intRadius + 1, 2 * intRadius + 1);356 blurShape := bmp.NewBitmap(2 * intRadius + 1, 2 * intRadius + 1); 285 357 blurShape.GradientFill(0, 0, blurShape.Width, blurShape.Height, BGRAWhite, 286 358 BGRABlack, gtRadial, pointF(intRadius, intRadius), pointF( … … 290 362 end; 291 363 292 function FilterBlurRadialNormal(bmp: TBGRADefaultBitmap; 293 radius: integer): TBGRADefaultBitmap; 294 var 295 blurShape: TBGRADefaultBitmap; 296 begin 297 blurShape := TBGRADefaultBitmap.Create(2 * radius + 1, 2 * radius + 1); 364 { This is a clever solution for fast computing of the blur 365 effect : it stores an array of vertical sums forming a square 366 around the pixel which moves with it. For each new pixel, 367 the vertical sums are kept except for the last column of 368 the square } 369 function FilterBlurFast(bmp: TBGRACustomBitmap; 370 radius: integer): TBGRACustomBitmap; 371 372 type 373 TRowSum = record 374 sumR,sumG,sumB,rgbDiv,sumA,aDiv: cardinal; 375 end; 376 377 function ComputeAverage(sum: TRowSum): TBGRAPixel; 378 begin 379 result.alpha:= (sum.sumA+sum.aDiv shr 1) div sum.aDiv; 380 result.red := (sum.sumR+sum.rgbDiv shr 1) div sum.rgbDiv; 381 result.green := (sum.sumG+sum.rgbDiv shr 1) div sum.rgbDiv; 382 result.blue := (sum.sumB+sum.rgbDiv shr 1) div sum.rgbDiv; 383 end; 384 385 {$I blurfast.inc} 386 387 { Normal radial blur compute a blur mask with a GradientFill and 388 then posterize to optimize general purpose blur } 389 function FilterBlurRadialNormal(bmp: TBGRACustomBitmap; 390 radius: integer): TBGRACustomBitmap; 391 var 392 blurShape: TBGRACustomBitmap; 393 n: Integer; 394 p: PBGRAPixel; 395 begin 396 blurShape := bmp.NewBitmap(2 * radius + 1, 2 * radius + 1); 298 397 blurShape.GradientFill(0, 0, blurShape.Width, blurShape.Height, BGRAWhite, 299 398 BGRABlack, gtRadial, pointF(radius, radius), pointF(-0.5, radius), dmSet); 399 p := blurShape.Data; 400 for n := 0 to blurShape.NbPixels-1 do 401 begin 402 p^.red := p^.red and $F0; 403 p^.green := p^.red; 404 p^.blue := p^.red; 405 inc(p); 406 end; 300 407 Result := FilterBlur(bmp, blurShape); 301 408 blurShape.Free; 302 409 end; 303 410 304 function FilterBlurDisk(bmp: TBGRADefaultBitmap; radius: integer): TBGRADefaultBitmap; 305 var 306 blurShape: TBGRADefaultBitmap; 307 begin 308 blurShape := TBGRADefaultBitmap.Create(2 * radius + 1, 2 * radius + 1); 411 { Blur disk creates a disk mask with a FillEllipse } 412 function FilterBlurDisk(bmp: TBGRACustomBitmap; radius: integer): TBGRACustomBitmap; 413 var 414 blurShape: TBGRACustomBitmap; 415 begin 416 blurShape := bmp.NewBitmap(2 * radius + 1, 2 * radius + 1); 309 417 blurShape.Fill(BGRABlack); 310 418 blurShape.FillEllipseAntialias(radius, radius, radius + 0.5, radius + 0.5, BGRAWhite); … … 313 421 end; 314 422 315 function FilterBlurCorona(bmp: TBGRADefaultBitmap; radius: integer): TBGRADefaultBitmap; 316 var 317 blurShape: TBGRADefaultBitmap; 318 begin 319 blurShape := TBGRADefaultBitmap.Create(2 * radius + 1, 2 * radius + 1); 423 { Corona blur use a circle as mask } 424 function FilterBlurCorona(bmp: TBGRACustomBitmap; radius: integer): TBGRACustomBitmap; 425 var 426 blurShape: TBGRACustomBitmap; 427 begin 428 blurShape := bmp.NewBitmap(2 * radius + 1, 2 * radius + 1); 320 429 blurShape.Fill(BGRABlack); 321 430 blurShape.EllipseAntialias(radius, radius, radius, radius, BGRAWhite, 1); … … 324 433 end; 325 434 326 function FilterBlurRadial(bmp: TBGRADefaultBitmap; radius: integer; 327 blurType: TRadialBlurType): TBGRADefaultBitmap; 328 begin 435 function FilterBlurRadial(bmp: TBGRACustomBitmap; radius: integer; 436 blurType: TRadialBlurType): TBGRACustomBitmap; 437 begin 438 if radius = 0 then 439 begin 440 result := bmp.Duplicate; 441 exit; 442 end; 329 443 case blurType of 330 444 rbCorona: Result := FilterBlurCorona(bmp, radius); 331 445 rbDisk: Result := FilterBlurDisk(bmp, radius); 332 446 rbNormal: Result := FilterBlurRadialNormal(bmp, radius); 447 rbFast: Result := FilterBlurFast(bmp, radius); 333 448 rbPrecise: Result := FilterBlurRadialPrecise(bmp, radius / 10); 334 449 else … … 337 452 end; 338 453 339 function FilterBlurMotion(bmp: TBGRADefaultBitmap; distance: single; 340 angle: single; oriented: boolean): TBGRADefaultBitmap; 341 var 342 blurShape: TBGRADefaultBitmap; 454 { This filter draws an antialiased line to make the mask, and 455 if the motion blur is oriented, does a GradientFill to orient it } 456 function FilterBlurMotion(bmp: TBGRACustomBitmap; distance: single; 457 angle: single; oriented: boolean): TBGRACustomBitmap; 458 var 459 blurShape: TBGRACustomBitmap; 343 460 intRadius: integer; 344 461 dx, dy, d: single; 345 462 begin 463 if distance = 0 then 464 begin 465 result := bmp.Duplicate; 466 exit; 467 end; 346 468 intRadius := ceil(distance / 2); 347 blurShape := TBGRADefaultBitmap.Create(2 * intRadius + 1, 2 * intRadius + 1);469 blurShape := bmp.NewBitmap(2 * intRadius + 1, 2 * intRadius + 1); 348 470 d := distance / 2; 349 471 dx := cos(angle * Pi / 180); … … 362 484 end; 363 485 364 function FilterBlur(bmp: TBGRADefaultBitmap; 365 blurMask: TBGRADefaultBitmap): TBGRADefaultBitmap; 366 var 367 yb, xb: integer; 368 dx, dy, mindx, maxdx, mindy, maxdy, n, j: integer; 369 a_pixels: array of TBGRAPixel; 370 weights: array of integer; 371 sumR, sumG, sumB, sumA, Adiv, RGBdiv: cardinal; 372 RGBweight: byte; 373 tempPixel, refPixel: TBGRAPixel; 374 shapeMatrix: array of array of byte; 375 pdest, psrc: PBGRAPixel; 376 blurOfs: TPoint; 377 bounds: TRect; 378 begin 379 blurOfs := point(blurMask.Width shr 1, blurMask.Height shr 1); 380 381 setlength(shapeMatrix, blurMask.Width, blurMask.Height); 382 n := 0; 383 for yb := 0 to blurMask.Height - 1 do 384 for xb := 0 to blurMask.Width - 1 do 385 begin 386 shapeMatrix[yb, xb] := blurMask.GetPixel(xb, yb).red; 387 if shapeMatrix[yb, xb] <> 0 then 388 Inc(n); 389 end; 390 391 setlength(a_pixels, n); 392 setlength(weights, n); 393 394 Result := bmp.NewBitmap(bmp.Width, bmp.Height); 395 bounds := bmp.GetImageBounds; 396 if (bounds.Right <= bounds.Left) or (bounds.Bottom <= Bounds.Top) then 486 { General purpose blur : compute pixel sum according to the mask and then 487 compute only difference while scanning from the left to the right } 488 function FilterBlurSmallMask(bmp: TBGRACustomBitmap; 489 blurMask: TBGRACustomBitmap): TBGRACustomBitmap; forward; 490 function FilterBlurSmallMaskWithShift(bmp: TBGRACustomBitmap; 491 blurMask: TBGRACustomBitmap; maskShift: integer): TBGRACustomBitmap; forward; 492 function FilterBlurBigMask(bmp: TBGRACustomBitmap; 493 blurMask: TBGRACustomBitmap): TBGRACustomBitmap; forward; 494 495 //make sure value is in the range 0..255 496 function clampByte(value: integer): byte; inline; 497 begin 498 if value < 0 then result := 0 else 499 if value > 255 then result := 255 else 500 result := value; 501 end; 502 503 function FilterPixelate(bmp: TBGRACustomBitmap; pixelSize: integer; 504 useResample: boolean; filter: TResampleFilter): TBGRACustomBitmap; 505 var yb,xb, xs,ys, tx,ty: integer; 506 psrc,pdest: PBGRAPixel; 507 temp,stretched: TBGRACustomBitmap; 508 oldfilter: TResampleFilter; 509 begin 510 if pixelSize < 1 then 511 begin 512 result := bmp.Duplicate; 397 513 exit; 398 bounds.Left := max(0, bounds.Left - blurOfs.X); 399 bounds.Top := max(0, bounds.Top - blurOfs.Y); 400 bounds.Right := min(bmp.Width, bounds.Right + blurMask.Width - 1 - blurOfs.X); 401 bounds.Bottom := min(bmp.Height, bounds.Bottom + blurMask.Height - 1 - blurOfs.Y); 402 403 for yb := bounds.Top to bounds.Bottom - 1 do 404 begin 405 pdest := Result.ScanLine[yb] + bounds.Left; 406 for xb := bounds.Left to Bounds.Right - 1 do 407 begin 408 n := 0; 409 mindx := max(-blurOfs.X, -xb); 410 mindy := max(-blurOfs.Y, -yb); 411 maxdx := min(blurMask.Width - 1 - blurOfs.X, bmp.Width - 1 - xb); 412 maxdy := min(blurMask.Height - 1 - blurOfs.Y, bmp.Height - 1 - yb); 413 for dy := mindy to maxdy do 414 begin 415 psrc := bmp.scanline[yb + dy] + (xb + mindx); 416 for dx := mindx to maxdx do 417 begin 418 j := shapeMatrix[dy + blurOfs.Y, dx + blurOfs.X]; 419 if j <> 0 then 420 begin 421 a_pixels[n] := psrc^; 422 weights[n] := (a_pixels[n].alpha * j + 127) shr 8; 423 Inc(n); 424 end; 425 Inc(psrc); 426 end; 514 end; 515 result := bmp.NewBitmap(bmp.Width,bmp.Height); 516 517 tx := (bmp.Width+pixelSize-1) div pixelSize; 518 ty := (bmp.Height+pixelSize-1) div pixelSize; 519 if not useResample then 520 begin 521 temp := bmp.NewBitmap(tx,ty); 522 523 xs := (bmp.Width mod pixelSize) div 2; 524 ys := (bmp.Height mod pixelSize) div 2; 525 526 for yb := 0 to temp.height-1 do 527 begin 528 pdest := temp.ScanLine[yb]; 529 psrc := bmp.scanline[ys]+xs; 530 inc(ys,pixelSize); 531 for xb := 0 to temp.width-1 do 532 begin 533 pdest^ := psrc^; 534 inc(pdest); 535 inc(psrc,pixelSize); 427 536 end; 428 sumR := 0; 429 sumG := 0; 430 sumB := 0; 431 sumA := 0; 432 Adiv := 0; 433 RGBdiv := 0; 434 435 {$hints off} 436 for j := 0 to n - 1 do 437 begin 438 tempPixel := a_pixels[j]; 439 RGBweight := (weights[j] * tempPixel.alpha + 128) div 255; 440 sumR += tempPixel.red * RGBweight; 441 sumG += tempPixel.green * RGBweight; 442 sumB += tempPixel.blue * RGBweight; 443 RGBdiv += RGBweight; 444 sumA += tempPixel.alpha; 445 Adiv += 1; 446 end; 447 {$hints on} 448 449 if (Adiv = 0) or (RGBdiv = 0) then 450 refPixel := BGRAPixelTransparent 451 else 452 begin 453 refPixel.alpha := (sumA + Adiv shr 1) div Adiv; 454 if refPixel.alpha = 0 then 455 refPixel := BGRAPixelTransparent 456 else 457 begin 458 refPixel.red := (sumR + RGBdiv shr 1) div RGBdiv; 459 refPixel.green := (sumG + RGBdiv shr 1) div RGBdiv; 460 refPixel.blue := (sumB + RGBdiv shr 1) div RGBdiv; 461 end; 462 end; 463 464 pdest^ := refPixel; 465 Inc(pdest); 466 end; 467 end; 468 Result.InvalidateBitmap; 469 end; 470 471 function FilterEmboss(bmp: TBGRADefaultBitmap; angle: single): TBGRADefaultBitmap; 537 end; 538 temp.InvalidateBitmap; 539 end else 540 begin 541 oldfilter := bmp.ResampleFilter; 542 bmp.ResampleFilter := filter; 543 temp := bmp.Resample(tx,ty,rmFineResample); 544 bmp.ResampleFilter := oldfilter; 545 end; 546 stretched := temp.Resample(temp.Width*pixelSize,temp.Height*pixelSize,rmSimpleStretch); 547 temp.free; 548 if bmp.Width mod pixelSize = 0 then 549 xs := 0 550 else 551 xs := (-pixelSize+(bmp.Width mod pixelSize)) div 2; 552 if bmp.Height mod pixelSize = 0 then 553 ys := 0 554 else 555 ys := (-pixelSize+(bmp.Height mod pixelSize)) div 2; 556 result.PutImage(xs,ys,stretched,dmSet); 557 stretched.Free; 558 end; 559 560 function FilterBlur(bmp: TBGRACustomBitmap; 561 blurMask: TBGRACustomBitmap): TBGRACustomBitmap; 562 var 563 maskSum: int64; 564 i: Integer; 565 p: PBGRAPixel; 566 maskShift: integer; 567 begin 568 maskSum := 0; 569 p := blurMask.data; 570 for i := 0 to blurMask.NbPixels-1 do 571 begin 572 inc(maskSum,p^.red); 573 inc(p); 574 end; 575 maskShift := 0; 576 while maskSum > 32768 do 577 begin 578 inc(maskShift); 579 maskSum := maskSum shr 1; 580 end; 581 //check if sum can be stored in a 32-bit signed integer 582 if maskShift = 0 then 583 result := FilterBlurSmallMask(bmp,blurMask) else 584 if maskShift < 8 then 585 result := FilterBlurSmallMaskWithShift(bmp,blurMask,maskShift) else 586 result := FilterBlurBigMask(bmp,blurMask); 587 end; 588 589 //32-bit blur with shift 590 function FilterBlurSmallMaskWithShift(bmp: TBGRACustomBitmap; 591 blurMask: TBGRACustomBitmap; maskShift: integer): TBGRACustomBitmap; 592 593 var 594 sumR, sumG, sumB, sumA, Adiv, RGBdiv : integer; 595 596 function ComputeAverage: TBGRAPixel; inline; 597 begin 598 result.alpha := (sumA + Adiv shr 1) div Adiv; 599 if result.alpha = 0 then 600 result := BGRAPixelTransparent 601 else 602 begin 603 result.red := clampByte((sumR + RGBdiv shr 1) div RGBdiv); 604 result.green := clampByte((sumG + RGBdiv shr 1) div RGBdiv); 605 result.blue := clampByte((sumB + RGBdiv shr 1) div RGBdiv); 606 end; 607 end; 608 609 {$define PARAM_MASKSHIFT} 610 {$I blurnormal.inc} 611 612 //32-bit blur 613 function FilterBlurSmallMask(bmp: TBGRACustomBitmap; 614 blurMask: TBGRACustomBitmap): TBGRACustomBitmap; 615 616 var 617 sumR, sumG, sumB, sumA, Adiv : integer; 618 619 function ComputeAverage: TBGRAPixel; inline; 620 begin 621 result.alpha := (sumA + Adiv shr 1) div Adiv; 622 if result.alpha = 0 then 623 result := BGRAPixelTransparent 624 else 625 begin 626 result.red := clampByte((sumR + sumA shr 1) div sumA); 627 result.green := clampByte((sumG + sumA shr 1) div sumA); 628 result.blue := clampByte((sumB + sumA shr 1) div sumA); 629 end; 630 end; 631 632 {$I blurnormal.inc} 633 634 //floating point blur 635 function FilterBlurBigMask(bmp: TBGRACustomBitmap; 636 blurMask: TBGRACustomBitmap): TBGRACustomBitmap; 637 638 var 639 sumR, sumG, sumB, sumA, Adiv : single; 640 641 function ComputeAverage: TBGRAPixel; inline; 642 begin 643 result.alpha := round(sumA/Adiv); 644 if result.alpha = 0 then 645 result := BGRAPixelTransparent 646 else 647 begin 648 result.red := clampByte(round(sumR/sumA)); 649 result.green := clampByte(round(sumG/sumA)); 650 result.blue := clampByte(round(sumB/sumA)); 651 end; 652 end; 653 654 {$I blurnormal.inc} 655 656 { Emboss filter computes the difference between each pixel and the surrounding pixels 657 in the specified direction. } 658 function FilterEmboss(bmp: TBGRACustomBitmap; angle: single): TBGRACustomBitmap; 472 659 var 473 660 yb, xb: integer; … … 475 662 idx1, idy1, idx2, idy2, idx3, idy3, idx4, idy4: integer; 476 663 w: array[1..4] of single; 477 iw: integer;664 iw: cardinal; 478 665 c: array[0..4] of TBGRAPixel; 479 666 … … 485 672 bounds: TRect; 486 673 begin 674 //compute pixel position and weight 487 675 dx := cos(angle * Pi / 180); 488 676 dy := sin(angle * Pi / 180); … … 501 689 w[4] := (1 - abs(idx4 - dx)) * (1 - abs(idy4 - dy)); 502 690 691 //fill with gray 503 692 Result := bmp.NewBitmap(bmp.Width, bmp.Height); 504 693 Result.Fill(BGRA(128, 128, 128, 255)); … … 512 701 bounds.Bottom := min(bmp.Height, bounds.Bottom + 1); 513 702 703 //loop through destination 514 704 for yb := bounds.Top to bounds.bottom - 1 do 515 705 begin … … 518 708 begin 519 709 c[0] := bmp.getPixel(xb, yb); 520 c[1] := bmp.getPixel( xb + idx1, yb + idy1);521 c[2] := bmp.getPixel( xb + idx2, yb + idy2);522 c[3] := bmp.getPixel( xb + idx3, yb + idy3);523 c[4] := bmp.getPixel( xb + idx4, yb + idy4);710 c[1] := bmp.getPixel(integer(xb + idx1), integer(yb + idy1)); 711 c[2] := bmp.getPixel(integer(xb + idx2), integer(yb + idy2)); 712 c[3] := bmp.getPixel(integer(xb + idx3), integer(yb + idy3)); 713 c[4] := bmp.getPixel(integer(xb + idx4), integer(yb + idy4)); 524 714 525 715 sumR := 0; … … 530 720 RGBdiv := 0; 531 721 722 //compute sum 532 723 {$hints off} 533 724 for i := 1 to 4 do … … 546 737 {$hints on} 547 738 739 //average 548 740 if (Adiv = 0) or (RGBdiv = 0) then 549 741 refPixel := c[0] … … 555 747 refPixel.alpha := (sumA * 255 + Adiv shr 1) div Adiv; 556 748 end; 749 750 //difference with center pixel 557 751 {$hints off} 558 752 tempPixel.red := max(0, min(512 * 255, 65536 + refPixel.red * … … 571 765 end; 572 766 573 function FilterEmbossHighlight(bmp: TBGRADefaultBitmap; 574 FillSelection: boolean): TBGRADefaultBitmap; 767 { Like general emboss, but with fixed direction and automatic color with transparency } 768 function FilterEmbossHighlight(bmp: TBGRACustomBitmap; 769 FillSelection: boolean): TBGRACustomBitmap; 575 770 var 576 771 yb, xb: integer; … … 710 905 end; 711 906 712 function FilterNormalize(bmp: TBGRADefaultBitmap; 713 eachChannel: boolean = True): TBGRADefaultBitmap; 907 { Normalize compute min-max of specified channel and apply an affine transformation 908 to make it use the full range of values } 909 function FilterNormalize(bmp: TBGRACustomBitmap; 910 eachChannel: boolean = True): TBGRACustomBitmap; 714 911 var 715 912 psrc, pdest: PBGRAPixel; … … 831 1028 end; 832 1029 833 function FilterRotate(bmp: TBGRADefaultBitmap; origin: TPointF; 834 angle: single): TBGRADefaultBitmap; 1030 { Rotates the image. To do this, loop through the destination and 1031 calculates the position in the source bitmap with an affine transformation } 1032 function FilterRotate(bmp: TBGRACustomBitmap; origin: TPointF; 1033 angle: single): TBGRACustomBitmap; 835 1034 var 836 1035 bounds: TRect; … … 926 1125 end; 927 1126 928 function FilterGrayscale(bmp: TBGRADefaultBitmap): TBGRADefaultBitmap; 1127 { Filter grayscale applies BGRAToGrayscale function to all pixels } 1128 function FilterGrayscale(bmp: TBGRACustomBitmap): TBGRACustomBitmap; 929 1129 var 930 1130 bounds: TRect; … … 952 1152 end; 953 1153 954 function FilterContour(bmp: TBGRADefaultBitmap): TBGRADefaultBitmap; 1154 { Filter contour compute a grayscale image, then for each pixel 1155 calculates the difference with surrounding pixels (in intensity and alpha) 1156 and draw black pixels when there is a difference } 1157 function FilterContour(bmp: TBGRACustomBitmap): TBGRACustomBitmap; 955 1158 var 956 1159 yb, xb: integer; … … 964 1167 965 1168 bounds: TRect; 966 gray: TBGRA DefaultBitmap;1169 gray: TBGRACustomBitmap; 967 1170 begin 968 1171 bmpWidth := bmp.Width; … … 1066 1269 end; 1067 1270 1068 function FilterSphere(bmp: TBGRADefaultBitmap): TBGRADefaultBitmap; 1271 { Compute the distance for each pixel to the center of the bitmap, 1272 calculate the corresponding angle with arcsin, use this angle 1273 to determine a distance from the center in the source bitmap } 1274 function FilterSphere(bmp: TBGRACustomBitmap): TBGRACustomBitmap; 1069 1275 var 1070 1276 cx, cy, x, y, len, fact: single; 1071 1277 xb, yb: integer; 1072 mask: TBGRA DefaultBitmap;1278 mask: TBGRACustomBitmap; 1073 1279 begin 1074 1280 Result := bmp.NewBitmap(bmp.Width, bmp.Height); … … 1099 1305 end; 1100 1306 1101 function FilterCylinder(bmp: TBGRADefaultBitmap): TBGRADefaultBitmap; 1307 { Applies twirl scanner. See TBGRATwirlScanner } 1308 function FilterTwirl(bmp: TBGRACustomBitmap; ACenter: TPoint; ARadius: Single; ATurn: Single=1; AExponent: Single=3): TBGRACustomBitmap; 1309 var twirl: TBGRATwirlScanner; 1310 begin 1311 twirl := TBGRATwirlScanner.Create(bmp,ACenter,ARadius,ATurn,AExponent); 1312 Result := bmp.NewBitmap(bmp.Width, bmp.Height); 1313 result.Fill(twirl); 1314 twirl.free; 1315 end; 1316 1317 { Compute the distance for each pixel to the vertical axis of the bitmap, 1318 calculate the corresponding angle with arcsin, use this angle 1319 to determine a distance from the vertical axis in the source bitmap } 1320 function FilterCylinder(bmp: TBGRACustomBitmap): TBGRACustomBitmap; 1102 1321 var 1103 1322 cx, cy, x, y, len, fact: single; … … 1125 1344 end; 1126 1345 1127 function FilterPlane(bmp: TBGRA DefaultBitmap): TBGRADefaultBitmap;1346 function FilterPlane(bmp: TBGRACustomBitmap): TBGRACustomBitmap; 1128 1347 const resampleGap=0.6; 1129 1348 var 1130 1349 cy, x1, x2, y1, y2, z1, z2, h: single; 1131 1350 yb: integer; 1132 resampledBmp: TBGRA DefaultBitmap;1351 resampledBmp: TBGRACustomBitmap; 1133 1352 resampledBmpWidth: integer; 1134 1353 resampledFactor,newResampleFactor: single; 1135 sub,resampledSub: TBGRA DefaultBitmap;1354 sub,resampledSub: TBGRACustomBitmap; 1136 1355 partRect: TRect; 1137 1356 resampleSizeY : integer; … … 1191 1410 end; 1192 1411 1193 function FilterMedian(bmp: TBGRADefaultBitmap; 1194 Option: TMedianOption): TBGRADefaultBitmap; 1412 { For each component, sort values to get the median } 1413 function FilterMedian(bmp: TBGRACustomBitmap; 1414 Option: TMedianOption): TBGRACustomBitmap; 1195 1415 1196 1416 function ComparePixLt(p1, p2: TBGRAPixel): boolean; … … 1236 1456 for dx := -1 to 1 do 1237 1457 begin 1238 a_pixels[n] := bmp.GetPixel( xb + dx, yb + dy);1458 a_pixels[n] := bmp.GetPixel(integer(xb + dx), integer(yb + dy)); 1239 1459 if a_pixels[n].alpha = 0 then 1240 1460 a_pixels[n] := BGRAPixelTransparent; -
GraphicTest/BGRABitmap/bgragtkbitmap.pas
r210 r317 37 37 private 38 38 FPixBuf: Pointer; 39 procedure SlowDrawTransparent(ABitmap: TBGRADefaultBitmap; 40 ACanvas: TCanvas; ARect: TRect); 39 { procedure SlowDrawTransparent(ABitmap: TBGRADefaultBitmap; 40 ACanvas: TCanvas; ARect: TRect);} 41 procedure DrawTransparent(ACanvas: TCanvas; Rect: TRect); 42 procedure DrawOpaque(ACanvas: TCanvas; Rect: TRect); 41 43 protected 42 44 procedure ReallocData; override; 43 45 procedure FreeData; override; 44 procedure DrawOpaque(ACanvas: TCanvas; Rect: TRect);45 46 public 46 47 procedure DataDrawTransparent(ACanvas: TCanvas; Rect: TRect; … … 50 51 procedure Draw(ACanvas: TCanvas; Rect: TRect; Opaque: boolean = True); override; 51 52 procedure DataDrawOpaque(ACanvas: TCanvas; Rect: TRect; AData: Pointer; 52 ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); 53 override; 53 ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); override; 54 54 procedure GetImageFromCanvas(CanvasSource: TCanvas; x, y: integer); override; 55 55 end; … … 71 71 {$ENDIF} 72 72 73 procedure TBGRAGtkBitmap.SlowDrawTransparent(ABitmap: TBGRADefaultBitmap;73 {procedure TBGRAGtkBitmap.SlowDrawTransparent(ABitmap: TBGRADefaultBitmap; 74 74 ACanvas: TCanvas; ARect: TRect); 75 75 var 76 background, temp: TBGRA DefaultBitmap;76 background, temp: TBGRACustomBitmap; 77 77 w, h: integer; 78 78 … … 92 92 background.Draw(ACanvas, ARect.Left, ARect.Top, True); 93 93 background.Free; 94 end; 94 end;} 95 95 96 96 procedure TBGRAGtkBitmap.ReallocData; 97 97 begin 98 {$IFDEF LCLgtk2} 99 If FPixBuf <> nil then g_object_unref(FPixBuf); 100 {$ELSE} 101 If FPixBuf <> nil then gdk_pixbuf_unref(FPixBuf); 102 {$ENDIF} 103 FPixBuf := nil; 98 104 inherited ReallocData; 99 FPixbuf := gdk_pixbuf_new_from_data(pguchar(FData), 100 GDK_COLORSPACE_RGB, True, 8, Width, Height, Width*Sizeof(TBGRAPixel), nil, nil); 101 if FPixbuf = nil then 102 raise Exception.Create('Error initializing Pixbuf'); 105 if (FWidth <> 0) and (FHeight <> 0) then 106 begin 107 FPixbuf := gdk_pixbuf_new_from_data(pguchar(FData), 108 GDK_COLORSPACE_RGB, True, 8, Width, Height, Width*Sizeof(TBGRAPixel), nil, nil); 109 if FPixbuf = nil then 110 raise Exception.Create('Error initializing Pixbuf'); 111 end; 103 112 end; 104 113 … … 114 123 end; 115 124 116 procedure TBGRAGtkBitmap.Draw Opaque(ACanvas: TCanvas; Rect: TRect);125 procedure TBGRAGtkBitmap.DrawTransparent(ACanvas: TCanvas; Rect: TRect); 117 126 var DrawWidth,DrawHeight: integer; 118 127 stretched: TBGRAGtkBitmap; … … 126 135 begin 127 136 stretched := Resample(DrawWidth,DrawHeight,rmSimpleStretch) as TBGRAGtkBitmap; 128 stretched.Draw Opaque(ACanvas,Rect);137 stretched.DrawTransparent(ACanvas,Rect); 129 138 stretched.Free; 130 139 exit; 131 140 end; 132 141 133 //SwapRedBlue;142 SwapRedBlue; 134 143 gdk_pixbuf_render_to_drawable(FPixBuf, 135 144 TGtkDeviceContext(ACanvas.Handle).Drawable, … … 140 149 Width,Height, 141 150 GDK_RGB_DITHER_NORMAL,0,0); 142 //SwapRedBlue; 151 SwapRedBlue; 152 end; 153 154 procedure TBGRAGtkBitmap.DrawOpaque(ACanvas: TCanvas; Rect: TRect); 155 begin 156 DataDrawOpaque(ACanvas,Rect,Data,LineOrder,Width,Height); 143 157 end; 144 158 … … 146 160 AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); 147 161 var 148 Temp: TBGRAPtrBitmap; 149 begin 150 Temp := TBGRAPtrBitmap.Create(AWidth, AHeight, AData); 151 Temp.LineOrder := ALineOrder; 152 SlowDrawTransparent(Temp, ACanvas, Rect); 153 Temp.Free; 162 TempGtk: TBGRAGtkBitmap; 163 temp: integer; 164 begin 165 if (AHeight = 0) or (AWidth = 0) or (Rect.Left = Rect.Right) or 166 (Rect.Top = Rect.Bottom) then 167 exit; 168 169 if Rect.Right < Rect.Left then 170 begin 171 temp := Rect.Left; 172 Rect.Left := Rect.Right; 173 Rect.Right := temp; 174 end; 175 176 if Rect.Bottom < Rect.Top then 177 begin 178 temp := Rect.Top; 179 Rect.Top := Rect.Bottom; 180 Rect.Bottom := temp; 181 end; 182 183 TempGtk := TBGRAGtkBitmap.Create(AWidth, AHeight); 184 Move(AData^,TempGtk.Data^,TempGtk.NbPixels*sizeof(TBGRAPixel)); 185 if ALineOrder <> TempGtk.LineOrder then TempGtk.VerticalFlip; 186 TempGtk.DrawTransparent(ACanvas,Rect); 187 TempGtk.Free; 154 188 end; 155 189 … … 161 195 DrawOpaque(ACanvas, Rect(X, Y, X + Width, Y + Height)) 162 196 else 163 SlowDrawTransparent(Self,ACanvas, Rect(X, Y, X + Width, Y + Height));197 DrawTransparent(ACanvas, Rect(X, Y, X + Width, Y + Height)); 164 198 end; 165 199 … … 171 205 DrawOpaque(ACanvas, Rect) 172 206 else 173 SlowDrawTransparent(Self,ACanvas, Rect);207 DrawTransparent(ACanvas, Rect); 174 208 end; 175 209 176 210 procedure TBGRAGtkBitmap.DataDrawOpaque(ACanvas: TCanvas; Rect: TRect; 177 211 AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); 178 var stretched: TBGRADefaultBitmap; 179 begin 180 if (AHeight = 0) or (AWidth = 0) then 181 exit; 182 183 if (AWidth <> Width) or (AHeight <> Height) then 184 begin 185 stretched := Resample(AWidth,AHeight,rmSimpleStretch); 186 stretched.DataDrawOpaque(ACanvas,Rect,AData,stretched.LineOrder,AWidth,AHeight) 187 end; 188 212 var ptr: TBGRAPtrBitmap; 213 stretched: TBGRACustomBitmap; 214 temp: integer; 215 pos: TPoint; 216 dest: HDC; 217 begin 218 if (AHeight = 0) or (AWidth = 0) or (Rect.Left = Rect.Right) or 219 (Rect.Top = Rect.Bottom) then 220 exit; 221 222 if Rect.Right < Rect.Left then 223 begin 224 temp := Rect.Left; 225 Rect.Left := Rect.Right; 226 Rect.Right := temp; 227 end; 228 229 if Rect.Bottom < Rect.Top then 230 begin 231 temp := Rect.Top; 232 Rect.Top := Rect.Bottom; 233 Rect.Bottom := temp; 234 end; 235 236 if (AWidth <> Rect.Right-Rect.Left) or (AHeight <> Rect.Bottom-Rect.Top) then 237 begin 238 ptr := TBGRAPtrBitmap.Create(AWidth,AHeight,AData); 239 ptr.LineOrder := ALineOrder; 240 stretched := ptr.Resample(Rect.Right-Rect.Left,Rect.Bottom-Rect.Top); 241 ptr.free; 242 DataDrawOpaque(ACanvas,Rect,AData,stretched.LineOrder,stretched.Width,stretched.Height); 243 stretched.Free; 244 exit; 245 end; 246 247 dest := ACanvas.Handle; 248 pos := TGtkDeviceContext(dest).Offset; 249 pos.X += rect.Left; 250 pos.Y += rect.Top; 189 251 If ALineOrder = riloBottomToTop then VerticalFlip; 190 252 SwapRedBlue; 191 gdk_pixbuf_render_to_drawable(FPixBuf, 192 TGtkDeviceContext(ACanvas.Handle).Drawable, 193 TGtkDeviceContext(ACanvas.Handle).GC, 194 0,0,Rect.Left,Rect.Top,AWidth,AHeight, 195 GDK_RGB_DITHER_NORMAL,0,0); 253 gdk_draw_rgb_32_image(TGtkDeviceContext(dest).Drawable, 254 TGtkDeviceContext(Dest).GC, pos.X,pos.Y, 255 AWidth,AHeight, GDK_RGB_DITHER_NORMAL, 256 AData, AWidth*sizeof(TBGRAPixel)); 196 257 SwapRedBlue; 197 258 If ALineOrder = riloBottomToTop then VerticalFlip; … … 200 261 procedure TBGRAGtkBitmap.GetImageFromCanvas(CanvasSource: TCanvas; x, y: integer); 201 262 var 202 subBmp: TBGRA DefaultBitmap;263 subBmp: TBGRACustomBitmap; 203 264 subRect: TRect; 204 265 cw,ch: integer; … … 240 301 end. 241 302 303 -
GraphicTest/BGRABitmap/bgrapaintnet.pas
r210 r317 5 5 interface 6 6 7 { This unit reads Paint.NET files. It needs BGRADNetDeserial to deserialize binary .Net objects. 8 9 A Paint.NET image consists in three parts : 10 - Xml header 11 - Binary serialized information (contains layer information) 12 - Compressed data (pixel data) 13 14 The class TPaintDotNetFile do not read the Xml header. ComputeFlatImage builds the resulting image 15 by using blending operations to merge layers. 16 17 The unit registers a TFPCustomImageReader so that it can be read by any image reading function of FreePascal } 18 7 19 uses 8 Classes, SysUtils, BGRADNetDeserial, BGRA Bitmap, BGRABitmapTypes;20 Classes, SysUtils, BGRADNetDeserial, BGRALayers, BGRABitmap, BGRABitmapTypes, FPImage; 9 21 10 22 type … … 12 24 { TPaintDotNetFile } 13 25 14 TPaintDotNetFile = class 26 TPaintDotNetFile = class(TBGRACustomLayeredBitmap) 15 27 public 16 procedure LoadFromFile(filename: string); 17 procedure LoadFromStream(stream: TStream); 18 procedure Clear; 19 function ToString: string;20 destructor Destroy; override;28 procedure LoadFromFile(filename: string); override; 29 procedure LoadFromStream(stream: TStream); override; 30 procedure Clear; override; 31 function ToString: ansistring; override; 32 function GetLayerBitmapCopy(layer: integer): TBGRABitmap; override; 21 33 constructor Create; 22 function Width: integer; 23 function Height: integer; 24 function NbLayers: integer; 25 function BlendOperation(Layer: integer): TBlendOperation; 26 function LayerVisible(layer: integer): boolean; 27 function LayerOpacity(layer: integer): byte; 28 function LayerName(layer: integer): string; 29 function MakeBitmapLayer(layer: integer): TBGRABitmap; 30 function ComputeFlatImage: TBGRABitmap; 34 protected 35 function GetWidth: integer; override; 36 function GetHeight: integer; override; 37 function GetNbLayers: integer; override; 38 function GetBlendOperation(Layer: integer): TBlendOperation; override; 39 function GetLayerVisible(layer: integer): boolean; override; 40 function GetLayerOpacity(layer: integer): byte; override; 41 function GetLayerName(layer: integer): string; override; 31 42 private 32 43 XmlHeader: string; 33 44 ThumbNail: TBGRABitmap; 34 45 Content: TDotNetDeserialization; 35 Document: PSerializedObject;36 Layers: PSerializedObject;46 Document: TSerializedClass; 47 Layers: TSerializedClass; 37 48 LayerData: array of TMemoryStream; 38 function GetLayer(num: integer): PSerializedObject;39 function GetBlendOperation(layer: PSerializedObject): TBlendOperation;40 function GetLayerName(layer: PSerializedObject): string;41 function GetLayerVisible(layer: PSerializedObject): boolean;42 function GetLayerOpacity(layer: PSerializedObject): byte;49 function InternalGetLayer(num: integer): TSerializedClass; 50 function InternalGetBlendOperation(layer: TSerializedClass): TBlendOperation; 51 function InternalGetLayerName(layer: TSerializedClass): string; 52 function InternalGetLayerVisible(layer: TSerializedClass): boolean; 53 function InternalGetLayerOpacity(layer: TSerializedClass): byte; 43 54 function LayerDataSize(numLayer: integer): int64; 44 55 procedure LoadLayer(dest: TMemoryStream; src: TStream; uncompressedSize: int64); 56 end; 57 58 { TFPReaderPaintDotNet } 59 60 TFPReaderPaintDotNet = class(TFPCustomImageReader) 61 protected 62 function InternalCheck(Stream: TStream): boolean; override; 63 procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override; 45 64 end; 46 65 … … 146 165 {$hints on} 147 166 167 { TFPReaderPaintDotNet } 168 169 function TFPReaderPaintDotNet.InternalCheck(Stream: TStream): boolean; 170 begin 171 result := IsPaintDotNetStream(stream); 172 end; 173 174 procedure TFPReaderPaintDotNet.InternalRead(Stream: TStream; Img: TFPCustomImage 175 ); 176 var 177 pdn: TPaintDotNetFile; 178 flat: TBGRABitmap; 179 x,y: integer; 180 begin 181 pdn := TPaintDotNetFile.Create; 182 try 183 pdn.LoadFromStream(Stream); 184 flat := pdn.ComputeFlatImage; 185 try 186 Img.SetSize(pdn.Width,pdn.Height); 187 for y := 0 to pdn.Height-1 do 188 for x := 0 to pdn.Width-1 do 189 Img.Colors[x,y] := BGRAToFPColor(flat.GetPixel(x,y)); 190 finally 191 flat.free; 192 end; 193 pdn.Free; 194 except 195 on ex: Exception do 196 begin 197 pdn.Free; 198 raise Exception.Create('Error while loading Paint.NET file. ' + ex.Message); 199 end; 200 end; 201 end; 202 148 203 { TPaintDotNetFile } 149 204 … … 163 218 var 164 219 header: packed array[0..3] of char; 165 XmlHeaderSize: longword;220 XmlHeaderSize: integer; 166 221 CompressionFormat: word; 167 222 i: integer; … … 192 247 IntToStr(Compressionformat) + ')'); 193 248 end; 194 Document := Content.Find Object('Document');249 Document := Content.FindClass('Document'); 195 250 if Document <> nil then 196 Layers := Content.GetObjectField(Document ^, 'layers');251 Layers := Content.GetObjectField(Document, 'layers') as TSerializedClass; 197 252 SetLength(LayerData, NbLayers); 198 253 for i := 0 to NbLayers - 1 do … … 203 258 end; 204 259 205 function TPaintDotNetFile.ToString: string;260 function TPaintDotNetFile.ToString: ansistring; 206 261 var 207 262 i, j, nbbytes: integer; … … 216 271 for i := 0 to NbLayers - 1 do 217 272 begin 218 Result += LineEnding + 'Layer ' + IntToStr(i) + ' : ' + LayerName (i)+ LineEnding;273 Result += LineEnding + 'Layer ' + IntToStr(i) + ' : ' + LayerName[i] + LineEnding; 219 274 Result += '[ '; 220 275 LayerData[i].Position := 0; … … 234 289 Result += ']' + lineending; 235 290 end; 236 end;237 238 destructor TPaintDotNetFile.Destroy;239 begin240 content.Free;241 Thumbnail.Free;242 inherited Destroy;243 291 end; 244 292 … … 265 313 end; 266 314 267 function TPaintDotNetFile. Width: integer;315 function TPaintDotNetFile.GetWidth: integer; 268 316 begin 269 317 if Document = nil then 270 318 Result := 0 271 319 else 272 Result := StrToInt(Content.GetSimpleField(Document ^, 'width'));273 end; 274 275 function TPaintDotNetFile. Height: integer;320 Result := StrToInt(Content.GetSimpleField(Document, 'width')); 321 end; 322 323 function TPaintDotNetFile.GetHeight: integer; 276 324 begin 277 325 if Document = nil then 278 326 Result := 0 279 327 else 280 Result := StrToInt(Content.GetSimpleField(Document ^, 'height'));281 end; 282 283 function TPaintDotNetFile. NbLayers: integer;328 Result := StrToInt(Content.GetSimpleField(Document, 'height')); 329 end; 330 331 function TPaintDotNetFile.GetNbLayers: integer; 284 332 begin 285 333 if Layers = nil then 286 334 Result := 0 287 335 else 288 Result := StrToInt(Content.GetSimpleField(Layers ^, '_size'));289 end; 290 291 function TPaintDotNetFile. BlendOperation(Layer: integer): TBlendOperation;292 begin 293 Result := GetBlendOperation(GetLayer(layer));294 end; 295 296 function TPaintDotNetFile. LayerVisible(layer: integer): boolean;297 begin 298 Result := GetLayerVisible(GetLayer(layer));299 end; 300 301 function TPaintDotNetFile. LayerOpacity(layer: integer): byte;302 begin 303 Result := GetLayerOpacity(GetLayer(layer));304 end; 305 306 function TPaintDotNetFile. LayerName(layer: integer): string;307 begin 308 Result := GetLayerName(GetLayer(layer));309 end; 310 311 function TPaintDotNetFile. MakeBitmapLayer(layer: integer): TBGRABitmap;336 Result := StrToInt(Content.GetSimpleField(Layers, '_size')); 337 end; 338 339 function TPaintDotNetFile.GetBlendOperation(Layer: integer): TBlendOperation; 340 begin 341 Result := InternalGetBlendOperation(InternalGetLayer(layer)); 342 end; 343 344 function TPaintDotNetFile.GetLayerVisible(layer: integer): boolean; 345 begin 346 Result := InternalGetLayerVisible(InternalGetLayer(layer)); 347 end; 348 349 function TPaintDotNetFile.GetLayerOpacity(layer: integer): byte; 350 begin 351 Result := InternalGetLayerOpacity(InternalGetLayer(layer)); 352 end; 353 354 function TPaintDotNetFile.GetLayerName(layer: integer): string; 355 begin 356 Result := InternalGetLayerName(InternalGetLayer(layer)); 357 end; 358 359 function TPaintDotNetFile.GetLayerBitmapCopy(layer: integer): TBGRABitmap; 312 360 begin 313 361 if (layer < 0) or (layer >= NbLayers) then … … 315 363 316 364 Result := TBGRABitmap.Create(Width, Height); 317 if Result.NbPixels* 4 <> LayerData[layer].Size then365 if int64(Result.NbPixels) * 4 <> LayerData[layer].Size then 318 366 begin 319 367 Result.Free; … … 331 379 end; 332 380 333 function TPaintDotNetFile.ComputeFlatImage: TBGRABitmap; 334 var 335 tempLayer, tempMerge: TBGRABitmap; 336 i: integer; 337 begin 338 Result := TBGRABitmap.Create(Width, Height); 339 for i := 0 to NbLayers - 1 do 340 begin 341 tempLayer := MakeBitmapLayer(i); 342 if tempLayer <> nil then 343 begin 344 //first layer is simply the background 345 if i = 0 then 346 Result.PutImage(0, 0, tempLayer, dmSet) 347 else 348 //simple blend operations 349 if BlendOperation(i) in [boTransparent, boLinearBlend] then 350 begin 351 tempLayer.ApplyGlobalOpacity(LayerOpacity(i)); 352 Result.BlendImage(0, 0, tempLayer, BlendOperation(i)); 353 end 354 else 355 //complex blend operations are done in a third bitmap 356 begin 357 tempMerge := Result.Duplicate as TBGRABitmap; 358 tempMerge.BlendImage(0, 0, tempLayer, BlendOperation(i)); 359 tempMerge.ApplyGlobalOpacity(LayerOpacity(i)); 360 Result.PutImage(0, 0, tempMerge, dmFastBlend); 361 tempMerge.Free; 362 end; 363 tempLayer.Free; 364 end; 365 end; 366 end; 367 368 function TPaintDotNetFile.GetLayerName(layer: PSerializedObject): string; 369 var 370 prop: PSerializedObject; 381 function TPaintDotNetFile.InternalGetLayerName(layer: TSerializedClass): string; 382 var 383 prop: TCustomSerializedObject; 371 384 begin 372 385 if layer = nil then … … 374 387 else 375 388 begin 376 prop := Content.GetObjectField(layer ^, 'Layer+properties');389 prop := Content.GetObjectField(layer, 'Layer+properties'); 377 390 if prop = nil then 378 391 Result := '' 379 392 else 380 393 begin 381 Result := Content.GetSimpleField(prop ^, 'name');394 Result := Content.GetSimpleField(prop, 'name'); 382 395 end; 383 396 end; … … 386 399 function TPaintDotNetFile.LayerDataSize(numLayer: integer): int64; 387 400 var 388 layer, surface, scan0: PSerializedObject;389 begin 390 layer := GetLayer(numLayer);401 layer, surface, scan0: TCustomSerializedObject; 402 begin 403 layer := InternalGetLayer(numLayer); 391 404 if layer = nil then 392 405 Result := 0 393 406 else 394 407 begin 395 surface := Content.GetObjectField(layer ^, 'surface');408 surface := Content.GetObjectField(layer, 'surface'); 396 409 if surface = nil then 397 410 Result := 0 398 411 else 399 412 begin 400 scan0 := Content.GetObjectField(surface ^, 'scan0');401 Result := StrToInt64(Content.GetSimpleField(scan0 ^, 'length64'));413 scan0 := Content.GetObjectField(surface, 'scan0'); 414 Result := StrToInt64(Content.GetSimpleField(scan0, 'length64')); 402 415 end; 403 416 end; … … 457 470 end; 458 471 459 function TPaintDotNetFile. GetLayer(num: integer): PSerializedObject;460 var 461 layerList: PSerializedObject;472 function TPaintDotNetFile.InternalGetLayer(num: integer): TSerializedClass; 473 var 474 layerList: TCustomSerializedObject; 462 475 begin 463 476 if Layers = nil then … … 468 481 else 469 482 begin 470 layerList := Content.GetObjectField(Layers ^, '_items');471 Result := Content.GetObject(layerList ^.fields[num].Value);472 end; 473 end; 474 475 function TPaintDotNetFile. GetBlendOperation(layer: PSerializedObject): TBlendOperation;476 var 477 prop, blendOp: PSerializedObject;483 layerList := Content.GetObjectField(Layers, '_items'); 484 Result := Content.GetObject(layerList.FieldAsString[num]) as TSerializedClass; 485 end; 486 end; 487 488 function TPaintDotNetFile.InternalGetBlendOperation(layer: TSerializedClass): TBlendOperation; 489 var 490 prop, blendOp: TCustomSerializedObject; 478 491 blendName: string; 479 492 begin … … 482 495 else 483 496 begin 484 prop := Content.GetObjectField(layer ^, 'properties');497 prop := Content.GetObjectField(layer, 'properties'); 485 498 if prop = nil then 486 499 Result := boTransparent 487 500 else 488 501 begin 489 blendOp := Content.GetObjectField(prop ^, 'blendOp');502 blendOp := Content.GetObjectField(prop, 'blendOp'); 490 503 if blendOp = nil then 491 504 Result := boTransparent 492 505 else 493 506 begin 494 blendName := Content.GetObjectType(blendOp);507 blendName := blendOp.TypeAsString; 495 508 if (pos('+', blendName) <> 0) then 496 509 Delete(blendName, 1, pos('+', blendName)); … … 548 561 end; 549 562 550 function TPaintDotNetFile. GetLayerVisible(layer: PSerializedObject): boolean;551 var 552 prop: PSerializedObject;563 function TPaintDotNetFile.InternalGetLayerVisible(layer: TSerializedClass): boolean; 564 var 565 prop: TCustomSerializedObject; 553 566 begin 554 567 if layer = nil then … … 556 569 else 557 570 begin 558 prop := Content.GetObjectField(layer ^, 'Layer+properties');571 prop := Content.GetObjectField(layer, 'Layer+properties'); 559 572 if prop = nil then 560 573 Result := False 561 574 else 562 575 begin 563 Result := (Content.GetSimpleField(prop ^, 'visible') = 'True');564 end; 565 end; 566 end; 567 568 function TPaintDotNetFile. GetLayerOpacity(layer: PSerializedObject): byte;569 var 570 prop: PSerializedObject;576 Result := (Content.GetSimpleField(prop, 'visible') = 'True'); 577 end; 578 end; 579 end; 580 581 function TPaintDotNetFile.InternalGetLayerOpacity(layer: TSerializedClass): byte; 582 var 583 prop: TCustomSerializedObject; 571 584 begin 572 585 if layer = nil then … … 574 587 else 575 588 begin 576 prop := Content.GetObjectField(layer ^, 'Layer+properties');589 prop := Content.GetObjectField(layer, 'Layer+properties'); 577 590 if prop = nil then 578 591 Result := 0 579 592 else 580 593 begin 581 Result := StrToInt(Content.GetSimpleField(prop^, 'opacity')); 582 end; 583 end; 584 end; 585 586 {var fout: TFileStream; 587 comp: Tcompressionstream; 588 589 gzipHeader: packed record 590 magicWord: word; 591 compMethod,flags: byte; 592 fileModif: Longword; 593 extraflag,os: byte; 594 end; } 594 Result := StrToInt(Content.GetSimpleField(prop, 'opacity')); 595 end; 596 end; 597 end; 595 598 596 599 initialization 597 600 598 { gzipHeader.magicWord := $8b1F; 599 gzipHeader.compMethod := 8; 600 gzipHeader.flags := 0; 601 gzipHeader.fileModif := 0; 602 gzipHeader.extraflag := 0; 603 gzipHeader.os := $ff; 604 605 fout := TFileStream.Create('testcomp.gz', fmCreate); 606 fout.Write(gzipHeader,sizeof(gzipHeader)); 607 comp := Tcompressionstream.Create(cldefault,fout,true); 608 comp.WriteAnsiString('Hello world'); 609 comp.free; 610 fout.Free; } 601 ImageHandlers.RegisterImageReader ('Paint.NET image', 'pdn', TFPReaderPaintDotNet); 611 602 612 603 end. 613 604 605 -
GraphicTest/BGRABitmap/bgrapolygon.pas
r210 r317 3 3 {$mode objfpc}{$H+} 4 4 5 { This unit contains polygon drawing functions and spline functions. 6 7 Shapes are drawn using a TFillShapeInfo object, which calculates the 8 intersection of an horizontal line and the polygon. 9 10 Various shapes are handled : 11 - TFillPolyInfo : polygon 12 - TFillEllipseInfo : ellipse 13 - TFillBorderEllipseInfo : ellipse border 14 - TFillRoundRectangleInfo : round rectangle (or other corners) 15 - TFillBorderRoundRectInfo : round rectangle border 16 17 Various fill modes : 18 - Alternate : each time there is an intersection, it enters or go out of the polygon 19 - Winding : filled when the sum of ascending and descending intersection is non zero 20 - Color : fill with a color defined as a TBGRAPixel argument 21 - Erase : erase with an alpha in the TBGRAPixel argument 22 - Texture : draws a texture with the IBGRAScanner argument 23 24 Various border handling : 25 - aliased : one horizontal line intersection is calculated per pixel in the vertical loop 26 - antialiased : more lines are calculated and a density is computed by adding them together 27 - multi-polygon antialiasing and superposition (TBGRAMultiShapeFiller) : same as above but 28 by combining multiple polygons at the same time, and optionally subtracting top polygons 29 } 30 5 31 interface 6 32 7 33 uses 8 Classes, SysUtils, BGRADefaultBitmap, BGRABitmapTypes; 34 Classes, SysUtils, BGRABitmapTypes, BGRAFillInfo, Graphics; 35 36 procedure FillShapeAntialias(bmp: TBGRACustomBitmap; shapeInfo: TFillShapeInfo; 37 c: TBGRAPixel; EraseMode: boolean; scan: IBGRAScanner; NonZeroWinding: boolean); 38 procedure FillShapeAntialiasWithTexture(bmp: TBGRACustomBitmap; shapeInfo: TFillShapeInfo; 39 scan: IBGRAScanner; NonZeroWinding: boolean); 40 procedure FillShapeAliased(bmp: TBGRACustomBitmap; shapeInfo: TFillShapeInfo; 41 c: TBGRAPixel; EraseMode: boolean; scan: IBGRAScanner; NonZeroWinding: boolean; drawmode: TDrawMode; AliasingIncludeBottomRight: Boolean= false); 9 42 10 43 type 11 ArrayOfSingle = array of single; 12 13 { TFillShapeInfo } 14 15 TFillShapeInfo = class 16 function GetBounds: TRect; virtual; 17 function NbMaxIntersection: integer; virtual; 18 procedure ComputeIntersection(cury: single; var inter: ArrayOfSingle; 19 var nbInter: integer); virtual; 20 end; 21 22 procedure FillShapeAntialias(bmp: TBGRADefaultBitmap; shapeInfo: TFillShapeInfo; 44 45 { TBGRAMultishapeFiller } 46 47 TBGRAMultishapeFiller = class 48 protected 49 nbShapes: integer; 50 shapes: array of record 51 info: TFillShapeInfo; 52 internalInfo: boolean; 53 texture: IBGRAScanner; 54 internalTexture: TObject; 55 color: TExpandedPixel; 56 bounds: TRect; 57 end; 58 procedure AddShape(AInfo: TFillShapeInfo; AInternalInfo: boolean; ATexture: IBGRAScanner; AInternalTexture: TObject; AColor: TBGRAPixel); 59 function CheckRectangleBorderBounds(var x1, y1, x2, y2: single; w: single): boolean; 60 public 61 FillMode : TFillMode; 62 PolygonOrder: TPolygonOrder; 63 Antialiasing: Boolean; 64 AliasingIncludeBottomRight: Boolean; 65 constructor Create; 66 destructor Destroy; override; 67 procedure AddShape(AShape: TFillShapeInfo; AColor: TBGRAPixel); 68 procedure AddShape(AShape: TFillShapeInfo; ATexture: IBGRAScanner); 69 procedure AddPolygon(const points: array of TPointF; AColor: TBGRAPixel); 70 procedure AddPolygon(const points: array of TPointF; ATexture: IBGRAScanner); 71 procedure AddTriangleLinearColor(pt1, pt2, pt3: TPointF; c1, c2, c3: TBGRAPixel); 72 procedure AddTriangleLinearMapping(pt1, pt2, pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF); 73 procedure AddQuadLinearColor(pt1, pt2, pt3, pt4: TPointF; c1, c2, c3, c4: TBGRAPixel); 74 procedure AddQuadLinearMapping(pt1, pt2, pt3, pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF); 75 procedure AddQuadPerspectiveMapping(pt1, pt2, pt3, pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF); 76 procedure AddEllipse(x, y, rx, ry: single; AColor: TBGRAPixel); 77 procedure AddEllipse(x, y, rx, ry: single; ATexture: IBGRAScanner); 78 procedure AddEllipseBorder(x, y, rx, ry, w: single; AColor: TBGRAPixel); 79 procedure AddEllipseBorder(x, y, rx, ry, w: single; ATexture: IBGRAScanner); 80 procedure AddRoundRectangle(x1, y1, x2, y2, rx, ry: single; AColor: TBGRAPixel; options: TRoundRectangleOptions= []); 81 procedure AddRoundRectangle(x1, y1, x2, y2, rx, ry: single; ATexture: IBGRAScanner; options: TRoundRectangleOptions= []); 82 procedure AddRoundRectangleBorder(x1, y1, x2, y2, rx, ry, w: single; AColor: TBGRAPixel; options: TRoundRectangleOptions= []); 83 procedure AddRoundRectangleBorder(x1, y1, x2, y2, rx, ry, w: single; ATexture: IBGRAScanner; options: TRoundRectangleOptions= []); 84 procedure AddRectangle(x1, y1, x2, y2: single; AColor: TBGRAPixel); 85 procedure AddRectangle(x1, y1, x2, y2: single; ATexture: IBGRAScanner); 86 procedure AddRectangleBorder(x1, y1, x2, y2, w: single; AColor: TBGRAPixel); 87 procedure AddRectangleBorder(x1, y1, x2, y2, w: single; ATexture: IBGRAScanner); 88 procedure Draw(dest: TBGRACustomBitmap); 89 end; 90 91 procedure FillPolyAliased(bmp: TBGRACustomBitmap; points: array of TPointF; 92 c: TBGRAPixel; EraseMode: boolean; NonZeroWinding: boolean; drawmode: TDrawMode); 93 procedure FillPolyAliasedWithTexture(bmp: TBGRACustomBitmap; points: array of TPointF; 94 scan: IBGRAScanner; NonZeroWinding: boolean; drawmode: TDrawMode); 95 procedure FillPolyAntialias(bmp: TBGRACustomBitmap; points: array of TPointF; 96 c: TBGRAPixel; EraseMode: boolean; NonZeroWinding: boolean); 97 procedure FillPolyAntialiasWithTexture(bmp: TBGRACustomBitmap; points: array of TPointF; 98 scan: IBGRAScanner; NonZeroWinding: boolean); 99 100 procedure FillEllipseAntialias(bmp: TBGRACustomBitmap; x, y, rx, ry: single; 23 101 c: TBGRAPixel; EraseMode: boolean); 24 25 type 26 { TFillPolyInfo } 27 28 TFillPolyInfo = class(TFillShapeInfo) 29 private 30 FPoints: array of TPointF; 31 FSlopes: array of single; 32 FEmptyPt, FChangedir: array of boolean; 33 FNext, FPrev: array of integer; 34 public 35 constructor Create(points: array of TPointF); 36 function GetBounds: TRect; override; 37 function NbMaxIntersection: integer; override; 38 procedure ComputeIntersection(cury: single; var inter: ArrayOfSingle; 39 var nbInter: integer); override; 40 end; 41 42 procedure FillPolyAntialias(bmp: TBGRADefaultBitmap; points: array of TPointF; 102 procedure FillEllipseAntialiasWithTexture(bmp: TBGRACustomBitmap; x, y, rx, ry: single; 103 scan: IBGRAScanner); 104 105 procedure BorderEllipseAntialias(bmp: TBGRACustomBitmap; x, y, rx, ry, w: single; 43 106 c: TBGRAPixel; EraseMode: boolean); 44 45 type 46 { TFillEllipseInfo } 47 48 TFillEllipseInfo = class(TFillShapeInfo) 49 private 50 FX, FY, FRX, FRY: single; 51 public 52 constructor Create(x, y, rx, ry: single); 53 function GetBounds: TRect; override; 54 function NbMaxIntersection: integer; override; 55 procedure ComputeIntersection(cury: single; var inter: ArrayOfSingle; 56 var nbInter: integer); override; 57 end; 58 59 procedure FillEllipseAntialias(bmp: TBGRADefaultBitmap; x, y, rx, ry: single; 60 c: TBGRAPixel; EraseMode: boolean); 61 62 type 63 { TFillBorderEllipseInfo } 64 65 TFillBorderEllipseInfo = class(TFillShapeInfo) 66 private 67 innerBorder, outerBorder: TFillEllipseInfo; 68 public 69 constructor Create(x, y, rx, ry, w: single); 70 function GetBounds: TRect; override; 71 function NbMaxIntersection: integer; override; 72 procedure ComputeIntersection(cury: single; var inter: ArrayOfSingle; 73 var nbInter: integer); override; 74 destructor Destroy; override; 75 end; 76 77 procedure BorderEllipseAntialias(bmp: TBGRADefaultBitmap; x, y, rx, ry, w: single; 78 c: TBGRAPixel; EraseMode: boolean); 107 procedure BorderEllipseAntialiasWithTexture(bmp: TBGRACustomBitmap; x, y, rx, ry, w: single; 108 scan: IBGRAScanner); 109 110 procedure FillRoundRectangleAntialias(bmp: TBGRACustomBitmap; x1, y1, x2, y2, rx, ry: single; 111 options: TRoundRectangleOptions; c: TBGRAPixel; EraseMode: boolean); 112 procedure FillRoundRectangleAntialiasWithTexture(bmp: TBGRACustomBitmap; x1, y1, x2, y2, rx, ry: single; 113 options: TRoundRectangleOptions; scan: IBGRAScanner); 114 115 procedure BorderRoundRectangleAntialias(bmp: TBGRACustomBitmap; x1, y1, x2, y2, rx, ry, w: single; 116 options: TRoundRectangleOptions; c: TBGRAPixel; EraseMode: boolean); 117 procedure BorderRoundRectangleAntialiasWithTexture(bmp: TBGRACustomBitmap; x1, y1, x2, y2, rx, ry, w: single; 118 options: TRoundRectangleOptions; scan: IBGRAScanner); 119 120 procedure BorderAndFillRoundRectangleAntialias(bmp: TBGRACustomBitmap; x1, y1, x2, y2, rx, ry, w: single; 121 options: TRoundRectangleOptions; bordercolor,fillcolor: TBGRAPixel; bordertexture,filltexture: IBGRAScanner; EraseMode: boolean); 79 122 80 123 implementation 81 124 82 uses Math, bgrablend; 83 84 procedure FillShapeAntialias(bmp: TBGRADefaultBitmap; shapeInfo: TFillShapeInfo; 85 c: TBGRAPixel; EraseMode: boolean); 86 const 87 precision = 11; 88 var 89 bounds: TRect; 90 miny, maxy, minx, maxx: integer; 91 92 inter: array of single; 125 uses Math, BGRABlend, BGRAGradientScanner, BGRATransform; 126 127 procedure FillShapeAntialias(bmp: TBGRACustomBitmap; shapeInfo: TFillShapeInfo; 128 c: TBGRAPixel; EraseMode: boolean; scan: IBGRAScanner; NonZeroWinding: boolean); 129 var 130 inter: array of TIntersectionInfo; 93 131 nbInter: integer; 94 density: packed array of single; 132 133 firstScan, lastScan: record 134 inter: array of TIntersectionInfo; 135 nbInter: integer; 136 end; 137 138 miny, maxy, minx, maxx, 139 densMinX, densMaxX: integer; 140 141 density: PDensity; 95 142 96 143 xb, yb, yc, i, j: integer; 97 144 98 temp, cury, x1, x2: single;145 x1, x2, x1b,x2b: single; 99 146 ix1, ix2: integer; 100 147 pdest: PBGRAPixel; 101 pdens: PSingle; 102 103 begin 104 bounds := shapeInfo.GetBounds; 105 if (bounds.Right <= bounds.left) or (bounds.bottom <= bounds.top) then 106 exit; 107 108 miny := bounds.top; 109 maxy := bounds.bottom - 1; 110 minx := bounds.left; 111 maxx := bounds.right - 1; 112 113 if minx < 0 then 114 minx := 0; 115 if maxx < 0 then 116 exit; 117 if maxx > bmp.Width - 1 then 118 maxx := bmp.Width - 1; 119 if minx > bmp.Width - 1 then 120 exit; 121 if miny < 0 then 122 miny := 0; 123 if miny > bmp.Height - 1 then 124 exit; 125 if maxy > bmp.Height - 1 then 126 maxy := bmp.Height - 1; 127 if maxy < 0 then 128 exit; 129 130 setlength(inter, shapeInfo.NbMaxIntersection); 131 setlength(density, maxx - minx + 2); //one more for safety 148 pdens: PDensity; 149 150 curvedSeg,optimised: boolean; 151 ec: TExpandedPixel; 152 c2:TBGRAPixel; 153 MemScanCopy,pscan: pbgrapixel; 154 ScanNextPixelProc: TScanNextPixelFunction; 155 temp: Single; 156 157 function GetYScan(num: integer): single; inline; 158 begin 159 result := yb + (num * 2 + 1) / (AntialiasPrecision * 2); 160 end; 161 162 procedure SubTriangleDensity(x1,density1, x2, density2: single); 163 var ix1,ix2,n: integer; 164 slope: single; 165 function densityAt(x: single): single; inline; 166 begin 167 result := (x-x1)*slope+density1; 168 end; 169 var 170 curdens: single; 171 pdens: pdensity; 172 begin 173 if (x1 <> x2) and (x1 < maxx + 1) and (x2 >= minx) then 174 begin 175 slope := (density2-density1)/(x2-x1); 176 if x1 < minx then 177 begin 178 density1 := densityAt(minx); 179 x1 := minx; 180 end; 181 if x2 >= maxx + 1 then 182 begin 183 density2 := densityAt(maxx+1); 184 x2 := maxx + 1; 185 end; 186 ix1 := floor(x1); 187 ix2 := floor(x2); 188 189 if ix1 = ix2 then 190 (density + (ix1 - minx))^ -= round((x2 - x1)*(density1+density2)/2) 191 else 192 begin 193 (density + (ix1 - minx))^ := max(0, (density + (ix1 - minx))^ - round((1 - (x1 - ix1))*(density1+densityAt(ix1+1))/2) ); 194 if (ix2 <= maxx) then 195 (density + (ix2 - minx))^ := max(0, (density + (ix2 - minx))^ - round((x2 - ix2)*(density2+densityAt(ix2))/2) ); 196 end; 197 if ix2 > ix1 + 1 then 198 begin 199 curdens := densityAt(ix1+1.5); 200 pdens := density + (ix1+1 - minx); 201 for n := ix2-1-(ix1+1) downto 0 do 202 begin 203 pdens^ -= round(curdens); 204 curdens += slope; 205 inc(pdens); 206 end; 207 end; 208 end; 209 end; 210 211 begin 212 if (scan=nil) and (c.alpha=0) then exit; 213 If not shapeInfo.ComputeMinMax(minx,miny,maxx,maxy,bmp) then exit; 214 215 inter := shapeInfo.CreateIntersectionArray; 216 getmem(density, (maxx - minx + 2)*sizeof(TDensity)); //more for safety 217 ec := GammaExpansion(c); 218 c2 := c; 219 220 MemScanCopy := nil; 221 ScanNextPixelProc := nil; 222 if scan <> nil then 223 begin 224 if scan.IsScanPutPixelsDefined then 225 GetMem(MemScanCopy,(maxx-minx+1)*sizeof(TBGRAPixel)); 226 ScanNextPixelProc := @scan.ScanNextPixel; 227 end; 228 229 curvedSeg := shapeInfo.SegmentsCurved; 230 if not curvedSeg then 231 begin 232 firstScan.inter := shapeInfo.CreateIntersectionArray; 233 lastScan.inter := shapeInfo.CreateIntersectionArray; 234 end; 132 235 133 236 //vertical scan … … 135 238 begin 136 239 //mean density 137 for i := 0 to high(density) do 138 density[i] := 0; 139 140 //precision scan 141 for yc := 0 to precision - 1 do 142 begin 143 cury := yb + (yc * 2 + 1) / (precision * 2); 144 145 //find intersections 146 nbinter := 0; 147 shapeInfo.ComputeIntersection(cury, inter, nbInter); 148 if nbinter = 0 then 149 continue; 150 151 //sort intersections 152 for i := 1 to nbinter - 1 do 153 begin 154 j := i; 155 while (j > 0) and (inter[j - 1] > inter[j]) do 240 fillchar(density^,(maxx-minx+1)*sizeof(TDensity),0); 241 242 densMinX := maxx+1; 243 densMaxX := minx-1; 244 245 if not curvedSeg then 246 begin 247 with firstScan do 248 shapeInfo.ComputeAndSort(yb+1/256,inter,nbInter,NonZeroWinding); 249 with lastScan do 250 shapeInfo.ComputeAndSort(yb+255/256,inter,nbInter,NonZeroWinding); 251 if (firstScan.nbInter = lastScan.nbInter) and (firstScan.nbInter >= 2) then 252 begin 253 optimised := true; 254 for i := 0 to firstScan.nbInter-1 do 255 if firstScan.inter[i].numSegment <> lastScan.inter[i].numSegment then 256 begin 257 optimised := false; 258 break; 259 end; 260 end else 261 optimised := false; 262 263 if optimised then 264 begin 265 for i := 0 to firstScan.nbinter div 2 - 1 do 156 266 begin 157 temp := inter[j - 1]; 158 inter[j - 1] := inter[j]; 159 inter[j] := temp; 160 Dec(j); 267 x1 := firstScan.inter[i+i].interX; 268 x1b := lastScan.inter[i+i].interX; 269 if (x1 > x1b) then 270 begin 271 temp := x1; 272 x1 := x1b; 273 x1b := temp; 274 end; 275 x2 := firstScan.inter[i+i+1].interX; 276 x2b := lastScan.inter[i+i+1].interX; 277 if (x2 < x2b) then 278 begin 279 temp := x2; 280 x2 := x2b; 281 x2b := temp; 282 end; 283 {$i filldensitysegment256.inc} 284 SubTriangleDensity(x1,256,x1b,0); 285 SubTriangleDensity(x2b,0,x2,256); 161 286 end; 162 end; 163 164 //fill density 165 for i := 0 to nbinter div 2 - 1 do 166 begin 167 x1 := inter[i + i]; 168 x2 := inter[i + i + 1]; 169 if (x1 <> x2) and (x1 < maxx + 1) and (x2 >= minx) then 287 end else 288 begin 289 for yc := 0 to AntialiasPrecision - 1 do 170 290 begin 171 if x1 < minx then 172 x1 := minx; 173 if x2 >= maxx + 1 then 174 x2 := maxx + 1; 175 ix1 := floor(x1); 176 ix2 := floor(x2); 177 if ix1 = ix2 then 178 density[ix1 - minx] += x2 - x1 291 //find intersections 292 shapeInfo.ComputeAndSort(GetYScan(yc),inter,nbInter,NonZeroWinding); 293 294 {$i filldensity256.inc} 295 end; 296 end; 297 end else 298 begin 299 optimised := false; 300 //precision scan 301 for yc := 0 to AntialiasPrecision - 1 do 302 begin 303 //find intersections 304 shapeInfo.ComputeAndSort(GetYScan(yc),inter,nbInter,NonZeroWinding); 305 306 {$i filldensity256.inc} 307 end; 308 end; 309 310 if optimised then 311 {$i renderdensity256.inc} 312 else 313 {$define PARAM_ANTIALIASINGFACTOR} 314 {$i renderdensity256.inc} 315 end; 316 317 freemem(MemScanCopy); 318 shapeInfo.FreeIntersectionArray(inter); 319 320 if not curvedSeg then 321 begin 322 with firstScan do 323 begin 324 for i := 0 to high(inter) do 325 inter[i].free; 326 end; 327 with lastScan do 328 begin 329 for i := 0 to high(inter) do 330 inter[i].free; 331 end; 332 end; 333 freemem(density); 334 335 bmp.InvalidateBitmap; 336 end; 337 338 procedure FillShapeAliased(bmp: TBGRACustomBitmap; shapeInfo: TFillShapeInfo; 339 c: TBGRAPixel; EraseMode: boolean; scan: IBGRAScanner; NonZeroWinding: boolean; drawmode: TDrawMode; AliasingIncludeBottomRight: Boolean= false); 340 var 341 inter: array of TIntersectionInfo; 342 nbInter: integer; 343 344 miny, maxy, minx, maxx: integer; 345 xb,yb, i: integer; 346 x1, x2: single; 347 ix1, ix2: integer; 348 pdest: PBGRAPixel; 349 AliasingOfs: TPointF; 350 ec: TExpandedPixel; 351 352 begin 353 if (scan=nil) and (c.alpha=0) then exit; 354 If not shapeInfo.ComputeMinMax(minx,miny,maxx,maxy,bmp) then exit; 355 inter := shapeInfo.CreateIntersectionArray; 356 357 if AliasingIncludeBottomRight then 358 AliasingOfs := PointF(0,0) else 359 AliasingOfs := PointF(-0.0001,-0.0001); 360 361 ec := GammaExpansion(c); 362 if (scan = nil) and (c.alpha = 255) then drawmode := dmSet; 363 364 //vertical scan 365 for yb := miny to maxy do 366 begin 367 //find intersections 368 shapeInfo.ComputeAndSort( yb+0.5-AliasingOfs.Y, inter, nbInter, NonZeroWinding); 369 370 for i := 0 to nbinter div 2 - 1 do 371 begin 372 x1 := inter[i + i].interX-AliasingOfs.X; 373 x2 := inter[i + i+ 1].interX-AliasingOfs.X; 374 375 if x1 <> x2 then 376 begin 377 ComputeAliasedRowBounds(x1,x2, minx,maxx, ix1,ix2); 378 if ix1 <= ix2 then 379 begin 380 //render scanline 381 if scan <> nil then //with texture scan 382 begin 383 pdest := bmp.ScanLine[yb] + ix1; 384 scan.ScanMoveTo(ix1,yb); 385 ScannerPutPixels(scan,pdest,ix2-ix1+1,drawmode); 386 end else 387 if EraseMode then //erase with alpha 388 begin 389 pdest := bmp.ScanLine[yb] + ix1; 390 for xb := ix1 to ix2 do 391 begin 392 ErasePixelInline(pdest, c.alpha); 393 Inc(pdest); 394 end; 395 end 179 396 else 180 397 begin 181 density[ix1 - minx] += 1 - (x1 - ix1); 182 if (ix2 <= maxx) then 183 density[ix2 - minx] += x2 - ix2; 184 end; 185 if ix2 > ix1 + 1 then 186 begin 187 for j := ix1 + 1 to ix2 - 1 do 188 density[j - minx] += 1; 398 case drawmode of 399 dmFastBlend: bmp.FastBlendHorizLine(ix1,yb,ix2, c); 400 dmDrawWithTransparency: bmp.DrawHorizLine(ix1,yb,ix2, ec); 401 dmSet: bmp.SetHorizLine(ix1,yb,ix2, c); 402 dmXor: bmp.XorHorizLine(ix1,yb,ix2, c); 403 end; 189 404 end; 190 405 end; 191 406 end; 192 193 407 end; 194 195 pdest := bmp.ScanLine[yb] + minx; 196 pdens := @density[0]; 197 //render scanline 198 if EraseMode then 199 begin 200 for xb := minx to maxx do 201 begin 202 temp := pdens^; 203 Inc(pdens); 204 if temp <> 0 then 205 ErasePixelInline(pdest, round(c.alpha * temp / precision)); 206 Inc(pdest); 207 end; 208 end 209 else 210 begin 211 for xb := minx to maxx do 212 begin 213 temp := pdens^; 214 Inc(pdens); 215 if temp <> 0 then 216 DrawPixelInline(pdest, BGRA(c.red, c.green, c.blue, round( 217 c.alpha * temp / precision))); 218 Inc(pdest); 219 end; 220 end; 221 end; 222 408 end; 409 410 shapeInfo.FreeIntersectionArray(inter); 223 411 bmp.InvalidateBitmap; 224 412 end; 225 413 226 procedure FillPolyAntialias(bmp: TBGRADefaultBitmap; points: array of TPointF; 227 c: TBGRAPixel; EraseMode: boolean); 414 procedure FillShapeAntialiasWithTexture(bmp: TBGRACustomBitmap; 415 shapeInfo: TFillShapeInfo; scan: IBGRAScanner; NonZeroWinding: boolean); 416 begin 417 FillShapeAntialias(bmp,shapeInfo,BGRAPixelTransparent,False,scan,NonZeroWinding); 418 end; 419 420 procedure FillPolyAliased(bmp: TBGRACustomBitmap; points: array of TPointF; 421 c: TBGRAPixel; EraseMode: boolean; NonZeroWinding: boolean; drawmode: TDrawMode); 228 422 var 229 423 info: TFillPolyInfo; … … 233 427 234 428 info := TFillPolyInfo.Create(points); 235 FillShapeAntialias(bmp, info, c, EraseMode); 236 info.Free; 237 end; 238 239 procedure FillEllipseAntialias(bmp: TBGRADefaultBitmap; x, y, rx, ry: single; 429 FillShapeAliased(bmp, info, c, EraseMode, nil, NonZeroWinding, drawmode); 430 info.Free; 431 end; 432 433 procedure FillPolyAliasedWithTexture(bmp: TBGRACustomBitmap; 434 points: array of TPointF; scan: IBGRAScanner; NonZeroWinding: boolean; drawmode: TDrawMode); 435 var 436 info: TFillPolyInfo; 437 begin 438 if length(points) < 3 then 439 exit; 440 441 info := TFillPolyInfo.Create(points); 442 FillShapeAliased(bmp, info, BGRAPixelTransparent,False,scan, NonZeroWinding, drawmode); 443 info.Free; 444 end; 445 446 procedure FillPolyAntialias(bmp: TBGRACustomBitmap; points: array of TPointF; 447 c: TBGRAPixel; EraseMode: boolean; NonZeroWinding: boolean); 448 var 449 info: TFillPolyInfo; 450 begin 451 if length(points) < 3 then 452 exit; 453 454 info := TFillPolyInfo.Create(points); 455 FillShapeAntialias(bmp, info, c, EraseMode, nil, NonZeroWinding); 456 info.Free; 457 end; 458 459 procedure FillPolyAntialiasWithTexture(bmp: TBGRACustomBitmap; 460 points: array of TPointF; scan: IBGRAScanner; NonZeroWinding: boolean 461 ); 462 var 463 info: TFillPolyInfo; 464 begin 465 if length(points) < 3 then 466 exit; 467 468 info := TFillPolyInfo.Create(points); 469 FillShapeAntialiasWithTexture(bmp, info, scan, NonZeroWinding); 470 info.Free; 471 end; 472 473 procedure FillEllipseAntialias(bmp: TBGRACustomBitmap; x, y, rx, ry: single; 240 474 c: TBGRAPixel; EraseMode: boolean); 241 475 var 242 476 info: TFillEllipseInfo; 243 477 begin 244 if (rx = 0) or (ry = 0) then478 if (rx = 0) or (ry = 0) or (x = EmptySingle) or (y = EmptySingle) then 245 479 exit; 246 480 247 481 info := TFillEllipseInfo.Create(x, y, rx, ry); 248 FillShapeAntialias(bmp, info, c, EraseMode); 249 info.Free; 250 end; 251 252 procedure BorderEllipseAntialias(bmp: TBGRADefaultBitmap; x, y, rx, ry, w: single; 482 FillShapeAntialias(bmp, info, c, EraseMode, nil, False); 483 info.Free; 484 end; 485 486 procedure FillEllipseAntialiasWithTexture(bmp: TBGRACustomBitmap; x, y, rx, 487 ry: single; scan: IBGRAScanner); 488 var 489 info: TFillEllipseInfo; 490 begin 491 if (rx = 0) or (ry = 0) or (x = EmptySingle) or (y = EmptySingle) then 492 exit; 493 494 info := TFillEllipseInfo.Create(x, y, rx, ry); 495 FillShapeAntialiasWithTexture(bmp, info, scan, False); 496 info.Free; 497 end; 498 499 procedure BorderEllipseAntialias(bmp: TBGRACustomBitmap; x, y, rx, ry, w: single; 253 500 c: TBGRAPixel; EraseMode: boolean); 254 501 var 255 502 info: TFillBorderEllipseInfo; 256 503 begin 257 if (rx = 0) or (ry = 0) then504 if (rx = 0) or (ry = 0) or (w=0) or (x = EmptySingle) or (y = EmptySingle) then 258 505 exit; 259 506 info := TFillBorderEllipseInfo.Create(x, y, rx, ry, w); 260 FillShapeAntialias(bmp, info, c, EraseMode); 261 info.Free; 262 end; 263 264 { TFillShapeInfo } 265 266 function TFillShapeInfo.GetBounds: TRect; 267 begin 268 Result := rect(0, 0, 0, 0); 269 end; 270 271 function TFillShapeInfo.NbMaxIntersection: integer; 272 begin 273 Result := 0; 274 end; 275 276 {$hints off} 277 procedure TFillShapeInfo.ComputeIntersection(cury: single; 278 var inter: ArrayOfSingle; var nbInter: integer); 279 begin 280 281 end; 282 283 {$hints on} 284 285 { TFillPolyInfo } 286 287 constructor TFillPolyInfo.Create(points: array of TPointF); 288 var 289 i, j: integer; 290 First, cur, nbP: integer; 291 begin 292 setlength(FPoints, length(points)); 293 nbP := 0; 294 for i := 0 to high(points) do 295 if (i=0) or (points[i].x<>points[i-1].X) or (points[i].y<>points[i-1].y) then 296 begin 297 FPoints[nbP] := points[i]; 298 inc(nbP); 299 end; 300 if (nbP>0) and (FPoints[nbP-1].X = FPoints[0].X) and (FPoints[nbP-1].Y = FPoints[0].Y) then dec(NbP); 301 setlength(FPoints, nbP); 302 303 //look for empty points, correct coordinate and successors 304 setlength(FEmptyPt, length(FPoints)); 305 setlength(FNext, length(FPoints)); 306 307 cur := -1; 308 First := -1; 309 for i := 0 to high(FPoints) do 310 if not isEmptyPointF(FPoints[i]) then 311 begin 312 FEmptyPt[i] := False; 313 FPoints[i].x += 0.5; 314 FPoints[i].y += 0.5; 315 if cur <> -1 then 316 FNext[cur] := i; 317 if First = -1 then 318 First := i; 319 cur := i; 320 end 321 else 322 begin 323 if (First <> -1) and (cur <> First) then 324 FNext[cur] := First; 325 326 FEmptyPt[i] := True; 327 FNext[i] := -1; 328 cur := -1; 329 First := -1; 507 FillShapeAntialias(bmp, info, c, EraseMode, nil, False); 508 info.Free; 509 end; 510 511 procedure BorderEllipseAntialiasWithTexture(bmp: TBGRACustomBitmap; x, y, rx, 512 ry, w: single; scan: IBGRAScanner); 513 var 514 info: TFillBorderEllipseInfo; 515 begin 516 if (rx = 0) or (ry = 0) or (w=0) or (x = EmptySingle) or (y = EmptySingle) then 517 exit; 518 info := TFillBorderEllipseInfo.Create(x, y, rx, ry, w); 519 FillShapeAntialiasWithTexture(bmp, info, scan, False); 520 info.Free; 521 end; 522 523 { TBGRAMultishapeFiller } 524 525 procedure TBGRAMultishapeFiller.AddShape(AInfo: TFillShapeInfo; AInternalInfo: boolean; ATexture: IBGRAScanner; AInternalTexture: TObject; AColor: TBGRAPixel); 526 begin 527 if length(shapes) = nbShapes then 528 setlength(shapes, (length(shapes)+1)*2); 529 with shapes[nbShapes] do 530 begin 531 info := AInfo; 532 internalInfo:= AInternalInfo; 533 texture := ATexture; 534 internalTexture:= AInternalTexture; 535 color := GammaExpansion(AColor); 536 end; 537 inc(nbShapes); 538 end; 539 540 function TBGRAMultishapeFiller.CheckRectangleBorderBounds(var x1, y1, x2, 541 y2: single; w: single): boolean; 542 var temp: single; 543 begin 544 if x1 > x2 then 545 begin 546 temp := x1; 547 x1 := x2; 548 x2 := temp; 549 end; 550 if y1 > y2 then 551 begin 552 temp := y1; 553 y1 := y2; 554 y2 := temp; 555 end; 556 result := (x2-x1 > w) and (y2-y1 > w); 557 end; 558 559 constructor TBGRAMultishapeFiller.Create; 560 begin 561 nbShapes := 0; 562 shapes := nil; 563 PolygonOrder := poNone; 564 Antialiasing := True; 565 AliasingIncludeBottomRight := False; 566 end; 567 568 destructor TBGRAMultishapeFiller.Destroy; 569 var 570 i: Integer; 571 begin 572 for i := 0 to nbShapes-1 do 573 begin 574 if shapes[i].internalInfo then shapes[i].info.free; 575 shapes[i].texture := nil; 576 if shapes[i].internalTexture <> nil then shapes[i].internalTexture.Free; 577 end; 578 shapes := nil; 579 inherited Destroy; 580 end; 581 582 procedure TBGRAMultishapeFiller.AddShape(AShape: TFillShapeInfo; AColor: TBGRAPixel); 583 begin 584 AddShape(AShape,False,nil,nil,AColor); 585 end; 586 587 procedure TBGRAMultishapeFiller.AddShape(AShape: TFillShapeInfo; 588 ATexture: IBGRAScanner); 589 begin 590 AddShape(AShape,False,ATexture,nil,BGRAPixelTransparent); 591 end; 592 593 procedure TBGRAMultishapeFiller.AddPolygon(const points: array of TPointF; 594 AColor: TBGRAPixel); 595 begin 596 if length(points) <= 2 then exit; 597 AddShape(TFillPolyInfo.Create(points),True,nil,nil,AColor); 598 end; 599 600 procedure TBGRAMultishapeFiller.AddPolygon(const points: array of TPointF; 601 ATexture: IBGRAScanner); 602 begin 603 if length(points) <= 2 then exit; 604 AddShape(TFillPolyInfo.Create(points),True,ATexture,nil,BGRAPixelTransparent); 605 end; 606 607 procedure TBGRAMultishapeFiller.AddTriangleLinearColor(pt1, pt2, pt3: TPointF; c1, c2, 608 c3: TBGRAPixel); 609 var 610 grad: TBGRAGradientTriangleScanner; 611 begin 612 grad := TBGRAGradientTriangleScanner.Create(pt1,pt2,pt3, c1,c2,c3); 613 AddShape(TFillPolyInfo.Create([pt1,pt2,pt3]),True,grad,grad,BGRAPixelTransparent); 614 end; 615 616 procedure TBGRAMultishapeFiller.AddTriangleLinearMapping(pt1, pt2, 617 pt3: TPointF; texture: IBGRAScanner; tex1, tex2, tex3: TPointF); 618 var 619 mapping: TBGRATriangleLinearMapping; 620 begin 621 mapping := TBGRATriangleLinearMapping.Create(texture, pt1,pt2,pt3, tex1, tex2, tex3); 622 AddShape(TFillPolyInfo.Create([pt1,pt2,pt3]),True,mapping,mapping,BGRAPixelTransparent); 623 end; 624 625 procedure TBGRAMultishapeFiller.AddQuadLinearColor(pt1, pt2, pt3, pt4: TPointF; 626 c1, c2, c3, c4: TBGRAPixel); 627 var 628 center: TPointF; 629 centerColor: TBGRAPixel; 630 begin 631 center := (pt1+pt2+pt3+pt4)*(1/4); 632 centerColor := GammaCompression( MergeBGRA(MergeBGRA(GammaExpansion(c1),GammaExpansion(c2)), 633 MergeBGRA(GammaExpansion(c3),GammaExpansion(c4))) ); 634 AddTriangleLinearColor(pt1,pt2,center, c1,c2,centerColor); 635 AddTriangleLinearColor(pt2,pt3,center, c2,c3,centerColor); 636 AddTriangleLinearColor(pt3,pt4,center, c3,c4,centerColor); 637 AddTriangleLinearColor(pt4,pt1,center, c4,c1,centerColor); 638 end; 639 640 procedure TBGRAMultishapeFiller.AddQuadLinearMapping(pt1, pt2, pt3, 641 pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF); 642 var 643 center: TPointF; 644 centerTex: TPointF; 645 begin 646 center := (pt1+pt2+pt3+pt4)*(1/4); 647 centerTex := (tex1+tex2+tex3+tex4)*(1/4); 648 AddTriangleLinearMapping(pt1,pt2,center, texture,tex1,tex2,centerTex); 649 AddTriangleLinearMapping(pt2,pt3,center, texture,tex2,tex3,centerTex); 650 AddTriangleLinearMapping(pt3,pt4,center, texture,tex3,tex4,centerTex); 651 AddTriangleLinearMapping(pt4,pt1,center, texture,tex4,tex1,centerTex); 652 end; 653 654 procedure TBGRAMultishapeFiller.AddQuadPerspectiveMapping(pt1, pt2, pt3, 655 pt4: TPointF; texture: IBGRAScanner; tex1, tex2, tex3, tex4: TPointF); 656 var persp: TBGRAPerspectiveScannerTransform; 657 begin 658 persp := TBGRAPerspectiveScannerTransform.Create(texture,[tex1,tex2,tex3,tex4],[pt1,pt2,pt3,pt4]); 659 AddShape(TFillPolyInfo.Create([pt1,pt2,pt3,pt4]),True,persp,persp,BGRAPixelTransparent); 660 end; 661 662 procedure TBGRAMultishapeFiller.AddEllipse(x, y, rx, ry: single; AColor: TBGRAPixel 663 ); 664 begin 665 AddShape(TFillEllipseInfo.Create(x,y,rx,ry),True,nil,nil,AColor); 666 end; 667 668 procedure TBGRAMultishapeFiller.AddEllipse(x, y, rx, ry: single; 669 ATexture: IBGRAScanner); 670 begin 671 AddShape(TFillEllipseInfo.Create(x,y,rx,ry),True,ATexture,nil,BGRAPixelTransparent); 672 end; 673 674 procedure TBGRAMultishapeFiller.AddEllipseBorder(x, y, rx, ry, w: single; 675 AColor: TBGRAPixel); 676 begin 677 AddShape(TFillBorderEllipseInfo.Create(x,y,rx,ry,w),True,nil,nil,AColor); 678 end; 679 680 procedure TBGRAMultishapeFiller.AddEllipseBorder(x, y, rx, ry, w: single; 681 ATexture: IBGRAScanner); 682 begin 683 AddShape(TFillBorderEllipseInfo.Create(x,y,rx,ry,w),True,ATexture,nil,BGRAPixelTransparent); 684 end; 685 686 procedure TBGRAMultishapeFiller.AddRoundRectangle(x1, y1, x2, y2, rx, ry: single; 687 AColor: TBGRAPixel; options: TRoundRectangleOptions); 688 begin 689 AddShape(TFillRoundRectangleInfo.Create(x1, y1, x2, y2, rx, ry,options),True,nil,nil,AColor); 690 end; 691 692 procedure TBGRAMultishapeFiller.AddRoundRectangle(x1, y1, x2, y2, rx, ry: single; 693 ATexture: IBGRAScanner; options: TRoundRectangleOptions); 694 begin 695 AddShape(TFillRoundRectangleInfo.Create(x1, y1, x2, y2, rx, ry,options),True, 696 ATexture,nil,BGRAPixelTransparent); 697 end; 698 699 procedure TBGRAMultishapeFiller.AddRoundRectangleBorder(x1, y1, x2, y2, rx, 700 ry, w: single; AColor: TBGRAPixel; options: TRoundRectangleOptions); 701 begin 702 AddShape(TFillBorderRoundRectInfo.Create(x1, y1, x2, y2, rx, ry,w,options),True, 703 nil,nil,AColor); 704 end; 705 706 procedure TBGRAMultishapeFiller.AddRoundRectangleBorder(x1, y1, x2, y2, rx, ry, 707 w: single; ATexture: IBGRAScanner; options: TRoundRectangleOptions); 708 begin 709 AddShape(TFillBorderRoundRectInfo.Create(x1, y1, x2, y2, rx, ry,w,options),True, 710 ATexture,nil,BGRAPixelTransparent); 711 end; 712 713 procedure TBGRAMultishapeFiller.AddRectangle(x1, y1, x2, y2: single; 714 AColor: TBGRAPixel); 715 begin 716 AddPolygon([PointF(x1,y1),PointF(x2,y1),PointF(x2,y2),PointF(x1,y2)],AColor); 717 end; 718 719 procedure TBGRAMultishapeFiller.AddRectangle(x1, y1, x2, y2: single; 720 ATexture: IBGRAScanner); 721 begin 722 AddPolygon([PointF(x1,y1),PointF(x2,y1),PointF(x2,y2),PointF(x1,y2)],ATexture); 723 end; 724 725 procedure TBGRAMultishapeFiller.AddRectangleBorder(x1, y1, x2, y2, 726 w: single; AColor: TBGRAPixel); 727 var hw : single; 728 begin 729 hw := w/2; 730 if not CheckRectangleBorderBounds(x1,y1,x2,y2,w) then 731 AddRectangle(x1-hw,y1-hw,x2+hw,y2+hw,AColor) else 732 AddPolygon([PointF(x1-hw,y1-hw),PointF(x2+hw,y1-hw),PointF(x2+hw,y2+hw),PointF(x1-hw,y2+hw),EmptyPointF, 733 PointF(x1+hw,y2-hw),PointF(x2-hw,y2-hw),PointF(x2-hw,y1+hw),PointF(x1+hw,y1+hw)],AColor); 734 end; 735 736 procedure TBGRAMultishapeFiller.AddRectangleBorder(x1, y1, x2, y2, 737 w: single; ATexture: IBGRAScanner); 738 var hw : single; 739 begin 740 hw := w/2; 741 if not CheckRectangleBorderBounds(x1,y1,x2,y2,w) then 742 AddRectangle(x1-hw,y1-hw,x2+hw,y2+hw,ATexture) else 743 AddPolygon([PointF(x1-hw,y1-hw),PointF(x2+hw,y1-hw),PointF(x2+hw,y2+hw),PointF(x1-hw,y2+hw),EmptyPointF, 744 PointF(x1+hw,y2-hw),PointF(x2-hw,y2-hw),PointF(x2-hw,y1+hw),PointF(x1+hw,y1+hw)],ATexture); 745 end; 746 747 procedure TBGRAMultishapeFiller.Draw(dest: TBGRACustomBitmap); 748 var 749 shapeRow: array of record 750 density: PDensity; 751 densMinx,densMaxx: integer; 752 nbInter: integer; 753 inter: array of TIntersectionInfo; 754 end; 755 shapeRowsList: array of integer; 756 NbShapeRows: integer; 757 miny, maxy, minx, maxx, 758 rowminx, rowmaxx: integer; 759 760 procedure SubstractScanlines(src,dest: integer); 761 var i: integer; 762 763 procedure SubstractSegment(srcseg: integer); 764 var x1,x2, x3,x4: single; 765 j: integer; 766 767 procedure AddSegment(xa,xb: single); 768 var nb: PInteger; 769 prevNb,k: integer; 770 begin 771 nb := @shapeRow[dest].nbinter; 772 if length(shapeRow[dest].inter) < nb^+2 then 773 begin 774 prevNb := length(shapeRow[dest].inter); 775 setlength(shapeRow[dest].inter, nb^*2+2); 776 for k := prevNb to high(shapeRow[dest].inter) do 777 shapeRow[dest].inter[k] := shapes[dest].info.CreateIntersectionInfo; 778 end; 779 shapeRow[dest].inter[nb^].interX := xa; 780 shapeRow[dest].inter[nb^+1].interX := xb; 781 inc(nb^,2); 782 end; 783 784 begin 785 x1 := shapeRow[src].inter[(srcseg-1)*2].interX; 786 x2 := shapeRow[src].inter[srcseg*2-1].interX; 787 for j := shapeRow[dest].nbInter div 2 downto 1 do 788 begin 789 x3 := shapeRow[dest].inter[(j-1)*2].interX; 790 x4 := shapeRow[dest].inter[j*2-1].interX; 791 if (x2 <= x3) or (x1 >= x4) then continue; //not overlapping 792 if (x1 <= x3) and (x2 >= x4) then 793 shapeRow[dest].inter[j*2-1].interX := x3 //empty 794 else 795 if (x1 <= x3) and (x2 < x4) then 796 shapeRow[dest].inter[(j-1)*2].interX := x2 //remove left part 797 else 798 if (x1 > x3) and (x2 >= x4) then 799 shapeRow[dest].inter[j*2-1].interX := x1 else //remove right part 800 begin 801 //[x1,x2] is inside [x3,x4] 802 shapeRow[dest].inter[j*2-1].interX := x1; //left part 803 AddSegment(x2,x4); 804 end; 805 end; 330 806 end; 331 if (First <> -1) and (cur <> First) then 332 FNext[cur] := First; 333 334 setlength(FPrev, length(FPoints)); 335 for i := 0 to high(FPrev) do 336 FPrev[i] := -1; 337 for i := 0 to high(FNext) do 338 if FNext[i] <> -1 then 339 FPrev[FNext[i]] := i; 340 341 setlength(FSlopes, length(FPoints)); 342 setlength(FChangedir, length(FPoints)); 343 344 //compute slopes 345 for i := 0 to high(FPoints) do 346 if not FEmptyPt[i] then 347 begin 348 j := FNext[i]; 349 350 if FPoints[i].y <> FPoints[j].y then 351 FSlopes[i] := (FPoints[j].x - FPoints[i].x) / (FPoints[j].y - FPoints[i].y) 807 808 begin 809 for i := 1 to shapeRow[src].nbInter div 2 do 810 SubstractSegment(i); 811 end; 812 813 var 814 AliasingOfs: TPointF; 815 816 procedure AddOneLineDensity(cury: single); 817 var 818 i,k: integer; 819 ix1,ix2: integer; 820 x1,x2: single; 821 begin 822 for k := 0 to NbShapeRows-1 do 823 with shapeRow[shapeRowsList[k]], shapes[shapeRowsList[k]] do 824 begin 825 //find intersections 826 info.ComputeAndSort(cury, inter, nbInter, FillMode=fmWinding); 827 nbInter := nbInter and not 1; //even 828 end; 829 830 case PolygonOrder of 831 poLastOnTop: begin 832 for k := 1 to NbShapeRows-1 do 833 if shapeRow[shapeRowsList[k]].nbInter > 0 then 834 for i := 0 to k-1 do 835 SubstractScanlines(shapeRowsList[k],shapeRowsList[i]); 836 end; 837 poFirstOnTop: begin 838 for k := 0 to NbShapeRows-2 do 839 if shapeRow[shapeRowsList[k]].nbInter > 0 then 840 for i := k+1 to NbShapeRows-1 do 841 SubstractScanlines(shapeRowsList[k],shapeRowsList[i]); 842 end; 843 end; 844 845 for k := 0 to NbShapeRows-1 do 846 with shapeRow[shapeRowsList[k]] do 847 begin 848 //fill density 849 if not Antialiasing then 850 begin 851 for i := 0 to nbinter div 2 - 1 do 852 begin 853 x1 := inter[i + i].interX; 854 x2 := inter[i + i + 1].interX; 855 ComputeAliasedRowBounds(x1+AliasingOfs.X,x2+AliasingOfs.X,minx,maxx,ix1,ix2); 856 857 if ix1 < densMinx then densMinx := ix1; 858 if ix2 > densMaxx then densMaxx := ix2; 859 860 FillWord(density[ix1-minx],ix2-ix1+1,256); 861 end; 862 end else 863 {$I filldensity256.inc} 864 end; 865 866 for k := 0 to NbShapeRows-1 do 867 with shapeRow[shapeRowsList[k]] do 868 begin 869 if densMinX < rowminx then rowminx := densMinX; 870 if densMaxX > rowmaxx then rowmaxx := densMaxX; 871 end; 872 end; 873 874 type 875 TCardinalSum = record 876 sumR,sumG,sumB,sumA: cardinal; 877 end; 878 879 var 880 MultiEmpty: boolean; 881 bounds: TRect; 882 883 xb, yb, yc, j,k: integer; 884 pdest: PBGRAPixel; 885 886 curSum,nextSum: ^TCardinalSum; 887 sums: array of TCardinalSum; 888 889 pdens: PDensity; 890 w: cardinal; 891 ec: TExpandedPixel; 892 count: integer; 893 ScanNextFunc: function: TBGRAPixel of object; 894 895 begin 896 if nbShapes = 0 then exit; 897 if nbShapes = 1 then 898 begin 899 if Antialiasing then 900 FillShapeAntialias(dest,shapes[0].info,GammaCompression(shapes[0].color),False,shapes[0].texture,FillMode = fmWinding) else 901 FillShapeAliased(dest,shapes[0].info,GammaCompression(shapes[0].color),False,shapes[0].texture,FillMode = fmWinding, dmDrawWithTransparency, 902 AliasingIncludeBottomRight); 903 exit; 904 end; 905 bounds := Rect(0,0,0,0); 906 MultiEmpty := True; 907 for k := 0 to nbShapes-1 do 908 begin 909 If shapes[k].info.ComputeMinMax(minx,miny,maxx,maxy,dest) then 910 begin 911 shapes[k].bounds := rect(minx,miny,maxx+1,maxy+1); 912 if MultiEmpty then 913 begin 914 MultiEmpty := False; 915 bounds := shapes[k].bounds; 916 end else 917 begin 918 if minx < bounds.left then bounds.left := minx; 919 if miny < bounds.top then bounds.top := miny; 920 if maxx >= bounds.right then bounds.right := maxx+1; 921 if maxy >= bounds.bottom then bounds.bottom := maxy+1; 922 end; 923 end else 924 shapes[k].bounds := rect(0,0,0,0); 925 end; 926 if MultiEmpty then exit; 927 minx := bounds.left; 928 miny := bounds.top; 929 maxx := bounds.right-1; 930 maxy := bounds.bottom-1; 931 932 setlength(shapeRow, nbShapes); 933 for k := 0 to nbShapes-1 do 934 begin 935 shapeRow[k].inter := shapes[k].info.CreateIntersectionArray; 936 getmem(shapeRow[k].density, (maxx - minx + 2)*sizeof(TDensity)); //more for safety 937 end; 938 939 if AliasingIncludeBottomRight then 940 AliasingOfs := PointF(0,0) else 941 AliasingOfs := PointF(-0.0001,-0.0001); 942 943 setlength(sums,maxx-minx+2); //more for safety 944 setlength(shapeRowsList, nbShapes); 945 946 //vertical scan 947 for yb := miny to maxy do 948 begin 949 rowminx := maxx+1; 950 rowmaxx := minx-1; 951 952 //init shape rows 953 NbShapeRows := 0; 954 for k := 0 to nbShapes-1 do 955 if (yb >= shapes[k].bounds.top) and (yb < shapes[k].bounds.Bottom) then 956 begin 957 shapeRowsList[NbShapeRows] := k; 958 inc(NbShapeRows); 959 960 fillchar(shapeRow[k].density^,(maxx-minx+1)*sizeof(TDensity),0); 961 shapeRow[k].densMinx := maxx+1; 962 shapeRow[k].densMaxx := minx-1; 963 end; 964 965 If Antialiasing then 966 begin 967 //precision scan 968 for yc := 0 to AntialiasPrecision - 1 do 969 AddOneLineDensity( yb + (yc * 2 + 1) / (AntialiasPrecision * 2) ); 970 end else 971 begin 972 AddOneLineDensity( yb + 0.5 - AliasingOfs.Y ); 973 end; 974 975 rowminx := minx; 976 rowmaxx := maxx; 977 if rowminx <= rowmaxx then 978 begin 979 if rowminx < minx then rowminx := minx; 980 if rowmaxx > maxx then rowmaxx := maxx; 981 982 FillChar(sums[rowminx-minx],(rowmaxx-rowminx+1)*sizeof(sums[0]),0); 983 984 if Antialiasing then 985 {$define PARAM_ANTIALIASINGFACTOR} 986 {$i multishapeline.inc} 352 987 else 353 FSlopes[i] := EmptySingle; 354 355 FChangedir[i] := ((FPoints[i].y - FPoints[j].y > 0) and 356 (FPoints[FPrev[i]].y - FPoints[i].y < 0)) or 357 ((FPoints[i].y - FPoints[j].y < 0) and (FPoints[FPrev[i]].y - FPoints[i].y > 0)); 358 end 359 else 360 begin 361 FSlopes[i] := EmptySingle; 362 FChangedir[i] := False; 988 {$i multishapeline.inc}; 989 990 pdest := dest.ScanLine[yb] + rowminx; 991 xb := rowminx; 992 nextSum := @sums[xb-minx]; 993 while xb <= rowmaxx do 994 begin 995 curSum := nextSum; 996 inc(nextSum); 997 with curSum^ do 998 begin 999 if sumA <> 0 then 1000 begin 1001 ec.red := (sumR+sumA shr 1) div sumA; 1002 ec.green := (sumG+sumA shr 1) div sumA; 1003 ec.blue := (sumB+sumA shr 1) div sumA; 1004 if sumA > 255 then sumA := 255; 1005 ec.alpha := sumA shl 8 + sumA; 1006 count := 1; 1007 while (xb < rowmaxx) and (nextSum^.sumA = sumA) and (nextSum^.sumB = sumB) 1008 and (nextSum^.sumG = sumG) and (nextSum^.sumR = sumR) do 1009 begin 1010 inc(xb); 1011 inc(nextSum); 1012 inc(count); 1013 end; 1014 if count = 1 then 1015 DrawExpandedPixelInlineWithAlphaCheck(pdest,ec) else 1016 DrawExpandedPixelsInline(pdest, ec, count ); 1017 inc(pdest,count-1); 1018 end; 1019 end; 1020 inc(xb); 1021 inc(pdest); 1022 end; 363 1023 end; 364 1024 365 end; 366 367 function TFillPolyInfo.GetBounds: TRect; 368 var 369 minx, miny, maxx, maxy, i: integer; 370 begin 371 miny := floor(FPoints[0].y); 372 maxy := ceil(FPoints[0].y); 373 minx := floor(FPoints[0].x); 374 maxx := ceil(FPoints[0].x); 375 for i := 1 to high(FPoints) do 376 if not FEmptyPt[i] then 377 begin 378 if floor(FPoints[i].y) < miny then 379 miny := floor(FPoints[i].y) 380 else 381 if ceil(FPoints[i].y) > maxy then 382 maxy := ceil(FPoints[i].y); 383 384 if floor(FPoints[i].x) < minx then 385 minx := floor(FPoints[i].x) 386 else 387 if ceil(FPoints[i].x) > maxx then 388 maxx := ceil(FPoints[i].x); 1025 end; 1026 1027 for k := 0 to nbShapes-1 do 1028 begin 1029 freemem(shapeRow[k].density); 1030 shapes[k].info.FreeIntersectionArray(shapeRow[k].inter); 1031 end; 1032 1033 dest.InvalidateBitmap; 1034 end; 1035 1036 procedure FillRoundRectangleAntialias(bmp: TBGRACustomBitmap; x1, y1, x2, y2, 1037 rx, ry: single; options: TRoundRectangleOptions; c: TBGRAPixel; EraseMode: boolean); 1038 var 1039 info: TFillRoundRectangleInfo; 1040 begin 1041 if (x1 = x2) or (y1 = y2) then exit; 1042 info := TFillRoundRectangleInfo.Create(x1, y1, x2, y2, rx, ry, options); 1043 FillShapeAntialias(bmp, info, c, EraseMode,nil, False); 1044 info.Free; 1045 end; 1046 1047 procedure FillRoundRectangleAntialiasWithTexture(bmp: TBGRACustomBitmap; x1, 1048 y1, x2, y2, rx, ry: single; options: TRoundRectangleOptions; 1049 scan: IBGRAScanner); 1050 var 1051 info: TFillRoundRectangleInfo; 1052 begin 1053 if (x1 = x2) or (y1 = y2) then exit; 1054 info := TFillRoundRectangleInfo.Create(x1, y1, x2, y2, rx, ry, options); 1055 FillShapeAntialiasWithTexture(bmp, info, scan, False); 1056 info.Free; 1057 end; 1058 1059 procedure BorderRoundRectangleAntialias(bmp: TBGRACustomBitmap; x1, y1, x2, 1060 y2, rx, ry, w: single; options: TRoundRectangleOptions; c: TBGRAPixel; 1061 EraseMode: boolean); 1062 var 1063 info: TFillBorderRoundRectInfo; 1064 begin 1065 if (rx = 0) or (ry = 0) or (w=0) then exit; 1066 info := TFillBorderRoundRectInfo.Create(x1, y1, x2,y2, rx, ry, w, options); 1067 FillShapeAntialias(bmp, info, c, EraseMode, nil, False); 1068 info.Free; 1069 end; 1070 1071 procedure BorderRoundRectangleAntialiasWithTexture(bmp: TBGRACustomBitmap; x1, 1072 y1, x2, y2, rx, ry, w: single; options: TRoundRectangleOptions; 1073 scan: IBGRAScanner); 1074 var 1075 info: TFillBorderRoundRectInfo; 1076 begin 1077 if (rx = 0) or (ry = 0) or (w=0) then exit; 1078 info := TFillBorderRoundRectInfo.Create(x1, y1, x2,y2, rx, ry, w, options); 1079 FillShapeAntialiasWithTexture(bmp, info, scan, False); 1080 info.Free; 1081 end; 1082 1083 procedure BorderAndFillRoundRectangleAntialias(bmp: TBGRACustomBitmap; x1, y1, 1084 x2, y2, rx, ry, w: single; options: TRoundRectangleOptions; bordercolor, 1085 fillcolor: TBGRAPixel; bordertexture,filltexture: IBGRAScanner; EraseMode: boolean); 1086 var 1087 info: TFillBorderRoundRectInfo; 1088 multi: TBGRAMultishapeFiller; 1089 begin 1090 if (rx = 0) or (ry = 0) then exit; 1091 info := TFillBorderRoundRectInfo.Create(x1, y1, x2,y2, rx, ry, w, options); 1092 if not EraseMode then 1093 begin 1094 multi := TBGRAMultishapeFiller.Create; 1095 if filltexture <> nil then 1096 multi.AddShape(info.innerBorder, filltexture) else 1097 multi.AddShape(info.innerBorder, fillcolor); 1098 if w<>0 then 1099 begin 1100 if bordertexture <> nil then 1101 multi.AddShape(info, bordertexture) else 1102 multi.AddShape(info, bordercolor); 389 1103 end; 390 Result := rect(minx, miny, maxx + 1, maxy + 1); 391 end; 392 393 function TFillPolyInfo.NbMaxIntersection: integer; 394 begin 395 Result := length(FPoints); 396 end; 397 398 procedure TFillPolyInfo.ComputeIntersection(cury: single; 399 var inter: ArrayOfSingle; var nbInter: integer); 400 var 401 i, j: integer; 402 begin 403 for i := 0 to high(FPoints) do 404 if not FEmptyPt[i] then 405 begin 406 if cury = FPoints[i].y then 407 begin 408 if not FChangedir[i] then 409 begin 410 inter[nbinter] := FPoints[i].x; 411 Inc(nbinter); 412 end; 413 end 414 else 415 if (FSlopes[i] <> EmptySingle) then 416 begin 417 j := FNext[i]; 418 if (((cury >= FPoints[i].y) and (cury < FPoints[j].y)) or 419 ((cury > FPoints[j].y) and (cury <= FPoints[i].y))) then 420 begin 421 inter[nbinter] := (cury - FPoints[i].y) * FSlopes[i] + FPoints[i].x; 422 Inc(nbinter); 423 end; 424 end; 425 end; 426 end; 427 428 { TFillEllipseInfo } 429 430 constructor TFillEllipseInfo.Create(x, y, rx, ry: single); 431 begin 432 FX := x + 0.5; 433 FY := y + 0.5; 434 FRX := abs(rx); 435 FRY := abs(ry); 436 end; 437 438 function TFillEllipseInfo.GetBounds: TRect; 439 begin 440 Result := rect(floor(fx - frx), floor(fy - fry), ceil(fx + frx), ceil(fy + fry)); 441 end; 442 443 function TFillEllipseInfo.NbMaxIntersection: integer; 444 begin 445 Result := 2; 446 end; 447 448 procedure TFillEllipseInfo.ComputeIntersection(cury: single; 449 var inter: ArrayOfSingle; var nbInter: integer); 450 var 451 d: single; 452 begin 453 d := sqr((cury - FY) / FRY); 454 if d < 1 then 455 begin 456 d := sqrt(1 - d) * FRX; 457 inter[nbinter] := FX - d; 458 Inc(nbinter); 459 inter[nbinter] := FX + d; 460 Inc(nbinter); 461 end; 462 end; 463 464 { TFillBorderEllipseInfo } 465 466 constructor TFillBorderEllipseInfo.Create(x, y, rx, ry, w: single); 467 begin 468 if rx < 0 then 469 rx := -rx; 470 if ry < 0 then 471 ry := -ry; 472 outerBorder := TFillEllipseInfo.Create(x, y, rx + w / 2, ry + w / 2); 473 if (rx > w / 2) and (ry > w / 2) then 474 innerBorder := TFillEllipseInfo.Create(x, y, rx - w / 2, ry - w / 2) 475 else 476 innerBorder := nil; 477 end; 478 479 function TFillBorderEllipseInfo.GetBounds: TRect; 480 begin 481 Result := outerBorder.GetBounds; 482 end; 483 484 function TFillBorderEllipseInfo.NbMaxIntersection: integer; 485 begin 486 Result := 4; 487 end; 488 489 procedure TFillBorderEllipseInfo.ComputeIntersection(cury: single; 490 var inter: ArrayOfSingle; var nbInter: integer); 491 begin 492 outerBorder.ComputeIntersection(cury, inter, nbInter); 493 if innerBorder <> nil then 494 innerBorder.ComputeIntersection(cury, inter, nbInter); 495 end; 496 497 destructor TFillBorderEllipseInfo.Destroy; 498 begin 499 outerBorder.Free; 500 if innerBorder <> nil then 501 innerBorder.Free; 502 inherited Destroy; 503 end; 1104 multi.Draw(bmp); 1105 multi.Free; 1106 end else 1107 begin 1108 FillShapeAntialias(bmp, info.innerBorder, fillcolor, EraseMode, nil, False); 1109 FillShapeAntialias(bmp, info, bordercolor, EraseMode, nil, False); 1110 end; 1111 info.Free; 1112 end; 1113 1114 initialization 1115 1116 Randomize; 504 1117 505 1118 end. 506 -
GraphicTest/BGRABitmap/bgraqtbitmap.pas
r210 r317 59 59 procedure TBGRAQtBitmap.SlowDrawTransparent(ABitmap: TBGRADefaultBitmap; 60 60 ACanvas: TCanvas; ARect: TRect); 61 var62 background, temp: TBGRADefaultBitmap;63 w, h: integer;64 65 61 begin 66 w := ARect.Right - ARect.Left; 67 h := ARect.Bottom - ARect.Top; 68 background := NewBitmap(w, h); 69 background.GetImageFromCanvas(ACanvas, ARect.Left, ARect.Top); 70 if (ABitmap.Width = w) and (ABitmap.Height = h) then 71 background.PutImage(0, 0, ABitmap, dmDrawWithTransparency) 72 else 73 begin 74 temp := ABitmap.Resample(w, h, rmSimpleStretch); 75 background.PutImage(0, 0, temp, dmDrawWithTransparency); 76 temp.Free; 77 end; 78 background.Draw(ACanvas, ARect.Left, ARect.Top, True); 79 background.Free; 62 ACanvas.Draw(0,0, ABitmap.Bitmap); 80 63 end; 81 64 -
GraphicTest/BGRABitmap/bgraresample.pas
r210 r317 1 unit bgraresample;1 unit BGRAResample; 2 2 3 3 {$mode objfpc}{$H+} 4 4 5 { 6/2/2011 : fixed SimpleStretchSmaller }6 7 5 interface 8 6 7 { This unit provides resampling functions, i.e. resizing of bitmaps with or 8 without interpolation filters. 9 10 SimpleStretch does a fast stretch by splitting the image into zones defined 11 by integers. This can be quite ugly. 12 13 FineResample uses floating point coordinates to get an antialiased resample. 14 It can use minimal interpolation (4 pixels when upsizing) for simple interpolation 15 filters (linear and cosine-like) or wide kernel resample for complex interpolation. 16 In this cas, it calls WideKernelResample. 17 18 WideKernelResample can be called by custom filter kernel, derived 19 from TWideKernelFilter. It is slower of course than simple interpolation. } 20 9 21 uses 10 Classes, SysUtils, BGRADefaultBitmap; 11 12 function FineResample(bmp: TBGRADefaultBitmap; 13 NewWidth, NewHeight: integer): TBGRADefaultBitmap; 14 function SimpleStretch(bmp: TBGRADefaultBitmap; 15 NewWidth, NewHeight: integer): TBGRADefaultBitmap; 22 Classes, SysUtils, BGRABitmapTypes; 23 24 {------------------------------- Simple stretch ------------------------------------} 25 26 function SimpleStretch(bmp: TBGRACustomBitmap; 27 NewWidth, NewHeight: integer): TBGRACustomBitmap; 28 29 {---------------------------- Interpolation filters --------------------------------} 30 31 function FineInterpolation(t: single; ResampleFilter: TResampleFilter): single; 32 33 type 34 TWideKernelFilter = class 35 function Interpolation(t: single): single; virtual; abstract; 36 function ShouldCheckRange: boolean; virtual; abstract; 37 function KernelWidth: single; virtual; abstract; 38 end; 39 40 TMitchellKernel = class(TWideKernelFilter) 41 function Interpolation(t: single): single; override; 42 function ShouldCheckRange: boolean; override; 43 function KernelWidth: single; override; 44 end; 45 46 { TSplineKernel } 47 48 TSplineKernel = class(TWideKernelFilter) 49 public 50 Coeff: single; 51 constructor Create; 52 constructor Create(ACoeff: single); 53 function Interpolation(t: single): single; override; 54 function ShouldCheckRange: boolean; override; 55 function KernelWidth: single; override; 56 end; 57 58 { TCubicKernel } 59 60 TCubicKernel = class(TWideKernelFilter) 61 function pow3(x: single): single; inline; 62 function Interpolation(t: single): single; override; 63 function ShouldCheckRange: boolean; override; 64 function KernelWidth: single; override; 65 end; 66 67 function CreateInterpolator(style: TSplineStyle): TWideKernelFilter; 68 69 {-------------------------------- Fine resample ------------------------------------} 70 71 function FineResample(bmp: TBGRACustomBitmap; 72 NewWidth, NewHeight: integer; ResampleFilter: TResampleFilter): TBGRACustomBitmap; 73 74 function WideKernelResample(bmp: TBGRACustomBitmap; 75 NewWidth, NewHeight: integer; ResampleFilterSmaller, ResampleFilterLarger: TWideKernelFilter): TBGRACustomBitmap; 16 76 17 77 implementation 18 78 19 uses GraphType, BGRABitmapTypes, Math; 20 21 function FineResampleLarger(bmp: TBGRADefaultBitmap; 22 newWidth, newHeight: integer): TBGRADefaultBitmap; 79 uses GraphType, Math; 80 81 {-------------------------------- Simple stretch ------------------------------------} 82 83 function FastSimpleStretchLarger(bmp: TBGRACustomBitmap; 84 xFactor, yFactor: integer): TBGRACustomBitmap; 23 85 var 24 yb, xb: integer; 25 pdest: PBGRAPixel; 26 xsrc, ysrc, xfactor, yfactor: double; 27 ixsrc1, ixsrc2, iysrc1, iysrc2: integer; 28 cUpLeft, cUpRight, cLowLeft, cLowRight: TBGRAPixel; 29 factHoriz, factVert, factCorrX, factCorrY, Sum, fUpLeft, fUpRight, 30 fLowLeft, fLowRight, faUpLeft, faUpRight, faLowLeft, faLowRight: single; 31 rSum, gSum, bSum, aSum: single; 32 temp: TBGRADefaultBitmap; 86 y_src, yb, y_dest: integer; 87 88 x_src, xb: integer; 89 srcColor: TBGRAPixel; 90 91 PSrc: PBGRAPixel; 92 PDest: array of PBGRAPixel; 93 temp: PBGRAPixel; 94 95 begin 96 if (xFactor < 1) or (yFactor < 1) then 97 raise ERangeError.Create('FastSimpleStretchLarger: New dimensions must be greater or equal (*'+IntToStr(xFactor)+'x*'+IntToStr(yFactor)+')'); 98 99 Result := bmp.NewBitmap(bmp.Width * xFactor, bmp.Height * yFactor); 100 if (Result.Width = 0) or (Result.Height = 0) then 101 exit; 102 103 bmp.LoadFromBitmapIfNeeded; 104 105 SetLength(PDest, yFactor); 106 y_dest := 0; 107 for y_src := 0 to bmp.Height - 1 do 108 begin 109 PSrc := bmp.Scanline[y_src]; 110 for yb := 0 to yFactor - 1 do 111 PDest[yb] := Result.scanLine[y_dest + yb]; 112 113 for x_src := 0 to bmp.Width - 1 do 114 begin 115 srcColor := PSrc^; 116 Inc(PSrc); 117 118 for yb := 0 to yFactor - 1 do 119 begin 120 temp := PDest[yb]; 121 for xb := 0 to xFactor - 1 do 122 begin 123 temp^ := srcColor; 124 Inc(temp); 125 end; 126 PDest[yb] := temp; 127 end; 128 end; 129 Inc(y_dest, yFactor); 130 end; 131 132 Result.InvalidateBitmap; 133 end; 134 135 function SimpleStretchLarger(bmp: TBGRACustomBitmap; 136 newWidth, newHeight: integer): TBGRACustomBitmap; 137 var 138 x_src, y_src: integer; 139 inc_x_dest, mod_x_dest, acc_x_dest, inc_y_dest, mod_y_dest, acc_y_dest: integer; 140 x_dest, y_dest, prev_x_dest, prev_y_dest: integer; 141 142 xb, yb: integer; 143 srcColor: TBGRAPixel; 144 PDest, PSrc: PBGRAPixel; 145 delta, lineDelta: integer; 146 33 147 begin 34 148 if (newWidth < bmp.Width) or (newHeight < bmp.Height) then 35 raise ERangeError.Create('FineResampleLarger: New dimensions must be greater or equal ('+IntToStr(bmp.Width)+'x'+IntToStr(bmp.Height)+'->'+IntToStr(newWidth)+'x'+IntToStr(newHeight)+')'); 149 raise ERangeError.Create('SimpleStretchLarger: New dimensions must be greater or equal ('+IntToStr(bmp.Width)+'x'+IntToStr(bmp.Height)+'->'+IntToStr(newWidth)+'x'+IntToStr(newHeight)+')'); 150 151 if ((newWidth div bmp.Width) * bmp.Width = newWidth) and 152 ((newHeight div bmp.Height) * bmp.Height = newHeight) then 153 begin 154 Result := FastSimpleStretchLarger(bmp, newWidth div bmp.Width, 155 newHeight div bmp.Height); 156 exit; 157 end; 36 158 37 159 Result := bmp.NewBitmap(NewWidth, NewHeight); … … 41 163 bmp.LoadFromBitmapIfNeeded; 42 164 165 inc_x_dest := newwidth div bmp.Width; 166 mod_x_dest := newwidth mod bmp.Width; 167 inc_y_dest := newheight div bmp.Height; 168 mod_y_dest := newheight mod bmp.Height; 169 170 y_dest := 0; 171 acc_y_dest := bmp.Height div 2; 172 if Result.LineOrder = riloTopToBottom then 173 lineDelta := newWidth 174 else 175 lineDelta := -newWidth; 176 for y_src := 0 to bmp.Height - 1 do 177 begin 178 prev_y_dest := y_dest; 179 Inc(y_dest, inc_y_dest); 180 Inc(acc_y_dest, mod_y_dest); 181 if acc_y_dest >= bmp.Height then 182 begin 183 Dec(acc_y_dest, bmp.Height); 184 Inc(y_dest); 185 end; 186 187 PSrc := bmp.Scanline[y_src]; 188 189 x_dest := 0; 190 acc_x_dest := bmp.Width div 2; 191 for x_src := 0 to bmp.Width - 1 do 192 begin 193 prev_x_dest := x_dest; 194 Inc(x_dest, inc_x_dest); 195 Inc(acc_x_dest, mod_x_dest); 196 if acc_x_dest >= bmp.Width then 197 begin 198 Dec(acc_x_dest, bmp.Width); 199 Inc(x_dest); 200 end; 201 202 srcColor := PSrc^; 203 Inc(PSrc); 204 205 PDest := Result.scanline[prev_y_dest] + prev_x_dest; 206 delta := lineDelta - (x_dest - prev_x_dest); 207 for yb := prev_y_dest to y_dest - 1 do 208 begin 209 for xb := prev_x_dest to x_dest - 1 do 210 begin 211 PDest^ := srcColor; 212 Inc(PDest); 213 end; 214 Inc(PDest, delta); 215 end; 216 end; 217 end; 218 Result.InvalidateBitmap; 219 end; 220 221 function SimpleStretchSmallerFactor2(source: TBGRACustomBitmap): TBGRACustomBitmap; 222 var xb,yb: integer; 223 pdest: PBGRAPixel; 224 psrc1,psrc2: PBGRAPixel; 225 asum: integer; 226 a1,a2,a3,a4: integer; 227 newWidth,newHeight: integer; 228 begin 229 newWidth := source.Width div 2; 230 newHeight := source.Height div 2; 231 result := source.NewBitmap(newWidth,newHeight); 232 for yb := 0 to newHeight-1 do 233 begin 234 pdest := result.ScanLine[yb]; 235 psrc1 := source.Scanline[yb shl 1]; 236 psrc2 := source.Scanline[yb shl 1+1]; 237 for xb := newWidth-1 downto 0 do 238 begin 239 asum := psrc1^.alpha + (psrc1+1)^.alpha + psrc2^.alpha + (psrc2+1)^.alpha; 240 if asum = 0 then 241 pdest^ := BGRAPixelTransparent 242 else if asum = 1020 then 243 begin 244 pdest^.alpha := 255; 245 pdest^.red := (psrc1^.red + (psrc1+1)^.red + psrc2^.red + (psrc2+1)^.red + 2) shr 2; 246 pdest^.green := (psrc1^.green + (psrc1+1)^.green + psrc2^.green + (psrc2+1)^.green+ 2) shr 2; 247 pdest^.blue := (psrc1^.blue + (psrc1+1)^.blue + psrc2^.blue + (psrc2+1)^.blue+ 2) shr 2; 248 end else 249 begin 250 pdest^.alpha := asum shr 2; 251 a1 := psrc1^.alpha; 252 a2 := (psrc1+1)^.alpha; 253 a3 := psrc2^.alpha; 254 a4 := (psrc2+1)^.alpha; 255 pdest^.red := (psrc1^.red*a1 + (psrc1+1)^.red*a2 + psrc2^.red*a3 + (psrc2+1)^.red*a4 + (asum shr 1)) div asum; 256 pdest^.green := (psrc1^.green*a1 + (psrc1+1)^.green*a2 + psrc2^.green*a3 + (psrc2+1)^.green*a4+ (asum shr 1)) div asum; 257 pdest^.blue := (psrc1^.blue*a1 + (psrc1+1)^.blue*a2 + psrc2^.blue*a3 + (psrc2+1)^.blue*a4+ (asum shr 1)) div asum; 258 end; 259 inc(psrc1,2); 260 inc(psrc2,2); 261 inc(pdest); 262 end; 263 end; 264 end; 265 266 function SimpleStretchSmallerFactor4(source: TBGRACustomBitmap): TBGRACustomBitmap; 267 var xb,yb: integer; 268 pdest: PBGRAPixel; 269 psrc1,psrc2,psrc3,psrc4: PBGRAPixel; 270 asum: integer; 271 a1,a2,a3,a4, 272 a5,a6,a7,a8, 273 a9,a10,a11,a12, 274 a13,a14,a15,a16: integer; 275 newWidth,newHeight: integer; 276 begin 277 newWidth := source.Width div 4; 278 newHeight := source.Height div 4; 279 result := source.NewBitmap(newWidth,newHeight); 280 for yb := 0 to newHeight-1 do 281 begin 282 pdest := result.ScanLine[yb]; 283 psrc1 := source.Scanline[yb shl 2]; 284 psrc2 := source.Scanline[yb shl 2+1]; 285 psrc3 := source.Scanline[yb shl 2+2]; 286 psrc4 := source.Scanline[yb shl 2+3]; 287 for xb := newWidth-1 downto 0 do 288 begin 289 asum := psrc1^.alpha + (psrc1+1)^.alpha + (psrc1+2)^.alpha + (psrc1+3)^.alpha + 290 psrc2^.alpha + (psrc2+1)^.alpha + (psrc2+2)^.alpha + (psrc2+3)^.alpha + 291 psrc3^.alpha + (psrc3+1)^.alpha + (psrc3+2)^.alpha + (psrc3+3)^.alpha + 292 psrc4^.alpha + (psrc4+1)^.alpha + (psrc4+2)^.alpha + (psrc4+3)^.alpha; 293 if asum = 0 then 294 pdest^ := BGRAPixelTransparent 295 else if asum = 4080 then 296 begin 297 pdest^.alpha := 255; 298 pdest^.red := (psrc1^.red + (psrc1+1)^.red + (psrc1+2)^.red + (psrc1+3)^.red + 299 psrc2^.red + (psrc2+1)^.red + (psrc2+2)^.red + (psrc2+3)^.red + 300 psrc3^.red + (psrc3+1)^.red + (psrc3+2)^.red + (psrc3+3)^.red + 301 psrc4^.red + (psrc4+1)^.red + (psrc4+2)^.red + (psrc4+3)^.red + 8) shr 4; 302 pdest^.green := (psrc1^.green + (psrc1+1)^.green + (psrc1+2)^.green + (psrc1+3)^.green + 303 psrc2^.green + (psrc2+1)^.green + (psrc2+2)^.green + (psrc2+3)^.green + 304 psrc3^.green + (psrc3+1)^.green + (psrc3+2)^.green + (psrc3+3)^.green + 305 psrc4^.green + (psrc4+1)^.green + (psrc4+2)^.green + (psrc4+3)^.green + 8) shr 4; 306 pdest^.blue := (psrc1^.blue + (psrc1+1)^.blue + (psrc1+2)^.blue + (psrc1+3)^.blue + 307 psrc2^.blue + (psrc2+1)^.blue + (psrc2+2)^.blue + (psrc2+3)^.blue + 308 psrc3^.blue + (psrc3+1)^.blue + (psrc3+2)^.blue + (psrc3+3)^.blue + 309 psrc4^.blue + (psrc4+1)^.blue + (psrc4+2)^.blue + (psrc4+3)^.blue + 8) shr 4; 310 end else 311 begin 312 pdest^.alpha := asum shr 4; 313 a1 := psrc1^.alpha; 314 a2 := (psrc1+1)^.alpha; 315 a3 := (psrc1+2)^.alpha; 316 a4 := (psrc1+3)^.alpha; 317 a5 := psrc2^.alpha; 318 a6 := (psrc2+1)^.alpha; 319 a7 := (psrc2+2)^.alpha; 320 a8 := (psrc2+3)^.alpha; 321 a9 := psrc3^.alpha; 322 a10 := (psrc3+1)^.alpha; 323 a11 := (psrc3+2)^.alpha; 324 a12 := (psrc3+3)^.alpha; 325 a13 := psrc4^.alpha; 326 a14 := (psrc4+1)^.alpha; 327 a15 := (psrc4+2)^.alpha; 328 a16 := (psrc4+3)^.alpha; 329 pdest^.red := (psrc1^.red*a1 + (psrc1+1)^.red*a2 + (psrc1+2)^.red*a3 + (psrc1+3)^.red*a4 + 330 psrc2^.red*a5 + (psrc2+1)^.red*a6 + (psrc2+2)^.red*a7 + (psrc2+3)^.red*a8 + 331 psrc3^.red*a9 + (psrc3+1)^.red*a10 + (psrc3+2)^.red*a11 + (psrc3+3)^.red*a12 + 332 psrc4^.red*a13 + (psrc4+1)^.red*a14 + (psrc4+2)^.red*a15 + (psrc4+3)^.red*a16 + (asum shr 1)) div asum; 333 pdest^.green := (psrc1^.green*a1 + (psrc1+1)^.green*a2 + (psrc1+2)^.green*a3 + (psrc1+3)^.green*a4 + 334 psrc2^.green*a5 + (psrc2+1)^.green*a6 + (psrc2+2)^.green*a7 + (psrc2+3)^.green*a8 + 335 psrc3^.green*a9 + (psrc3+1)^.green*a10 + (psrc3+2)^.green*a11 + (psrc3+3)^.green*a12 + 336 psrc4^.green*a13 + (psrc4+1)^.green*a14 + (psrc4+2)^.green*a15 + (psrc4+3)^.green*a16 + (asum shr 1)) div asum; 337 pdest^.blue := (psrc1^.blue*a1 + (psrc1+1)^.blue*a2 + (psrc1+2)^.blue*a3 + (psrc1+3)^.blue*a4 + 338 psrc2^.blue*a5 + (psrc2+1)^.blue*a6 + (psrc2+2)^.blue*a7 + (psrc2+3)^.blue*a8 + 339 psrc3^.blue*a9 + (psrc3+1)^.blue*a10 + (psrc3+2)^.blue*a11 + (psrc3+3)^.blue*a12 + 340 psrc4^.blue*a13 + (psrc4+1)^.blue*a14 + (psrc4+2)^.blue*a15 + (psrc4+3)^.blue*a16 + (asum shr 1)) div asum; 341 end; 342 inc(psrc1,4); 343 inc(psrc2,4); 344 inc(psrc3,4); 345 inc(psrc4,4); 346 inc(pdest); 347 end; 348 end; 349 end; 350 351 function SimpleStretchSmallerFactor(source: TBGRACustomBitmap; fx,fy: integer): TBGRACustomBitmap; 352 var xb,yb,ys,iy,ix: integer; 353 pdest: PBGRAPixel; 354 psrc: array of PBGRAPixel; 355 psrci: PBGRAPixel; 356 asum,maxsum: integer; 357 newWidth,newHeight: integer; 358 r,g,b,nbi: integer; 359 begin 360 newWidth := source.Width div fx; 361 newHeight := source.Height div fy; 362 result := source.NewBitmap(newWidth,newHeight); 363 ys := 0; 364 maxsum := 255*fx*fy; 365 nbi := fx*fy; 366 setlength(psrc, fy); 367 for yb := 0 to newHeight-1 do 368 begin 369 pdest := result.ScanLine[yb]; 370 for iy := fy-1 downto 0 do 371 begin 372 psrc[iy] := source.Scanline[ys]; 373 inc(ys); 374 end; 375 for xb := newWidth-1 downto 0 do 376 begin 377 asum := 0; 378 for iy := fy-1 downto 0 do 379 begin 380 psrci := psrc[iy]; 381 for ix := fx-1 downto 0 do 382 asum += (psrci+ix)^.alpha; 383 end; 384 if asum = 0 then 385 pdest^ := BGRAPixelTransparent 386 else if asum = maxsum then 387 begin 388 pdest^.alpha := 255; 389 r := 0; 390 g := 0; 391 b := 0; 392 for iy := fy-1 downto 0 do 393 begin 394 psrci := psrc[iy]; 395 for ix := fx-1 downto 0 do 396 begin 397 with (psrci+ix)^ do 398 begin 399 r += red; 400 g += green; 401 b += blue; 402 end; 403 end; 404 end; 405 pdest^.red := (r + (nbi shr 1)) div nbi; 406 pdest^.green := (g + (nbi shr 1)) div nbi; 407 pdest^.blue := (b + (nbi shr 1)) div nbi; 408 end else 409 begin 410 pdest^.alpha := (asum + (nbi shr 1)) div nbi; 411 r := 0; 412 g := 0; 413 b := 0; 414 for iy := fy-1 downto 0 do 415 begin 416 psrci := psrc[iy]; 417 for ix := fx-1 downto 0 do 418 begin 419 with (psrci+ix)^ do 420 begin 421 r += integer(red)*integer(alpha); 422 g += integer(green)*integer(alpha); 423 b += integer(blue)*integer(alpha); 424 end; 425 end; 426 end; 427 pdest^.red := (r + (asum shr 1)) div asum; 428 pdest^.green := (g + (asum shr 1)) div asum; 429 pdest^.blue := (b + (asum shr 1)) div asum; 430 end; 431 for iy := fy-1 downto 0 do 432 inc(psrc[iy],fx); 433 inc(pdest); 434 end; 435 end; 436 end; 437 438 function SimpleStretchSmaller(bmp: TBGRACustomBitmap; 439 newWidth, newHeight: integer): TBGRACustomBitmap; 440 var 441 x_dest, y_dest: integer; 442 inc_x_src, mod_x_src, acc_x_src, inc_y_src, mod_y_src, acc_y_src: integer; 443 x_src, y_src, prev_x_src, prev_y_src: integer; 444 x_src2, y_src2: integer; 445 446 xb, yb: integer; 447 v1, v2, v3, v4, v4shr1: int64; 448 nb,a: integer; 449 pdest, psrc, psrcscan: PBGRAPixel; 450 lineDelta, delta: integer; 451 452 begin 453 if (newWidth > bmp.Width) or (newHeight > bmp.Height) then 454 raise ERangeError.Create('SimpleStretchSmaller: New dimensions must be smaller or equal ('+IntToStr(bmp.Width)+'x'+IntToStr(bmp.Height)+'->'+IntToStr(newWidth)+'x'+IntToStr(newHeight)+')'); 455 456 if (newWidth = 0) or (newHeight = 0) or (bmp.Width = 0) or (bmp.Height = 0) then 457 begin 458 Result := bmp.NewBitmap(NewWidth, NewHeight); 459 exit; 460 end; 461 462 if (newWidth*2 = bmp.Width) and (newHeight*2 = bmp.Height) then 463 begin 464 result := SimpleStretchSmallerFactor2(bmp); 465 exit 466 end 467 else 468 if (newWidth*4 = bmp.Width) and (newHeight*4 = bmp.Height) then 469 begin 470 result := SimpleStretchSmallerFactor4(bmp); 471 exit; 472 end 473 else 474 if (newWidth < bmp.Width) and (newHeight < bmp.Height) and 475 (bmp.Width mod newWidth = 0) and (bmp.Height mod newHeight = 0) then 476 begin 477 result := SimpleStretchSmallerFactor(bmp, bmp.Width div newWidth, bmp.Height div newHeight); 478 exit; 479 end; 480 481 Result := bmp.NewBitmap(NewWidth, NewHeight); 482 483 bmp.LoadFromBitmapIfNeeded; 484 485 inc_x_src := bmp.Width div newWidth; 486 mod_x_src := bmp.Width mod newWidth; 487 inc_y_src := bmp.Height div newHeight; 488 mod_y_src := bmp.Height mod newHeight; 489 490 if bmp.lineOrder = riloTopToBottom then 491 lineDelta := bmp.Width 492 else 493 lineDelta := -bmp.Width; 494 495 y_src := 0; 496 acc_y_src := 0; 497 for y_dest := 0 to newHeight - 1 do 498 begin 499 PDest := Result.ScanLine[y_dest]; 500 501 prev_y_src := y_src; 502 Inc(y_src, inc_y_src); 503 Inc(acc_y_src, mod_y_src); 504 if acc_y_src >= newHeight then 505 begin 506 Dec(acc_y_src, newHeight); 507 Inc(y_src); 508 end; 509 if y_src > prev_y_src then 510 y_src2 := y_src - 1 511 else 512 y_src2 := y_src; 513 psrcscan := bmp.Scanline[prev_y_src]; 514 515 x_src := 0; 516 acc_x_src := 0; 517 for x_dest := 0 to newWidth - 1 do 518 begin 519 prev_x_src := x_src; 520 Inc(x_src, inc_x_src); 521 Inc(acc_x_src, mod_x_src); 522 if acc_x_src >= newWidth then 523 begin 524 Dec(acc_x_src, newWidth); 525 Inc(x_src); 526 end; 527 if x_src > prev_x_src then 528 x_src2 := x_src - 1 529 else 530 x_src2 := x_src; 531 532 v1 := 0; 533 v2 := 0; 534 v3 := 0; 535 v4 := 0; 536 nb := 0; 537 delta := lineDelta - (x_src2 - prev_x_src + 1); 538 539 PSrc := psrcscan + prev_x_src; 540 for yb := prev_y_src to y_src2 do 541 begin 542 for xb := prev_x_src to x_src2 do 543 begin 544 with PSrc^ do 545 begin 546 a := alpha; 547 {$HINTS OFF} 548 v1 += integer(red) * a; 549 v2 += integer(green) * a; 550 v3 += integer(blue) * a; 551 {$HINTS ON} 552 end; 553 v4 += a; 554 Inc(PSrc); 555 Inc(nb); 556 end; 557 Inc(PSrc, delta); 558 end; 559 560 if (v4 <> 0) and (nb <> 0) then 561 begin 562 v4shr1 := v4 shr 1; 563 with PDest^ do 564 begin 565 red := (v1 + v4shr1) div v4; 566 green := (v2 + v4shr1) div v4; 567 blue := (v3 + v4shr1) div v4; 568 alpha := (v4 + (nb shr 1)) div nb; 569 end; 570 end 571 else 572 PDest^ := BGRAPixelTransparent; 573 574 Inc(PDest); 575 end; 576 end; 577 Result.InvalidateBitmap; 578 end; 579 580 function SimpleStretch(bmp: TBGRACustomBitmap; 581 NewWidth, NewHeight: integer): TBGRACustomBitmap; 582 var 583 temp, newtemp: TBGRACustomBitmap; 584 begin 585 if (NewWidth = bmp.Width) and (NewHeight = bmp.Height) then 586 Result := bmp.Duplicate 587 else 588 if (NewWidth >= bmp.Width) and (NewHeight >= bmp.Height) then 589 Result := SimpleStretchLarger(bmp, NewWidth, NewHeight) 590 else 591 if (NewWidth <= bmp.Width) and (NewHeight <= bmp.Height) then 592 Result := SimpleStretchSmaller(bmp, NewWidth, NewHeight) 593 else 594 begin 595 temp := bmp; 596 597 if NewWidth < bmp.Width then 598 begin 599 newtemp := SimpleStretchSmaller(temp, NewWidth, temp.Height); 600 if (temp <> bmp) then 601 temp.Free; 602 temp := newtemp; 603 end; 604 605 if NewHeight < bmp.Height then 606 begin 607 newtemp := SimpleStretchSmaller(temp, temp.Width, NewHeight); 608 if (temp <> bmp) then 609 temp.Free; 610 temp := newtemp; 611 end; 612 613 if NewWidth > bmp.Width then 614 begin 615 newtemp := SimpleStretchLarger(temp, NewWidth, temp.Height); 616 if (temp <> bmp) then 617 temp.Free; 618 temp := newtemp; 619 end; 620 621 if NewHeight > bmp.Height then 622 begin 623 newtemp := SimpleStretchLarger(temp, temp.Width, NewHeight); 624 if (temp <> bmp) then 625 temp.Free; 626 temp := newtemp; 627 end; 628 629 if temp <> bmp then 630 Result := temp 631 else 632 Result := bmp.Duplicate; 633 end; 634 end; 635 636 {---------------------------- Interpolation filters ----------------------------------------} 637 638 function FineInterpolation(t: single; ResampleFilter: TResampleFilter): single; 639 begin 640 if ResampleFilter = rfLinear then 641 result := t else 642 begin 643 if t <= 0.5 then 644 result := t*t*2 else 645 result := 1-(1-t)*(1-t)*2; 646 if ResampleFilter <> rfCosine then result := (result+t)*0.5; 647 end; 648 end; 649 650 { TCubicKernel } 651 652 function TCubicKernel.pow3(x: single): single; 653 begin 654 if x <= 0.0 then 655 result:=0.0 656 else 657 result:=x * x * x; 658 end; 659 660 function TCubicKernel.Interpolation(t: single): single; 661 const globalfactor = 1/6; 662 begin 663 if t > 2 then 664 result := 0 665 else 666 result:= globalfactor * 667 (pow3(t + 2 ) - 4 * pow3(t + 1 ) + 6 * pow3(t ) - 4 * pow3(t - 1 ) ); 668 end; 669 670 function TCubicKernel.ShouldCheckRange: boolean; 671 begin 672 Result:= false; 673 end; 674 675 function TCubicKernel.KernelWidth: single; 676 begin 677 Result:= 2; 678 end; 679 680 { TMitchellKernel } 681 682 function TMitchellKernel.Interpolation(t: single): single; 683 var 684 tt, ttt: single; 685 const OneEighteenth = 1 / 18; 686 begin 687 t := Abs(t); 688 tt := Sqr(t); 689 ttt := tt * t; 690 if t < 1 then Result := (21 * ttt - 36 * tt + 16 ) * OneEighteenth 691 else if t < 2 then Result := (- 7 * ttt + 36 * tt - 60 * t + 32) * OneEighteenth 692 else Result := 0; 693 end; 694 695 function TMitchellKernel.ShouldCheckRange: Boolean; 696 begin 697 Result := True; 698 end; 699 700 function TMitchellKernel.KernelWidth: single; 701 begin 702 Result := 2; 703 end; 704 705 { TSplineKernel } 706 707 constructor TSplineKernel.Create; 708 begin 709 coeff := 0.5; 710 end; 711 712 constructor TSplineKernel.Create(ACoeff: single); 713 begin 714 Coeff := ACoeff; 715 end; 716 717 function TSplineKernel.Interpolation(t: single): single; 718 var 719 tt, ttt: single; 720 begin 721 t := Abs(t); 722 tt := Sqr(t); 723 ttt := tt * t; 724 if t < 1 then 725 Result := (2 - Coeff) * ttt - (3 - Coeff) * tt + 1 726 else if t < 2 then 727 Result := -Coeff * (ttt - 5 * tt + 8 * t - 4) 728 else 729 Result := 0; 730 end; 731 732 function TSplineKernel.ShouldCheckRange: Boolean; 733 begin 734 Result := True; 735 end; 736 737 function TSplineKernel.KernelWidth: single; 738 begin 739 Result := 2; 740 end; 741 742 {--------------------------------------------- Fine resample ------------------------------------------------} 743 744 function FineResampleLarger(bmp: TBGRACustomBitmap; 745 newWidth, newHeight: integer; ResampleFilter: TResampleFilter): TBGRACustomBitmap; 746 type 747 TInterpolationEntry = record 748 isrc1,isrc2,factCorr: integer; 749 end; 750 var 751 yb, xb: integer; 752 pdest,psrc1,psrc2: PBGRAPixel; 753 xsrc, ysrc, xfactor, yfactor: double; 754 xTab,yTab: array of TInterpolationEntry; 755 xInfo,yInfo: TInterpolationEntry; 756 cUpLeft, cUpRight, cLowLeft, cLowRight: TBGRAPixel; 757 factHoriz, factVert: single; 758 fUpLeft, fUpRight, fLowLeft, fLowRight: integer; 759 faUpLeft, faUpRight, faLowLeft, faLowRight: integer; 760 rSum, gSum, bSum, aSum: integer; 761 temp: TBGRACustomBitmap; 762 begin 763 if (newWidth < bmp.Width) or (newHeight < bmp.Height) then 764 raise ERangeError.Create('FineResampleLarger: New dimensions must be greater or equal ('+IntToStr(bmp.Width)+'x'+IntToStr(bmp.Height)+'->'+IntToStr(newWidth)+'x'+IntToStr(newHeight)+')'); 765 766 if (newWidth = 0) or (newHeight = 0) then 767 begin 768 Result := bmp.NewBitmap(NewWidth, NewHeight); 769 exit; 770 end; 771 772 bmp.LoadFromBitmapIfNeeded; 773 43 774 if (bmp.Width = 1) and (bmp.Height = 1) then 44 775 begin 776 Result := bmp.NewBitmap(NewWidth, NewHeight); 45 777 Result.Fill(bmp.GetPixel(0, 0)); 46 778 exit; … … 52 784 temp.PutImage(0, 0, bmp, dmSet); 53 785 temp.PutImage(1, 0, bmp, dmSet); 54 Result := FineResampleLarger(temp, 2, newHeight );786 Result := FineResampleLarger(temp, 2, newHeight, ResampleFilter); 55 787 temp.Free; 56 788 temp := Result; 57 Result := SimpleStretch(temp, 1,temp.Height);789 Result := SimpleStretch(temp, newWidth,temp.Height); 58 790 temp.Free; 59 791 exit; … … 65 797 temp.PutImage(0, 0, bmp, dmSet); 66 798 temp.PutImage(0, 1, bmp, dmSet); 67 Result := FineResampleLarger(temp, newWidth, 2 );799 Result := FineResampleLarger(temp, newWidth, 2, ResampleFilter); 68 800 temp.Free; 69 801 temp := Result; 70 Result := SimpleStretch(temp, temp.Width, 1);802 Result := SimpleStretch(temp, temp.Width,newHeight); 71 803 temp.Free; 72 804 exit; 73 805 end; 74 806 807 Result := bmp.NewBitmap(NewWidth, NewHeight); 75 808 yfactor := (bmp.Height - 1) / (newHeight - 1); 76 809 xfactor := (bmp.Width - 1) / (newWidth - 1); 810 811 setlength(yTab, newHeight); 77 812 for yb := 0 to newHeight - 1 do 78 813 begin 814 ysrc := yb * yfactor; 815 factVert := frac(ysrc); 816 yTab[yb].isrc1 := floor(ysrc); 817 yTab[yb].isrc2 := min(bmp.Height-1, ceil(ysrc)); 818 yTab[yb].factCorr := round(FineInterpolation(factVert,ResampleFilter)*256); 819 end; 820 setlength(xTab, newWidth); 821 for xb := 0 to newWidth - 1 do 822 begin 823 xsrc := xb * xfactor; 824 factHoriz := frac(xsrc); 825 xTab[xb].isrc1 := floor(xsrc); 826 xTab[xb].isrc2 := min(bmp.Width-1,ceil(xsrc)); 827 xTab[xb].factCorr := round(FineInterpolation(factHoriz,ResampleFilter)*256); 828 end; 829 830 for yb := 0 to newHeight - 1 do 831 begin 79 832 pdest := Result.Scanline[yb]; 80 ysrc := yb * yfactor; 81 iysrc1 := floor(ysrc); 82 factVert := frac(ysrc); 83 if (factVert = 0) then 84 iysrc2 := iysrc1 85 else 86 iysrc2 := ceil(ysrc); 87 factCorrY := 0.5 - cos(factVert * Pi) / 2; 833 yInfo := yTab[yb]; 834 psrc1 := bmp.scanline[yInfo.isrc1]; 835 psrc2 := bmp.scanline[yInfo.isrc2]; 88 836 for xb := 0 to newWidth - 1 do 89 837 begin 90 xsrc := xb * xfactor; 91 ixsrc1 := floor(xsrc); 92 factHoriz := frac(xsrc); 93 if (factHoriz = 0) then 94 ixsrc2 := ixsrc1 95 else 96 ixsrc2 := ceil(xsrc); 97 factCorrX := 0.5 - cos(factHoriz * Pi) / 2; 98 99 cUpLeft := bmp.GetPixel(ixsrc1, iysrc1); 100 cUpRight := bmp.GetPixel(ixsrc2, iysrc1); 101 cLowLeft := bmp.GetPixel(ixsrc1, iysrc2); 102 cLowRight := bmp.GetPixel(ixsrc2, iysrc2); 103 104 fUpLeft := (1 - factCorrX) * (1 - factCorrY); 105 fUpRight := factCorrX * (1 - factCorrY); 106 fLowLeft := (1 - factCorrX) * factCorrY; 107 fLowRight := factCorrX * factCorrY; 838 xInfo := xTab[xb]; 839 840 cUpLeft := (psrc1 + xInfo.isrc1)^; 841 cUpRight := (psrc1 + xInfo.isrc2)^; 842 cLowLeft := (psrc2 + xInfo.isrc1)^; 843 cLowRight := (psrc2 + xInfo.isrc2)^; 844 845 fLowRight := (xInfo.factCorr * yInfo.factCorr + 128) shr 8; 846 fLowLeft := yInfo.factCorr - fLowRight; 847 fUpRight := xInfo.factCorr - fLowRight; 848 fUpLeft := (256 - xInfo.factCorr) - fLowLeft; 108 849 109 850 faUpLeft := fUpLeft * cUpLeft.alpha; … … 112 853 faLowRight := fLowRight * cLowRight.alpha; 113 854 114 Sum := fUpLeft + fUpRight + fLowLeft + fLowRight;115 855 rSum := cUpLeft.red * faUpLeft + cUpRight.red * faUpRight + 116 856 cLowLeft.red * faLowLeft + cLowRight.red * faLowRight; … … 125 865 pdest^ := BGRAPixelTransparent 126 866 else 127 pdest^ := BGRA( round(rSum / aSum), round(gSum / aSum),128 round(bSum / aSum), round(aSum / Sum));867 pdest^ := BGRA((rSum + aSum shr 1) div aSum, (gSum + aSum shr 1) div aSum, 868 (bSum + aSum shr 1) div aSum, (aSum + 128) shr 8); 129 869 Inc(pdest); 130 870 … … 133 873 end; 134 874 135 function FastSimpleStretchLarger(bmp: TBGRADefaultBitmap; 136 xFactor, yFactor: integer): TBGRADefaultBitmap; 137 var 138 y_src, yb, y_dest: integer; 139 140 x_src, xb: integer; 141 srcColor: TBGRAPixel; 142 143 PSrc: PBGRAPixel; 144 PDest: array of PBGRAPixel; 145 temp: PBGRAPixel; 146 147 begin 148 if (xFactor < 1) or (yFactor < 1) then 149 raise ERangeError.Create('FastSimpleStretchLarger: New dimensions must be greater or equal (*'+IntToStr(xFactor)+'x*'+IntToStr(yFactor)+')'); 150 151 Result := bmp.NewBitmap(bmp.Width * xFactor, bmp.Height * yFactor); 152 if (Result.Width = 0) or (Result.Height = 0) then 153 exit; 154 155 bmp.LoadFromBitmapIfNeeded; 156 157 SetLength(PDest, yFactor); 158 y_dest := 0; 159 for y_src := 0 to bmp.Height - 1 do 160 begin 161 PSrc := bmp.Scanline[y_src]; 162 for yb := 0 to yFactor - 1 do 163 PDest[yb] := Result.scanLine[y_dest + yb]; 164 165 for x_src := 0 to bmp.Width - 1 do 166 begin 167 srcColor := PSrc^; 168 Inc(PSrc); 169 170 for yb := 0 to yFactor - 1 do 171 begin 172 temp := PDest[yb]; 173 for xb := 0 to xFactor - 1 do 174 begin 175 temp^ := srcColor; 176 Inc(temp); 177 end; 178 PDest[yb] := temp; 179 end; 180 end; 181 Inc(y_dest, yFactor); 182 end; 183 184 Result.InvalidateBitmap; 185 end; 186 187 function SimpleStretchLarger(bmp: TBGRADefaultBitmap; 188 newWidth, newHeight: integer): TBGRADefaultBitmap; 189 var 190 x_src, y_src: integer; 191 inc_x_dest, mod_x_dest, acc_x_dest, inc_y_dest, mod_y_dest, acc_y_dest: integer; 192 x_dest, y_dest, prev_x_dest, prev_y_dest: integer; 193 194 xb, yb: integer; 195 srcColor: TBGRAPixel; 196 PDest, PSrc: PBGRAPixel; 197 delta, lineDelta: integer; 198 199 begin 200 if (newWidth < bmp.Width) or (newHeight < bmp.Height) then 201 raise ERangeError.Create('SimpleStretchLarger: New dimensions must be greater or equal ('+IntToStr(bmp.Width)+'x'+IntToStr(bmp.Height)+'->'+IntToStr(newWidth)+'x'+IntToStr(newHeight)+')'); 202 203 if ((newWidth div bmp.Width) * bmp.Width = newWidth) and 204 ((newHeight div bmp.Height) * bmp.Height = newHeight) then 205 begin 206 Result := FastSimpleStretchLarger(bmp, newWidth div bmp.Width, 207 newHeight div bmp.Height); 208 exit; 209 end; 210 211 Result := bmp.NewBitmap(NewWidth, NewHeight); 212 if (newWidth = 0) or (newHeight = 0) then 213 exit; 214 215 bmp.LoadFromBitmapIfNeeded; 216 217 inc_x_dest := newwidth div bmp.Width; 218 mod_x_dest := newwidth mod bmp.Width; 219 inc_y_dest := newheight div bmp.Height; 220 mod_y_dest := newheight mod bmp.Height; 221 222 y_dest := 0; 223 acc_y_dest := bmp.Height div 2; 224 if Result.LineOrder = riloTopToBottom then 225 lineDelta := newWidth 226 else 227 lineDelta := -newWidth; 228 for y_src := 0 to bmp.Height - 1 do 229 begin 230 prev_y_dest := y_dest; 231 Inc(y_dest, inc_y_dest); 232 Inc(acc_y_dest, mod_y_dest); 233 if acc_y_dest >= bmp.Height then 234 begin 235 Dec(acc_y_dest, bmp.Height); 236 Inc(y_dest); 237 end; 238 239 PSrc := bmp.Scanline[y_src]; 240 241 x_dest := 0; 242 acc_x_dest := bmp.Width div 2; 243 for x_src := 0 to bmp.Width - 1 do 244 begin 245 prev_x_dest := x_dest; 246 Inc(x_dest, inc_x_dest); 247 Inc(acc_x_dest, mod_x_dest); 248 if acc_x_dest >= bmp.Width then 249 begin 250 Dec(acc_x_dest, bmp.Width); 251 Inc(x_dest); 252 end; 253 254 srcColor := PSrc^; 255 Inc(PSrc); 256 257 PDest := Result.scanline[prev_y_dest] + prev_x_dest; 258 delta := lineDelta - (x_dest - prev_x_dest); 259 for yb := prev_y_dest to y_dest - 1 do 260 begin 261 for xb := prev_x_dest to x_dest - 1 do 262 begin 263 PDest^ := srcColor; 264 Inc(PDest); 265 end; 266 Inc(PDest, delta); 267 end; 268 end; 269 end; 270 Result.InvalidateBitmap; 271 end; 272 273 function SimpleStretchSmaller(bmp: TBGRADefaultBitmap; 274 newWidth, newHeight: integer): TBGRADefaultBitmap; 275 var 276 x_dest, y_dest: integer; 277 inc_x_src, mod_x_src, acc_x_src, inc_y_src, mod_y_src, acc_y_src: integer; 278 x_src, y_src, prev_x_src, prev_y_src: integer; 279 x_src2, y_src2: integer; 280 281 xb, yb: integer; 282 v1, v2, v3, v4, v4shr1: int64; 283 nb: integer; 284 c: TBGRAPixel; 285 pdest, psrc: PBGRAPixel; 286 lineDelta, delta: integer; 287 begin 288 if (newWidth > bmp.Width) or (newHeight > bmp.Height) then 289 raise ERangeError.Create('SimpleStretchSmaller: New dimensions must be smaller or equal ('+IntToStr(bmp.Width)+'x'+IntToStr(bmp.Height)+'->'+IntToStr(newWidth)+'x'+IntToStr(newHeight)+')'); 290 Result := bmp.NewBitmap(NewWidth, NewHeight); 291 if (newWidth = 0) or (newHeight = 0) or (bmp.Width = 0) or (bmp.Height = 0) then 292 exit; 293 294 bmp.LoadFromBitmapIfNeeded; 295 296 inc_x_src := bmp.Width div newWidth; 297 mod_x_src := bmp.Width mod newWidth; 298 inc_y_src := bmp.Height div newHeight; 299 mod_y_src := bmp.Height mod newHeight; 300 301 if bmp.lineOrder = riloTopToBottom then 302 lineDelta := bmp.Width 303 else 304 lineDelta := -bmp.Width; 305 306 y_src := 0; 307 acc_y_src := 0; 308 for y_dest := 0 to newHeight - 1 do 309 begin 310 PDest := Result.ScanLine[y_dest]; 311 312 prev_y_src := y_src; 313 Inc(y_src, inc_y_src); 314 Inc(acc_y_src, mod_y_src); 315 if acc_y_src >= newHeight then 316 begin 317 Dec(acc_y_src, newHeight); 318 Inc(y_src); 319 end; 320 if y_src > prev_y_src then 321 y_src2 := y_src - 1 322 else 323 y_src2 := y_src; 324 325 x_src := 0; 326 acc_x_src := 0; 327 for x_dest := 0 to newWidth - 1 do 328 begin 329 prev_x_src := x_src; 330 Inc(x_src, inc_x_src); 331 Inc(acc_x_src, mod_x_src); 332 if acc_x_src >= newWidth then 333 begin 334 Dec(acc_x_src, newWidth); 335 Inc(x_src); 336 end; 337 if x_src > prev_x_src then 338 x_src2 := x_src - 1 339 else 340 x_src2 := x_src; 341 342 v1 := 0; 343 v2 := 0; 344 v3 := 0; 345 v4 := 0; 346 nb := 0; 347 delta := lineDelta - (x_src2 - prev_x_src + 1); 348 PSrc := bmp.Scanline[prev_y_src] + prev_x_src; 349 for yb := prev_y_src to y_src2 do 350 begin 351 for xb := prev_x_src to x_src2 do 352 begin 353 c := PSrc^; 354 Inc(PSrc); 355 {$HINTS OFF} 356 v1 += integer(c.red) * integer(c.alpha); 357 v2 += integer(c.green) * integer(c.alpha); 358 v3 += integer(c.blue) * integer(c.alpha); 359 {$HINTS ON} 360 v4 += c.alpha; 361 Inc(nb); 362 end; 363 Inc(PSrc, delta); 364 end; 365 366 if (v4 <> 0) and (nb <> 0) then 367 begin 368 v4shr1 := v4 shr 1; 369 c.red := (v1 + v4shr1) div v4; 370 c.green := (v2 + v4shr1) div v4; 371 c.blue := (v3 + v4shr1) div v4; 372 c.alpha := (v4 + (nb shr 1)) div nb; 373 end 374 else 375 begin 376 c.alpha := 0; 377 c.red := 0; 378 c.green := 0; 379 c.blue := 0; 380 end; 381 PDest^ := c; 382 Inc(PDest); 383 end; 384 end; 385 Result.InvalidateBitmap; 386 end; 387 388 function FineResampleSmaller(bmp: TBGRADefaultBitmap; 389 newWidth, newHeight: integer): TBGRADefaultBitmap; 875 function FineResampleSmaller(bmp: TBGRACustomBitmap; 876 newWidth, newHeight: integer): TBGRACustomBitmap; 390 877 var 391 878 yb, xb, yb2, xb2: integer; … … 571 1058 end; 572 1059 573 function FineResample(bmp: TBGRADefaultBitmap; 574 NewWidth, NewHeight: integer): TBGRADefaultBitmap; 1060 function CreateInterpolator(style: TSplineStyle): TWideKernelFilter; 1061 begin 1062 case Style of 1063 ssInside, ssInsideWithEnds: result := TCubicKernel.Create; 1064 ssCrossing, ssCrossingWithEnds: result := TMitchellKernel.Create; 1065 ssOutside: result := TSplineKernel.Create(0.5); 1066 ssRoundOutside: result := TSplineKernel.Create(0.75); 1067 ssVertexToSide: result := TSplineKernel.Create(1); 1068 else 1069 raise Exception.Create('Unknown spline style'); 1070 end; 1071 end; 1072 1073 function FineResample(bmp: TBGRACustomBitmap; 1074 NewWidth, NewHeight: integer; ResampleFilter: TResampleFilter): TBGRACustomBitmap; 575 1075 var 576 temp, newtemp: TBGRADefaultBitmap; 577 begin 1076 temp, newtemp: TBGRACustomBitmap; 1077 tempFilter1,tempFilter2: TWideKernelFilter; 1078 begin 1079 case ResampleFilter of 1080 rfBicubic: //blur 1081 begin 1082 tempFilter1 := TCubicKernel.Create; 1083 result := WideKernelResample(bmp,NewWidth,NewHeight,tempFilter1,tempFilter1); 1084 tempFilter1.Free; 1085 exit; 1086 end; 1087 rfMitchell: 1088 begin 1089 tempFilter1 := TMitchellKernel.Create; 1090 result := WideKernelResample(bmp,NewWidth,NewHeight,tempFilter1,tempFilter1); 1091 tempFilter1.Free; 1092 exit; 1093 end; 1094 rfSpline: 1095 begin 1096 tempFilter1 := TSplineKernel.Create; 1097 result := WideKernelResample(bmp,NewWidth,NewHeight,tempFilter1,tempFilter1); 1098 tempFilter1.Free; 1099 exit; 1100 end; 1101 rfBestQuality: 1102 begin 1103 tempFilter1 := TSplineKernel.Create; 1104 tempFilter2 := TMitchellKernel.Create; 1105 result := WideKernelResample(bmp,NewWidth,NewHeight,tempFilter2,tempFilter1); 1106 tempFilter1.Free; 1107 tempFilter2.Free; 1108 exit; 1109 end; 1110 end; 1111 578 1112 if (NewWidth = bmp.Width) and (NewHeight = bmp.Height) then 579 1113 Result := bmp.Duplicate 580 1114 else 581 1115 if (NewWidth >= bmp.Width) and (NewHeight >= bmp.Height) then 582 Result := FineResampleLarger(bmp, NewWidth, NewHeight )1116 Result := FineResampleLarger(bmp, NewWidth, NewHeight, ResampleFilter) 583 1117 else 584 1118 if (NewWidth <= bmp.Width) and (NewHeight <= bmp.Height) then … … 606 1140 if NewWidth > bmp.Width then 607 1141 begin 608 newtemp := FineResampleLarger(temp, NewWidth, temp.Height );1142 newtemp := FineResampleLarger(temp, NewWidth, temp.Height, ResampleFilter); 609 1143 if (temp <> bmp) then 610 1144 temp.Free; … … 614 1148 if NewHeight > bmp.Height then 615 1149 begin 616 newtemp := FineResampleLarger(temp, temp.Width, NewHeight );1150 newtemp := FineResampleLarger(temp, temp.Width, NewHeight, ResampleFilter); 617 1151 if (temp <> bmp) then 618 1152 temp.Free; … … 627 1161 end; 628 1162 629 function SimpleStretch(bmp: TBGRADefaultBitmap; 630 NewWidth, NewHeight: integer): TBGRADefaultBitmap; 1163 {------------------------ Wide kernel filtering adapted from Graphics32 ---------------------------} 1164 1165 function Constrain(const Value, Lo, Hi: Integer): Integer; 1166 begin 1167 if Value < Lo then 1168 Result := Lo 1169 else if Value > Hi then 1170 Result := Hi 1171 else 1172 Result := Value; 1173 end; 1174 1175 type 1176 TPointRec = record 1177 Pos: Integer; 1178 Weight: Single; 1179 end; 1180 1181 TCluster = array of TPointRec; 1182 TMappingTable = array of TCluster; 1183 1184 {$warnings off} 1185 function BuildMappingTable( 1186 DstLo, DstHi: Integer; 1187 ClipLo, ClipHi: Integer; 1188 SrcLo, SrcHi: Integer; 1189 KernelSmaller,KernelLarger: TWideKernelFilter): TMappingTable; 1190 Const FullEdge = false; 631 1191 var 632 temp, newtemp: TBGRADefaultBitmap; 633 begin 634 if (NewWidth = bmp.Width) and (NewHeight = bmp.Height) then 635 Result := bmp.Duplicate 636 else 637 if (NewWidth >= bmp.Width) and (NewHeight >= bmp.Height) then 638 Result := SimpleStretchLarger(bmp, NewWidth, NewHeight) 639 else 640 if (NewWidth <= bmp.Width) and (NewHeight <= bmp.Height) then 641 Result := SimpleStretchSmaller(bmp, NewWidth, NewHeight) 642 else 643 begin 644 temp := bmp; 645 646 if NewWidth < bmp.Width then 647 begin 648 newtemp := SimpleStretchSmaller(temp, NewWidth, temp.Height); 649 if (temp <> bmp) then 650 temp.Free; 651 temp := newtemp; 652 end; 653 654 if NewHeight < bmp.Height then 655 begin 656 newtemp := SimpleStretchSmaller(temp, temp.Width, NewHeight); 657 if (temp <> bmp) then 658 temp.Free; 659 temp := newtemp; 660 end; 661 662 if NewWidth > bmp.Width then 663 begin 664 newtemp := SimpleStretchLarger(temp, NewWidth, temp.Height); 665 if (temp <> bmp) then 666 temp.Free; 667 temp := newtemp; 668 end; 669 670 if NewHeight > bmp.Height then 671 begin 672 newtemp := SimpleStretchLarger(temp, temp.Width, NewHeight); 673 if (temp <> bmp) then 674 temp.Free; 675 temp := newtemp; 676 end; 677 678 if temp <> bmp then 679 Result := temp 680 else 681 Result := bmp.Duplicate; 682 end; 1192 SrcW, DstW, ClipW: Integer; 1193 FilterWidth: Single; 1194 Scale, OldScale: Single; 1195 Center: Single; 1196 Left, Right: Integer; 1197 I, J, K: Integer; 1198 Weight: Single; 1199 begin 1200 SrcW := SrcHi - SrcLo; 1201 DstW := DstHi - DstLo; 1202 ClipW := ClipHi - ClipLo; 1203 if SrcW = 0 then 1204 begin 1205 Result := nil; 1206 Exit; 1207 end 1208 else if SrcW = 1 then 1209 begin 1210 SetLength(Result, ClipW); 1211 for I := 0 to ClipW - 1 do 1212 begin 1213 SetLength(Result[I], 1); 1214 Result[I][0].Pos := 0; 1215 Result[I][0].Weight := 1; 1216 end; 1217 Exit; 1218 end; 1219 SetLength(Result, ClipW); 1220 if ClipW = 0 then Exit; 1221 1222 if FullEdge then Scale := DstW / SrcW 1223 else Scale := (DstW - 1) / (SrcW - 1); 1224 1225 K := 0; 1226 1227 if Scale = 0 then 1228 begin 1229 SetLength(Result[0], 1); 1230 Result[0][0].Pos := (SrcLo + SrcHi) div 2; 1231 Result[0][0].Weight := 1; 1232 end 1233 else if Scale < 1 then 1234 begin 1235 FilterWidth := KernelSmaller.KernelWidth; 1236 OldScale := Scale; 1237 Scale := 1 / Scale; 1238 FilterWidth := FilterWidth * Scale; 1239 for I := 0 to ClipW - 1 do 1240 begin 1241 if FullEdge then 1242 Center := SrcLo - 0.5 + (I - DstLo + ClipLo + 0.5) * Scale 1243 else 1244 Center := SrcLo + (I - DstLo + ClipLo) * Scale; 1245 Left := Floor(Center - FilterWidth); 1246 Right := Ceil(Center + FilterWidth); 1247 for J := Left to Right do 1248 begin 1249 Weight := KernelSmaller.Interpolation((Center - J) * OldScale) * OldScale; 1250 if Weight <> 0 then 1251 begin 1252 K := Length(Result[I]); 1253 SetLength(Result[I], K + 1); 1254 Result[I][K].Pos := Constrain(J, SrcLo, SrcHi - 1); 1255 Result[I][K].Weight := Weight; 1256 end; 1257 end; 1258 if Length(Result[I]) = 0 then 1259 begin 1260 SetLength(Result[I], 1); 1261 Result[I][0].Pos := Floor(Center); 1262 Result[I][0].Weight := 1; 1263 end; 1264 end; 1265 end 1266 else // scale > 1 1267 begin 1268 FilterWidth := KernelLarger.KernelWidth; 1269 Scale := 1 / Scale; 1270 for I := 0 to ClipW - 1 do 1271 begin 1272 if FullEdge then 1273 Center := SrcLo - 0.5 + (I - DstLo + ClipLo + 0.5) * Scale 1274 else 1275 Center := SrcLo + (I - DstLo + ClipLo) * Scale; 1276 Left := Floor(Center - FilterWidth); 1277 Right := Ceil(Center + FilterWidth); 1278 for J := Left to Right do 1279 begin 1280 Weight := KernelLarger.Interpolation(Center - j); 1281 if Weight <> 0 then 1282 begin 1283 K := Length(Result[I]); 1284 SetLength(Result[I], k + 1); 1285 Result[I][K].Pos := Constrain(j, SrcLo, SrcHi - 1); 1286 Result[I][K].Weight := Weight; 1287 end; 1288 end; 1289 end; 1290 end; 1291 end; 1292 {$warnings on} 1293 1294 function WideKernelResample(bmp: TBGRACustomBitmap; 1295 NewWidth, NewHeight: integer; ResampleFilterSmaller, ResampleFilterLarger: TWideKernelFilter): TBGRACustomBitmap; 1296 type 1297 TSum = record 1298 sumR,sumG,sumB,sumA: single; 1299 end; 1300 1301 var 1302 mapX,mapY: TMappingTable; 1303 xb,yb,xc,yc,MapXLoPos,MapXHiPos: integer; 1304 clusterX,clusterY: TCluster; 1305 verticalSum: array of TSum; 1306 scanlinesSrc: array of PBGRAPixel; 1307 sum: TSum; 1308 c: TBGRAPixel; 1309 w,wa: single; 1310 pdest: PBGRAPixel; 1311 begin 1312 result := bmp.NewBitmap(NewWidth,NewHeight); 1313 if (NewWidth=0) or (NewHeight=0) then exit; 1314 mapX := BuildMappingTable(0,NewWidth,0,NewWidth,0,bmp.Width,ResampleFilterSmaller,ResampleFilterLarger); 1315 mapY := BuildMappingTable(0,NewHeight,0,NewHeight,0,bmp.Height,ResampleFilterSmaller,ResampleFilterLarger); 1316 1317 MapXLoPos := MapX[0][0].Pos; 1318 MapXHiPos := MapX[NewWidth - 1][High(MapX[NewWidth - 1])].Pos; 1319 1320 setlength(verticalSum, MapXHiPos-MapXLoPos+1); 1321 1322 setlength(scanlinesSrc, bmp.Height); 1323 for yb := 0 to bmp.Height-1 do 1324 scanlinesSrc[yb] := bmp.ScanLine[yb]; 1325 1326 for yb := 0 to NewHeight-1 do 1327 begin 1328 clusterY := mapY[yb]; 1329 1330 for xb := MapXLoPos to MapXHiPos do 1331 begin 1332 fillchar(verticalSum[xb - MapXLoPos],sizeof(verticalSum[xb - MapXLoPos]),0); 1333 for yc := 0 to high(clusterY) do 1334 with verticalSum[xb - MapXLoPos] do 1335 begin 1336 c := (scanlinesSrc[clusterY[yc].Pos]+xb)^; 1337 w := clusterY[yc].Weight; 1338 wa := w * c.alpha; 1339 sumA += wa; 1340 sumR += c.red * wa; 1341 sumG += c.green * wa; 1342 sumB += c.blue * wa; 1343 end; 1344 end; 1345 1346 pdest := result.Scanline[yb]; 1347 1348 for xb := 0 to NewWidth-1 do 1349 begin 1350 clusterX := mapX[xb]; 1351 {$hints off} 1352 fillchar(sum,sizeof(sum),0); 1353 {$hints on} 1354 for xc := 0 to high(clusterX) do 1355 begin 1356 w := clusterX[xc].Weight; 1357 with verticalSum[ClusterX[xc].Pos - MapXLoPos] do 1358 begin 1359 sum.sumA += sumA*w; 1360 sum.sumR += sumR*w; 1361 sum.sumG += sumG*w; 1362 sum.sumB += sumB*w; 1363 end; 1364 end; 1365 1366 if sum.sumA < 0.5 then 1367 pdest^ := BGRAPixelTransparent else 1368 begin 1369 c.red := constrain(round(sum.sumR/sum.sumA),0,255); 1370 c.green := constrain(round(sum.sumG/sum.sumA),0,255); 1371 c.blue := constrain(round(sum.sumB/sum.sumA),0,255); 1372 if sum.sumA > 255 then 1373 c.alpha := 255 else 1374 c.alpha := round(sum.sumA); 1375 pdest^ := c; 1376 end; 1377 inc(pdest); 1378 end; 1379 end; 1380 683 1381 end; 684 1382 -
GraphicTest/BGRABitmap/readme.txt
r210 r317 1 BGRABitmap v 2.2- Drawing routines with alpha blending and antialiasing with Lazarus.1 BGRABitmap v5.5 - Drawing routines with alpha blending and antialiasing with Lazarus. 2 2 3 3 These routines allow to manipulate 32bit images in BGRA format. -
GraphicTest/GraphicTest.lpi
r222 r317 2 2 <CONFIG> 3 3 <ProjectOptions> 4 <Version Value=" 7"/>4 <Version Value="9"/> 5 5 <General> 6 6 <MainUnit Value="0"/> 7 < TargetFileExt Value=".exe"/>7 <UseXPManifest Value="True"/> 8 8 <Icon Value="0"/> 9 <UseXPManifest Value="True"/> 10 <ActiveEditorIndexAtStart Value="2"/> 9 <ActiveWindowIndexAtStart Value="0"/> 11 10 </General> 11 <BuildModes Count="1"> 12 <Item1 Name="default" Default="True"/> 13 </BuildModes> 12 14 <PublishOptions> 13 15 <Version Value="2"/> … … 21 23 </local> 22 24 </RunParams> 23 <RequiredPackages Count=" 2">25 <RequiredPackages Count="3"> 24 26 <Item1> 25 <PackageName Value=" lazopenglcontext"/>27 <PackageName Value="bgrabitmappack"/> 26 28 </Item1> 27 29 <Item2> 30 <PackageName Value="lazopenglcontext"/> 31 </Item2> 32 <Item3> 28 33 <PackageName Value="LCL"/> 29 </Item 2>34 </Item3> 30 35 </RequiredPackages> 31 <Units Count=" 50">36 <Units Count="61"> 32 37 <Unit0> 33 38 <Filename Value="GraphicTest.lpr"/> 34 39 <IsPartOfProject Value="True"/> 35 40 <UnitName Value="GraphicTest"/> 41 <TopLine Value="1"/> 36 42 <CursorPos X="51" Y="15"/> 37 <TopLine Value="1"/> 38 <UsageCount Value="56"/> 43 <UsageCount Value="58"/> 39 44 </Unit0> 40 45 <Unit1> … … 44 49 <ResourceBaseClass Value="Form"/> 45 50 <UnitName Value="UMainForm"/> 46 <CursorPos X="3" Y="188"/> 47 <TopLine Value="186"/> 51 <IsVisibleTab Value="True"/> 48 52 <EditorIndex Value="0"/> 49 <UsageCount Value="56"/> 50 <Loaded Value="True"/> 53 <WindowIndex Value="0"/> 54 <TopLine Value="118"/> 55 <CursorPos X="32" Y="135"/> 56 <UsageCount Value="58"/> 57 <Loaded Value="True"/> 58 <LoadedDesigner Value="True"/> 51 59 </Unit1> 52 60 <Unit2> 53 61 <Filename Value="StopWatch.pas"/> 54 62 <UnitName Value="StopWatch"/> 63 <TopLine Value="1"/> 55 64 <CursorPos X="42" Y="22"/> 56 <TopLine Value="1"/>57 65 <UsageCount Value="15"/> 58 66 </Unit2> … … 61 69 <IsPartOfProject Value="True"/> 62 70 <UnitName Value="UPlatform"/> 71 <TopLine Value="1"/> 63 72 <CursorPos X="1" Y="1"/> 64 <TopLine Value="1"/> 65 <UsageCount Value="56"/> 73 <UsageCount Value="58"/> 66 74 </Unit3> 67 75 <Unit4> 68 76 <Filename Value="../../lazarus/lcl/intfgraphics.pas"/> 69 77 <UnitName Value="IntfGraphics"/> 78 <TopLine Value="244"/> 70 79 <CursorPos X="49" Y="262"/> 71 <TopLine Value="244"/>72 80 <UsageCount Value="9"/> 73 81 </Unit4> … … 75 83 <Filename Value="/usr/share/fpcsrc/2.4.0/packages/fcl-image/src/fpimage.pp"/> 76 84 <UnitName Value="FPimage"/> 85 <TopLine Value="121"/> 77 86 <CursorPos X="57" Y="142"/> 78 <TopLine Value="121"/>79 87 <UsageCount Value="9"/> 80 88 </Unit5> 81 89 <Unit6> 82 90 <Filename Value="../../lazarus/lcl/include/lclintfh.inc"/> 91 <TopLine Value="85"/> 83 92 <CursorPos X="10" Y="102"/> 84 <TopLine Value="85"/>85 93 <UsageCount Value="9"/> 86 94 </Unit6> 87 95 <Unit7> 88 96 <Filename Value="../../lazarus/lcl/include/lclintf.inc"/> 97 <TopLine Value="153"/> 89 98 <CursorPos X="1" Y="160"/> 90 <TopLine Value="153"/>91 99 <UsageCount Value="9"/> 92 100 </Unit7> … … 94 102 <Filename Value="../../lazarus/lcl/graphics.pp"/> 95 103 <UnitName Value="Graphics"/> 104 <TopLine Value="1282"/> 96 105 <CursorPos X="15" Y="1299"/> 97 <TopLine Value="1282"/>98 106 <UsageCount Value="9"/> 99 107 </Unit8> 100 108 <Unit9> 101 109 <Filename Value="../../lazarus/lcl/include/rasterimage.inc"/> 110 <TopLine Value="546"/> 102 111 <CursorPos X="11" Y="553"/> 103 <TopLine Value="546"/>104 112 <UsageCount Value="9"/> 105 113 </Unit9> 106 114 <Unit10> 107 115 <Filename Value="../../lazarus/lcl/include/picture.inc"/> 116 <TopLine Value="389"/> 108 117 <CursorPos X="1" Y="411"/> 109 <TopLine Value="389"/>110 118 <UsageCount Value="6"/> 111 119 </Unit10> 112 120 <Unit11> 113 121 <Filename Value="../../lazarus/lcl/interfaces/gtk2/gtk2lclintf.inc"/> 122 <TopLine Value="444"/> 114 123 <CursorPos X="1" Y="461"/> 115 <TopLine Value="444"/>116 124 <UsageCount Value="9"/> 117 125 </Unit11> 118 126 <Unit12> 119 127 <Filename Value="/usr/share/fpcsrc/2.4.0/packages/gtk2/src/gtk+/gdk/gdkimage.inc"/> 128 <TopLine Value="14"/> 120 129 <CursorPos X="24" Y="21"/> 121 <TopLine Value="14"/>122 130 <UsageCount Value="9"/> 123 131 </Unit12> 124 132 <Unit13> 125 133 <Filename Value="/usr/share/fpcsrc/2.4.0/packages/fcl-image/src/fpimage.inc"/> 134 <TopLine Value="313"/> 126 135 <CursorPos X="24" Y="316"/> 127 <TopLine Value="313"/>128 136 <UsageCount Value="9"/> 129 137 </Unit13> 130 138 <Unit14> 131 139 <Filename Value="/usr/share/fpcsrc/2.4.0/packages/fcl-image/src/fppalette.inc"/> 140 <TopLine Value="149"/> 132 141 <CursorPos X="3" Y="151"/> 133 <TopLine Value="149"/>134 142 <UsageCount Value="9"/> 135 143 </Unit14> … … 137 145 <Filename Value="../../lazarus/lcl/graphtype.pp"/> 138 146 <UnitName Value="GraphType"/> 147 <TopLine Value="171"/> 139 148 <CursorPos X="3" Y="188"/> 140 <TopLine Value="171"/>141 149 <UsageCount Value="8"/> 142 150 </Unit15> 143 151 <Unit16> 144 152 <Filename Value="/usr/share/fpcsrc/2.4.0/rtl/inc/systemh.inc"/> 153 <TopLine Value="496"/> 145 154 <CursorPos X="11" Y="519"/> 146 <TopLine Value="496"/>147 155 <UsageCount Value="13"/> 148 156 </Unit16> … … 151 159 <IsPartOfProject Value="True"/> 152 160 <UnitName Value="UDrawMethod"/> 153 <CursorPos X="29" Y="244"/>154 <TopLine Value="237"/>155 161 <EditorIndex Value="2"/> 156 <UsageCount Value="50"/> 162 <WindowIndex Value="0"/> 163 <TopLine Value="690"/> 164 <CursorPos X="3" Y="709"/> 165 <UsageCount Value="52"/> 157 166 <Loaded Value="True"/> 158 167 </Unit17> … … 161 170 <IsPartOfProject Value="True"/> 162 171 <UnitName Value="UFastBitmap"/> 163 <CursorPos X="19" Y="110"/>164 <TopLine Value="101"/>165 172 <EditorIndex Value="1"/> 166 <UsageCount Value="50"/> 173 <WindowIndex Value="0"/> 174 <TopLine Value="185"/> 175 <CursorPos X="39" Y="198"/> 176 <UsageCount Value="52"/> 167 177 <Loaded Value="True"/> 168 178 </Unit18> 169 179 <Unit19> 170 <Filename Value="../../../Projekty2/FreePascalManager/trunk/Instance/1/Lazarus/lcl/include/rasterimage.inc"/> 180 <Filename Value="../../FreePascalManager/trunk/Instance/1/Lazarus/lcl/include/rasterimage.inc"/> 181 <TopLine Value="292"/> 171 182 <CursorPos X="1" Y="308"/> 172 <TopLine Value="292"/>173 183 <UsageCount Value="12"/> 174 184 </Unit19> 175 185 <Unit20> 176 <Filename Value=" bgrabitmap/bgradefaultbitmap.pas"/>186 <Filename Value="BGRABitmap/bgradefaultbitmap.pas"/> 177 187 <UnitName Value="BGRADefaultBitmap"/> 178 <CursorPos X="57" Y="292"/> 179 <TopLine Value="279"/> 180 <UsageCount Value="10"/> 188 <EditorIndex Value="13"/> 189 <WindowIndex Value="0"/> 190 <TopLine Value="655"/> 191 <CursorPos X="25" Y="666"/> 192 <UsageCount Value="11"/> 193 <Loaded Value="True"/> 181 194 </Unit20> 182 195 <Unit21> 183 196 <Filename Value="bgrabitmap/bgrawinbitmap.pas"/> 184 197 <UnitName Value="BGRAWinBitmap"/> 198 <TopLine Value="133"/> 185 199 <CursorPos X="1" Y="146"/> 186 <TopLine Value="133"/>187 200 <UsageCount Value="10"/> 188 201 </Unit21> 189 202 <Unit22> 190 <Filename Value="../../ ../Projekty2/FreePascalManager/trunk/Instance/1/Lazarus/lcl/extctrls.pp"/>203 <Filename Value="../../FreePascalManager/trunk/Instance/1/Lazarus/lcl/extctrls.pp"/> 191 204 <UnitName Value="ExtCtrls"/> 205 <TopLine Value="584"/> 192 206 <CursorPos X="3" Y="597"/> 193 <TopLine Value="584"/>194 207 <UsageCount Value="9"/> 195 208 </Unit22> 196 209 <Unit23> 197 <Filename Value="../../../Projekty2/FreePascalManager/trunk/Instance/1/Lazarus/lcl/include/winapih.inc"/> 210 <Filename Value="../../FreePascalManager/trunk/Instance/1/Lazarus/lcl/include/winapih.inc"/> 211 <TopLine Value="32"/> 198 212 <CursorPos X="10" Y="45"/> 199 <TopLine Value="32"/>200 213 <UsageCount Value="11"/> 201 214 </Unit23> 202 215 <Unit24> 203 <Filename Value="../../../Projekty2/FreePascalManager/trunk/Instance/1/Lazarus/lcl/include/winapi.inc"/> 216 <Filename Value="../../FreePascalManager/trunk/Instance/1/Lazarus/lcl/include/winapi.inc"/> 217 <TopLine Value="51"/> 204 218 <CursorPos X="3" Y="53"/> 205 <TopLine Value="51"/>206 219 <UsageCount Value="11"/> 207 220 </Unit24> 208 221 <Unit25> 209 <Filename Value="../../ ../Projekty2/FreePascalManager/trunk/Instance/1/Lazarus/lcl/graphics.pp"/>222 <Filename Value="../../FreePascalManager/trunk/Instance/1/Lazarus/lcl/graphics.pp"/> 210 223 <UnitName Value="Graphics"/> 224 <TopLine Value="1314"/> 211 225 <CursorPos X="31" Y="1327"/> 212 <TopLine Value="1314"/>213 226 <UsageCount Value="11"/> 214 227 </Unit25> 215 228 <Unit26> 216 <Filename Value="../../../Projekty2/FreePascalManager/trunk/Instance/1/FPC/rtl/objpas/classes/classesh.inc"/> 229 <Filename Value="../../FreePascalManager/trunk/Instance/1/FPC/rtl/objpas/classes/classesh.inc"/> 230 <TopLine Value="1883"/> 217 231 <CursorPos X="10" Y="1896"/> 218 <TopLine Value="1883"/>219 232 <UsageCount Value="11"/> 220 233 </Unit26> 221 234 <Unit27> 222 <Filename Value="../../../Projekty2/FreePascalManager/trunk/Instance/1/FPC/rtl/inc/heaph.inc"/> 235 <Filename Value="../../FreePascalManager/trunk/Instance/1/FPC/rtl/inc/heaph.inc"/> 236 <TopLine Value="75"/> 223 237 <CursorPos X="31" Y="88"/> 224 <TopLine Value="75"/>225 238 <UsageCount Value="9"/> 226 239 </Unit27> 227 240 <Unit28> 228 <Filename Value="../../../Projekty2/FreePascalManager/trunk/Instance/1/FPC/rtl/inc/heap.inc"/> 241 <Filename Value="../../FreePascalManager/trunk/Instance/1/FPC/rtl/inc/heap.inc"/> 242 <TopLine Value="309"/> 229 243 <CursorPos X="3" Y="311"/> 230 <TopLine Value="309"/>231 244 <UsageCount Value="8"/> 232 245 </Unit28> … … 234 247 <Filename Value="bgrabitmap/bgrabitmaptypes.pas"/> 235 248 <UnitName Value="BGRABitmapTypes"/> 249 <TopLine Value="24"/> 236 250 <CursorPos X="3" Y="37"/> 237 <TopLine Value="24"/>238 251 <UsageCount Value="10"/> 239 252 </Unit29> 240 253 <Unit30> 241 <Filename Value="../../ ../Projekty2/FreePascalManager/trunk/Instance/1/Lazarus/lcl/graphtype.pp"/>254 <Filename Value="../../FreePascalManager/trunk/Instance/1/Lazarus/lcl/graphtype.pp"/> 242 255 <UnitName Value="GraphType"/> 256 <TopLine Value="271"/> 243 257 <CursorPos X="23" Y="292"/> 244 <TopLine Value="271"/>245 258 <UsageCount Value="9"/> 246 259 </Unit30> … … 248 261 <Filename Value="UBitmaps.pas"/> 249 262 <UnitName Value="UBitmaps"/> 263 <TopLine Value="1"/> 250 264 <CursorPos X="41" Y="62"/> 251 <TopLine Value="1"/>252 265 <UsageCount Value="18"/> 253 266 </Unit31> 254 267 <Unit32> 255 <Filename Value="../../ ../Projekty2/FreePascalManager/trunk/Instance/1/FPC/packages/fcl-image/src/fpimage.pp"/>268 <Filename Value="../../FreePascalManager/trunk/Instance/1/FPC/packages/fcl-image/src/fpimage.pp"/> 256 269 <UnitName Value="FPimage"/> 270 <TopLine Value="23"/> 257 271 <CursorPos X="4" Y="35"/> 258 <TopLine Value="23"/>259 272 <UsageCount Value="8"/> 260 273 </Unit32> 261 274 <Unit33> 262 <Filename Value="../../../Projekty2/FreePascalManager/trunk/Instance/1/Lazarus/lcl/include/canvas.inc"/> 275 <Filename Value="../../FreePascalManager/trunk/Instance/1/Lazarus/lcl/include/canvas.inc"/> 276 <TopLine Value="1456"/> 263 277 <CursorPos X="1" Y="1471"/> 264 <TopLine Value="1456"/>265 278 <UsageCount Value="8"/> 266 279 </Unit33> 267 280 <Unit34> 268 <Filename Value="../../../Projekty2/FreePascalManager/trunk/Instance/1/FPC/rtl/win/wininc/func.inc"/> 281 <Filename Value="../../FreePascalManager/trunk/Instance/1/FPC/rtl/win/wininc/func.inc"/> 282 <TopLine Value="780"/> 269 283 <CursorPos X="10" Y="793"/> 270 <TopLine Value="780"/>271 284 <UsageCount Value="8"/> 272 285 </Unit34> … … 274 287 <Filename Value="bgrabitmap/bgrablend.pas"/> 275 288 <UnitName Value="BGRABlend"/> 289 <TopLine Value="217"/> 276 290 <CursorPos X="3" Y="219"/> 277 <TopLine Value="217"/>278 291 <UsageCount Value="8"/> 279 292 </Unit35> … … 281 294 <Filename Value="BGRABitmap/bgrabitmap.pas"/> 282 295 <UnitName Value="BGRABitmap"/> 296 <TopLine Value="52"/> 283 297 <CursorPos X="23" Y="72"/> 284 <TopLine Value="52"/>285 298 <UsageCount Value="18"/> 286 299 </Unit36> … … 288 301 <Filename Value="BGRABitmap/bgragtkbitmap.pas"/> 289 302 <UnitName Value="BGRAGtkBitmap"/> 303 <TopLine Value="29"/> 290 304 <CursorPos X="36" Y="36"/> 291 <TopLine Value="29"/>292 305 <UsageCount Value="18"/> 293 306 </Unit37> … … 295 308 <Filename Value="BGRABitmap/bgraresample.pas"/> 296 309 <UnitName Value="bgraresample"/> 310 <TopLine Value="629"/> 297 311 <CursorPos X="30" Y="638"/> 298 <TopLine Value="629"/>299 312 <UsageCount Value="18"/> 300 313 </Unit38> … … 302 315 <Filename Value="../../../lazarus/components/opengl/glqtcontext.pas"/> 303 316 <UnitName Value="GLQTContext"/> 317 <TopLine Value="1"/> 304 318 <CursorPos X="1" Y="1"/> 305 <TopLine Value="1"/>306 319 <UsageCount Value="18"/> 307 320 </Unit39> … … 309 322 <Filename Value="../../../lazarus/components/opengl/openglcontext.pas"/> 310 323 <UnitName Value="OpenGLContext"/> 324 <TopLine Value="135"/> 311 325 <CursorPos X="34" Y="152"/> 312 <TopLine Value="135"/>313 326 <UsageCount Value="18"/> 314 327 </Unit40> … … 316 329 <Filename Value="../../../lazarus/components/opengl/glgtkglxcontext.pas"/> 317 330 <UnitName Value="GLGtkGlxContext"/> 331 <TopLine Value="699"/> 318 332 <CursorPos X="3" Y="704"/> 319 <TopLine Value="699"/>320 333 <UsageCount Value="18"/> 321 334 </Unit41> … … 323 336 <Filename Value="/usr/share/fpcsrc/2.4.0/packages/opengl/src/gl.pp"/> 324 337 <UnitName Value="GL"/> 338 <TopLine Value="1502"/> 325 339 <CursorPos X="3" Y="1499"/> 326 <TopLine Value="1502"/>327 340 <UsageCount Value="18"/> 328 341 </Unit42> 329 342 <Unit43> 330 343 <Filename Value="../../../lazarus/lcl/include/customform.inc"/> 344 <TopLine Value="898"/> 331 345 <CursorPos X="38" Y="928"/> 332 <TopLine Value="898"/>333 346 <UsageCount Value="17"/> 334 347 </Unit43> 335 348 <Unit44> 336 349 <Filename Value="/usr/share/fpcsrc/2.4.0/rtl/inc/heaph.inc"/> 350 <TopLine Value="63"/> 337 351 <CursorPos X="43" Y="80"/> 338 <TopLine Value="63"/>339 352 <UsageCount Value="9"/> 340 353 </Unit44> 341 354 <Unit45> 342 355 <Filename Value="../../../lazarus/lcl/include/custombitmap.inc"/> 356 <TopLine Value="21"/> 343 357 <CursorPos X="1" Y="38"/> 344 <TopLine Value="21"/>345 358 <UsageCount Value="9"/> 346 359 </Unit45> … … 348 361 <Filename Value="/usr/share/fpcsrc/2.4.0/packages/opengl/src/glext.pp"/> 349 362 <UnitName Value="GLext"/> 363 <TopLine Value="2783"/> 350 364 <CursorPos X="15" Y="2800"/> 351 <TopLine Value="2783"/>352 365 <UsageCount Value="15"/> 353 366 </Unit46> 354 367 <Unit47> 355 368 <Filename Value="/usr/share/fpcsrc/2.4.0/rtl/i386/i386.inc"/> 369 <TopLine Value="185"/> 356 370 <CursorPos X="11" Y="202"/> 357 <TopLine Value="185"/>358 371 <UsageCount Value="13"/> 359 372 </Unit47> 360 373 <Unit48> 361 374 <Filename Value="/usr/share/fpcsrc/2.4.0/rtl/inc/generic.inc"/> 375 <TopLine Value="245"/> 362 376 <CursorPos X="3" Y="250"/> 363 <TopLine Value="245"/>364 377 <UsageCount Value="13"/> 365 378 </Unit48> 366 379 <Unit49> 367 380 <Filename Value="/usr/share/fpcsrc/2.4.0/rtl/inc/system.inc"/> 381 <TopLine Value="188"/> 368 382 <CursorPos X="3" Y="190"/> 369 <TopLine Value="188"/>370 383 <UsageCount Value="13"/> 371 384 </Unit49> 385 <Unit50> 386 <Filename Value="../../../Lazarus/0.9.31_2.6.0/fpc/2.6.0/source/rtl/inc/mathh.inc"/> 387 <EditorIndex Value="14"/> 388 <WindowIndex Value="0"/> 389 <TopLine Value="65"/> 390 <CursorPos X="14" Y="78"/> 391 <UsageCount Value="11"/> 392 <Loaded Value="True"/> 393 </Unit50> 394 <Unit51> 395 <Filename Value="../../../Lazarus/0.9.31_2.6.0/components/opengl/openglcontext.pas"/> 396 <UnitName Value="OpenGLContext"/> 397 <EditorIndex Value="9"/> 398 <WindowIndex Value="0"/> 399 <TopLine Value="387"/> 400 <CursorPos X="3" Y="389"/> 401 <UsageCount Value="11"/> 402 <Loaded Value="True"/> 403 </Unit51> 404 <Unit52> 405 <Filename Value="../../../Lazarus/0.9.31_2.6.0/components/opengl/glwin32wglcontext.pas"/> 406 <UnitName Value="GLWin32WGLContext"/> 407 <EditorIndex Value="10"/> 408 <WindowIndex Value="0"/> 409 <TopLine Value="236"/> 410 <CursorPos X="3" Y="240"/> 411 <UsageCount Value="11"/> 412 <Loaded Value="True"/> 413 </Unit52> 414 <Unit53> 415 <Filename Value="../../../Lazarus/0.9.31_2.6.0/fpc/2.6.0/source/rtl/win/wininc/func.inc"/> 416 <EditorIndex Value="12"/> 417 <WindowIndex Value="0"/> 418 <TopLine Value="988"/> 419 <CursorPos X="10" Y="1001"/> 420 <UsageCount Value="11"/> 421 <Loaded Value="True"/> 422 </Unit53> 423 <Unit54> 424 <Filename Value="../../../Lazarus/0.9.31_2.6.0/fpc/2.6.0/source/rtl/win/wininc/ascdef.inc"/> 425 <EditorIndex Value="11"/> 426 <WindowIndex Value="0"/> 427 <TopLine Value="236"/> 428 <CursorPos X="10" Y="249"/> 429 <UsageCount Value="11"/> 430 <Loaded Value="True"/> 431 </Unit54> 432 <Unit55> 433 <Filename Value="../../../Lazarus/0.9.31_2.6.0/fpc/2.6.0/source/rtl/objpas/objpas.pp"/> 434 <UnitName Value="objpas"/> 435 <EditorIndex Value="8"/> 436 <WindowIndex Value="0"/> 437 <TopLine Value="15"/> 438 <CursorPos X="8" Y="28"/> 439 <UsageCount Value="11"/> 440 <Loaded Value="True"/> 441 </Unit55> 442 <Unit56> 443 <Filename Value="../../../Lazarus/0.9.31_2.6.0/lcl/graphics.pp"/> 444 <UnitName Value="Graphics"/> 445 <EditorIndex Value="4"/> 446 <WindowIndex Value="0"/> 447 <TopLine Value="1292"/> 448 <CursorPos X="15" Y="1305"/> 449 <UsageCount Value="11"/> 450 <Loaded Value="True"/> 451 </Unit56> 452 <Unit57> 453 <Filename Value="../../../Lazarus/0.9.31_2.6.0/lcl/include/rasterimage.inc"/> 454 <EditorIndex Value="5"/> 455 <WindowIndex Value="0"/> 456 <TopLine Value="247"/> 457 <CursorPos X="1" Y="260"/> 458 <UsageCount Value="11"/> 459 <Loaded Value="True"/> 460 </Unit57> 461 <Unit58> 462 <Filename Value="../../../Lazarus/0.9.31_2.6.0/fpc/2.6.0/source/rtl/inc/systemh.inc"/> 463 <EditorIndex Value="3"/> 464 <WindowIndex Value="0"/> 465 <TopLine Value="501"/> 466 <CursorPos X="11" Y="514"/> 467 <UsageCount Value="11"/> 468 <Loaded Value="True"/> 469 </Unit58> 470 <Unit59> 471 <Filename Value="../../../Lazarus/0.9.31_2.6.0/lcl/include/custombitmap.inc"/> 472 <EditorIndex Value="7"/> 473 <WindowIndex Value="0"/> 474 <TopLine Value="403"/> 475 <CursorPos X="1" Y="416"/> 476 <UsageCount Value="10"/> 477 <Loaded Value="True"/> 478 </Unit59> 479 <Unit60> 480 <Filename Value="../../../Lazarus/0.9.31_2.6.0/lcl/include/bitmapcanvas.inc"/> 481 <EditorIndex Value="6"/> 482 <WindowIndex Value="0"/> 483 <TopLine Value="90"/> 484 <CursorPos X="1" Y="103"/> 485 <UsageCount Value="10"/> 486 <Loaded Value="True"/> 487 </Unit60> 372 488 </Units> 373 489 <JumpHistory Count="30" HistoryIndex="29"> 374 490 <Position1> 375 <Filename Value="U DrawMethod.pas"/>376 <Caret Line="2 48" Column="1" TopLine="224"/>491 <Filename Value="UMainForm.pas"/> 492 <Caret Line="233" Column="30" TopLine="210"/> 377 493 </Position1> 378 494 <Position2> 379 <Filename Value="U DrawMethod.pas"/>380 <Caret Line=" 250" Column="1" TopLine="224"/>495 <Filename Value="UMainForm.pas"/> 496 <Caret Line="117" Column="1" TopLine="112"/> 381 497 </Position2> 382 498 <Position3> 383 <Filename Value="U DrawMethod.pas"/>384 <Caret Line=" 251" Column="1" TopLine="224"/>499 <Filename Value="UMainForm.pas"/> 500 <Caret Line="190" Column="12" TopLine="178"/> 385 501 </Position3> 386 502 <Position4> 387 <Filename Value="U DrawMethod.pas"/>388 <Caret Line=" 254" Column="1" TopLine="226"/>503 <Filename Value="UMainForm.pas"/> 504 <Caret Line="145" Column="21" TopLine="138"/> 389 505 </Position4> 390 506 <Position5> 391 <Filename Value="U DrawMethod.pas"/>392 <Caret Line=" 256" Column="1" TopLine="228"/>507 <Filename Value="UMainForm.pas"/> 508 <Caret Line="142" Column="1" TopLine="137"/> 393 509 </Position5> 394 510 <Position6> 395 <Filename Value="U DrawMethod.pas"/>396 <Caret Line=" 257" Column="1" TopLine="229"/>511 <Filename Value="UMainForm.pas"/> 512 <Caret Line="192" Column="14" TopLine="187"/> 397 513 </Position6> 398 514 <Position7> 399 <Filename Value="U DrawMethod.pas"/>400 <Caret Line="1 05" Column="30" TopLine="98"/>515 <Filename Value="UMainForm.pas"/> 516 <Caret Line="199" Column="1" TopLine="184"/> 401 517 </Position7> 402 518 <Position8> 403 <Filename Value="U DrawMethod.pas"/>404 <Caret Line=" 260" Column="97" TopLine="233"/>519 <Filename Value="UMainForm.pas"/> 520 <Caret Line="156" Column="1" TopLine="143"/> 405 521 </Position8> 406 522 <Position9> 407 <Filename Value="U DrawMethod.pas"/>408 <Caret Line=" 237" Column="1" TopLine="218"/>523 <Filename Value="UMainForm.pas"/> 524 <Caret Line="189" Column="82" TopLine="177"/> 409 525 </Position9> 410 526 <Position10> 411 <Filename Value="U DrawMethod.pas"/>412 <Caret Line=" 224" Column="54" TopLine="207"/>527 <Filename Value="UMainForm.pas"/> 528 <Caret Line="144" Column="43" TopLine="136"/> 413 529 </Position10> 414 530 <Position11> 415 <Filename Value="U DrawMethod.pas"/>416 <Caret Line=" 237" Column="1" TopLine="220"/>531 <Filename Value="UMainForm.pas"/> 532 <Caret Line="185" Column="20" TopLine="183"/> 417 533 </Position11> 418 534 <Position12> 419 <Filename Value="U DrawMethod.pas"/>420 <Caret Line=" 240" Column="26" TopLine="223"/>535 <Filename Value="UMainForm.pas"/> 536 <Caret Line="191" Column="3" TopLine="189"/> 421 537 </Position12> 422 538 <Position13> 423 <Filename Value="U DrawMethod.pas"/>424 <Caret Line="23 7" Column="117" TopLine="220"/>539 <Filename Value="UMainForm.pas"/> 540 <Caret Line="236" Column="58" TopLine="215"/> 425 541 </Position13> 426 542 <Position14> 427 <Filename Value="U DrawMethod.pas"/>428 <Caret Line=" 240" Column="1" TopLine="224"/>543 <Filename Value="UMainForm.pas"/> 544 <Caret Line="124" Column="14" TopLine="107"/> 429 545 </Position14> 430 546 <Position15> 431 <Filename Value="U DrawMethod.pas"/>432 <Caret Line="2 81" Column="45" TopLine="263"/>547 <Filename Value="UMainForm.pas"/> 548 <Caret Line="206" Column="19" TopLine="203"/> 433 549 </Position15> 434 550 <Position16> 435 551 <Filename Value="UMainForm.pas"/> 436 <Caret Line="1 45" Column="49" TopLine="130"/>552 <Caret Line="117" Column="3" TopLine="115"/> 437 553 </Position16> 438 554 <Position17> 439 <Filename Value="U DrawMethod.pas"/>440 <Caret Line="1 82" Column="3" TopLine="173"/>555 <Filename Value="UMainForm.pas"/> 556 <Caret Line="118" Column="1" TopLine="113"/> 441 557 </Position17> 442 558 <Position18> 443 <Filename Value="U DrawMethod.pas"/>444 <Caret Line=" 257" Column="42" TopLine="243"/>559 <Filename Value="UMainForm.pas"/> 560 <Caret Line="119" Column="1" TopLine="113"/> 445 561 </Position18> 446 562 <Position19> 447 <Filename Value="U DrawMethod.pas"/>448 <Caret Line=" 336" Column="18" TopLine="311"/>563 <Filename Value="UMainForm.pas"/> 564 <Caret Line="242" Column="1" TopLine="223"/> 449 565 </Position19> 450 566 <Position20> 451 <Filename Value="U DrawMethod.pas"/>452 <Caret Line="2 34" Column="38" TopLine="220"/>567 <Filename Value="UMainForm.pas"/> 568 <Caret Line="243" Column="1" TopLine="223"/> 453 569 </Position20> 454 570 <Position21> 455 571 <Filename Value="UMainForm.pas"/> 456 <Caret Line=" 117" Column="26" TopLine="106"/>572 <Caret Line="244" Column="1" TopLine="223"/> 457 573 </Position21> 458 574 <Position22> 459 575 <Filename Value="UMainForm.pas"/> 460 <Caret Line=" 180" Column="3" TopLine="178"/>576 <Caret Line="245" Column="1" TopLine="223"/> 461 577 </Position22> 462 578 <Position23> 463 579 <Filename Value="UMainForm.pas"/> 464 <Caret Line="1 82" Column="9" TopLine="179"/>580 <Caret Line="120" Column="1" TopLine="107"/> 465 581 </Position23> 466 582 <Position24> 467 583 <Filename Value="UMainForm.pas"/> 468 <Caret Line="1 86" Column="92" TopLine="177"/>584 <Caret Line="121" Column="1" TopLine="107"/> 469 585 </Position24> 470 586 <Position25> 471 587 <Filename Value="UMainForm.pas"/> 472 <Caret Line="1 83" Column="1" TopLine="177"/>588 <Caret Line="122" Column="1" TopLine="107"/> 473 589 </Position25> 474 590 <Position26> 475 591 <Filename Value="UMainForm.pas"/> 476 <Caret Line="1 84" Column="1" TopLine="177"/>592 <Caret Line="123" Column="1" TopLine="107"/> 477 593 </Position26> 478 594 <Position27> 479 595 <Filename Value="UMainForm.pas"/> 480 <Caret Line="1 40" Column="29" TopLine="133"/>596 <Caret Line="129" Column="37" TopLine="115"/> 481 597 </Position27> 482 598 <Position28> 483 599 <Filename Value="UMainForm.pas"/> 484 <Caret Line="14 2" Column="29" TopLine="135"/>600 <Caret Line="148" Column="3" TopLine="139"/> 485 601 </Position28> 486 602 <Position29> 487 603 <Filename Value="UMainForm.pas"/> 488 <Caret Line="1 41" Column="29" TopLine="134"/>604 <Caret Line="133" Column="32" TopLine="116"/> 489 605 </Position29> 490 606 <Position30> 491 607 <Filename Value="UMainForm.pas"/> 492 <Caret Line="1 46" Column="20" TopLine="135"/>608 <Caret Line="134" Column="32" TopLine="117"/> 493 609 </Position30> 494 610 </JumpHistory> 495 611 </ProjectOptions> 496 612 <CompilerOptions> 497 <Version Value=" 8"/>613 <Version Value="11"/> 498 614 <Target> 499 615 <Filename Value="GraphicTest"/> 500 616 </Target> 501 617 <SearchPaths> 502 <IncludeFiles Value="$(ProjOutDir)/"/> 503 <OtherUnitFiles Value="BGRABitmap/"/> 618 <IncludeFiles Value="$(ProjOutDir)"/> 504 619 <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> 505 620 </SearchPaths> 621 <Parsing> 622 <SyntaxOptions> 623 <UseAnsiStrings Value="False"/> 624 </SyntaxOptions> 625 </Parsing> 506 626 <Linking> 507 627 <Options> -
GraphicTest/GraphicTest.lpr
r211 r317 8 8 {$ENDIF}{$ENDIF} 9 9 Interfaces, // this includes the LCL widgetset 10 Forms, lazopenglcontext, UMainForm, UPlatform, UDrawMethod, UFastBitmap; 10 Forms, lazopenglcontext, UMainForm, UPlatform, UDrawMethod, UFastBitmap, 11 bgrabitmappack; 11 12 12 13 {$R *.res} -
GraphicTest/UDrawMethod.pas
r212 r317 41 41 TDrawMethodClass = class of TDrawMethod; 42 42 43 { TDummyMethod } 44 45 TDummyMethod = class(TDrawMethod) 46 constructor Create; override; 47 procedure DrawFrame(FastBitmap: TFastBitmap); override; 48 end; 49 43 50 { TCanvasPixels } 44 51 … … 84 91 85 92 TBitmapRawImageDataPaintBox = class(TDrawMethod) 93 constructor Create; override; 94 procedure DrawFrame(FastBitmap: TFastBitmap); override; 95 end; 96 97 { TBitmapRawImageDataMove } 98 99 TBitmapRawImageDataMove = class(TDrawMethod) 86 100 constructor Create; override; 87 101 procedure DrawFrame(FastBitmap: TFastBitmap); override; … … 121 135 122 136 const 123 DrawMethodClasses: array[0.. 8] of TDrawMethodClass = (137 DrawMethodClasses: array[0..10] of TDrawMethodClass = ( 124 138 TCanvasPixels, TCanvasPixelsUpdateLock, TLazIntfImageColorsCopy, 125 139 TLazIntfImageColorsNoCopy, TBitmapRawImageData, TBitmapRawImageDataPaintBox, 126 TBGRABitmapPaintBox, TOpenGLMethod, TOpenGLPBOMethod); 140 TBitmapRawImageDataMove, TBGRABitmapPaintBox, TOpenGLMethod, TOpenGLPBOMethod, 141 TDummyMethod); 127 142 128 143 implementation 144 145 { TDummyMethod } 146 147 constructor TDummyMethod.Create; 148 begin 149 inherited Create; 150 Caption := 'Dummy'; 151 end; 152 153 procedure TDummyMethod.DrawFrame(FastBitmap: TFastBitmap); 154 var 155 Y, X: Integer; 156 PixelPtr: PInteger; 157 RowPtr: PInteger; 158 P: TPixelFormat; 159 RawImage: TRawImage; 160 BytePerPixel: Integer; 161 BytePerRow: Integer; 162 begin 163 P := Bitmap.PixelFormat; 164 with FastBitmap do 165 try 166 //Bitmap.BeginUpdate(False); 167 RawImage := Bitmap.RawImage; 168 RowPtr := PInteger(RawImage.Data); 169 BytePerPixel := RawImage.Description.BitsPerPixel div 8; 170 BytePerRow := RawImage.Description.BytesPerLine; 171 finally 172 //Bitmap.EndUpdate(False); 173 end; 174 end; 175 176 { TBitmapRawImageDataMove } 177 178 constructor TBitmapRawImageDataMove.Create; 179 begin 180 inherited; 181 Caption := 'TBitmap.RawImage.Data Move'; 182 end; 183 184 procedure TBitmapRawImageDataMove.DrawFrame(FastBitmap: TFastBitmap); 185 var 186 Y, X: Integer; 187 PixelPtr: PInteger; 188 RowPtr: PInteger; 189 P: TPixelFormat; 190 RawImage: TRawImage; 191 BytePerPixel: Integer; 192 BytePerRow: Integer; 193 begin 194 P := Bitmap.PixelFormat; 195 with FastBitmap do 196 try 197 Bitmap.BeginUpdate(False); 198 RawImage := Bitmap.RawImage; 199 RowPtr := PInteger(RawImage.Data); 200 BytePerPixel := RawImage.Description.BitsPerPixel div 8; 201 BytePerRow := RawImage.Description.BytesPerLine; 202 Move(FastBitmap.PixelsData^, RowPtr^, Size.Y * BytePerRow); 203 finally 204 Bitmap.EndUpdate(False); 205 end; 206 end; 129 207 130 208 { TOpenGLPBOMethod } … … 455 533 456 534 procedure TBitmapRawImageData.DrawFrame(FastBitmap: TFastBitmap); 457 type458 TFastBitmapPixelComponents = packed record459 end;460 535 var 461 536 Y, X: Integer; -
GraphicTest/UFastBitmap.pas
r212 r317 31 31 property Size: TPoint read FSize write SetSize; 32 32 property Pixels[X, Y: Integer]: TFastBitmapPixel read GetPixel write SetPixel; 33 property PixelsData: PByte read FPixelsData; 33 34 end; 34 35 -
GraphicTest/UMainForm.lfm
r212 r317 1 1 object MainForm: TMainForm 2 Left = 2143 Height = 3934 Top = 1065 Width = 6802 Left = 187 3 Height = 421 4 Top = 68 5 Width = 735 6 6 Caption = 'Graphic test' 7 ClientHeight = 3938 ClientWidth = 6807 ClientHeight = 421 8 ClientWidth = 735 9 9 OnClose = FormClose 10 10 OnCreate = FormCreate 11 11 OnDestroy = FormDestroy 12 OnShow = FormShow 12 13 LCLVersion = '0.9.31' 13 14 object PageControl1: TPageControl 14 Left = 3 1215 Height = 37315 Left = 360 16 Height = 401 16 17 Top = 16 17 Width = 3 6518 ActivePage = TabSheet 318 Width = 372 19 ActivePage = TabSheet1 19 20 Anchors = [akTop, akLeft, akRight, akBottom] 20 TabIndex = 221 TabIndex = 0 21 22 TabOrder = 0 22 23 object TabSheet1: TTabSheet 23 24 Caption = 'TImage' 24 ClientHeight = 3 4625 ClientWidth = 36 125 ClientHeight = 375 26 ClientWidth = 364 26 27 object Image1: TImage 27 28 Left = 6 28 Height = 27829 Height = 307 29 30 Top = 7 30 Width = 35 131 Width = 354 31 32 Anchors = [akTop, akLeft, akRight, akBottom] 32 33 end … … 48 49 end 49 50 end 50 object ButtonStart: TButton 51 Left = 7 52 Height = 25 53 Top = 9 54 Width = 75 55 Caption = 'Start' 56 OnClick = ButtonStartClick 57 TabOrder = 1 58 end 59 object Label1: TLabel 60 Left = 9 61 Height = 14 62 Top = 95 63 Width = 24 64 Caption = 'FPS:' 65 ParentColor = False 66 end 67 object Label2: TLabel 68 Left = 128 69 Height = 14 70 Top = 95 71 Width = 10 72 Caption = ' ' 73 ParentColor = False 74 end 75 object ButtonStop: TButton 76 Left = 95 77 Height = 25 78 Top = 9 79 Width = 75 80 Caption = 'Stop' 81 Enabled = False 82 OnClick = ButtonStopClick 83 TabOrder = 2 84 end 85 object Label3: TLabel 86 Left = 9 87 Height = 14 88 Top = 112 89 Width = 83 90 Caption = 'Frame duration' 91 ParentColor = False 92 end 93 object Label4: TLabel 94 Left = 128 95 Height = 14 96 Top = 112 97 Width = 10 98 Caption = ' ' 99 ParentColor = False 100 end 101 object ListView1: TListView 51 object ListViewMethods: TListView 102 52 Left = 8 103 Height = 253104 Top = 136105 Width = 29653 Height = 345 54 Top = 8 55 Width = 344 106 56 Anchors = [akTop, akLeft, akBottom] 107 57 Columns = < 108 58 item 109 59 Caption = 'Method' 110 Width = 14060 Width = 200 111 61 end 112 62 item … … 118 68 Width = 75 119 69 end> 120 TabOrder = 3 70 OwnerData = True 71 ReadOnly = True 72 RowSelect = True 73 TabOrder = 1 121 74 ViewStyle = vsReport 75 OnData = ListViewMethodsData 76 OnSelectItem = ListViewMethodsSelectItem 77 end 78 object ButtonSingleTest: TButton 79 Left = 8 80 Height = 25 81 Top = 360 82 Width = 115 83 Anchors = [akLeft, akBottom] 84 Caption = 'Test one method' 85 OnClick = ButtonSingleTestClick 86 TabOrder = 2 122 87 end 123 88 object ButtonBenchmark: TButton 124 Left = 22989 Left = 136 125 90 Height = 25 126 Top = 101 127 Width = 75 128 Caption = 'Benchmark' 91 Top = 360 92 Width = 112 93 Anchors = [akLeft, akBottom] 94 Caption = 'Test all methods' 129 95 OnClick = ButtonBenchmarkClick 130 TabOrder = 4 131 end 132 object ComboBox1: TComboBox 133 Left = 7 134 Height = 25 135 Top = 64 136 Width = 297 137 ItemHeight = 0 138 Style = csDropDownList 139 TabOrder = 5 140 end 141 object Label5: TLabel 142 Left = 9 143 Height = 14 144 Top = 47 145 Width = 46 146 Caption = 'Method:' 147 ParentColor = False 96 TabOrder = 3 148 97 end 149 98 object FloatSpinEdit1: TFloatSpinEdit 150 Left = 1 7599 Left = 160 151 100 Height = 21 152 Top = 103 153 Width = 50 101 Top = 392 102 Width = 58 103 Anchors = [akLeft, akBottom] 154 104 Increment = 1 155 105 MaxValue = 100 156 106 MinValue = 0 157 TabOrder = 6107 TabOrder = 4 158 108 Value = 1 109 end 110 object ButtonStop: TButton 111 Left = 256 112 Height = 25 113 Top = 360 114 Width = 75 115 Anchors = [akLeft, akBottom] 116 Caption = 'Stop' 117 OnClick = ButtonStopClick 118 TabOrder = 5 119 end 120 object Label1: TLabel 121 Left = 8 122 Height = 14 123 Top = 395 124 Width = 137 125 Anchors = [akLeft, akBottom] 126 Caption = 'Single method test duration:' 127 ParentColor = False 128 end 129 object Label2: TLabel 130 Left = 224 131 Height = 14 132 Top = 395 133 Width = 6 134 Anchors = [akLeft, akBottom] 135 Caption = 's' 136 ParentColor = False 159 137 end 160 138 object Timer1: TTimer 161 139 Interval = 500 162 140 OnTimer = Timer1Timer 163 left = 2 09164 top = 1 6141 left = 238 142 top = 136 165 143 end 166 144 end -
GraphicTest/UMainForm.pas
r212 r317 20 20 21 21 TMainForm = class(TForm) 22 ButtonStop: TButton; 22 23 ButtonBenchmark: TButton; 23 ButtonStart: TButton; 24 ButtonStop: TButton; 25 ComboBox1: TComboBox; 24 ButtonSingleTest: TButton; 26 25 FloatSpinEdit1: TFloatSpinEdit; 27 26 Image1: TImage; 28 27 Label1: TLabel; 29 28 Label2: TLabel; 30 Label3: TLabel; 31 Label4: TLabel; 32 Label5: TLabel; 33 ListView1: TListView; 29 ListViewMethods: TListView; 34 30 PageControl1: TPageControl; 35 31 PaintBox1: TPaintBox; … … 39 35 Timer1: TTimer; 40 36 procedure ButtonBenchmarkClick(Sender: TObject); 41 procedure ButtonS tartClick(Sender: TObject);37 procedure ButtonSingleTestClick(Sender: TObject); 42 38 procedure ButtonStopClick(Sender: TObject); 43 39 procedure FormClose(Sender: TObject; var CloseAction: TCloseAction); 44 40 procedure FormCreate(Sender: TObject); 45 41 procedure FormDestroy(Sender: TObject); 42 procedure FormShow(Sender: TObject); 43 procedure ListViewMethodsData(Sender: TObject; Item: TListItem); 44 procedure ListViewMethodsSelectItem(Sender: TObject; Item: TListItem; 45 Selected: Boolean); 46 46 procedure Timer1Timer(Sender: TObject); 47 47 private … … 50 50 TextureData: Pointer; 51 51 MethodIndex: Integer; 52 SingleTestActive: Boolean; 53 AllTestActive: Boolean; 52 54 procedure OpenGLControl1Resize(Sender: TObject); 53 55 procedure InitGL; 56 procedure UpdateMethodList; 57 procedure UpdateInterface; 54 58 public 55 59 DrawMethods: TObjectList; // TObjectList<TDrawMethod> … … 86 90 Bitmap.PixelFormat := pf24bit; 87 91 Image1.Picture.Bitmap.SetSize(TFastBitmap(Scenes[0]).Size.X, TFastBitmap(Scenes[0]).Size.Y); 92 Image1.Picture.Bitmap.PixelFormat := pf32bit; 88 93 Bitmap.SetSize(TFastBitmap(Scenes[0]).Size.X, TFastBitmap(Scenes[0]).Size.Y); 89 94 … … 100 105 101 106 DrawMethods := TObjectList.Create; 102 ComboBox1.Clear;103 107 for I := 0 to High(DrawMethodClasses) do begin 104 108 NewDrawMethod := DrawMethodClasses[I].Create; … … 109 113 NewDrawMethod.Init; 110 114 DrawMethods.Add(NewDrawMethod); 111 ComboBox1.Items.Add(NewDrawMethod.Caption); 112 end; 113 ComboBox1.ItemIndex := DrawMethods.Count - 1; 114 end; 115 116 procedure TMainForm.ButtonStartClick(Sender: TObject); 117 begin 118 MethodIndex := ComboBox1.ItemIndex; 119 ButtonStop.Enabled := True; 120 ButtonStart.Enabled := False; 121 Timer1.Enabled := True; 122 if MethodIndex >= 0 then 123 with TDrawMethod(DrawMethods[MethodIndex]) do begin 124 PageControl1.TabIndex := Integer(PaintObject); 125 Application.ProcessMessages; 126 repeat 127 DrawFrameTiming(TFastBitmap(Scenes[SceneIndex])); 128 SceneIndex := (SceneIndex + 1) mod Scenes.Count; 115 end; 116 end; 117 118 procedure TMainForm.ButtonSingleTestClick(Sender: TObject); 119 begin 120 try 121 SingleTestActive := True; 122 UpdateInterface; 123 Timer1.Enabled := True; 124 MethodIndex := ListViewMethods.Selected.Index; 125 Timer1.Enabled := True; 126 if MethodIndex >= 0 then 127 with TDrawMethod(DrawMethods[MethodIndex]) do begin 128 PageControl1.TabIndex := Integer(PaintObject); 129 129 Application.ProcessMessages; 130 until not ButtonStop.Enabled; 131 end; 132 ButtonStopClick(Self); 130 repeat 131 DrawFrameTiming(TFastBitmap(Scenes[SceneIndex])); 132 SceneIndex := (SceneIndex + 1) mod Scenes.Count; 133 Application.ProcessMessages; 134 until not SingleTestActive; 135 end; 136 finally 137 Timer1.Enabled := False; 138 SingleTestActive := False; 139 UpdateInterface; 140 end; 133 141 end; 134 142 135 143 procedure TMainForm.ButtonBenchmarkClick(Sender: TObject); 136 144 var 137 NewItem: TListItem;138 145 I: Integer; 139 146 C: Integer; 140 147 StartTime: TDateTime; 141 148 begin 142 Timer1.Enabled := True;143 with ListView1, Items do144 149 try 145 //BeginUpdate; 146 Clear; 150 AllTestActive := True; 151 UpdateInterface; 152 Timer1.Enabled := True; 153 with ListViewMethods, Items do 147 154 for I := 0 to DrawMethods.Count - 1 do 148 155 with TDrawMethod(DrawMethods[I]) do begin … … 154 161 SceneIndex := (SceneIndex + 1) mod Scenes.Count; 155 162 Application.ProcessMessages; 156 until (NowPrecise - StartTime) > OneSecond * FloatSpinEdit1.Value; 157 NewItem := Add; 158 NewItem.Caption := Caption; 159 NewItem.SubItems.Add(FloatToStr(RoundTo(FrameDuration / OneMillisecond, -3))); 160 NewItem.SubItems.Add(FloatToStr(RoundTo(1 / (FrameDuration / OneSecond), -3))); 163 until ((NowPrecise - StartTime) > OneSecond * FloatSpinEdit1.Value) or not AllTestActive; 161 164 end; 162 165 finally 163 //EndUpdate; 166 Timer1.Enabled := False; 167 AllTestActive := False; 168 UpdateInterface; 164 169 end; 165 170 end; … … 167 172 procedure TMainForm.ButtonStopClick(Sender: TObject); 168 173 begin 169 ButtonStart.Enabled := True;170 ButtonStop.Enabled:= False;174 SingleTestActive := False; 175 AllTestActive := False; 171 176 end; 172 177 … … 184 189 end; 185 190 191 procedure TMainForm.FormShow(Sender: TObject); 192 begin 193 UpdateMethodList; 194 UpdateInterface; 195 end; 196 197 procedure TMainForm.ListViewMethodsData(Sender: TObject; Item: TListItem); 198 begin 199 if (Item.Index >= 0) and (Item.Index < DrawMethods.Count) then 200 with TDrawMethod(DrawMethods[Item.Index]) do begin 201 Item.Caption := Caption; 202 if FrameDuration > 0 then 203 Item.SubItems.Add(FloatToStr(RoundTo(1 / (FrameDuration / OneSecond), -3))) 204 else Item.SubItems.Add('0'); 205 Item.SubItems.Add(FloatToStr(RoundTo(FrameDuration / OneMillisecond, -3)) + ' ms'); 206 end; 207 end; 208 209 procedure TMainForm.ListViewMethodsSelectItem(Sender: TObject; Item: TListItem; 210 Selected: Boolean); 211 begin 212 UpdateInterface; 213 end; 214 186 215 procedure TMainForm.Timer1Timer(Sender: TObject); 187 216 begin 188 if (MethodIndex >= 0) then 189 with TDrawMethod(DrawMethods[MethodIndex]) do begin 190 if (FrameDuration > 0) then 191 Label2.Caption := FloatToStr(RoundTo(1 / (FrameDuration / OneSecond), -3)) 192 else Label2.Caption := '0'; 193 Label4.Caption := FloatToStr(RoundTo(FrameDuration / OneMillisecond, -3)) + ' ms'; 194 end; 217 UpdateMethodList; 195 218 end; 196 219 … … 220 243 end; 221 244 245 procedure TMainForm.UpdateMethodList; 246 begin 247 ListViewMethods.Items.Count := DrawMethods.Count; 248 ListViewMethods.Refresh; 249 end; 250 251 procedure TMainForm.UpdateInterface; 252 begin 253 ButtonSingleTest.Enabled := not SingleTestActive and not AllTestActive and Assigned(ListViewMethods.Selected); 254 ButtonBenchmark.Enabled := not AllTestActive and not SingleTestActive; 255 ButtonStop.Enabled := SingleTestActive or AllTestActive; 256 end; 257 222 258 end. 223 259
Note:
See TracChangeset
for help on using the changeset viewer.