STM

Top  Previous  Next

{

StellaMAP közös függvénykönyvtár

--------------------------------

DELPHI VCL Unit

}

unit Stm;

 

interface

 

uses

SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,

Forms, StdCtrls, ExtCtrls, Inifiles, Dialogs, Printers, Szamok, Szoveg,

AlmType, {Geom,} DGrafik, StPrint;

 

Type el = (bal,jobb,also,felso); kinnkod = set of el;

 

procedure Rajzol(Canvas:TCanvas; cw:TMapConfig;T,B: TPoint; Rajzmod:TRajzmodType;

        AMode: TPenMode; ujrajz: Boolean);

procedure Pont_rajzolas(ms,rtgstream:TMemoryStream;lreteg:array of boolean;

            cw:TMapConfig;ca: TCanvas;t:Trect);

procedure Vonal_rajzolas(ms,rtgstream:TMemoryStream;lreteg:array of boolean;

            cw:TMapConfig;ca: TCanvas;t:Trect);

procedure Szoveg_rajzolas(ms,rtgstream:TMemoryStream;lreteg:array of boolean;

            cw:TMapConfig;ca: TCanvas;t:Trect);

 

procedure Alapratesz(var cw:TMapconfig);

procedure StreamMeretek(tm:TRajzelemStream;var cw:TMapConfig);

 

procedure precnull(var p: Tpontrecord);

procedure vrecnull(var p: TVonalrecord);

procedure szrecnull(var p: Tszovegrecord);

procedure jrecnull(var p: Tjelkulcsrecord);

procedure rrecnull(var p: Tretegrecord);

 

procedure RetegStreamAlap(var rs:TMemorystream);

 

Function  PontrekordKap(tm:TMemoryStream;ap: Longint):Tpontrecord;

Function  VonalrekordKap(tm:TMemoryStream;ap: Longint):TVonalrecord;

Function  SzovegrekordKap(tm:TMemoryStream;ap: Longint):Tszovegrecord;

Function  JelkulcsrekordKap(tm:TMemoryStream;ap: Longint):Tjelkulcsrecord;

Function  RetegrekordKap(rtgstream:TMemoryStream;arec: word): Tretegrecord;

Function  FontrekordKap(Fontstream:TMemoryStream;arec: word): TFontrecord;

Function  FontStylusKap(fkod:integer): TFontStyles;

 

Procedure PontRekordIr(tm:TMemoryStream; arec: longint; pr: Tpontrecord);

Procedure VonalRekordIr(tm:TMemoryStream; arec: longint; vr: TVonalrecord);

Procedure SzovegRekordIr(tm:TMemoryStream; arec: longint; szr: Tszovegrecord);

 

Function  Pontkeres(tm:TMemoryStream;  cw:TMapConfig; x,y:Longint;

        var pr: Tpontrecord; var ap: Longint): boolean;

function  Vonalkeres(tm:TMemoryStream; cw:TMapConfig;  x,y:Longint;

        var vrec:TVonalrecord; var ap: Longint): boolean;

Function  Feliratkeres(tm:TMemoryStream;  cw:TMapConfig; x,y:Longint;

        var szrec: Tszovegrecord; var ap: Longint): boolean;

Function  LegkozelebbiPont(tm:TMemoryStream;p:TPoint2D;var ap: Longint):Tpontrecord;

 

procedure Pontrajzol(ca:TCanvas; x,y,m: integer; pm: TColor);

 

function  KepToMap(t:TRect;cw:TMapConfig):TRect2D;

function  MapToScreen(ca: TCanvas;x,y: Extended; cw: TMapConfig):Tpoint;

function  ScreenToMap(mxy: TPoint; cw: TMapConfig):TPoint2D;

 

{StellaMAP Térkép állomány betöltése/mentése memóriastream-re/ről}

procedure SaveMapToFile(rs:TRajzelemStream;fn:string);

procedure LoadMapFromFile(rs:TRajzelemStream;fn:string);

 

function Point2D(X, Y: double): TPoint2D;

function Rect2D(X1, Y1, X2, Y2: double): TRect2D;

Function PontInKep(x,y:double;t:TRect2D):boolean;

function CorrectRealRect(t:TRect2D):TRect2D;

Function SzakaszNegyszogMetszes(var p1,p2:TPoint2D;t:TRect2D):boolean;

Function KeTPontTavolsaga(x1,y1,x2,y2: double): double;

Function SzakaszSzog(x1,y1,x2,y2: double): double;

Function IsAblakSzakaszMetszes(u,v,r:double; p: TRect2d):boolean;

function RelAngle2D(PA, PB: TPoint2D): double;

function Angle2D(P: TPoint2D): double;

Function KetPontonAtmenoEgyenes(x1,y1,x2,y2:double):Tegyenesfgv;

Function Kozben(a,b,x,tures: double): boolean;

 

