// verzia 081001

unit KorUnit2;

interface

uses
  Classes, Windows, Graphics, ExtCtrls, Messages, SysUtils, Forms;

type
  TKor = class
  private
    FX,FY,FSmer:real;
    FDole:boolean;
    FFP:TColor;
    FHP:integer;
    FVidno:boolean;
    FTvarPole:array of real;
    FFarbaTvaru:TColor;
    FHrubkaTvaru:integer;
    FTvarBMP:TBitmap;
    procedure Zobraz(c:TCanvas);
  public
    constructor Create; overload;
    constructor Create(nx,ny:real; uhol:real = 0); overload;
    destructor Destroy; override;

    procedure Dopredu(dlzka:real); virtual;
    procedure Vpravo(uhol:real); virtual;
    procedure Vlavo(uhol:real); virtual;
    procedure ZmenSmer(uhol:real); virtual;
    procedure ZmenXY(nx,ny:real); virtual;
    procedure PresunXY(nx,ny:real); virtual;
    procedure PH; virtual;
    procedure PD; virtual;
    procedure ZmenPero(ndole:boolean); virtual;
    procedure ZmenFP(farba:TColor); virtual;
    procedure ZmenHP(hrubka:integer); virtual;
    procedure ZmenVidno(nvidno:boolean); virtual;
    procedure Ukaz; virtual;
    procedure Skry; virtual;
    procedure ZmenTvar(const pole:array of real); overload; virtual;
    procedure ZmenTvar(bmp:TBitmap); overload; virtual; 
    procedure ZmenFarbuTvaru(farba:TColor); virtual;
    procedure ZmenHrubkuTvaru(hrubka:integer); virtual;

    procedure Pis(text:string); virtual;
    function  Smerom(nx,ny:real):real; virtual;
    procedure Vypln(farba:TColor); virtual;
    function  Vzd(nx,ny:real):real; virtual;
    function  Blizko(nx,ny:real):boolean; virtual;

    property  X:real read FX;
    property  Y:real read FY;
    property  Smer:real read FSmer write ZmenSmer;
    property  Dole:boolean read FDole write ZmenPero;
    property  Vidno:boolean read FVidno write ZmenVidno;
    property  FP:TColor read FFP write ZmenFP;
    property  HP:integer read FHP write ZmenHP;
    property  FarbaTvaru:TColor read FFarbaTvaru write ZmenFarbuTvaru;
    property  HrubkaTvaru:integer read FHrubkaTvaru write ZmenHrubkuTvaru;
  end;

//////////////////////////////////////////////////////////////////////////////////////////

const
  rad = pi/180;
  deg = 180/pi;

var
  sirka,vyska:integer;
  spomal:integer = 0;

procedure Zmaz(fpoz:TColor = clWhite);
procedure Cakaj(MilliSec:Longint);

procedure ZrusKory;
procedure test;
function  Naraz(blokuj:boolean = true):boolean;
procedure NastavPlochu(p:TImage);

//////////////////////////////////////////////////////////////////////////////////////////

implementation

uses
  //Controls,
  Dialogs;

procedure Inicializuj; forward;
procedure testSkry; forward;

var
  g:TCanvas = nil;
  plocha:TImage = nil;
  blok:boolean = false;
  pukaz:integer = 0;
  kory:array of TKor;
  maxkor:integer = -1;

//////////////////////////////////////////////////////////////////////////////////////////

constructor TKor.Create;
begin
  Inicializuj;
  Create(sirka/2,vyska/2);
end;

constructor TKor.Create(nx,ny,uhol:real);
var
  i:integer;
begin
  Inicializuj;
  FX:=nx; FY:=ny; FSmer:=uhol;
  FFP:=clBlack; FHP:=1;
  FDole:=true; FVidno:=false;
  FTvarPole:=nil; FHrubkaTvaru:=1;
  ZmenTvar([90,8,-105,30.9,-150,30.9,-105,8]); FFarbaTvaru:=clGreen;
//  ZmenTvar([120,11.5,-135,38.6,-150,38.6,-135,11.5]); FFarbaTvaru:=clred;
  i:=0; while (i<=maxkor) and (kory[i]<>nil) do inc(i);
  if i>high(kory) then SetLength(kory, Length(kory)+10);
  kory[i]:=self; if i>maxkor then maxkor:=i;
  test;
end;

destructor TKor.Destroy;
var
  i:integer;
begin
  if FVidno then dec(pukaz);
  FTvarPole:=nil;
  i:=0; while (i<=maxkor) and (kory[i]<>self) do inc(i);
  if i<=maxkor then kory[i]:=nil;
  testSkry;
  inherited;
