1{ $Id: graphutil.pp 53711 2016-12-17 22:58:08Z juha $ } 2{ 3 /*************************************************************************** 4 graphtype.pp 5 ------------ 6 Graphic utility functions. 7 8 ***************************************************************************/ 9 10 ***************************************************************************** 11 This file is part of the Lazarus Component Library (LCL) 12 13 See the file COPYING.modifiedLGPL.txt, included in this distribution, 14 for details about the license. 15 ***************************************************************************** 16} 17unit GraphUtil; 18 19{$mode objfpc}{$H+} 20 21interface 22 23uses 24 Types, Math, 25 Graphics, GraphType, LCLType, LCLIntf; 26 27function ColorToGray(const AColor: TColor): Byte; 28procedure ColorToHLS(const AColor: TColor; out H, L, S: Byte); 29procedure RGBtoHLS(const R, G, B: Byte; out H, L, S: Byte); 30function HLStoColor(const H, L, S: Byte): TColor; 31procedure HLStoRGB(const H, L, S: Byte; out R, G, B: Byte); 32 33// specific things: 34 35{ 36 Draw gradient from top to bottom with parabolic color grow 37} 38procedure DrawVerticalGradient(Canvas: TCanvas; ARect: TRect; TopColor, BottomColor: TColor); 39 40{ 41 Draw nice looking window with Title 42} 43procedure DrawGradientWindow(Canvas: TCanvas; WindowRect: TRect; TitleHeight: Integer; BaseColor: TColor); 44 45 46{ 47 Draw arrows 48} 49type TScrollDirection=(sdLeft,sdRight,sdUp,sdDown); 50 TArrowType = (atSolid, atArrows); 51const NiceArrowAngle=45*pi/180; 52 53procedure DrawArrow(Canvas:TCanvas;Direction:TScrollDirection; Location: TPoint; Size: Longint; ArrowType: TArrowType=atSolid); 54procedure DrawArrow(Canvas:TCanvas;p1,p2: TPoint; ArrowType: TArrowType=atSolid); 55procedure DrawArrow(Canvas:TCanvas;p1,p2: TPoint; ArrowLen: longint; ArrowAngleRad: float=NiceArrowAngle; ArrowType: TArrowType=atSolid); 56 57procedure FloodFill(Canvas: TCanvas; X, Y: Integer; lColor: TColor; FillStyle: TFillStyle); 58 59// delphi compatibility 60procedure ColorRGBToHLS(clrRGB: COLORREF; var Hue, Luminance, Saturation: Word); 61function ColorHLSToRGB(Hue, Luminance, Saturation: Word): TColorRef; 62function ColorAdjustLuma(clrRGB: TColor; n: Integer; fScale: BOOL): TColor; 63function GetHighLightColor(const Color: TColor; Luminance: Integer = 19): TColor; 64function GetShadowColor(const Color: TColor; Luminance: Integer = -50): TColor; 65 66// misc 67function NormalizeRect(const R: TRect): TRect; 68procedure WaveTo(ADC: HDC; X, Y, R: Integer); 69 70implementation 71 72//TODO: Check code on endianess 73 74procedure ExtractRGB(RGB: TColorRef; var R, G, B: Byte); inline; 75begin 76 R := RGB and $FF; 77 G := (RGB shr 8) and $FF; 78 B := (RGB shr 16) and $FF; 79end; 80 81function ColorToGray(const AColor: TColor): Byte; 82var 83 RGB: TColorRef; 84begin 85 if AColor = clNone 86 then RGB := 0 87 else RGB := ColorToRGB(AColor); 88 Result := Trunc(0.222 * (RGB and $FF) + 0.707 * ((RGB shr 8) and $FF) + 0.071 * (RGB shr 16 and $FF)); 89end; 90 91procedure ColorToHLS(const AColor: TColor; out H, L, S: Byte); 92var 93 R, G, B: Byte; 94 RGB: TColorRef; 95begin 96 RGB := ColorToRGB(AColor); 97 ExtractRGB(RGB, R, G, B); 98 99 RGBtoHLS(R, G, B, H, L, S); 100end; 101 102function HLStoColor(const H, L, S: Byte): TColor; 103var 104 R, G, B: Byte; 105begin 106 HLStoRGB(H, L, S, R, G, B); 107 Result := R or (G shl 8) or (B shl 16); 108end; 109 110procedure RGBtoHLS(const R, G, B: Byte; out H, L, S: Byte); 111var aDelta, aMin, aMax: Byte; 112begin 113 aMin := Math.min(Math.min(R, G), B); 114 aMax := Math.max(Math.max(R, G), B); 115 aDelta := aMax - aMin; 116 if aDelta > 0 then 117 begin 118 if aMax = B 119 then H := round(170 + 42.5*(R - G)/aDelta) { 2*255/3; 255/6 } 120 else if aMax = G 121 then H := round(85 + 42.5*(B - R)/aDelta) { 255/3 } 122 else if G >= B 123 then H := round(42.5*(G - B)/aDelta) 124 else H := round(255 + 42.5*(G - B)/aDelta); 125 end; 126 L := (aMax + aMin) div 2; 127 if (L = 0) or (aDelta = 0) 128 then S := 0 129 else if L <= 127 130 then S := round(255*aDelta/(aMax + aMin)) 131 else S := round(255*aDelta/(510 - aMax - aMin)); 132end; 133 134 135procedure HLSToRGB(const H, L, S: Byte; out R, G, B: Byte); 136var hue, chroma, x: Single; 137begin 138 if S > 0 then 139 begin { color } 140 hue:=6*H/255; 141 chroma := S*(1 - abs(0.0078431372549*L - 1)); { 2/255 } 142 G := trunc(hue); 143 B := L - round(0.5*chroma); 144 x := B + chroma*(1 - abs(hue - 1 - G and 254)); 145 case G of 146 0: begin 147 R := B + round(chroma); 148 G := round(x); 149 end; 150 1: begin 151 R := round(x); 152 G := B + round(chroma); 153 end; 154 2: begin 155 R := B; 156 G := B + round(chroma); 157 B := round(x); 158 end; 159 3: begin 160 R := B; 161 G := round(x); 162 inc(B, round(chroma)); 163 end; 164 4: begin 165 R := round(x); 166 G := B; 167 inc(B, round(chroma)); 168 end; 169 otherwise 170 R := B + round(chroma); 171 G := B; 172 B := round(x); 173 end; 174 end else 175 begin { grey } 176 R := L; 177 G := L; 178 B := L; 179 end; 180end; 181 182 183 184 185procedure DrawArrow(Canvas: TCanvas; Direction: TScrollDirection; 186 Location: TPoint; Size: Longint; ArrowType: TArrowType); 187const ScrollDirectionX:array[TScrollDirection]of longint=(-1,+1,0,0); 188 ScrollDirectionY:array[TScrollDirection]of longint=(0,0,-1,+1); 189begin 190 DrawArrow(Canvas,Location, 191 point(ScrollDirectionX[Direction]*size+Location.x,ScrollDirectionY[Direction]*size+Location.y), 192 max(5,size div 10), 193 NiceArrowAngle,ArrowType); 194end; 195 196procedure DrawArrow(Canvas: TCanvas; p1, p2: TPoint; ArrowType: TArrowType); 197begin 198 DrawArrow(Canvas,p1,p2,round(sqrt(sqr(p1.x-p2.x)+sqr(p1.y-p2.y))/10),NiceArrowAngle,ArrowType); 199end; 200 201procedure DrawArrow(Canvas: TCanvas; p1, p2: TPoint; ArrowLen: longint; 202 ArrowAngleRad: float; ArrowType: TArrowType); 203var {NormalizedLineX, NormalizedLineY, LineLen,} LineAngle: float; 204 ArrowPoint1, ArrowPoint2: TPoint; 205begin 206 LineAngle:=arctan2(p2.y-p1.y,p2.x-p1.x); 207 ArrowPoint1.x:=round(ArrowLen*cos(pi+LineAngle-ArrowAngleRad))+p2.x; 208 ArrowPoint1.y:=round(ArrowLen*sin(pi+LineAngle-ArrowAngleRad))+p2.y; 209 ArrowPoint2.x:=round(ArrowLen*cos(pi+LineAngle+ArrowAngleRad))+p2.x; 210 ArrowPoint2.y:=round(ArrowLen*sin(pi+LineAngle+ArrowAngleRad))+p2.y; 211 212 Canvas.Line(p1,p2); 213 214 case ArrowType of 215 atSolid: begin 216 canvas.Polygon([ArrowPoint1,p2,ArrowPoint2]); 217 end; 218 atArrows: begin 219 Canvas.LineTo(ArrowPoint1.x,ArrowPoint1.y); 220 Canvas.Line(p2.x,p2.y,ArrowPoint2.x,ArrowPoint2.y); 221 end; 222 end; 223end; 224 225type 226 ByteRA = array [1..1] of byte; 227 Bytep = ^ByteRA; 228 LongIntRA = array [1..1] of LongInt; 229 LongIntp = ^LongIntRA; 230 231procedure FloodFill(Canvas: TCanvas; X, Y: Integer; lColor: TColor; 232 FillStyle: TFillStyle); 233//Written by Chris Rorden 234// Very slow, because uses Canvas.Pixels. 235//A simple first-in-first-out circular buffer (the queue) for flood-filling contiguous voxels. 236//This algorithm avoids stack problems associated simple recursive algorithms 237//http://steve.hollasch.net/cgindex/polygons/floodfill.html [^] 238const 239 kFill = 0; //pixels we will want to flood fill 240 kFillable = 128; //voxels we might flood fill 241 kUnfillable = 255; //voxels we can not flood fill 242var 243 lWid,lHt,lQSz,lQHead,lQTail: integer; 244 lQRA: LongIntP; 245 lMaskRA: ByteP; 246 247 procedure IncQra(var lVal, lQSz: integer);//nested inside FloodFill 248 begin 249 inc(lVal); 250 if lVal >= lQSz then 251 lVal := 1; 252 end; //nested Proc IncQra 253 254 function Pos2XY (lPos: integer): TPoint; 255 begin 256 result.X := ((lPos-1) mod lWid)+1; //horizontal position 257 result.Y := ((lPos-1) div lWid)+1; //vertical position 258 end; //nested Proc Pos2XY 259 260 procedure TestPixel(lPos: integer); 261 begin 262 if (lMaskRA^[lPos]=kFillable) then begin 263 lMaskRA^[lPos] := kFill; 264 lQra^[lQHead] := lPos; 265 incQra(lQHead,lQSz); 266 end; 267 end; //nested Proc TestPixel 268 269 procedure RetirePixel; //nested inside FloodFill 270 var 271 lVal: integer; 272 lXY : TPoint; 273 begin 274 lVal := lQra^[lQTail]; 275 lXY := Pos2XY(lVal); 276 if lXY.Y > 1 then 277 TestPixel (lVal-lWid);//pixel above 278 if lXY.Y < lHt then 279 TestPixel (lVal+lWid);//pixel below 280 if lXY.X > 1 then 281 TestPixel (lVal-1); //pixel to left 282 if lXY.X < lWid then 283 TestPixel (lVal+1); //pixel to right 284 incQra(lQTail,lQSz); //done with this pixel 285 end; //nested proc RetirePixel 286 287var 288 lTargetColorVal,lDefaultVal: byte; 289 lX,lY,lPos: integer; 290 lBrushColor: TColor; 291begin //FloodFill 292 if FillStyle = fsSurface then begin 293 //fill only target color with brush - bounded by nontarget color. 294 if Canvas.Pixels[X,Y] <> lColor then exit; 295 lTargetColorVal := kFillable; 296 lDefaultVal := kUnfillable; 297 end else begin //fsBorder 298 //fill non-target color with brush - bounded by target-color 299 if Canvas.Pixels[X,Y] = lColor then exit; 300 lTargetColorVal := kUnfillable; 301 lDefaultVal := kFillable; 302 end; 303 //if (lPt < 1) or (lPt > lMaskSz) or (lMaskP[lPt] <> 128) then exit; 304 lHt := Canvas.Height; 305 lWid := Canvas.Width; 306 lQSz := lHt * lWid; 307 //Qsz should be more than the most possible simultaneously active pixels 308 //Worst case scenario is a click at the center of a 3x3 image: all 9 pixels will be active simultaneously 309 //for larger images, only a tiny fraction of pixels will be active at one instance. 310 //perhaps lQSz = ((lHt*lWid) div 4) + 32; would be safe and more memory efficient 311 if (lHt < 1) or (lWid < 1) then exit; 312 getmem(lQra,lQSz*sizeof(longint)); //very wasteful - 313 getmem(lMaskRA,lHt*lWid*sizeof(byte)); 314 for lPos := 1 to (lHt*lWid) do 315 lMaskRA^[lPos] := lDefaultVal; //assume all voxels are non targets 316 lPos := 0; 317 // MG: it is very slow to access the whole (!) canvas with pixels 318 for lY := 0 to (lHt-1) do 319 for lX := 0 to (lWid-1) do begin 320 lPos := lPos + 1; 321 if Canvas.Pixels[lX,lY] = lColor then 322 lMaskRA^[lPos] := lTargetColorVal; 323 end; 324 lQHead := 2; 325 lQTail := 1; 326 lQra^[lQTail] := ((Y * lWid)+X+1); //NOTE: both X and Y start from 0 not 1 327 lMaskRA^[lQra^[lQTail]] := kFill; 328 RetirePixel; 329 while lQHead <> lQTail do 330 RetirePixel; 331 lBrushColor := Canvas.Brush.Color; 332 lPos := 0; 333 for lY := 0 to (lHt-1) do 334 for lX := 0 to (lWid-1) do begin 335 lPos := lPos + 1; 336 if lMaskRA^[lPos] = kFill then 337 Canvas.Pixels[lX,lY] := lBrushColor; 338 end; 339 freemem(lMaskRA); 340 freemem(lQra); 341end; 342 343procedure ColorRGBToHLS(clrRGB: COLORREF; var Hue, Luminance, Saturation: Word); 344var 345 H, L, S: Byte; 346begin 347 ColorToHLS(clrRGB, H, L, S); 348 Hue := H; 349 Luminance := L; 350 Saturation := S; 351end; 352 353function ColorHLSToRGB(Hue, Luminance, Saturation: Word): TColorRef; 354begin 355 Result := HLStoColor(Hue, Luminance, Saturation); 356end; 357 358function ColorAdjustLuma(clrRGB: TColor; n: Integer; fScale: BOOL): TColor; 359var 360 H, L, S: Byte; 361begin 362 // what is fScale? 363 ColorToHLS(clrRGB, H, L, S); 364 Result := HLStoColor(H, L + n, S); 365end; 366 367function GetHighLightColor(const Color: TColor; Luminance: Integer): TColor; 368begin 369 Result := ColorAdjustLuma(Color, Luminance, False); 370end; 371 372function GetShadowColor(const Color: TColor; Luminance: Integer): TColor; 373begin 374 Result := ColorAdjustLuma(Color, Luminance, False); 375end; 376 377function NormalizeRect(const R: TRect): TRect; 378begin 379 if R.Left <= R.Right then 380 begin 381 Result.Left := R.Left; 382 Result.Right := R.Right; 383 end 384 else 385 begin 386 Result.Left := R.Right; 387 Result.Right := R.Left; 388 end; 389 390 if R.Top <= R.Bottom then 391 begin 392 Result.Top := R.Top; 393 Result.Bottom := R.Bottom; 394 end 395 else 396 begin 397 Result.Top := R.Bottom; 398 Result.Bottom := R.Top; 399 end; 400end; 401 402procedure DrawVerticalGradient(Canvas: TCanvas; ARect: TRect; TopColor, BottomColor: TColor); 403var 404 y, h: Integer; 405 r1, g1, b1: byte; 406 r2, g2, b2: byte; 407 dr, dg, db: integer; 408 409 function GetColor(pos, total: integer): TColor; 410 411 function GetComponent(c1, dc: integer): integer; 412 begin 413 Result := Round(dc / sqr(total) * sqr(pos) + c1); 414 end; 415 416 begin 417 Result := 418 GetComponent(r1, dr) or 419 (GetComponent(g1, dg) shl 8) or 420 (GetComponent(b1, db) shl 16); 421 end; 422 423begin 424 ExtractRGB(ColorToRGB(TopColor), r1, g1, b1); 425 ExtractRGB(ColorToRGB(BottomColor), r2, g2, b2); 426 dr := r2 - r1; 427 dg := g2 - g1; 428 db := b2 - b1; 429 h := ARect.Bottom - ARect.Top; 430 for y := ARect.Top to ARect.Bottom do 431 begin 432 Canvas.Pen.Color := GetColor(y - ARect.Top, h); 433 Canvas.Line(ARect.Left, y, ARect.Right, y); 434 end; 435end; 436 437procedure DrawGradientWindow(Canvas: TCanvas; WindowRect: TRect; TitleHeight: Integer; BaseColor: TColor); 438begin 439 Canvas.Brush.Color := BaseColor; 440 Canvas.FrameRect(WindowRect); 441 InflateRect(WindowRect, -1, -1); 442 WindowRect.Bottom := WindowRect.Top + TitleHeight; 443 DrawVerticalGradient(Canvas, WindowRect, GetHighLightColor(BaseColor), GetShadowColor(BaseColor)); 444end; 445 446procedure WaveTo(ADC: HDC; X, Y, R: Integer); 447var 448 Direction, Cur: Integer; 449 PenPos, Dummy: TPoint; 450begin 451 dec(R); 452 // get the current pos 453 MoveToEx(ADC, 0, 0, @PenPos); 454 MoveToEx(ADC, PenPos.X, PenPos.Y, @Dummy); 455 456 Direction := 1; 457 // vertical wave 458 if PenPos.X = X then 459 begin 460 Cur := PenPos.Y; 461 if Cur < Y then 462 while (Cur < Y) do 463 begin 464 X := X + Direction * R; 465 LineTo(ADC, X, Cur + R); 466 Direction := -Direction; 467 inc(Cur, R); 468 end 469 else 470 while (Cur > Y) do 471 begin 472 X := X + Direction * R; 473 LineTo(ADC, X, Cur - R); 474 Direction := -Direction; 475 dec(Cur, R); 476 end; 477 end 478 else 479 // horizontal wave 480 begin 481 Cur := PenPos.X; 482 if (Cur < X) then 483 while (Cur < X) do 484 begin 485 Y := Y + Direction * R; 486 LineTo(ADC, Cur + R, Y); 487 Direction := -Direction; 488 inc(Cur, R); 489 end 490 else 491 while (Cur > X) do 492 begin 493 Y := Y + Direction * R; 494 LineTo(ADC, Cur - R, Y); 495 Direction := -Direction; 496 dec(Cur, R); 497 end; 498 end; 499end; 500 501end. 502