var xbal,xjobb,yalso,yfelso: double;

 

implementation

 

 

procedure Rajzol(Canvas:TCanvas; cw:TMapConfig;T,B: TPoint; Rajzmod:TRajzmodType;

        AMode: TPenMode; ujrajz: Boolean);

begin

With Canvas do

begin

  With Pen do begin

     Color:=clBlack;

     Style:=psSolid;

     Mode :=AMode;

  end;

  Brush.Color:=clWhite;

  Brush.style:=bsClear;

  If (T.X<>B.x) OR (T.Y<>B.Y) then

  begin

      If ujrajz then

          case RajzMod of

          rmPont :      Pen.Color := cw.pontszin;

          rmVonal,rmPontVonallal:  Pen.Color := rrec.vonalszin;

          rmFelirat :   Pen.Color := rrec.szovegszin;

          rmvonaltorol: Pen.Color := cw.alapszin;

          rmTermanual,rmvonalkijelol,rmMetszes,rmVetites,rmIvmetszes,

             rmBemeres,rmKituzes:

             begin Pen.Color := clRed; Pen.Width:=2; end;

          end;

      case RajzMod of

      rmPont:  Rectangle(T.X-cw.pontmeret,T.Y-cw.pontmeret,T.X+cw.pontmeret,

               T.Y+cw.pontmeret);

      rmvonal,rmvonalkijelol,rmTavmeres,rmvonaltorol,rmSokszog,

      rmTermanual,rmMetszes,rmVetites,rmIvmetszes,rmBemeres,rmKituzes,

      rmElometszes,rmHatrametszes,rmPontAtrak:

          begin

              MoveTo(T.X, T.Y); LineTo(B.X, B.Y);

          end;

      rmPontVonallal:

          begin

              MoveTo(T.X, T.Y); LineTo(B.X, B.Y);

              Pen.Color := cw.pontszin;

              Rectangle(T.X-cw.pontmeret,T.Y-cw.pontmeret,T.X+cw.pontmeret,

               T.Y+cw.pontmeret);

              Rectangle(B.X-cw.pontmeret,B.Y-cw.pontmeret,B.X+cw.pontmeret,

               B.Y+cw.pontmeret);

          end;

      rmAblak      : Rectangle(T.X, T.Y, B.X, B.Y);

      rmkepterulet,rmablakkijelol : Rectangle(T.X, T.Y, B.X, B.Y);

      rmNegyszog   : Rectangle(T.X, T.Y, B.X, B.Y);

      rmEllipszis  : Ellipse(T.X, T.Y, B.X, B.Y);

      end;

  end;

end;

end;

 

procedure Pont_rajzolas(ms,rtgstream:TMemoryStream;lreteg:array of boolean;

            cw:TMapConfig;ca: TCanvas;t:Trect);

var i,x,y,x1,y1: integer;

  d,szog: real;

  ymax: integer;

  prec: Tpontrecord;

  rrec: Tretegrecord;

  kep: TRect2D;

label 1;

begin

cw.pontszam:=ms.Size div SizeOf(Tpontrecord);

If cw.pontszam>0 then begin

With ca do

  if cw.pontlatszik and (cw.pontszam>0) then

  begin

  kep:=Rect2D(cw.origox+t.left/cw.nagyitas, cw.origoy+t.top/cw.nagyitas,

          cw.origox+t.right/cw.nagyitas, cw.origoy+t.bottom/cw.nagyitas);

 

  ymax := Cliprect.bottom;

  SetPen(ca,clBlack,1,psSolid,pmCopy);

  IF not cw.TEXTkenyszer then begin

     If cw.printing then Font.Size:= Trunc(cw.pr.pBetumeret*cw.nagyitas)

     else Font.Size:= Trunc(cw.nagyitas);

     If Font.Size<2 then Font.Size:=2;

  end;

  Font.Color:=cw.pontszin;

  ms.Seek(0,0);

  For i:=1 to cw.pontszam do begin

    ms.Read(prec,SizeOf(prec));

    If (((prec.jelzo and 1)=0) or (cw.toroltek)) then begin

     If PontInKep(prec.x,prec.y,kep) then begin

        If cw.printing then begin

           x:=Trunc(cw.pr.paspx*cw.nagyitas*(prec.x-cw.origox));

           y:=ymax-Trunc(cw.pr.paspy*cw.nagyitas*(prec.y-cw.origoy));

        end else begin

           x:=Trunc(cw.nagyitas*(prec.x-cw.origox));

           y:=ymax-Trunc(cw.nagyitas*(prec.y-cw.origoy));

        end;

       If (cw.toroltek and ((prec.jelzo and 1)=1)) then

         SetPen(ca,clRed,4,psdot,pen.mode);

       If cw.kijelolesek and (GetBit(prec.jelzo,7)=1) then

         SetPen(ca,clBlue,2,psSolid,pmCopy);

       If prec.jelzo=0 then SetPen(ca,cw.pontszin,1,psSolid,pen.mode);

       if (cw.csakkijeloltek and (GetBit(prec.jelzo,7)=1)) or

          (cw.csaktoroltek and ((prec.jelzo and 1)=1)) or

          (not cw.csakkijeloltek) and (not cw.csaktoroltek) then

       begin

       Rectangle(x-cw.pontmeret,y-cw.pontmeret,x+cw.pontmeret,y+cw.pontmeret);

       If cw.pontszamlatszik then TextOut(x+2,y+2,IntToStr(prec.No));

       end;

    end; end;

  end;

  Pen.Mode := pmCopy;

  Pen.Style := psSolid;

  end;