end;

procedure TKor.Vpravo(uhol:real);
begin
  ZmenSmer(FSmer+uhol);
end;

procedure TKor.Vlavo(uhol:real);
begin
  ZmenSmer(FSmer-uhol);
end;

procedure TKor.ZmenSmer(uhol:real);
begin
  FSmer:=uhol;
  while FSmer<0 do FSmer:=FSmer+360;
  while FSmer>=360 do FSmer:=FSmer-360;
  test;
end;

procedure TKor.Dopredu(dlzka:real);
begin
  ZmenXY(FX+sin(FSmer*rad)*dlzka,FY-cos(FSmer*rad)*dlzka);
end;

procedure TKor.ZmenXY(nx,ny:real);
begin
  if not FDole then PresunXY(nx,ny)
  else begin
    g.Brush.Style:=bsSolid;
    g.Pen.Color:=FFP;
    g.Pen.Width:=FHP;
    g.PolyLine([Point(round(FX),round(FY)),Point(round(nx),round(ny))]);
    FX:=nx; FY:=ny;
    test;
  end;
end;

procedure TKor.PresunXY(nx,ny:real);
begin
  FX:=nx; FY:=ny;
  g.MoveTo(round(FX),round(FY));
  test;
end;

procedure TKor.PH;
begin
  FDole:=false;
  test;
end;

procedure TKor.PD;
begin
  FDole:=true;
  test;
end;

procedure TKor.ZmenPero(ndole:boolean);
begin
  if ndole then PD else PH;
end;

procedure TKor.ZmenFP(farba:TColor);
begin
  FFP:=farba;
  test;
end;

procedure TKor.ZmenHP(hrubka:integer);
begin
  FHP:=hrubka;
  test;
end;

//////////////////////////////////////////////////////////////////////////////////////////

procedure TKor.Vypln(farba:TColor);
var
  nx,ny:integer;
begin
  nx:=round(FX); ny:=round(FY);
  g.Brush.Color:=farba;
  g.Brush.Style:=bsSolid;
  g.FloodFill(nx,ny,g.Pixels[nx,ny],fsSurface);
  test;
end;

function TKor.Smerom(nx,ny:real):real;
var
  uhol:real;
begin
  nx:=nx-FX; ny:=FY-ny;
  if ny=0 then
    if nx=0 then uhol:=0
    else if nx<0 then uhol:=270 else uhol:=90
  else if ny>0 then
    if nx>=0 then uhol:=arctan(nx/ny)*deg
    else uhol:=360-arctan(-nx/ny)*deg
  else
    if nx>=0 then uhol:=180-arctan(-nx/ny)*deg
    else uhol:=180+arctan(nx/ny)*deg;
  Result:=uhol;
  test;
end;

function TKor.Vzd(nx,ny:real):real;
begin
  Result:=sqrt(sqr(nx-FX)+sqr(ny-FY));
end;

function TKor.Blizko(nx,ny:real):boolean;
begin
  Result:=FVidno and (sqr(nx-FX)+sqr(ny-FY)<100);
end;

procedure TKor.Pis(text:string);
begin
  g.Font.Color:=FFP;
  g.TextOut(round(FX),round(FY),text);
  test;
end;

//////////////////////////////////////////////////////////////////////////////////////////

procedure TKor.ZmenVidno(nvidno:boolean);
begin
  if nvidno then Ukaz else Skry;
end;

procedure TKor.Ukaz;
begin
  if not FVidno then begin
    FVidno:=true; inc(pukaz);
  end;
  test;
end;

procedure TKor.Skry;
begin
  if FVidno then dec(pukaz);
  FVidno:=false;
  testSkry;
end;

procedure TKor.ZmenTvar(const pole:array of real);
var
  i:integer;
begin
  FTvarBMP:=nil;
  SetLength(FTvarPole,Length(pole));
  for i:=0 to high(pole) do FTvarPole[i]:=pole[i];
  testSkry;
end;

procedure TKor.ZmenTvar(bmp:TBitmap);
begin
  FTvarBMP:=bmp;
  testSkry;
end;

procedure TKor.ZmenFarbuTvaru(farba:TColor);
begin
  FFarbaTvaru:=farba; test;
end;

procedure TKor.ZmenHrubkuTvaru(hrubka:integer);
begin
  if hrubka<=0 then hrubka:=1;
  FHrubkaTvaru:=hrubka; test;
end;

procedure TKor.Zobraz(c:TCanvas);
var
  i:integer;
  x1,y1,s1:real;
