home *** CD-ROM | disk | FTP | other *** search
/ Chip 2005 November / CDVD1105.ISO / Software / Freeware / programare / graphics32 / Examples / Vcl / GradLines_Ex / MainUnit.pas < prev   
Encoding:
Pascal/Delphi Source File  |  2004-07-15  |  7.4 KB  |  319 lines

  1. unit MainUnit;
  2.  
  3. (* ***** BEGIN LICENSE BLOCK *****
  4.  * Version: MPL 1.1
  5.  *
  6.  * The contents of this file are subject to the Mozilla Public License Version
  7.  * 1.1 (the "License"); you may not use this file except in compliance with
  8.  * the License. You may obtain a copy of the License at
  9.  * http://www.mozilla.org/MPL/
  10.  *
  11.  * Software distributed under the License is distributed on an "AS IS" basis,
  12.  * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
  13.  * for the specific language governing rights and limitations under the
  14.  * License.
  15.  *
  16.  * The Original Code is Graphics32
  17.  *
  18.  * The Initial Developer of the Original Code is
  19.  * Alex A. Denisov
  20.  *
  21.  * Portions created by the Initial Developer are Copyright (C) 2000-2004
  22.  * the Initial Developer. All Rights Reserved.
  23.  *
  24.  * Contributor(s):
  25.  *
  26.  * ***** END LICENSE BLOCK ***** *)
  27.  
  28. // TPaintBox32 and DrawLineFSP example
  29. // Author: Alex Denissov
  30. // http://g32.org
  31.  
  32.  
  33. interface
  34.  
  35. uses
  36.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  37.   StdCtrls, GR32, GR32_Blend, ExtCtrls, GR32_Image;
  38.  
  39. type
  40.   TVector2f = record
  41.     X, Y: Single;
  42.   end;
  43.  
  44.   TLine = class
  45.   public
  46.     Bitmap: TBitmap32;
  47.     P1, P2: TVector2f;     // positions
  48.     V1, V2: TVector2f;     // velocities
  49.     C1, C2, C3: TColor32;  // colors that define gradient pattern
  50.     t1, t2, t3: Single;
  51.     MaxVelocity: Single;
  52.     constructor Create(ABitmap: TBitmap32);
  53.     procedure Advance(DeltaT: Single);
  54.     function GetLength: Single;
  55.     procedure Paint;
  56.   end;
  57.  
  58.   TForm1 = class(TForm)
  59.     PaintBox: TPaintBox32;
  60.     Button1: TButton;
  61.     Button2: TButton;
  62.     Button3: TButton;
  63.     RadioGroup1: TRadioGroup;
  64.     RadioGroup2: TRadioGroup;
  65.     Label1: TLabel;
  66.     Panel1: TPanel;
  67.     procedure Button1Click(Sender: TObject);
  68.     procedure FormCreate(Sender: TObject);
  69.     procedure Button2Click(Sender: TObject);
  70.     procedure Button3Click(Sender: TObject);
  71.     procedure BitmapLayerMouseDown(Sender: TObject;
  72.       Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  73.     procedure BitmapLayerMouseUp(Sender: TObject; Button: TMouseButton;
  74.       Shift: TShiftState; X, Y: Integer);
  75.     procedure RadioGroup1Click(Sender: TObject);
  76.     procedure RadioGroup2Click(Sender: TObject);
  77.   protected
  78.     Lines: array of TLine;
  79.     P: TPoint; // mouse shift
  80.     M: Boolean; // mouse down flag
  81.     FadeCount: Integer;
  82.     Pass: Integer;
  83.     DrawPasses: Integer;
  84.     procedure AppEventsIdle(Sender: TObject; var Done: Boolean);
  85.   public
  86.     procedure AddLine;
  87.     procedure AddLines(N: Integer);
  88.   end;
  89.  
  90. var
  91.   Form1: TForm1;
  92.  
  93. implementation
  94.  
  95. uses Math;
  96.  
  97. function vAdd(const A, B: TVector2f): TVector2f;
  98. begin
  99.   Result.X := A.X + B.X;
  100.   Result.Y := A.Y + B.Y;
  101. end;
  102.  
  103. function vSub(const A, B: TVector2f): TVector2f;
  104. begin
  105.   Result.X := A.X - B.X;
  106.   Result.Y := A.Y - B.Y;
  107. end;
  108.  
  109. function vLen(const A: TVector2f): Single;
  110. begin
  111.   Result := SqRt(SqR(A.X) + SqR(A.Y));
  112. end;
  113.  
  114. function vDot(const A, B: TVector2f): Single;
  115. begin
  116.   Result := A.X * B.X + A.Y * B.Y;
  117. end;
  118.  
  119. function vScale(const A: TVector2f; Factor: Single): TVector2f;
  120. begin
  121.   Result.X := A.X * Factor;
  122.   Result.Y := A.Y * Factor;
  123. end;
  124.  
  125. {$R *.DFM}
  126.  
  127.  
  128. { TLine }
  129.  
  130. procedure TLine.Advance(DeltaT: Single);
  131.  
  132. {}procedure AdvancePoint(var P, V: TVector2f; t: Single);
  133.   begin
  134.     { apply velocities }
  135.     P.X := P.X + V.X * t;
  136.     P.Y := P.Y + V.Y * t;
  137.  
  138.     { reflect from walls }
  139.     if P.X < 0 then
  140.     begin
  141.       P.X := 0;
  142.       V.X := -V.X;
  143.     end;
  144.     if P.X >= Form1.PaintBox.Width then
  145.     begin
  146.       P.X := Form1.PaintBox.Width - 1;
  147.       V.X := - V.X;
  148.     end;
  149.     if P.Y < 0 then
  150.     begin
  151.       P.Y := 0;
  152.       V.Y := -V.Y;
  153.     end;
  154.     if P.Y >= Form1.PaintBox.Height then
  155.     begin
  156.       P.Y := Form1.PaintBox.Height - 1;
  157.       V.Y := - V.Y
  158.     end;
  159.  
  160.     { change velocity a little bit }
  161.     V.X := V.X + t * (Random - 0.5) / 4;
  162.     V.Y := V.Y + t * (Random - 0.5) / 4;
  163.  
  164.     { limit velocity }
  165.     if vLen(V1) > MaxVelocity then V1 := vScale(V1, 1 / vLen(V1));
  166.     if vLen(V2) > MaxVelocity then V2 := vScale(V2, 1 / vLen(V2));
  167.   end;
  168. begin
  169.   AdvancePoint(P1, V1, DeltaT);
  170.   AdvancePoint(P2, V2, DeltaT);
  171.  
  172.   C1 := HSLtoRGB(t1, Sin(t1 / 1.8) * 0.4 + 0.6, 0.5);
  173.   C1 := SetAlpha(C1, Round(Sin(t1) * 25 + 50));
  174.   t1 := t1 + Random / 300;
  175.  
  176.   C2 := HSLtoRGB(t2, Sin(t2 / 1.8) * 0.4 + 0.6, 0.5);
  177.   C2 := SetAlpha(C2, Round(Sin(t2) * 25 + 50));
  178.   t2 := t2 + Random / 400;
  179.  
  180.   C3 := HSLtoRGB(t3, Sin(t3 / 1.8) * 0.4 + 0.6, 0.5);
  181.   C3 := SetAlpha(C3, Round(Sin(t3) * 25 + 50));
  182.   t3 := t3 + Random / 400;
  183. end;
  184.  
  185. constructor TLine.Create(ABitmap: TBitmap32);
  186. begin
  187.   Bitmap := ABitmap;
  188.   MaxVelocity := 1;
  189. end;
  190.  
  191. function TLine.GetLength: Single;
  192. begin
  193.   Result := vLen(vSub(P1, P2));
  194. end;
  195.  
  196. procedure TLine.Paint;
  197. var
  198.   L: Single;
  199. begin
  200.   // this shows how to draw a gradient line
  201.   L := GetLength;
  202.   if L < 1 then Exit;
  203.   Bitmap.SetStipple([C1, C2, C3]);
  204.   Bitmap.StippleStep := 2 / L; {2 = 3 - 1 = Number of colors in a pattern - 1}
  205.   Bitmap.StippleCounter := 0;
  206.   Bitmap.LineFSP(P1.X, P1.Y, P2.X, P2.Y);
  207. end;
  208.  
  209. { TForm1 }
  210.  
  211. procedure TForm1.AddLine;
  212. var
  213.   L: TLine;
  214. begin
  215.   SetLength(Lines, Length(Lines) + 1);
  216.   L := TLine.Create(PaintBox.Buffer);
  217.   Lines[High(Lines)] := L;
  218.   L.t1 := Random * 3;
  219.   L.t2 := Random * 3;
  220.   L.t3 := Random * 3;
  221.   L.P1.X := Random(PaintBox.Buffer.Width - 1);
  222.   L.P2.X := Random(PaintBox.Buffer.Width - 1);
  223.   L.P1.Y := Random(PaintBox.Buffer.Height - 1);
  224.   L.P2.Y := Random(PaintBox.Buffer.Height - 1);
  225.   Panel1.Caption := IntToStr(Length(Lines));
  226. end;
  227.  
  228. procedure TForm1.AddLines(N: Integer);
  229. var
  230.   i: Integer;
  231. begin
  232.   for i := 0 to N - 1 do AddLine;
  233. end;
  234.  
  235. procedure TForm1.AppEventsIdle(Sender: TObject; var Done: Boolean);
  236. var
  237.   I, J: Integer;
  238.   P: PColor32;
  239. begin
  240.   for J := 0 to DrawPasses - 1 do
  241.     for I := 0 to High(Lines) do
  242.     begin
  243.       Lines[I].Advance(1);
  244.       Lines[I].Paint;
  245.     end;
  246.  
  247.   if FadeCount > 0 then
  248.   begin
  249.     if Pass = 0 then with PaintBox.Buffer do
  250.     begin
  251.       P := @Bits[0];
  252.       for I := 0 to Width * Height -1 do
  253.       begin
  254.         BlendMem($10000000, P^);
  255.         Inc(P);
  256.       end;
  257.       EMMS;
  258.     end;
  259.     Dec(Pass);
  260.     if (Pass < 0) or (Pass > FadeCount) then Pass := FadeCount;
  261.   end;
  262.   PaintBox.Invalidate;
  263. end;
  264.  
  265. procedure TForm1.FormCreate(Sender: TObject);
  266. begin
  267.   FadeCount := 7;
  268.   DrawPasses := 2;
  269.   Application.OnIdle := AppEventsIdle;
  270. end;
  271.  
  272. procedure TForm1.Button1Click(Sender: TObject);
  273. begin
  274.   AddLine;
  275. end;
  276.  
  277. procedure TForm1.Button2Click(Sender: TObject);
  278. begin
  279.   AddLines(10);
  280. end;
  281.  
  282. procedure TForm1.Button3Click(Sender: TObject);
  283. var
  284.   I: Integer;
  285. begin
  286.   for I := High(Lines) downto 0 do Lines[I].Free;
  287.   Lines := nil;
  288.   PaintBox.Buffer.Clear;
  289.   Panel1.Caption := '0';
  290. end;
  291.  
  292. procedure TForm1.BitmapLayerMouseDown(Sender: TObject;
  293.   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  294. begin
  295.   // X and Y here are relative to layer origin
  296.   P := Point(X, Y);
  297.   M := True;
  298. end;
  299.  
  300. procedure TForm1.BitmapLayerMouseUp(Sender: TObject;
  301.   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  302. begin
  303.   M := False;
  304. end;
  305.  
  306. procedure TForm1.RadioGroup1Click(Sender: TObject);
  307. const
  308.   FC: array [0..2] of Integer = (0, 7, 1);
  309. begin
  310.   FadeCount := FC[RadioGroup1.ItemIndex];
  311. end;
  312.  
  313. procedure TForm1.RadioGroup2Click(Sender: TObject);
  314. begin
  315.   DrawPasses := (RadioGroup2.ItemIndex + 1) * 3 - 2;
  316. end;
  317.  
  318. end.
  319.