Screen.Cursor:=crDefault;

end;

end;

 

procedure Vonal_rajzolas(ms,rtgstream:TMemoryStream;lreteg:array of boolean;

            cw:TMapConfig;ca: TCanvas;t:Trect);

var i,x,y,x1,y1: integer;

  fele: TPoint;

  d,szog: real;

  meret: Longint;

  ymax: integer;

  p1,p2: TPoint2d;

  tt: TRect;

  kep: TRect2D;      {Képernyőterület a MAP-en}

begin

Try

cw.vonalszam:=ms.Size div SizeOf(TVonalrecord);

With ca do

  if (cw.vonallatszik) and (cw.vonalszam>0) then

  begin

  kep:=KepToMap(t,cw);

  ymax := t.bottom-t.top;

  SetPen(ca,clBlack,1,psSolid,pmCopy);

  IF not cw.TEXTkenyszer then begin

     Font.Name := 'Arial';

     If cw.printing then Font.Size:= Trunc(cw.pr.pBetumeret*cw.nagyitas)

     else Font.Size:= Trunc(cw.nagyitas);

     If Font.Size<1 then Font.Size:=1;

     Font.Style:=[];

  end;

      Font.Color:=cw.pontszin;

  ms.Seek(0,0);

  For i:=1 to cw.vonalszam do begin

    ms.Read(vrec,SizeOf(vrec));

    If lreteg[vrec.reteg] and (((vrec.jelzo and 1)=0) or cw.toroltek

       or cw.kijelolesek) then begin

       p1:=Point2d(vrec.x1,vrec.y1);

       p2:=Point2d(vrec.x2,vrec.y2);

  If SzakaszNegyszogMetszes(p1,p2,kep) then

  begin

     If cw.printing then begin

        x := Trunc(cw.pr.paspx*cw.nagyitas*(vrec.x1-cw.origox));

        y := ymax-Trunc(cw.pr.paspy*cw.nagyitas*(vrec.y1-cw.origoy));

        x1:= Trunc(cw.pr.paspx*cw.nagyitas*(vrec.x2-cw.origox));

        y1:= ymax-Trunc(cw.pr.paspy*cw.nagyitas*(vrec.y2-cw.origoy));

     end else begin

        x := Trunc(cw.nagyitas*(p1.x-cw.origox));

        y := ymax-Trunc(cw.nagyitas*(p1.y-cw.origoy));

        x1:= Trunc(cw.nagyitas*(p2.x-cw.origox));

        y1:= ymax-Trunc(cw.nagyitas*(p2.y-cw.origoy));

     end;

 

     If vrec.jelzo=0 then begin

         rrec := RetegrekordKap(rtgstream,vrec.reteg);

{           If Fhomogenrajz then

         SetPen(ca,clBlack,rrec.vonalvastag,TPenStyle(rrec.vonalstylus)

           ,pen.mode) else}

         SetPen(ca,rrec.vonalszin,rrec.vonalvastag,TPenStyle(rrec.vonalstylus)

           ,pen.mode);

         If vrec.vastag>0 then Pen.width:=vrec.vastag;

         If vrec.tipus<>0 then Pen.style:=Tpenstyle(vrec.tipus);

         If cw.printing then Pen.width := Pen.width*cw.pr.vonalvastag;

     end;

     If (vrec.jelzo and 1)=0 then

     begin MoveTo(x,y); LineTo(x1,y1);

        If cw.tavlatszik then begin

           d := KeTPontTavolsaga(vrec.x1,vrec.y1,vrec.x2,vrec.y2);

           Case cw.tavmod of

           tmNormal: begin

              x := Trunc((x+x1)/2); y := Trunc((y+y1)/2);

              TextOut(x,y+Font.height,Format('%6.2f',[d]));

           end;

           tmSzogben: begin

              szog := Fok(Szakaszszog(x,y1,x1,y));

              If (szog>=90) and (szog<=270) then szog:= szog-180;

              x := Trunc((x+x1)/2); y := Trunc((y+y1)/2);

              x := x-Trunc(Font.height*COS(Radian(90+szog)));

              y := y+Trunc(Font.height*SIN(Radian(90+szog)));

              RotText(ca,x,y,Format('%6.2f',[d]),10*Trunc(szog));

           end;

           end;

        end;

     end;

     end;

    end;

  end;

  Pen.width := 1;

  Pen.Mode := pmCopy;

  Pen.Style := psSolid;

  end;

