From ec10928af5ccfa8d0a6e4b453c536d2831cc9fba Mon Sep 17 00:00:00 2001 From: Ivan Mahonin Date: Jan 18 2019 12:27:14 +0000 Subject: lazarus: snake --- diff --git a/lazarus/snake/project1.ico b/lazarus/snake/project1.ico new file mode 100644 index 0000000..0341321 Binary files /dev/null and b/lazarus/snake/project1.ico differ diff --git a/lazarus/snake/project1.lpi b/lazarus/snake/project1.lpi new file mode 100644 index 0000000..3afe492 --- /dev/null +++ b/lazarus/snake/project1.lpi @@ -0,0 +1,79 @@ + + + + + + + + + <ResourceType Value="res"/> + <UseXPManifest Value="True"/> + <Icon Value="0"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <RequiredPackages Count="1"> + <Item1> + <PackageName Value="LCL"/> + </Item1> + </RequiredPackages> + <Units Count="2"> + <Unit0> + <Filename Value="project1.lpr"/> + <IsPartOfProject Value="True"/> + </Unit0> + <Unit1> + <Filename Value="unit1.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form1"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit1"/> + </Unit1> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <Target> + <Filename Value="project1"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/lazarus/snake/project1.lpr b/lazarus/snake/project1.lpr new file mode 100644 index 0000000..58c35dc --- /dev/null +++ b/lazarus/snake/project1.lpr @@ -0,0 +1,21 @@ +program project1; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Interfaces, // this includes the LCL widgetset + Forms, Unit1 + { you can add units after this }; + +{$R *.res} + +begin + RequireDerivedFormResource:=True; + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. + diff --git a/lazarus/snake/project1.res b/lazarus/snake/project1.res new file mode 100644 index 0000000..e994dfa Binary files /dev/null and b/lazarus/snake/project1.res differ diff --git a/lazarus/snake/unit1.lfm b/lazarus/snake/unit1.lfm new file mode 100644 index 0000000..00a5be3 --- /dev/null +++ b/lazarus/snake/unit1.lfm @@ -0,0 +1,35 @@ +object Form1: TForm1 + Left = 45 + Height = 545 + Top = 166 + Width = 825 + Caption = 'Form1' + ClientHeight = 545 + ClientWidth = 825 + OnCreate = FormCreate + OnMouseMove = FormMouseMove + OnPaint = FormPaint + LCLVersion = '1.6.2.0' + object Label1: TLabel + Left = 24 + Height = 21 + Top = 18 + Width = 43 + Caption = 'Label1' + ParentColor = False + end + object Label2: TLabel + Left = 24 + Height = 21 + Top = 40 + Width = 43 + Caption = 'Label2' + ParentColor = False + end + object Timer1: TTimer + Interval = 10 + OnTimer = Timer1Timer + left = 137 + top = 27 + end +end diff --git a/lazarus/snake/unit1.pas b/lazarus/snake/unit1.pas new file mode 100644 index 0000000..f5a405a --- /dev/null +++ b/lazarus/snake/unit1.pas @@ -0,0 +1,186 @@ +unit Unit1; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, + ExtCtrls, Math; + +type + + { TForm1 } + + TForm1 = class(TForm) + Label1: TLabel; + Label2: TLabel; + Timer1: TTimer; + procedure FormCreate(Sender: TObject); + procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); + procedure FormPaint(Sender: TObject); + procedure Timer1Timer(Sender: TObject); + private + { private declarations } + public + { public declarations } + end; + +const + ballR = 20; + pointR = 5; + +var + Form1: TForm1; + points: array of TPoint; + count: integer; + ball: TPoint; + maxLen: single = 200; + len: single; + + lenLabel, maxlenLabel: integer; + +implementation + +{$R *.lfm} + +function getLen: single; +var + i: integer; +begin + Result := 0; + for i:=1 to count-1 do + Result := Result + sqrt(sqr(points[i].x-points[i-1].x) + sqr(points[i].y-points[i-1].y)); + len := Result; +end; + +function IntersectsCircles(p1, p2: TPoint; r1, r2: single): boolean; +begin + Result := sqr(p1.x-p2.x) + sqr(p1.Y-p2.y) < sqr(r1+r2); +end; + +function IntersectsLines(a1, a2, b1, b2: TPoint): boolean; +var + x1, y1, x2, y2, r, d2, d1: single; +begin + Result := false; + + r := sqr(a2.x-a1.x) + sqr(a2.y-a1.y); + if r = 0 then exit; + x1 := ((a2.x-a1.x)*(b1.x-a1.x) + (a2.y-a1.y)*(b1.y-a1.y))/r; + y1 := ((a1.y-a2.y)*(b1.x-a1.x) + (a2.x-a1.x)*(b1.y-a1.y))/r; + x2 := ((a2.x-a1.x)*(b2.x-a1.x) + (a2.y-a1.y)*(b2.y-a1.y))/r; + y2 := ((a1.y-a2.y)*(b2.x-a1.x) + (a2.x-a1.x)*(b2.y-a1.y))/r; + + if y1 = y2 then exit; + + d2 := y1/(y1-y2); + if (d2 <= 0) or (d2 > 1) then exit; + d1 := d2*(x2-x1) + x1; + if (d1 <= 0) or (d1 > 1) then exit; + Result := true; +end; + +procedure GenerateBall; +var + i: integer; + retry: boolean; +begin + retry := true; + while retry do begin + ball.x := RandomRange(ballR, Form1.ClientWidth-ballR); + ball.y := RandomRange(ballR, Form1.ClientHeight-ballR); + retry := false; + for i := 0 to count - 1 do + if IntersectsCircles(ball, points[i], ballR, pointR) then + retry := true; + end; +end; + +procedure RemovePoints(cnt: integer); +var + i: integer; +begin + with Form1 do begin + Canvas.Pen.Color := Color; + Canvas.Pen.Width := 2*pointR; + Canvas.MoveTo(points[0].x, points[0].y); + for i := 0 to min(cnt, count-1) do Canvas.LineTo(points[i].x, points[i].y); + for i := cnt to count-1 do points[i-cnt] := points[i]; + count := count - cnt; + setLength(points, count); + FormPaint(nil); + end; +end; + +procedure AddPoint(p: TPoint); +var + i: integer; + len: single; +begin + if count > 0 then begin + len := sqrt(sqr(points[count-1].x-p.x) + sqr(points[count-1].y-p.y)); + if len < pointR then exit; + end; + + while getLen > maxLen do RemovePoints(1); + + count := count + 1; + setLength(points, count); + points[count-1] := p; + + for i := count-10 downto 1 do begin + if IntersectsLines(points[count-1], points[count-2], points[i], points[i-1]) then begin + RemovePoints(i); + maxLen := getLen; + break; + end; + end; + + if IntersectsCircles(p, ball, pointR, ballR) then begin + GenerateBall; + maxLen := maxLen + 2*ballR; + end; + + Form1.Refresh(); +end; + +procedure TForm1.FormCreate(Sender: TObject); +begin + Randomize; + GenerateBall; +end; + +procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, + Y: Integer); +begin + AddPoint(Point(x, y)); +end; + +procedure TForm1.FormPaint(Sender: TObject); +begin + Canvas.Pen.Color := clBlack; + Canvas.Pen.Width := 2*pointR; + Canvas.Polyline(points); + + Canvas.Pen.Color := clBlue; + Canvas.Pen.Width := 2*ballR; + Canvas.MoveTo(round(ball.x), round(ball.y)); + Canvas.LineTo(round(ball.x), round(ball.y)); +end; + +procedure TForm1.Timer1Timer(Sender: TObject); +begin + if round(len) <> lenLabel then begin + lenLabel := round(len); + Label1.Caption := 'length ' + IntToStr(lenLabel); + Label2.Caption := 'max length ' + IntToStr(maxlenLabel); + end; + if round(len) > maxlenLabel then begin + maxlenLabel := round(len); + Label2.Caption := 'max length ' + IntToStr(maxlenLabel); + end; +end; + +end. +