begin
  if not FVidno then exit;
  if FTvarBMP<>nil then
    c.Draw(round(FX)-FTvarBMP.Width div 2,round(FY)-FTvarBMP.Height div 2,FTvarBMP)
  else if FTvarPole<>nil then begin
    c.MoveTo(round(FX),round(FY));
    c.Pen.Color:=FFarbaTvaru;
    c.Pen.Width:=FHrubkaTvaru;
    c.Pen.Style:=psSolid;
    x1:=FX; y1:=FY; s1:=FSmer;
    for i:=low(FTvarPole) to high(FTvarPole) do begin
      if not odd(i) then s1:=s1+FTvarPole[i]
      else if FTvarPole[i]<>0 then begin
        x1:=x1+sin(s1*rad)*FTvarPole[i]; y1:=y1-cos(s1*rad)*FTvarPole[i];
        c.LineTo(round(x1),round(y1));
      end;
    end;
  end;
end;

//////////////////////////////////////////////////////////////////////////////////////////

procedure Zmaz(fpoz:TColor);
begin
  Inicializuj;
  g.Brush.Color:=fpoz;
  g.Brush.Style:=bsSolid;
  g.FillRect(Rect(0,0,sirka,vyska));
  g.Brush.Style:=bsClear;
  test;
end;

procedure Cakaj(MilliSec:Longint);
var
  potom:TDateTime;
begin
  potom:=Now + EncodeTime(0,MilliSec div 60000,(MilliSec div 1000) mod 60,MilliSec mod 1000);
  while Now < potom do Application.ProcessMessages;
end;

procedure test;
begin
  if blok or (spomal=0) then exit;
  if (pukaz<>0) and (plocha<>nil) then
    plocha.Repaint;
  if spomal=1 then Application.ProcessMessages
  else Cakaj(spomal);
end;

procedure testSkry;
begin
  if blok or (spomal=0) then exit;
  if plocha<>nil then plocha.Repaint;
  if spomal=1 then Application.ProcessMessages
  else Cakaj(spomal);
end;

function naraz(blokuj:boolean):boolean;
begin
  Result:=blok; blok:=false; test; blok:=blokuj;
end;

procedure ZrusKory;
var
  i:integer;
begin
  for i:=0 to maxkor do kory[i].Free;
end;

//////////////////////////////////////////////////////////////////////////////////////

type
  tobj = class
    FImageWindowProc: TWndMethod;
    procedure myClose(Sender: TObject; var Action: TCloseAction);
    procedure ImageWndProc(var Msg: TMessage);
  end;

var
  fl:boolean = true;
  obj:tobj = nil;

procedure tobj.ImageWndProc(var Msg: TMessage);
var
  i:integer;
  C:TCanvas;
begin
  FImageWindowProc(Msg);
  if fl and (Msg.Msg=WM_PAINT) and (pukaz>0) then begin
    fl:=false;
    C:=TCanvas.Create;
    C.Handle:=TWMPAINT(Msg).DC;
    for i:=0 to maxkor do
      if kory[i]<>nil then kory[i].Zobraz(C);
    C.Free;
    fl:=true;
  end;
end;

procedure tobj.myClose(Sender: TObject; var Action: TCloseAction);
begin
  halt;
end;

procedure NastavPlochu(p:TImage);
var
  f:TForm;
begin
  if g<>nil then exit;
  if p.Owner is TForm then begin
    f:=TForm(p.Owner);
    f.OnClose:=obj.myClose;
    f.DoubleBuffered:=true;
  end;
  g:=p.Canvas; plocha:=p;
  sirka:=p.Width; vyska:=p.Height;
  obj:=tobj.Create;
  obj.FImageWindowProc:=p.WindowProc;
  p.WindowProc:=obj.ImageWndProc;
end;

procedure Inicializuj;
var
  i,n:integer;
  f:TForm;
begin
  if g<>nil then exit;
  f:=Application.MainForm;
  if f=nil then begin
    n:=Application.ComponentCount; i:=0;
    while (i<n) and not (Application.Components[i] is TForm) do inc(i);
    if i=n then begin
      ShowMessage('vadná aplikácia - nenašiel som formulár');
      Halt;
    end;
    f:=TForm(Application.Components[i]);
  end;
  n:=f.ControlCount; i:=0;
  while (i<n) and not (f.Controls[i] is TImage) do inc(i);
  if i>=n then begin
    ShowMessage('vadná aplikácia - nenašiel som grafickú plochu');
    halt;
  end;
  NastavPlochu(TImage(f.Controls[i]));
end;

end.