Except

  On Exception do ShowMessage('Vonal ábrázolási hiba!');

end;

end;

 

procedure Szoveg_rajzolas(ms,rtgstream:TMemoryStream;lreteg:array of boolean;

            cw:TMapConfig;ca: TCanvas;t:Trect);

var i,x,y,x1,y1: integer;

  t1: TRect;

  fele: TPoint;

  d,szog: real;

  meret: Longint;

  ymax: integer;

  Rgn: HRgn;

  szrec: Tszovegrecord;

  rrec: Tretegrecord;

  pe: TPen;

  torzitas: real;

  Fixtext : TFont;

label 1;

begin

With ca do

  if cw.szoveglatszik then

  begin

  pe:=Pen;

  torzitas:= Screen.PixelsPerInch/GetPrAspectX;

  t := ClipRect;

  Rgn := CreateRectRgn(t.left,t.top,t.right,t.bottom);

  ymax := t.bottom;

  IF not cw.TEXTkenyszer then begin

     If cw.printing then Font.Size:= Trunc(cw.pr.pBetumeret*cw.nagyitas)

     else Font.Size:= Trunc(cw.nagyitas);

     If Font.Size<2 then Font.Size:=2;

  end else begin

      FixText.Name:='Courier';

      FixText.Size:=8;

      Font.Assign(FixText);

  end;

  ms.Seek(0,0);

  meret := SizeOf(szrec);

  For i:=1 to cw.szovegszam do begin

    ms.Read(szrec,meret);

    If lreteg[szrec.reteg] and ((szrec.jelzo and 1)=0) then begin

     If cw.printing then begin

        x := Trunc(cw.pr.paspx*cw.nagyitas*(szrec.x-cw.origox));

        y := ymax-Trunc(cw.pr.paspx*cw.nagyitas*(szrec.y-cw.origoy));

     end else begin

        x := Trunc(cw.nagyitas*(szrec.x-cw.origox));

        y := ymax-Trunc(cw.nagyitas*(szrec.y-cw.origoy));

     end;

     If PtInRegion(Rgn,x,y) then begin

            If Font.Size>0 then begin

                  rrec := RetegrekordKap(rtgstream,szrec.reteg);

                  IF not cw.TEXTkenyszer then begin

                     Font.Name  := rrec.fontnev;

                     Font.size  := Trunc(cw.nagyitas * rrec.fontmeret/4);

                     Font.Style := FontStylusKap(rrec.fontstylus);

                  end;

                  Font.Color := rrec.szovegszin;

                  If cw.printing then

                     Font.size  := Trunc(cw.pr.pbetumeret * Font.size);

                  If printer.printing then

                    Font.size  := Trunc(Font.size * torzitas);

               x := x-Trunc(ca.Font.height*COS(Radian(90+szrec.szog/10)));

               y := y+Trunc(ca.Font.height*SIN(Radian(90+szrec.szog/10)));

               If Font.Size>1 then RotText(ca,x,y,szrec.szoveg,szrec.szog);

            end;

     end;

    end;

  end;

  Pen:=pe;

  {Pen.Mode := pmCopy;

  Pen.Style := psSolid;}

  end;

1:DeleteObject(Rgn);

Screen.Cursor:=crDefault;

end;

 

procedure Alapratesz(var cw:TMapconfig);

var i: longint;

begin

DecimalSeparator:='.';

With cw do begin

filenev  := '';

filetipus:= '';

RMod := rmNincs;

valtozott:= False;

pontmeret:= 2;

pontszam := 0;

vonalszam:= 0;

szovegszam:=0;

jelkulcsszam:=0;

nagyitas := 1;

minx     := 0;

maxx     := 0;

miny     := 0;

maxy     := 0;

{  nkeret   := Rect(0,0,Width div 4,Trunc(1.1*Height/4));}

If aspx<0 then aspx:=1;

If tentativtures<4 then tentativtures:=4;

pr.peldany:=1;

pr.paspx:=1; pr.paspy:=1;

pr.vonalvastag:=1;

pr.pbetumeret :=1;

end;

{

For i:=0 to 255 do lreteg[i]:=True;

For i:=1 to 4 do tm[i].Clear;

}

end;

 

{ StreamMeretek

Meghatározza a max pont,vonal,szöveg számot }

procedure StreamMeretek(tm:TRajzelemStream;var cw:TMapConfig);

begin

cw.pontszam    := tm[1].Size div SizeOf(prec);

cw.vonalszam   := tm[2].Size div SizeOf(vrec);

cw.szovegszam  := tm[3].Size div SizeOf(szrec);

cw.jelkulcsszam:= tm[4].Size div SizeOf(jrec);

end;

 

procedure precnull(var p: Tpontrecord);

begin

With P do begin

  No:=0; x:=0; y:=0; z:=0; pkod:=0; reteg:=0; info:=0; obj:=0; jelzo:=0;

end;

end;

 

procedure vrecnull(var p: TVonalrecord);

begin

With p do begin

reteg:=0; x1:=0; y1:=0; z1:=0; x2:=0; y2:=0; z2:=0;

vastag:=0; tipus:=0; obj1:=0; obj2:=0; jelzo:=0;

end;

end;

 

procedure szrecnull(var p: Tszovegrecord);

begin

With P do begin

  reteg:=0; x:=0; y:=0; kozsegkod:=0; szoveg:=space(20);

  font:=0; szeles:=1; stilus:=0; szog:=0; obj:=0; jelzo:=0;

end;

end;

 

procedure jrecnull(var p: Tjelkulcsrecord);

begin

With jrec do begin

kod:=0; reteg:=0; x:=0.0; y:=0.0; meret:= 0; szog:=0; obj:=0; jelzo:=0;

end;

end;

 

procedure rrecnull(var p: Tretegrecord);

begin

With P do begin

retegszam   :=0;

retegnev    :=space(20);

pontszin    :=clBlack;

vonalszin   :=clBlack;

vonalvastag :=1;

vonalstylus :=0;

szovegszin  :=clGreen;

fontnev     :='Arial';

fontmeret   :=10;

fontstylus  :=0;

vedett      :=False;

end;

end;

 

{ A réteg stream-et feltölti alapértékekkel 0..255 }

procedure RetegStreamAlap(var rs:TMemorystream);

var i:integer;

begin

If rs=nil then rs:=TMemoryStream.Create else rs.Clear;

For i:=0 to 254 do begin

    rrecnull(rrec); rs.Write(rrec,SizeOf(rrec));

end;

end;

 

Function PontrekordKap(tm:TMemoryStream;ap: Longint):Tpontrecord;

begin

tm.Seek(ap * SizeOf(result),0);

tm.Read(Result,SizeOf(Result));

end;

 

Function VonalRekordKap(tm:TMemoryStream;ap: Longint):TVonalrecord;

begin

tm.Seek(ap * SizeOf(result),0);

tm.Read(Result,SizeOf(Result));

end;

 

Function SzovegrekordKap(tm:TMemoryStream;ap: Longint):Tszovegrecord;

begin

tm.Seek(ap * SizeOf(result),0);

tm.Read(Result,SizeOf(Result));

end;

 

Function JelkulcsrekordKap(tm:TMemoryStream;ap: Longint):Tjelkulcsrecord;

begin

tm.Seek(ap * SizeOf(result),0);

tm.Read(Result,SizeOf(Result));

end;

 

Function RetegrekordKap(rtgstream:TMemoryStream;arec: word): Tretegrecord;

begin

Try

If rtgstream.Size>0 then

with rtgstream do begin

  Seek(arec * SizeOf(rrec),0);

  Read(result,SizeOf(rrec));

end;

except

  RRecNull(Result);

end;

end;

 

Function FontrekordKap(Fontstream:TMemoryStream;arec: word): TFontrecord;

begin

with Fontstream do begin

  Seek(arec * SizeOf(frec),0);

  Read(result,SizeOf(frec));

end;

end;

 

{Fontstílus kinyerés: f = index, fs = jelenlegi stílus }

Function FontStylusKap(fkod:integer): TFontStyles;

begin

Case fkod of

0: Result:=[];

1: Result:=[fsBold];

2: Result:=[fsItalic];

3: Result:=[fsUnderline];

4: Result:=[fsStrikeout];

5: Result:=[fsBold,fsItalic];

6: Result:=[fsBold,fsItalic,fsUnderline];

7: Result:=[fsBold,fsItalic,fsStrikeout];

end;

end;

 

Procedure PontRekordIr(tm:TMemoryStream; arec:longint; pr: Tpontrecord);

begin

  tm.Seek(arec * SizeOf(pr),0); tm.Write(pr,SizeOf(pr));

end;

 

Procedure VonalRekordIr(tm:TMemoryStream; arec:longint; vr: TVonalrecord);

begin

  tm.Seek(arec * SizeOf(vr),0);  tm.Write(vr,SizeOf(vr));

end;

 

Procedure SzovegRekordIr(tm:TMemoryStream; arec:longint; szr: Tszovegrecord);

begin

  tm.Seek(arec * SizeOf(szr),0); tm.Write(szr,SizeOf(szr));

end;

 

{Pontkeresés: tm=pontok streamje, x,y=képkoordináták, pr=pontrekord,

            ap=a talált rekord streambeli sorszáma}

Function  Pontkeres(tm:TMemoryStream;  cw:TMapConfig; x,y:Longint;

        var pr: Tpontrecord; var ap: Longint): boolean;

var x1,y1,x2,y2,xx_,yy_: real;

  i: integer;

  tures: real;

begin

Result:=False;

xx_ := cw.origox + x / cw.nagyitas;

yy_ := cw.origoy + y / cw.nagyitas;

tures := cw.tentativtures / cw.nagyitas;

tm.Seek(0,0);

For i:=0 to (tm.Size div SizeOf(pr))-1 do begin

   tm.Read(pr,SizeOf(pr));

   x1 := pr.x - tures;

   x2 := pr.x + tures;

   y1 := pr.y - tures;

   y2 := pr.y + tures;

   If (xx_ > x1) And (xx_ < x2) Then

      If (yy_ > y1) And (yy_ < y2) Then

         If (GetBit(pr.jelzo,0)=0) or cw.toroltek then

         begin

          ap := i;

          Result := True;

          Exit;

         End;

end;

end;

 

function  Vonalkeres(tm:TMemoryStream; cw:TMapConfig;  x,y:Longint;

        var vrec:TVonalrecord; var ap: Longint): boolean;

var tures     : real;

  i         : longint;

  p         : TPoint2d;

  vr        : Tvonalrecord;

begin

Result:=False;

p.x := cw.origox + x / cw.nagyitas;

p.y := cw.origoy + y / cw.nagyitas;

tures := cw.tentativtures / cw.nagyitas;

tm.Seek(0,0);

ap := -1;

For i:=0 to (tm.Size div SizeOf(vr))-1 do begin

   tm.Read(vr,SizeOf(vr));

   If (((vr.jelzo and 1)=0) or cw.toroltek) then

   If IsAblakSzakaszMetszes(p.x,p.y,tures,Rect2d(vr.x1,vr.y1,vr.x2,vr.y2)) then

     begin

             ap := i;

             vrec := vr;

             Result := True;

             Exit;

     end;

end;

end;

 

Function  Feliratkeres(tm:TMemoryStream;  cw:TMapConfig; x,y:Longint;

        var szrec: Tszovegrecord; var ap: Longint): boolean;

var x1,y1,x2,y2,xx,yy: real;

  szr: Tszovegrecord;

  i,meret: longint;

  tures: real;

begin

Result:=False;

xx := cw.origox + x / cw.nagyitas;

yy := cw.origoy + y / cw.nagyitas;

tures := cw.tentativtures / cw.nagyitas;

tm.Seek(0,0);

meret := SizeOf(szr);

For i:=0 to (tm.Size div SizeOf(szr))-1 do begin

   tm.Read(szr,meret);

   x1 := szr.x - tures;

   x2 := szr.x + tures;

   y1 := szr.y - tures;

   y2 := szr.y + tures;

   If (xx > x1) And (xx < x2) Then

      If (yy > y1) And (yy < y2) Then

         If (GetBit(szr.jelzo,0)=0) or cw.toroltek then  begin

          ap := i;

          szrec:=szr;

          Result := True;

          Exit;

         End;

end;

end;

 

{ Egy adott p ponthoz legközelebbi térképpont megkeresése }

Function  LegkozelebbiPont(tm:TMemoryStream;p:TPoint2D;var ap: Longint):Tpontrecord;

var d,dd: real;

  i,meret : longint;

begin

meret:=tm.Size div SizeOf(prec);

if meret<1 then begin PrecNull(Result); p.x:=0;p.y:=0; exit; end;

tm.Seek(ap*sizeof(prec),0);

d := 10E+20;

For i:=0 to meret-1 do begin

    tm.Read(prec,SizeOf(prec));

    If (Getbit(prec.jelzo,0)<>1) then begin

    dd := KeTPontTavolsaga(p.x,p.y,prec.x,prec.y);

    If dd<d then begin

       d:=dd; Result:=prec;

       ap:=i;

    end;

    end;

end;

If d>1000000 then ap:=0;

end;

 

procedure Pontrajzol(ca:TCanvas; x,y,m: integer; pm: TColor);

Var pe:TPen;

begin

 pe:=ca.Pen;

 With ca.Pen do begin Mode := pmCopy; Color:= pm; Style := psSolid; end;

 ca.Rectangle(x-m,y-m,x+m,y+m);

 ca.Pen:=pe;

end;

 

{A képernyő területét adja a térképen}

function  KepToMap(t:TRect;cw:TMapConfig):TRect2D;

begin

  Result:=Rect2D(cw.origox+t.left/cw.nagyitas, cw.origoy+t.top/cw.nagyitas,

          cw.origox+t.right/cw.nagyitas, cw.origoy+t.bottom/cw.nagyitas);

end;

 

{ Térkép koord-ákat átszámolja képernyő koord-ákká}

function MapToScreen(ca: TCanvas;x,y: Extended; cw: TMapConfig):Tpoint;

var t: TRect;

begin

  t := ca.ClipRect;

  Result.x:=Trunc(cw.nagyitas*(x-cw.origox));

  Result.y:=t.bottom-Trunc(cw.nagyitas*(y-cw.origoy));

end;

 

{ Képernyő koord-ákat átszámolja térkép koord-ákká}

function ScreenToMap(mxy: TPoint; cw: TMapConfig):TPoint2D;

begin

 Result.x := cw.origox + mxy.x / cw.nagyitas;

 Result.y := cw.origoy + mxy.y / cw.nagyitas;

end;

 

{StellaMAP Térkép állomány betöltése/mentése memóriastream-re/ről}

procedure SaveMapToFile(rs:TRajzelemStream;fn:string);

var fnev,fpath: string;

begin

fpath:=F_Path(fn);

fnev :=fpath+'\'+F_Name(fn);

rs[1].SaveToFile(fnev+'.trk');

rs[2].SaveToFile(fnev+'.lin');

rs[3].SaveToFile(fnev+'.szv');

rs[4].SaveToFile(fnev+'.jlk');

end;

 

procedure LoadMapFromFile(rs:TRajzelemStream;fn:string);

var fnev,fpath: string;

begin

fpath:=F_Path(fn);

fnev :=fpath+'\'+F_Name(fn);

If FileExists(fnev+'.trk') then rs[1].LoadFromFile(fnev+'.trk');

If FileExists(fnev+'.lin') then rs[2].LoadFromFile(fnev+'.lin');

If FileExists(fnev+'.szv') then rs[3].LoadFromFile(fnev+'.szv');

If FileExists(fnev+'.jlk') then rs[4].LoadFromFile(fnev+'.jlk');

end;

 

function Point2D(X, Y: double): TPoint2D;

begin

Point2D.X := X;

Point2D.Y := Y;

end;

 

function Rect2D(X1, Y1, X2, Y2: double): TRect2D;

begin

Rect2D.X1 := X1; Rect2D.X2 := X2;

Rect2D.Y1 := Y1; Rect2D.Y2 := Y2;

end;

 

{Egy térképi pont rajta van-e a képterületen?}

Function PontInKep(x,y:double;t:TRect2D):boolean;

var tt: TRect2D;

begin

Result:=False;

tt:=CorrectRealRect(t);

If (x>=tt.x1) and (x<=tt.x2) and (y>=tt.y1) and (y<=tt.y2) then

   Result:=True;

end;

 

  {Normal rectangle vizsgálata és átalakítás: ball felső-jobb alsó sarokká.

  pl Rect(-1,4,5,-3) => Rect(-1,-3,5,4)}

  function CorrectRealRect(t:TRect2D):TRect2D;

  var k: double;

  begin

    result:=t;

    With Result do begin

      If x1>x2 then begin k:=x1; x1:=x2; x2:=k; end;

      If y1>y2 then begin k:=y1; y1:=y2; y2:=k; end;

    end;

  end;

 

{   Egyenes vágó algoritmus:

  Meghatározza egy szakasznak a képernyőre eső részét

  xi,yi : a szakasz végpontjai,

  t     : a metszendő téglalap alakú terület

}

Function Clip(var x1,y1,x2,y2:double;t:TRect2D):boolean;

label return;

var  c,c1,c2: kinnkod; x,y: double;

 

procedure Kod(x,y:double; var c :kinnkod);

begin

c:=[ ];

If x<xbal then c:=[bal] else if x>xjobb then c:=[jobb];

If y<yalso then c:=c+[also] else if y>yfelso then c:=c+[felso];

end;

 

begin

Result:=False;

xbal:=t.x1; xjobb:=t.x2;

yalso:=t.y1; yfelso:=t.y2;

  Kod(x1,y1,c1); Kod(x2,y2,c2);

while (c1<>[ ]) or (c2<>[ ]) do begin

   If (c1*c2)<>[ ] then goto return;

   c:=c1; if c=[ ] then c:=c2;

   If bal in c then begin {metszés a bal élen}

      y:=y1+(y2-y1)*(xbal-x1)/(x2-x1);

      x:=xbal end else

   If jobb in c then begin {metszés a jobb élen}

      y:=y1+(y2-y1)*(xjobb-x1)/(x2-x1);

      x:=xjobb end else

   If also in c then begin {metszés az alsó élen}

      x:=x1+(x2-x1)*(yalso-y1)/(y2-y1);

      y:=yalso end else

   If felso in c then begin {metszés a felső élen}

      x:=x1+(x2-x1)*(yfelso-y1)/(y2-y1);

      y:=yfelso end;

   if c=c1 then begin

      x1:=x;y1:=y;Kod(x,y,c1)

   end else begin

      x2:=x;y2:=y;Kod(x,y,c2)

   end;

end;

Result:=True;

return: end;

 

{   Szakasz vágó rutin:

  Megvizsgálja, hogy a szakasz metszi-e a t téglalap alakú területet.

  Ha igen -> meghatározza a bele eső szakasz végpontjait: p1,p2

  és True értékkel tér vissza

}

Function SzakaszNegyszogMetszes(var p1,p2:TPoint2D;t:TRect2D):boolean;

label return;

var k1,k2: kinnkod;

begin

Result:=False;

k1:=[]; k2:=[];

{Vizsgálat a t 4 élére, hogy kivül esik-e a szakasz}

If (p1.x<t.x1) and (p2.x<t.x1) then goto return;

If (p1.x>t.x2) and (p2.x>t.x2) then goto return;

If (p1.y<t.y1) and (p2.y<t.y1) then goto return;

If (p1.y>t.y2) and (p2.y>t.y2) then goto return;

{A szakasz teljesen a képernyőn van}

{egyébként vágni kell}

Result := Clip(p1.x,p1.y,p2.x,p2.y,t);

return:

end;

 

Function KeTPontTavolsaga(x1,y1,x2,y2: double): double;

begin

Result := Sqrt((x2-x1)*(x2-x1) + (y2-y1)*(y2-y1))

end;

 

{ x1,y1 a kezdőpontból kiindulva megadja a szakasz irányszögét rad-ban}

Function SzakaszSzog(x1,y1,x2,y2: double): double;

var szog,dx,dy,d,sinalfa : double;

  p1,p2: TPoint2D;

begin

Result:=Relangle2d(Point2d(x1,y1),Point2d(x2,y2));

end;

 

{Viysgálja hogy az u,v középpontú r sugarú négyzeten a p szakasz áthalad-e}

Function IsAblakSzakaszMetszes(u,v,r:double; p: TRect2d):boolean;

var ve : TEgyenesfgv;

  x12: TPoint2d;

  x1,y1,x2,y2: double;

label return;

begin

Result := False;

If (p.x1<u-r) and (p.x2<u-r) then goto return;

If (p.x1>u+r) and (p.x2>u+r) then goto return;

If (p.y1<v-r) and (p.y2<v-r) then goto return;

If (p.y1>v+r) and (p.y2>v+r) then goto return;

ve := KeTPontonAtmenoEgyenes(p.x1,p.y1,p.x2,p.y2);

If Abs(ve.a)>10e+3 then begin

   Result:=Kozben(u-r,u+r,ve.b,0); goto return;

end;

If Abs(ve.a)<0.01 then

   Result:=Kozben(v-r,v+r,ve.b,0)

else begin

   Result:=Kozben(u-r,u+r,((v-r)-ve.b)/ve.a,0);

   If Result then goto return;

   Result:=Kozben(u-r,u+r,((v+r)-ve.b)/ve.a,0);

   If Result then goto return;

   Result:=Kozben(v-r,v+r,ve.a*(u-r)+ve.b,0);

   If Result then goto return;

   Result:=Kozben(v-r,v+r,ve.a*(u+r)+ve.b,0);

end;

return:end;

 

function RelAngle2D(PA, PB: TPoint2D): double;

begin

RelAngle2D := Angle2D(Point2D(PB.X - PA.X, PB.Y - PA.Y));

end;

 

function Angle2D(P: TPoint2D): double;

begin

if P.X = 0 then

begin

  if P.Y > 0 then Result := Pi / 2;

  if P.Y = 0 then Result := 0;

  if P.Y < 0 then Result := Pi / -2;

end

else

  Result := Arctan(P.Y / P.X);

 

if P.X < 0 then

begin

  if P.Y < 0 then Result := Result + Pi;

  if P.Y >= 0 then Result := Result - Pi;

end;

 

If Result < 0 then Result := Result + 2 * Pi;

end;

 

{Ha a = 10e+30!, akkor az egyenes || az y tengellyek és b=x1 pl.(x=5),

ha a=0, akkor viszont || az x tengellyel pl. (y=3)}

Function KetPontonAtmenoEgyenes(x1,y1,x2,y2:double):Tegyenesfgv;

begin

If x1<>x2 then begin

 Result.a := (y2 - y1)/(x2 - x1);

 Result.b := y1 - (Result.a * x1);

end else

If x1=x2 then begin Result.a:=10e+30; Result.b:=x1;

end else

If y1=y2 then begin Result.a:=0; Result.b:=y1; end;

end;

 

Function Kozben(a,b,x,tures: double): boolean;

var k: double;

begin

If a>b then begin

   k:=a; a:=b; b:=k;

end;

Result := (a-tures<=x) and (x<=b+tures);

end;

 

end.