STMAP161

Top  Previous  Next

 

unit StMap161;

 

interface

 

Uses SysUtils, WinTypes, WinProcs, Classes, Graphics, Forms, Controls, AlmType,

    Szamok, Szoveg, Astro, Messages, Dialogs, Printers, StPrint, Gauges;

 

 

function RajzFilter(ca:TCanvas;cw:TMapConfig;rajzelem:integer;reteg,jelzo:byte):boolean;

procedure Pont_rajzolas(ca: TCanvas;t:Trect;ms:TStream; cw:TMapConfig);

procedure Vonal_rajzolas(ca:TCanvas;t:Trect;ms,rtgstream:TStream;

                           lreteg:array of boolean; cw:TMapConfig);

procedure Szoveg_rajzolas(ca: TCanvas;t:Trect;ms,rtgstream,fontstream:TStream;

                           lreteg:array of boolean; cw:TMapConfig);

procedure Jelkulcs_rajzolas(ca:TCanvas;t:Trect;ms,Jelkulcsstream:TStream;

                           lreteg:array of boolean; cw:TMapConfig);

procedure Jelkulcsrajz(ca: TCanvas;Jelkulcsstream:TStream;

                      jr:TJelkulcsRecord;x,y:integer;szog:real;cw: TMapConfig);

procedure Vonal_Homogen(ca:TCanvas;Color:TColor;t:Trect;ms,rtgstream:TStream;

                            lreteg:array of boolean; cw:TMapConfig);

{procedure UjrarajzolPRINT(stm: TStMapW);}

procedure AktretegMent(tm:TRajzelemStream; filename:string; aktreteg:byte);

 

   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 RetegstreamNull(var rtgstream:TMemoryStream);

 

Procedure RecNull(Var rec);

Procedure WriteRec(m: TStream; arec: longint; var rec; Count: Longint);

Procedure ReadRec(m: TStream; arec: longint; var rec; Count: Longint );

 

function Ujpont(var tm:TMemoryStream;var cw:TMapConfig;p: Tpontrecord):boolean;

function Ujvonal(var tm,rtgstream:TMemoryStream;var cw:TMapConfig;p: Tvonalrecord):boolean;

function Ujfelirat(var tm,rtgstream:TMemoryStream;var cw:TMapConfig;p: Tszovegrecord):boolean;

function Ujjelkulcs(var tm,rtgstream:TMemoryStream;var cw:TMapConfig;p: Tjelkulcsrecord):boolean;

function IsAzonosVonal(vr1,vr2:Tvonalrecord):boolean;

 

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

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

procedure cls(i: TCanvas; co: TColor);

procedure clsRect(i: TCanvas; t:TRect; co: TColor);

procedure ClsKivul(ca:TCanvas;x,y: integer;co:TColor);

procedure SetPen(ca:TCanvas;color:TColor;width:integer;style:TPenStyle;mode:TPenMode);

procedure Kereszt(Canv: TCanvas; r:TRect; co: TColor);

procedure ShowLine(ca:TCanvas;x1,y1,x2,y2:integer);

procedure RotText(ca:TCanvas; x,y:integer; szoveg:string; szog:integer);

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

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

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

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

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

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

function Szogdiff(alapszog,szog:double):double;

Function HaromszogEgyenlotlenseg(d1,d2,d3:double):boolean;

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

function Angle2D(P: TPoint2D): double;

Function Elforgatas(p,porigo:TPoint2d;szog:double):TPoint2d;

function Point3D(X, Y, Z: double): TPoint3D;

function Dist2P(P, P1, P2: TPoint2D): double;

function Dist2D(P: TPoint2D): double;

function Dist3D(P: TPoint3D): double;

function DistLine(A, B, C: double; P: TPoint2D): double;

function DistD1P(DX, DY: double; P1, P: TPoint2D): double;

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

function RelDist3D(PA, PB: TPoint3D): double;

procedure Rotate2D(var P: TPoint2D; Angle2D: double);

procedure RelRotate2D(var P: TPoint2D; PCentr: TPoint2D; Angle2D: double);

function NearLine2P(P, P1, P2: TPoint2D; D: double): Boolean;

function AddPoints(P1, P2: TPoint2D): TPoint2D;

function SubPoints(P1, P2: TPoint2D): TPoint2D;

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

Function Bennevan( t: TRect; p: TPoint):boolean;

Function FelezoPont(p1,p2:TPoint2d):TPoint2d;

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

Function EgypontonAtmenoMeroleges(e1:Tegyenesfgv;p1:TPoint2D):Tegyenesfgv;

function PontEgyenesTavolsaga(e1:Tegyenesfgv;p:TPoint2d):double;

Function KetEgyenesMetszespontja(ef1,ef2:Tegyenesfgv):TPoint2d;

Function HaromPontbolTeglalap(p1,p2,pk:TPoint2D):TTeglalap;

{ Egy ponton átmenő adott iránytangensű egyenes egyenletét

adja: p1 = pont, a = iránztangens }

Function HaromPontbolKor(p1,p2,p3:TPoint2D):TPoint3D;

procedure KorivRajzol(Ca:TCanvas;pp1,pp2,pp3:TPoint2D);

Function Egyenes1(p1:TPoint2d;a:double):Tegyenesfgv;

{ Két ponton p1,p2 átmenő egyenes iránytangensét adja}

Function Egyenes2(p1,p2:TPoint2d):double;

 

function MaxPontszamKeres(tm:TStream):longint;

Function Pontszamkeres(tm:TStream;var prec: TPontrecord;var ap: Longint): boolean;

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

function JelkulcsNevKeres(jks:TFileStream;var jk:TJelkulcsHeader;nev:string):boolean;

Function FontSorszamKap(fontlist:TStringlist;fontnev:string): integer;

Function FontStylusKap(fkod:integer): TFontStyles;

Function FontStylusBeallit(fStyle:TFontStyles): integer;

function VrecToPrec(vr:TVonalrecord):TPontrecord;

procedure VrecFromPrec(pr1,pr2:TPontrecord;var vr:TVonalrecord);

procedure PrinterParamNull(var pr:TPrinterParam);

Function RajzmodToString(rmod:TRajzmodType):string;

Function StringToRajzmod(rmodstring:string):TRajzmodType;

{Minden rétegben keres egy x,y végű vonalat}

Function VonalVegpontkeres(tm:TStream;x,y:double; var vrec: TVonalrecord;

                          var recno:longint):boolean;

{Vonal egyik végpontját az uj pontba rakja át}

procedure VonalVegpontAtrak(var vrec:TVonalrecord;oldp,newp:TPontrecord);

procedure PontBeillesztVonalra(var tm:TStream;vr:TVonalrecord;pp1:TPoint2d);

 

Function VanMarPont(tm:TStream;var p:TPontrecord):longint;

Function RetegbenFedoVonal(tm:TStream;v:TVonalrecord):longint;

function EgyenesekMetszese(v1,v2:TVonalrecord):TPontrecord;

Function Egyenes12(e1,e2:Tegyenes):TPoint2d;

Function OsztoPont(p1,p2:TPoint2d;arany:double):TPoint2d;

 

{ GEODEZIA }

function FokToGeoszog(fok:double):double;

procedure Geodezia1(p1,p2:TPoint2d; var fi,d:double);

function Geodezia2(p1:TPoint2d; fi,d:double):TPoint2d;

function Polaris(p1,p2:TPoint2d; fi,d:double):TPoint2d;

function Ortogonalismeres(p1,p2:TPoint2d; a,b:double):TPoint2d;

function PontToEgyenes(x1,y1,x2,y2:double; p:TPoint2d):double;

Function Ivmetszes(u1,v1,r1,u2,v2,r2: double;var p:TPoint2D):boolean;

Function Bemeres(u1,v1,r1,u2,v2,r2: double;var p:TPoint2D):boolean;

Function Elometszes(a,b:TPoint2D;alfa,beta:real):TPoint2D;

 

Function Filemegnyitas(var tm: TRajzelemStream;var rtgstream:TMemoryStream;

                          fnev: string;append: boolean; csik: TGauge):boolean;

procedure Filementes(tm: TRajzelemStream;fnev: string;csik:TGauge);

Function DXFTRKconverter(var tm: TRajzelemStream;var rtgstream:TMemoryStream;

         dxffn,trkfn:string;mentes:boolean;csik:TGauge):boolean;

procedure DXFkiiras(var tm: TRajzelemStream; var rtgstream:TMemoryStream;

         cw:TMapConfig; dxffn:string; csik:TGauge);

procedure PLTkiiras(var tm: TRajzelemStream; var rtgstream:TMemoryStream;

         cw:TMapConfig; pltfn:string; csik:TGauge);

procedure ViewMegnyit(fnev:string;var lreteg:array of boolean);

Function ConfigSave(fnev:string;cw:TMapConfig):boolean;

Function ConfigLoad(fnev:string;var cw:TMapConfig):boolean;

 

Procedure MAPForgat(var tm:TRajzelemStream;cent:TPoint2D;szog:real); export;

procedure SetJelzok(tm:TRajzelemStream;bit:integer;ertek:integer);

procedure SetCopyJelzok(tm:TRajzelemStream;bit1,bit2:integer);

procedure Jeloltek(tm:TRajzelemStream;jm:Tjelolesmod;aktReteg:byte);

procedure Jelzobeallit(jm:Tjelolesmod;var jelzo:byte);

function IsVedett(tm:TStream;reteg,jelzo:byte;uzenet:boolean):boolean;

procedure MindenRetegVedett(var tm:TMemoryStream;vedett:boolean);

procedure RegioFestes(PoliStream:TStream;ca:TCanvas;cw:TMapConfig);

Function IzolaltPont(tm:TRajzelemStream;p: Tpontrecord):integer;

 

procedure TransFormTo(var tm:TRajzelemStream;

                         Move,Rot,Flex:boolean;  {Eltolás,forgatás,nyujtás?}

                         POrigo:TPoint2d;        {elforgatás centruma}

                         dx,dy,                  {eltolási vektorok}

                         dfi,                    {elforgatás szöge}

                         nyujtas:real;           {nyujtási tényező}

                         jbit:integer);          {ez a jelző bit aktív}

function RelNyujtas(p,POrigo:TPoint2D;nyujtasx,nyujtasy:real):TPoint2D;

Function RetegSzamKap(rtgStream:TMemoryStream;rnev: string): word;

 

Function StandardColor(i:integer): TColor;

Function GetStandardColorIndex(co:TColor):integer;

 

var xbal,xjobb,yalso,yfelso: double;

 

Const

RajzmodFelirat : Array[0..62] of string[18] =('Nincs','Pont','Vonal','Felirat',

        'Jelkulcs','Kitöltő','Négyszög','Nagyító','Kicsinyítő','Ablak','Centrum',

        'Ellipszis','Köriv','Poligon','Obj','Objectum','Szakasz','Nagyít',

        'Kereknégyszög','Info','Ponttorol','Vonaltorol','Szovegtorol','Jelkulcstorol',

        'Reaktiv','Pontkijelölés','Vonalkijelölés','Feliratkijelölés',

        'Jelkulcskijelölés','Ablakkijelölés','Poligonkijelölés','Képterület',

        'Területmérés','Ter.manuálisan','Távmérés','HRSZkeresés',

        'Forgatás','Vetítés','Metszés','Ívmetszés','Merőleges','Bemérés',

        'Kitűzés','Tájékozás','Előmetszés','Hátrametszés','Oldalmetszés',

        'Polárispont','Beillesztett','Tájékozott1','Tájékozott2','Sokszögvonal',

        'HRSZ','TérképSQL','PontVonallal','Pontátrakás','Help','Betranszformálás',

        'Vonalátemelés','Pontbeillesztés','Téglalap','Vonalfelosztás',

        'Nagyítóablak');

 

implementation

 

Uses stmap16w;

 

{ RajzFilter(ca,cw,rajzelem,jelzo):boolean;

Ha ábrázolható => True;

ca      = Canvas;

cw      = TMapConfig paraméterek rekordja;

rajzelem= 1..4 (P,V,F,J)

jelzo   = a rajzelem rekord jelző byte-ja

}

function RajzFilter(ca:TCanvas;cw:TMapConfig;rajzelem:integer;reteg,jelzo:byte):boolean;

label 111;

begin

Result := not cw.csakkijeloltek and not cw.Csaktoroltek;

     If GetBit(jelzo,0)=1 then begin

        Result := cw.Csaktoroltek or cw.toroltek;

        If Result then begin

           If Rajzelem=3 then ca.Font.Color:=clSilver

           else SetPen(ca,clSilver,4,psSolid,pmCopy);

        end;

        If cw.Csaktoroltek then goto 111;

     end;

     If GetBit(jelzo,1)=1 then begin

        If Rajzelem=3 then ca.Font.Color:=clRed

        else SetPen(ca,clRed,3,psSolid,pmCopy);

        Result := True;

     end;

     If GetBit(jelzo,7)=1 then begin

        If cw.csakkijeloltek or cw.kijelolesek then begin

           If Rajzelem=3 then ca.Font.Color:=clBlue

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

        end;

        Result := Result or (cw.csakkijeloltek or cw.kijelolesek);

        If cw.csakkijeloltek then goto 111;

     end;

111:  If Result and cw.homogenrajz then

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

end;

 

 

procedure Pont_rajzolas(ca: TCanvas;t:Trect;ms:TStream; cw:TMapConfig);

var i,x,y: longint;

   prec: Tpontrecord;

   rrec: Tretegrecord;

   kep: TRect2D;

   ymax: integer;

   y0 : real;

{    bi : TBitmap;}

begin

Try

{  bi:=TBitmap.Create;

bi.width := ca.Cliprect.Right - ca.Cliprect.left;

bi.height := ca.Cliprect.bottom - ca.Cliprect.top;

bi.Canvas.CopyRect(ca.Cliprect,Ca,ca.Cliprect);}

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

With ca do

   begin

   ymax := t.bottom;

   If (t.bottom-t.top)<ca.cliprect.bottom then

   if t.top=0 then

      t:=Rect(t.left,ca.cliprect.bottom-t.bottom,t.right,ca.cliprect.bottom)

   else

      t:=Rect(t.left,0,t.right,ca.cliprect.bottom-t.top+16);

   kep:=KepToMap(t,cw);

   y0 := kep.y1;

   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;

      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 (i mod 2000)=0 then ca.Draw(0,0,bi);}

{           If (i mod 500)=0 then begin

             Application.ProcessMessages;

             If kiugras then exit;

          end;}

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

      If RajzFilter(ca,cw,1,prec.reteg,prec.jelzo) 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-y0));

         end else begin

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

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

         end;

         If cw.homogenrajz then SetPen(ca,clSilver,1,psSolid,pmCopy)

         else begin

              SetPen(ca,cw.pontszin,1,psSolid,pen.mode);

              If cw.printing and not cw.pr.szines then Pen.Color:=clBlack;

         end;

         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;

{    ca.Draw(0,0,bi);

   bi.Free;}

except

On Exception do exit;

end;

end;

 

procedure Vonal_rajzolas(ca:TCanvas;t:Trect;ms,rtgstream:TStream;

                           lreteg:array of boolean; cw:TMapConfig);

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

   vrec : TVonalrecord;

   rrec: TRetegrecord;

   d,szog: real;

   ymax: integer;

   p1,p2: TPoint2d;

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

   oldRec : TVonalrecord;

   y0 : real;

{    bi : TBitmap;}

begin

Try

{  bi:=TBitmap.Create;

bi.width := ca.Cliprect.Right - ca.Cliprect.left;

bi.height := ca.Cliprect.bottom - ca.Cliprect.top;

bi.Canvas.CopyRect(ca.Cliprect,Ca,ca.Cliprect);}

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

With ca do

   begin

   ymax := t.bottom;

   If (t.bottom-t.top)<ca.cliprect.bottom then

   if t.top=0 then

      t:=Rect(t.left,ca.cliprect.bottom-t.bottom,t.right,ca.cliprect.bottom)

   else

      t:=Rect(t.left,0,t.right,ca.cliprect.bottom-t.top+16);

   kep:=KepToMap(t,cw);

   y0 := kep.y1;

   If ca.Cliprect.top<>t.top then

   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);

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

   For i:=1 to cw.vonalszam do begin

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

{      If (i mod 1000)=0 then ca.Draw(0,0,bi);}

{      If (i mod 500)=0 then begin

        Application.ProcessMessages;

        If kiugras then exit;

     end;}

     If lreteg[vrec.reteg] then begin

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

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

   If SzakaszNegyszogMetszes(p1,p2,kep) then

   begin

   If RajzFilter(ca,cw,2,vrec.reteg,vrec.jelzo) 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-y0));

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

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

      end else begin

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

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

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

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

      end;

 

       if (oldrec.reteg<>vrec.reteg) or (oldrec.jelzo<>vrec.jelzo) then

       begin

       ReadRec(rtgstream,vrec.reteg,rrec,SizeOf(rrec));

       If rrec.vonalvastag=0 then rrec.vonalvastag:=1;

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

            ,pen.mode);

       end;

       oldrec:=vrec;

 

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

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

          If cw.printing then begin

             If vrec.vastag=0 then vrec.vastag:=1;

             Pen.Width := vrec.vastag*rrec.vonalvastag*cw.pr.vonalvastag;

{              Pen.width := Pen.width*cw.pr.vonalvastag;}

             If not cw.pr.szines then Pen.Color:=clBlack;

          end;

      If RajzFilter(ca,cw,2,vrec.reteg,vrec.jelzo) then begin

         ca.MoveTo(x,y); ca.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;

   end;

   end;

{    ca.Draw(0,0,bi);

   bi.Free;}

Except

   On Exception do exit;

end;

end;

 

procedure Vonal_Homogen(ca:TCanvas;Color:TColor;t:Trect;ms,rtgstream:TStream;

                           lreteg:array of boolean; cw:TMapConfig);

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

   vrec : TVonalrecord;

   rrec: TRetegrecord;

   d,szog: real;

   ymax: integer;

   p1,p2: TPoint2d;

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

   oldRec : TVonalrecord;

   y0 : real;

   bi : TBitmap;

begin

Try

bi:=TBitmap.Create;

bi.width := ca.Cliprect.Right - ca.Cliprect.left;

bi.height := ca.Cliprect.bottom - ca.Cliprect.top;

bi.Canvas.CopyRect(ca.Cliprect,Ca,ca.Cliprect);

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

With bi.canvas do

   begin

   ymax := t.bottom;

   If (t.bottom-t.top)<ca.cliprect.bottom then

   if t.top=0 then

      t:=Rect(t.left,ca.cliprect.bottom-t.bottom,t.right,ca.cliprect.bottom)

   else

      t:=Rect(t.left,0,t.right,ca.cliprect.bottom-t.top+16);

   kep:=KepToMap(t,cw);

   y0 := kep.y1;

   SetPen(bi.canvas,color,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);

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

   For i:=1 to cw.vonalszam do begin

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

     If (i mod 4000)=0 then ca.Draw(0,0,bi);

     If lreteg[vrec.reteg] and (GetBit(vrec.jelzo,0)=0) 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-y0));

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

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

      end else begin

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

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

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

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

      end;

 

       if (oldrec.reteg<>vrec.reteg) then

       begin

         ReadRec(rtgstream,vrec.reteg,rrec,SizeOf(rrec));

         If rrec.vonalvastag=0 then rrec.vonalvastag:=1;

         Pen.Width := rrec.vonalvastag;

       end;

       oldrec:=vrec;

 

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

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

          If cw.printing then begin

             If vrec.vastag=0 then vrec.vastag:=1;

             Pen.Width := vrec.vastag*rrec.vonalvastag*cw.pr.vonalvastag;

             If not cw.pr.szines then Pen.Color:=clBlack;

          end;

         bi.canvas.MoveTo(x,y); bi.canvas.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(bi.canvas,x,y,Format('%6.2f',[d]),10*Trunc(szog));

            end;

            end;

         end;

      end;

      end;

     end;

   end;

   ca.Draw(0,0,bi);

   bi.Free;

Except

   On Exception do exit;

end;

end;

 

procedure Szoveg_rajzolas(ca: TCanvas;t:Trect;ms,rtgstream,fontstream:TStream;

                           lreteg:array of boolean; cw:TMapConfig);

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

   d,szog: real;

   meret: Longint;

   ymax: integer;

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

   Rgn: HRgn;

   szrec: Tszovegrecord;

   rrec: Tretegrecord;

   frec: TFontrecord;

   torzitas: real;

   Fixtext : TFont;

   oldrec : Tszovegrecord;

   FontList:TStringList;

   y0 : real;

label 1;

begin

Try

if cw.szoveglatszik and not kiugras then

   With ca do

   begin

   FontList:=TStringList.Create;

   FontList.AddStrings(Screen.Fonts);

   torzitas:= Screen.PixelsPerInch/GetPrAspectX;

   ymax := t.bottom;

   If (t.bottom-t.top)<ca.cliprect.bottom then

   if t.top=0 then

      t:=Rect(t.left,ca.cliprect.bottom-t.bottom,t.right,ca.cliprect.bottom)

   else

      t:=Rect(t.left,0,t.right,ca.cliprect.bottom-t.top+16);

   kep:=KepToMap(t,cw);

   y0 := kep.y1;

   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;

   ms.Seek(0,0);

   meret := SizeOf(szrec);

   For i:=1 to cw.szovegszam do begin

     ms.Read(szrec,meret);

     If lreteg[szrec.reteg] then begin

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

      If cw.printing then begin

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

         y := ymax-Trunc(cw.pr.paspy*cw.nagyitas*(szrec.y-y0));

      end else begin

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

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

      end;

{              If Font.Size>0 then begin}

                   if (oldrec.reteg<>szrec.reteg) or (oldrec.jelzo<>szrec.jelzo) then begin

                      ReadRec(rtgstream,szrec.reteg,rrec,SizeOf(rrec));

                      IF not cw.TEXTkenyszer then begin

                         Font.Name := rrec.fontnev;

                         If cw.printing then

                            Font.size  := Trunc(cw.pr.pBetumeret*cw.nagyitas*rrec.fontmeret/8)

                         else

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

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

                      end;

                      Font.Color := rrec.szovegszin;

                   end;

                   oldrec:=szrec;

                   If not cw.TEXTkenyszer then begin

                      If szrec.szeles<>0 then

                         Font.size  := Trunc(szrec.szeles*cw.nagyitas * rrec.fontmeret/10);

                      If szrec.font<>0 then

                         Font.Name := FontList.Strings[(szrec.font) mod FontList.Count];

                   end;

{                    If cw.printing then

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

{                    If printer.printing then

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

                     If cw.printing and not cw.pr.szines then Font.Color:=clBlack;

                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

                   If RajzFilter(ca,cw,3,szrec.reteg,szrec.jelzo) then

                   If szrec.szog=0 then

                      TextOut(x,y,szrec.szoveg)

                   else

                      stmap161.RotText(ca,x,y,szrec.szoveg,szrec.szog);

             end;

      end;

     end;

   If FontList<>nil then FontList.Free;

   end;

{    end;}

except

On Exception do begin

    If fontlist<>nil then FontList.Free;

    exit;

end;

end;

end;

 

procedure Jelkulcs_rajzolas(ca:TCanvas;t:Trect;ms,Jelkulcsstream:TStream;

                           lreteg:array of boolean; cw:TMapConfig);

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

   d,szog: real;

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

   meret: Longint;

   ymax: integer;

   Rgn: HRgn;

   y0 : real;

begin

If (cw.jelkulcsszam>0) and cw.jelkulcslatszik then

With ca do

begin

   ymax := t.bottom;

   If (t.bottom-t.top)<ca.cliprect.bottom then

   if t.top=0 then

      t:=Rect(t.left,ca.cliprect.bottom-t.bottom,t.right,ca.cliprect.bottom)

   else

      t:=Rect(t.left,0,t.right,ca.cliprect.bottom-t.top+16);

   kep:=KepToMap(t,cw);

   y0 := kep.y1;

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

   ms.Seek(0,0);

   For i:=1 to cw.jelkulcsszam do begin

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

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

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

      y:=ymax-Trunc(cw.nagyitas*(jrec.y-y0));

      If PtInRegion(Rgn,x,y) then begin

         If RajzFilter(ca,cw,4,jrec.reteg,jrec.jelzo) then

           Jelkulcsrajz(Ca,Jelkulcsstream,jrec,x,y,jrec.szog,cw);

     end; end;

   end;

DeleteObject(Rgn);

end;

end;

 

 

procedure Jelkulcsrajz(ca: TCanvas;Jelkulcsstream:TStream;

                      jr:TJelkulcsRecord;x,y:integer;szog:real;cw: TMapConfig);

var ii:integer;

   szorzo: real;

   po,p1,p2,p11,p22: TPoint2d;

begin

   szorzo:=cw.jelkulcsmeret*cw.nagyitas;

   JelkulcsStream.Seek(jr.kod*SizeOf(jelkHeader),0);

   JelkulcsStream.Read(jelkHeader,SizeOf(jelkHeader));

   JelkulcsStream.Seek(jelkHeader.jkcim,0);

   po.x:=0; po.y:=0;

       For ii:=1 to jelkHeader.jkdb do begin

           JelkulcsStream.Read(jelkDATA,SizeOf(jelkDATA));

           With jelkDATA do begin

           szorzo:=szorzo*jr.meret/100;

           p11.x:=szorzo*jelkDATA.x1;

           p11.y:=szorzo*jelkDATA.y1;

           p22.x:=szorzo*jelkDATA.x2;

           p22.y:=szorzo*jelkDATA.y2;

           If szog<>0 then begin

             p1:=Elforgatas(p11,po,Radian(180+szog/100));

             p2:=Elforgatas(p22,po,Radian(180+szog/100));

           end else begin

             p1.x:=p11.x; p1.y:=p11.y;

             p2.x:=p22.x; p2.y:=p22.y;

           end;

           x1 := Trunc(p1.x);  y1 := Trunc(p1.y);

           x2 := Trunc(p2.x);  y2 := Trunc(p2.y);

           end;

       If cw.homogenrajz then Ca.Pen.Color:=cw.pontszin else

          Ca.pen.color:=jelkDATA.szin;

       Ca.pen.width:=Trunc(jelkDATA.vastag*0.04*cw.nagyitas);

       Case jelkDATA.kod of

       1: Ca.Pixels[x+jelkDATA.x1,y+jelkDATA.y1]:=jelkDATA.szin;

       2: begin

          Ca.MoveTo(x+jelkDATA.x1,y+jelkDATA.y1);

          Ca.LineTo(x+jelkDATA.x2,y+jelkDATA.y2);

          end;

       3: Ca.Ellipse(x+jelkDATA.x1,y+jelkDATA.y1,x+jelkDATA.x2,y+jelkDATA.y2);

       end;

    end;

end;

 

{Fekete-fehér nyomtatás}

{procedure UjrarajzolPRINT(stm: TStMapW);

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

   t,t1: TRect;

   fele: TPoint;

   meret: Longint;

   d,szog: real;

   ymax: integer;

   Rgn: HRgn;

   oki: boolean;

   cw: TMapconfig;

label 1;

begin

oki := kiugrik;

kiugrik := false;

Screen.Cursor:=crHourGlass;

StreamMeretek(stm.cw);

cw := stm.cw;

with ca do

begin

   Pen.Mode := pmCopy;

   Pen.Style := psSolid;

   Cls(Ca,clWhite);

   t := ClipRect;

   If stm.cw.kozepkereszt then begin

      Kereszt(ca,clGreen);

   end;

   Pen.Color  :=clBlack;

   Brush.Color:=clWhite;

   Brush.style:=bsClear;

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

   ymax := t.bottom;

 

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

   IF not TEXTkenyszer then begin

      Font.Name := 'Arial';

      Font.Size:= Trunc(stm.cw.pr.pBetumeret*stm.cw.nagyitas);

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

      Font.Style:=[];

   end;

       Font.Color:=clBlack;

       Pen.Mode:=pmCopy;

   stm.tm[2].Seek(0,0);

   For i:=1 to cw.vonalszam do begin

     stm.tm[2].Read(vrec,SizeOf(vrec));

     If lreteg[vrec.reteg] and ((vrec.jelzo and 1)=0) 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));

      If PtInRegion(Rgn,(x1+x) div 2,(y1+y) div 2)

         or PtInRegion(Rgn,x,y) or PtInRegion(Rgn,x1,y1) then begin

      rrec := stm.RetegrekordKap(vrec.reteg);

      Pen.Color := rrec.vonalszin;

      If Pen.Color=clWhite then

      Pen.Color:=clBlack;

      Pen.Style := TPenStyle(rrec.vonalstylus);

      Pen.Width := rrec.vonalvastag*cw.pr.vonalvastag;

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

      If stm.cw.tavlatszik then

      Case tavmod of

      tmNormal: begin

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

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

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

      end;

      tmSzogben: begin

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

         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;

   Pen.width := 1;

   Pen.Mode := pmCopy;

   Pen.Style := psSolid;

   end;

 

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

   begin

   Pen.Color :=clBlack;

   Pen.Mode  := pmCopy;

   IF not TEXTkenyszer then begin

      Font.Size:= Trunc(cw.pr.pBetumeret*cw.nagyitas);

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

   end else Font := stm.cw.Fixtext;

   stm.tm[1].Seek(0,0);

   For i:=1 to cw.pontszam do begin

     stm.tm[1].Read(prec,SizeOf(prec));

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

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

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

      If PtInRegion(Rgn,x,y) 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;

   Pen.Mode := pmCopy;

   Pen.Style := psSolid;

   end;

 

   if cw.szoveglatszik then begin

   IF TEXTkenyszer then begin

      Font.Size:= Trunc(cw.pr.pBetumeret*cw.nagyitas);

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

   end;

   tm[3].Seek(0,0);

   meret := SizeOf(szrec);

   For i:=1 to cw.szovegszam do begin

     tm[3].Read(szrec,meret);

     If lreteg[szrec.reteg] and ((szrec.jelzo and 1)=0) 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));

      If PtInRegion(Rgn,x,y) then begin

             rrec := stm.RetegrekordKap(szrec.reteg);

             IF not TEXTkenyszer then begin

                 Font.Name  := rrec.fontnev;

                 Font.size  := Trunc(cw.pr.pBetumeret*cw.nagyitas*rrec.fontmeret/8);

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

             end;

             If Font.Size>0 then begin

                Font.Color := clBlack;

                If Font.Color=clWhite then Font.Color:=clBlack;

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

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

                RotText(ca,x,y,szrec.szoveg,szrec.szog);

             end;

      end;

     end;

   end;

   Pen.Mode := pmCopy;

   Pen.Style := psSolid;

   end;

 

kiugrik := false;

 

end;

1:DeleteObject(Rgn);

Screen.Cursor:=crDefault;

end;

}

 

procedure precnull(var p: tpontrecord);

begin RecNull(p); end;

 

procedure vrecnull(var p: Tvonalrecord);

begin RecNull(p); end;

 

procedure szrecnull(var p: Tszovegrecord);

begin

p.reteg:=0; p.x:=0; p.y:=0; p.szoveg := '';  p.szeles := 1; p.szog:=0;

end;

 

procedure jrecnull(var p: Tjelkulcsrecord);

begin RecNull(p); end;

 

procedure rrecnull(var p: Tretegrecord);

begin

With P do begin

retegszam   :=0;

retegnev    :='';

pontszin    :=clBlack;

vonalszin   :=clBlack;

vonalvastag :=1;

vonalstylus :=0;

szovegszin  :=clGreen;

fontnev     :='Arial';

fontmeret   :=12;

fontstylus  :=0;

vedett      :=False;

end;

{  FillChar(p.retegnev,20,' ');}

end;

 

{A rétegstream-et feltölti alap rétegbeállításokkal}

procedure RetegstreamNull(var rtgstream:TMemoryStream);

var i: longint;

   p: Tretegrecord;

begin

rtgstream.Seek(0,0);

For i:=0 to 255 do begin

     rrecnull(p);

     p.retegszam:=i;

     rtgstream.Write(p,SizeOf(p));

end;

end;

 

{ Rekordok kinullázása}

Procedure RecNull(Var rec);

begin

    FillChar(rec,SizeOf(rec),0);

end;

 

{A stream-re ír 1 rekordot}

Procedure WriteRec(m: TStream; arec: longint; var rec; Count: Longint );

begin

m.Seek(arec * Count,0); m.Write(rec,Count);

end;

 

{A stream-ről olvas 1 rekordot}

Procedure ReadRec(m: TStream; arec: longint; var rec; Count: Longint );

begin

m.Seek(arec * Count,0); m.Read(rec,Count);

end;

 

function Ujpont(var tm:TMemoryStream;var cw:TMapConfig;p: Tpontrecord):boolean;

begin

Result := False;

If (VanMarPont(tm,p)=0) then begin

    tm.Seek(0,2);tm.Write(p,SizeOf(p));

    cw.pontszam:=tm.Size div SizeOf(p);

    Result := True;

end;

end;

 

function Ujvonal(var tm,rtgstream:TMemoryStream;var cw:TMapConfig;p: Tvonalrecord):boolean;

begin

Result := False;

If (RetegbenFedoVonal(tm,p)=0) and not IsVedett(rtgstream,p.reteg,p.jelzo,True) then begin

    tm.Seek(0,2);tm.Write(p,SizeOf(p));

    cw.vonalszam:=tm.Size div SizeOf(p);

    Result := True;

end;

end;

 

function Ujfelirat(var tm,rtgstream:TMemoryStream;var cw:TMapConfig;p: Tszovegrecord):boolean;

begin

Result := False;

If not IsVedett(rtgstream,p.reteg,p.jelzo,True) then begin

    tm.Seek(0,2);tm.Write(p,SizeOf(p));

    cw.szovegszam:=tm.Size div SizeOf(p);

    Result := True;

end;

end;

 

function Ujjelkulcs(var tm,rtgstream:TMemoryStream;var cw:TMapConfig;p: Tjelkulcsrecord):boolean;

begin

If not IsVedett(rtgstream,p.reteg,p.jelzo,True) then begin

    tm.Seek(0,2);tm.Write(p,SizeOf(p));

    cw.jelkulcsszam:=tm.Size div SizeOf(p);

    Result := True;

end;

end;

 

function IsAzonosVonal(vr1,vr2:Tvonalrecord):boolean;

begin

Result :=((vr1.x1=vr2.x1) and (vr1.x2=vr2.x2) and

    (vr1.y1=vr2.y1) and (vr1.y2=vr2.y2)) or

    ((vr1.x1=vr2.x2) and (vr1.x2=vr2.x1) and

    (vr1.y1=vr2.y2) and (vr1.y2=vr2.y1))

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;

 

procedure cls(i: TCanvas; co: TColor);

var pe: TPen; br: TBrush; c: Trect;

begin

with i as TCanvas do

begin

     pe:= Pen; br:=Brush; Pen.color:=co;

     brush.style:=bsSolid;

     Brush.color:=co;

     c:=cliprect;

     Rectangle(c.left,c.top,c.right,c.bottom);

     Pen:=pe; Brush := br;

end;

end;

 

procedure clsRect(i: TCanvas; t:TRect; co: TColor);

var br: TBrush; pe:TPen; c: Trect;

begin

with i as TCanvas do

begin

     br := Brush; pe:=Pen;

     Pen.Color:=co; Pen.Width:=1;

     brush.style:=bsSolid;

     Brush.color:=co; Pen.Color:=co;

     Rectangle(t.left,t.top,t.right,t.bottom);

     Brush := br; Pen:=pe;

end;

end;

 

procedure ClsKivul(ca:TCanvas;x,y: integer;co:TColor);

var pe : TPen; br: TBrush;

   c,c1,c2: TRect;

begin

with ca do

begin

     pe:=Pen; br := Brush;

     Pen.Color := co; pen.Mode := pmCopy;

     Pen.width := 1;

     Brush.color:=co; brush.style:=bsSolid;

     c:=cliprect;

     { OffsetRect(c,x,y);}

     If x>0 then Rectangle(0,0,x,c.bottom) else

        Rectangle(c.right+x,0,c.right,c.bottom);

     If y>0 then Rectangle(0,0,c.right,y) else

        Rectangle(0,c.bottom+y,c.right,c.bottom);

     Pen:=pe; Brush := br;

end;

end;

 

procedure Kereszt(Canv: TCanvas; r:TRect; co: TColor);

var DC: HDC;

   dx,dy: integer;

begin

Try

   DC:=GetDC(Canv.Handle);

   SetPen(Canv,co,1,psSolid,pmNotXor);

   dx := (r.right - r.left) div 2;

   dy := (r.bottom - r.top) div 2;

   Canv.MoveTo(dx,0); Canv.LineTo(dx,r.bottom);

   Canv.MoveTo(0,dy); Canv.LineTo(r.right,dy);

finally

   RestoreDC(Canv.Handle,DC);

end;

end;

 

{Grafikus toll beállítása}

procedure SetPen(ca:TCanvas;color:TColor;width:integer;style:TPenStyle;mode:TPenMode);

begin

ca.pen.Color:=color;

ca.pen.width:=width;

ca.pen.style:=style;

ca.pen.mode :=mode;

end;

 

procedure ShowLine(ca:TCanvas;x1,y1,x2,y2:integer);

begin ca.MoveTo(x1,y1); ca.LineTo(x2,y2);end;

 

procedure RotText(ca:TCanvas; x,y:integer; szoveg:string; szog:integer);

var th: THandle;

   tf: TLogfont;

   hf: HFont;

begin

Getobject(Ca.Font.handle,SizeOf(tf),@tf);

tf.lfEscapement:=szog;

tf.lfOutPrecision:=OUT_TT_ONLY_PRECIS;

hf:=CreateFontIndirect(tf);

th:=SelectObject(Ca.Handle,hf);

Ca.TextOut(x,y,szoveg);

DeleteObject(hf);

SelectObject(Ca.Handle,th);

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;

 

{   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: single): single;

begin

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

end;

 

{Ha a szög ellentétes =0, direkt irányban óramutató járásával ellentétesen

   0..2*pi rad.}

function Szogdiff(alapszog,szog:double):double;

begin

szog := szog - alapszog;

If szog<0 then szog:=2*pi+szog;

If szog>=2*pi then szog:=szog-2*pi;

Result := szog;

end;

 

Function HaromszogEgyenlotlenseg(d1,d2,d3:double):boolean;

begin

Result := (d1+d2>d3) and (d1+d3>d2) and (d3+d2>d1);

end;

 

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

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

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

   p1,p2: TPoint2D;

begin

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

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;

 

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

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

begin

Result:= (x>=t.x1) and (x<=t.x2) and (y>=t.y1) and (y<=t.y2);

end;

 

{ ELFORGATAS( pont,elforgatás centruma,szöge )}

Function Elforgatas(p,porigo:TPoint2d;szog:double):TPoint2d;

var c,s : double;

begin

c := COS(szog); s := SIN(szog);  {szög radiánban}

p.x := p.x - porigo.x;

p.y := p.y - porigo.y;

Result.x := p.x * c + p.y * s + porigo.x;

Result.y := p.y * c - p.x * s + porigo.y;

end;

 

function Dist2D(P: TPoint2D): double;

begin

Result := Sqrt(P.X * P.X + P.Y * P.Y);

end;

 

function Dist3D(P: TPoint3D): double;

begin

Dist3d := Sqrt(P.X * P.X + P.Y * P.Y + P.Z * P.Z);

end;

 

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

begin

Result := Dist2D(Point2D(PB.X - PA.X, PB.Y - PA.Y));

end;

 

function RelDist3D(PA, PB: TPoint3D): double;

begin

RelDist3D := Dist3D(Point3D(PB.X - PA.X, PB.Y - PA.Y, PB.Z - PA.Z));

end;

 

procedure Rotate2D(var P: TPoint2D; Angle2D: double);

var

Temp: TPoint2D;

begin

Temp.X := P.X * Cos(Angle2D) - P.Y * Sin(Angle2D);

Temp.Y := P.X * Sin(Angle2D) + P.Y * Cos(Angle2D);

P := Temp;

end;

 

procedure RelRotate2D(var P: TPoint2D; PCentr: TPoint2D; Angle2D: double);

var

Temp: TPoint2D;

begin

Temp := SubPoints(P, PCentr);

Rotate2D(Temp, Angle2D);

P := AddPoints(Temp, PCentr);

end;

 

function Point3D(X, Y, Z: double): TPoint3D;

begin

Point3D.X := X;

Point3D.Y := Y;

Point3D.Z := Z;

end;

 

function Dist2P(P, P1, P2: TPoint2D): double;

begin

Result := DistLine(P1.Y - P2.Y, P2.X - P1.X, -P1.Y * P2.X + P1.X * P2.Y, P);

end;

 

function DistLine(A, B, C: double; P: TPoint2D): double;

begin

Result := (A * P.X + B * P.Y + C) / Sqrt(Sqr(A) + Sqr(B));

end;

 

function DistD1P(DX, DY: double; P1, P: TPoint2D): double;

begin

Result := DistLine(DY, -DX, -DY * P1.X + DX * P1.Y, P);

end;

 

function NearLine2P(P, P1, P2: TPoint2D; D: double): Boolean;

begin

Result := False;

if DistD1P(-(P2.Y - P1.Y), P2.X - P1.X, P1, P) * DistD1P(-(P2.Y - P1.Y), P2.X - P1.X, P2, P) <= 0 then

   if Abs(Dist2P(P, P1, P2)) < D then Result := True;

end;

 

function AddPoints(P1, P2: TPoint2D): TPoint2D;

begin

AddPoints := Point2D(P1.X + P2.X, P1.Y + P2.Y);

end;

 

function SubPoints(P1, P2: TPoint2D): TPoint2D;

begin

SubPoints := Point2D(P1.X - P2.X, P1.Y - P2.Y);

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;

 

{ BENNEVAN : A fgv. True értéket ad vissza, ha az adott pont

          benne van a kijelölt alakzat befoglaló téglalapjában}

 

Function Bennevan( t: TRect; p: TPoint):boolean;

Var hc : HRgn;

begin

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

Result := PtInRegion(hc,p.x,p.y);

DeleteObject(hc);

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 EgypontonAtmenoMeroleges(e1:Tegyenesfgv;p1:TPoint2D):Tegyenesfgv;

begin

If e1.a<>0 then begin

Result.a:=-1/e1.a;

end else begin

Result.a:= 10e+37;

end;

Result.b:=p1.y-Result.a*p1.x;

end;

 

function PontEgyenesTavolsaga(e1:Tegyenesfgv;p:TPoint2d):double;

var e2:Tegyenesfgv;

   p1:TPoint2d;

begin

e2 := EgypontonAtmenoMeroleges(e1,p);

p1 := KetEgyenesMetszespontja(e1,e2);

Result := KeTPontTavolsaga(p1.x,p1.y,p.x,p.y);

end;

 

Function KetEgyenesMetszespontja(ef1,ef2:Tegyenesfgv):TPoint2d;

begin

Try

  Result.x := (ef1.b - ef2.b) / (ef2.a - ef1.a);

  Result.y := ef1.a * Result.x + ef1.b;

except

  Result := Point2d(1E+38,1E+38);

end;

end;

 

function MaxPontszamKeres(tm:TStream):longint;

var i: longint;

   pr: TPontRecord;

begin

tm.seek(0,0);

Result := 0;

for i:=1 to (tm.Size div SizeOf(Tpontrecord)) do begin

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

     If Result<pr.no then Result:=pr.no;

end;

end;

 

Function Pontszamkeres(tm:TStream;var prec: TPontrecord;var ap: Longint): boolean;

var i,psz: longint;

begin

  tm.Seek(0,0);

  psz := prec.No;

  Result := False;

  For i:=0 to (tm.Size div SizeOf(Tpontrecord)) do begin

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

      If prec.No = psz then begin

         ap:=i;

         Result := True;

         Exit;

      end;

  end;

end;

 

procedure Kitoltesrajzol(Ca:TCanvas;ktrec:TKitoltoRecord);

var x,y,ymax: integer;

   Rgn: HRgn;

   t: TRect;

begin

{

   if cw.kitoltolatszik then begin

      t := ca.ClipRect;

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

      ymax := t.bottom;

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

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

      ca.Brush.Style:= bsSolid;

      If ktrec.kod=0 then begin

         ca.Brush.Color:= ktrec.szin;

      end else begin

         ca.Brush.Bitmap:= MAPForm.mImage.Picture.Bitmap;

      end;

      ca.FloodFill(x,y,ca.Pixels[x,y],fsSurface);

      ca.Ellipse(x-cw.pontmeret,y-cw.pontmeret,x+cw.pontmeret,y+cw.pontmeret);

      DeleteObject(Rgn);

   end;

}

end;

 

function JelkulcsNevKeres(jks:TFileStream;var jk:TJelkulcsHeader;nev:string):boolean;

var i: integer;

begin

Jks.Seek(0,0);

Result := False;

For i:=1 to 1000 do begin

     Jks.Read(jk,SizeOf(jk));

     If jk.jknev=nev then begin

       Result := True;

       exit;

     end;

end;

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+6 then begin

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

end;

If ve.a=0 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;

 

{A fontnévből megadja a screenfont sorszámot: pl. szövegrekordhoz}

Function FontSorszamKap(fontlist:TStringlist;fontnev:string): integer;

var i: integer;

begin

for i:=0 to fontlist.Count-1 do

     If fontlist.Strings[i]=fontnev then begin

        Result := i;

        Exit;

     end;

end;

 

{Fontstílus kinyerés: fkod = index => Font 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;

 

{Fontstílus index kinyerés}

Function FontStylusBeallit(fStyle:TFontStyles): integer;

begin

If fStyle=[] then Result:=0;

If fStyle=[fsBold] then Result:=1;

If fStyle=[fsItalic] then Result:=2;

If fStyle=[fsUnderline] then Result:=3;

If fStyle=[fsStrikeout] then Result:=4;

If fStyle=[fsBold,fsItalic] then Result:=5;

If fStyle=[fsBold,fsItalic,fsUnderline] then Result:=6;

If fStyle=[fsBold,fsItalic,fsStrikeout] then Result:=7;

end;

 

{A vonalrekord második végpont adatait egy pontrekordba irja}

function VrecToPrec(vr:TVonalrecord):TPontrecord;

begin

With Result do begin

   recNull(Result);

   reteg:=vr.reteg; x:=vr.x2; y:=vr.y2; z:=vr.z2;

end;

end;

 

{Két pont koordinátákkal feltöltegy vonal rekordot}

procedure VrecFromPrec(pr1,pr2:TPontrecord;var vr:TVonalrecord);

begin

vr.x1:=pr1.x; vr.y1:=pr1.y; vr.z1:=pr1.z;

vr.x2:=pr2.x; vr.y2:=pr2.y; vr.z2:=pr2.z;

end;

 

procedure PrinterParamNull(var pr:TPrinterParam);

begin

With pr do begin

fejlec    := '';

peldany   := 1;

meretarany:= 4000;

lapx      := 1;

lapy      := 1;

paspx     := 1;

paspy     := 1;

szines    := False;

vonalvastag:=1;

pBetumeret:= 1;

keretezes := False;

laphelyzet:= poPortrait;

sablon    := 0;       {Sablon tipusa 0=Nincs sablon; 1..255 = sablon tipus}

ablak     := Rect(0,0,0,0);    {Térképablak}

end;

end;

 

Function RajzmodToString(rmod:TRajzmodType):string;

begin

Result := Rajzmodfelirat[Ord(rmod)];

end;

 

Function StringToRajzmod(rmodstring:string):TRajzmodType;

var i:integer;

begin

Result := rmNincs;

For i:=0 to High(RajzmodFelirat) do

If RajzmodFelirat[i]=rmodstring then Result := TRajzmodType(i);

end;

 

Function VonalVegpontkeres(tm:TStream;x,y:double; var vrec: TVonalrecord;

                          var recno:longint): boolean;

var meret: longint;

   vr: TVonalrecord;

begin

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

tm.Seek(RecNo*SizeOf(vr),0);

Result := False;

While RecNo<=meret do begin

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

     If ((vr.x1=x) and (vr.y1=y)) or ((vr.x2=x) and (vr.y2=y)) then

        If GetBit(vr.jelzo,0)=0 then begin

          vrec:=vr;

          Result := True;

          exit;

        end;

     Inc(Recno);

end;

end;

 

procedure VonalVegpontAtrak(var vrec:TVonalrecord;oldp,newp:TPontrecord);

begin

If ((vrec.x1=oldp.x) and (vrec.y1=oldp.y)) then begin

     vrec.x1:=newp.x; vrec.y1:=newp.y;

end;

If ((vrec.x2=oldp.x) and (vrec.y2=oldp.y)) then begin

     vrec.x2:=newp.x; vrec.y2:=newp.y;

end;

end;

 

 

{--------- Geodéziai rutinok ------------}

 

{ FokToGeoszog: Geodézia szöget ad vissza, É-tól indirect irányban.

------------  ill. geodéziai szöget fokká konvertál.

               Mindkét irányban megy az átváltás!

               geoszög <-> fok

Result: 0..360, Hiba esetén = -1 }

function FokToGeoszog(fok:double):double;

begin

Try

fok := fok - 360*(Trunc(Int(fok)) div 360);

Result := 90 - fok;

If Result<0 then Result := 360 + Result;

except

Result := -1;

end;

end;

 

{GEODEZIA1 : Két ismert pont koordinátáiból = p1,p2:TPoint2d,

---------   kiszámítja a Descartes irányszöget = fi [fok],

            valamint a távolságot              = d.}

procedure Geodezia1(p1,p2:TPoint2d; var fi,d:double);

begin

  fi:= Radian(Relangle2d(p1,p2));

  d := KeTPontTavolsaga(p1.x,p1.y,p2.x,p2.y);

end;

 

{GEODEZIA2 : Ismert egy pont koordinátái = p1:TPoint2d,

---------   és Descartes irányszög      = fi [fok],

            valamint a távolság         = d.

            Kiszámítja az uj pont koordinátáit= Result}

function Geodezia2(p1:TPoint2d; fi,d:double):TPoint2d;

begin

fi:=Fok(fi);

Result.x := p1.x + d * cos(fi);

Result.y := p1.y + d * sin(fi);

end;

 

{POLARIS : Két ismert pont által definiált egyeneshez képest a p1 pontból

          meghatározott irányszög eltérés (fi) és d távolság alapján:

          kiszámítja az uj pont koordinátáit}

function Polaris(p1,p2:TPoint2d; fi,d:double):TPoint2d;

var fi1,d1: double;

begin

Geodezia1(p1,p2,fi1,d1);

fi := fi + fi1;

Result := Geodezia2(p1,fi,d);

end;

 

{ORTOGONALISMERES:

          Két ismert pont alapján az egyik végpontból (p1) mérünk 'a'

          távolságot p2 felé, majd rá merőlegesen 'b' távolságot.

          Ennek alapján kiszámítjuk az uj pont koordinátáit (Result)}

function Ortogonalismeres(p1,p2:TPoint2d; a,b:double):TPoint2d;

var d,szog: double;

begin

    d:=KetPonttavolsaga(p1.x,p1.y,p2.x,p2.y);

    szog:=SzakaszSzog(p1.x,p1.y,p2.x,p2.y);

    Result.x := a; Result.y:=b;

    Rotate2D(Result,szog);          {Elforgatas a szakasz irányába}

    Result.x := p1.x+Result.x; Result.y:=p1.y+Result.y;

end;

 

{PontToEgyenes : pont és egyenes távolsága}

function PontToEgyenes(x1,y1,x2,y2:double; p:TPoint2d):double;

var e:Tegyenesfgv;

begin

e := KetPontonAtmenoEgyenes(x1,y1,x2,y2);

Result := PontEgyenesTavolsaga(e,p);

end;

 

{Két kör metszéspontjait adja:

In:     u,v,r = a kör középpontjának x,y koord.-ja és r a sugár

        p1,p2 = a metszéspontok

Out:    0 = Ha a körök nem metszik egymást; 1-2 = a metszéspontok száma}

Function Ivmetszes(u1,v1,r1,u2,v2,r2: double;var p:TPoint2D):boolean;

var d,a,b,x,y,szog: double;

   kpx,kpy: double;

begin

    Result := False;

    d:=KetPonttavolsaga(u1,v1,u2,v2);

    szog:=SzakaszSzog(u1,v1,u2,v2);

If HaromszogEgyenlotlenseg(d,r1,r2) and (d <= (r1+r2)) then begin

    {A két kör metszéspontjain áthaladó egyenes egyenlete}

    x := ((d*d)-(r2*r2)+(r1*r1))/(2*d);

    y := sqrt((r1*r1)-(x*x));

    p.x := x; p.y:=y;

    Rotate2D(p,szog);          {Elforgatas a szakasz irányába}

    p.x := u1+p.x; p.y:=v1+p.y;

    Result := True;

end;

end;

 

{ A szakasz egyik végétől r1, rá merőlegesen r2 távolságban lévő pont helyzete

In:     u,v,r = a kör középpontjának x,y koord.-ja és r a sugár

        p = a metszéspont}

Function Bemeres(u1,v1,r1,u2,v2,r2: double;var p:TPoint2D):boolean;

var d,szog: double;

begin

    d:=KetPonttavolsaga(u1,v1,u2,v2);

    szog:=SzakaszSzog(u1,v1,u2,v2);

    p.x := r1; p.y:=r2;

    Rotate2D(p,szog);          {Elforgatas a szakasz irányába}

    p.x := u1+p.x; p.y:=v1+p.y;

    Result := True;

end;

 

{ELŐMETSZÉS: in  : a,b a bázisvonal két végpontja,

                  alfa,béta a végpontokbűl mért irányszög

            out : a keresett pont térképi koordinátái

}

Function Elometszes(a,b:TPoint2D;alfa,beta:real):TPoint2D;

begin

Result.x := a.x+((b.x-a.x)*cot(alfa)-(b.y-a.y))/(cot(alfa)+cot(beta));

Result.y := a.y+((b.y-a.y)*cot(alfa)+(b.x-a.x))/(cot(alfa)+cot(beta));

end;

 

{Megvizsgálja, hogy van-e már az adott pozición pont:

  Result: a fedő pontok száma; 0 ha nincs még}

Function VanMarPont(tm:TStream;var p:TPontrecord):longint;

var meret,poz,i: longint;

   pp: TPontrecord;

begin

  poz := tm.position;

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

  Result := 0;

  tm.Seek(0,0);

  For i:=1 to Meret do begin

    tm.Read(pp,SizeOf(p));

    If (pp.x=p.x) and (pp.y=p.y) and (pp.z=p.z) and (GetBit(pp.jelzo,1)=0)

    then Inc(Result);

  end;

  tm.Seek(poz,0);

end;

 

{Megvizsgálja, hogy van-e az adott rétegben már vonal:

  Result: a fedő vonalak száma; 0 ha nincs még}

Function RetegbenFedoVonal(tm:TStream;v:TVonalrecord):longint;

var meret,poz,i: longint;

   vv: TVonalrecord;

begin

  poz := tm.position;

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

  Result := 0;

  tm.Seek(0,0);

  For i:=1 to Meret do begin

    tm.Read(vv,SizeOf(v));

    If (vv.reteg=v.reteg) then begin

       If (vv.x1+vv.x2=v.x1+v.x2) and (vv.y1+vv.y2=v.y1+v.y2)

          and (vv.z1+vv.z2=v.z1+v.z2) and (GetBit(vv.jelzo,0)=0)

       then

          Inc(Result);

    end;

  end;

  tm.Seek(poz,0);

end;

 

function EgyenesekMetszese(v1,v2:TVonalrecord):TPontrecord;

var erec1,erec2: TEgyenes;

   tp: TPoint2d;

begin

erec1.x1:=v1.x1; erec1.y1:=v1.y1; erec1.x2:=v1.x2; erec1.y2:=v1.y2;

erec2.x1:=v2.x1; erec2.y1:=v2.y1; erec2.x2:=v2.x2; erec2.y2:=v2.y2;

tp := Egyenes12(erec1,erec2);

recNull(Result);

With Result do begin

      x  := tp.x;

      y  := tp.y;

end;

end;

 

{ Két egyenes metszéspontjának koord.-ját adja}

Function Egyenes12(e1,e2:Tegyenes):TPoint2d;

var ef1,ef2: Tegyenesfgv;

begin

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

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

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

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

  Result.x := (ef1.b - ef2.b) / (ef2.a - ef1.a);

  Result.y := ef1.a * Result.x + ef1.b;

end;

 

{ StellaMap memóriastream mentése STMAP file-okba}

procedure Filementes(tm: TRajzelemStream;fnev: string;csik:TGauge);

var fn: string;

   hol: longint;

   ext: string;

begin

   if csik<>nil then begin csik.Visible:=True; csik.Progress:=0; hol:=0; end;

   fn:= Copy(fnev,1,Pos('.',fnev));

   tm[1].SaveToFile(fn+'trk');If csik<>nil then csik.Progress:=Trunc(25);

   tm[2].SaveToFile(fn+'lin');If csik<>nil then csik.Progress:=Trunc(50);

   tm[3].SaveToFile(fn+'szv');If csik<>nil then csik.Progress:=Trunc(75);

   tm[4].SaveToFile(fn+'jlk');If csik<>nil then csik.Progress:=Trunc(100);

   if csik<>nil then csik.Visible:=False;

end;

 

{ StellaMAP térképek beolvasása }

Function Filemegnyitas(var tm: TRajzelemStream;var rtgstream:TMemoryStream;

                          fnev: string;append: boolean; csik: TGauge):boolean;

Type Tdxfelozo = (semmi,pont,vonal,szoveg,jelkulcs,sokszog,kor);

var fn,sor: string;

   f: file; ft: TEXTFILE;

   resu: word;

   i,hol,fs: longint;

   filetipus : string;

   prec: TPontrecord;

   vrec: TVonalrecord;

   szrec: TSzovegrecord;

   jrec: TJelkulcsRecord;

   rrec: TRetegrecord;

   ITRpHeader  : ITRPontHeader;

   ITRprec     : ITRPontRecord;

   ITRvHeader  : ITRVonalHeader;

   ITRvrec     : ITRVonalRecord;

   ITRtHeader  : ITRTextHeader;

   ITRtrec     : ITRTextRecord;

   ITRjkHeader : ITRJelkulcsHeader;

   ITRjkrec    : ITRJelkulcsRecord;

   ITRrHeader  : ITRRetegHeader;

   ITRrrec     : ITRRetegRecord;

   dxfelozo,rmuj: Tdxfelozo;

   oldCur      : TCursor;

begin

Try

   fn := fnev;

   If not FileExists(fn) then begin

      MessageDlg('Nem létező file!',mtError,[mbOk],0);

      exit;

   end;

   oldCur := Screen.Cursor;

   Screen.Cursor := crHourGlass;

   filetipus := UpperCase(Copy(fnev,Pos('.',fnev)+1,3));

   fn:= Copy(fnev,1,Pos('.',fnev));

   if csik<>nil then begin csik.Visible:=True; csik.Progress:=0; hol:=0; end;

 

   For i:=1 to High(tm) do

      If not append then

         tm[i].Clear

      else

         tm[i].Seek(0,2);

 

 

{ StellaMAP térképek beolvasása }

If filetipus = 'TRK' then

begin

   If FileExists(fn+'TRK') then begin

      AssignFile(f,fn+'TRK');

      Reset(f,1);

      Repeat

            BlockRead(f,prec,Sizeof(prec),Resu);

            If Resu=SizeOf(prec) then tm[1].Write(prec,SizeOf(prec));

      Until Resu<>SizeOf(prec);

      CloseFile(f);

   end;

   If FileExists(fn+'LIN') then begin

      AssignFile(f,fn+'LIN');

      Reset(f,1);

      Repeat

            BlockRead(f,vrec,Sizeof(vrec),Resu);

            If Resu=SizeOf(vrec) then tm[2].Write(vrec,SizeOf(vrec));

      Until Resu<>SizeOf(vrec);

      CloseFile(f);

   end;

   If FileExists(fn+'SZV') then begin

      AssignFile(f,fn+'SZV');

      Reset(f,1);

      Repeat

            BlockRead(f,szrec,Sizeof(szrec),Resu);

            If Resu=SizeOf(szrec) then tm[3].Write(szrec,SizeOf(szrec));

      Until Resu<>SizeOf(szrec);

      CloseFile(f);

   end;

   If FileExists(fn+'JLK') then begin

      AssignFile(f,fn+'JLK');

      Reset(f,1);

      Repeat

            BlockRead(f,jrec,Sizeof(jrec),Resu);

            If Resu=SizeOf(jrec) then tm[4].Write(jrec,SizeOf(jrec));

      Until Resu<>SizeOf(jrec);

      CloseFile(f);

   end;

end;

{  If filetipus = 'TRK' then

begin

   If FileExists(fn+'trk') then tm[1].LoadFromFile(fn+'trk');

         If csik<>nil then csik.Progress:=Trunc(25);

   If FileExists(fn+'lin') then tm[2].LoadFromFile(fn+'lin');

         If csik<>nil then csik.Progress:=Trunc(50);

   If FileExists(fn+'szv') then tm[3].LoadFromFile(fn+'szv');

         If csik<>nil then csik.Progress:=Trunc(75);

   If FileExists(fn+'jlk') then tm[4].LoadFromFile(fn+'jlk');

         If csik<>nil then csik.Progress:=Trunc(100);

end;

}

{ ITR térképek beolvasása }

If filetipus = 'PT' then

begin

   AssignFile(f,fn+'PT');

   fs:=Filesize(f);

   Reset(f,1);

   BlockRead(f,ITRpHeader,Sizeof(ITRpHeader),Resu);

   hol := Sizeof(ITRpHeader);

   Repeat

     BlockRead(f,ITRPREC,Sizeof(ITRprec),Resu);

     If Resu=SizeOf(ITRprec) then

     begin

          prec.reteg:= ITRprec.reteg;

          prec.No   := ITRprec.No;

          prec.x    := ITRprec.x/100;

          prec.y    := ITRprec.y/100;

          prec.z    := ITRprec.z/100;

          prec.pkod := ITRprec.pkod;

          prec.info := 0;

          prec.obj  := 0;

          If ITRprec.azonosito=0 then prec.jelzo:=1 else

          prec.jelzo:= 0;

          If (prec.x+prec.y+prec.no)<>0 then

          tm[1].Write(prec,SizeOf(prec));

          hol := hol + Sizeof(ITRprec);

          If csik<>nil then csik.Progress:=Trunc(100*hol/fs);

     end;

   Until Resu<>SizeOf(ITRprec);

   CloseFile(f);

 

   { Vonalak beolvasása }

   AssignFile(f,fn+'EL');

   fs:=Filesize(f);

   Reset(f,1);

     BlockRead(f,ITRvHeader,Sizeof(ITRvHeader),Resu);

   Repeat

     BlockRead(f,ITRvREC,Sizeof(ITRvrec),Resu);

     If Resu=SizeOf(ITRvrec) then

     If (ITRVrec.x1<>0) and (ITRVrec.x2<>0) then

     begin

          vrec.reteg:= ITRvrec.reteg;

          vrec.x1   := ITRvrec.y1/100;

          vrec.y1   := ITRvrec.x1/100;

          vrec.z1   := 0;

          vrec.x2   := ITRvrec.y2/100;

          vrec.y2   := ITRvrec.x2/100;

          vrec.z2   := 0;

          vrec.vastag := 0;

          vrec.tipus  := 0;

          vrec.obj1  := 0;

          vrec.obj2  := 0;

          If ITRvrec.azonosito=0 then vrec.jelzo:=1 else

          vrec.jelzo:=0;

          tm[2].Write(vrec,SizeOf(vrec));

          hol := hol + Sizeof(ITRVrec);

          If csik<>nil then csik.Progress:=Trunc(100*hol/fs);

     end;

   Until Resu<>SizeOf(ITRvrec);

   CloseFile(f);

 

   { Jelkulcsok beolvasása }

   AssignFile(f,fn+'SI');

   fs:=Filesize(f);

   Reset(f,1);

     BlockRead(f,ITRjkHeader,Sizeof(ITRjkHeader),Resu);

   Repeat

     BlockRead(f,ITRjkrec,Sizeof(ITRjkrec),Resu);

     If Resu=SizeOf(ITRjkrec) then

     begin

          jrec.kod   := ITRjkrec.jkkod-1;

          jrec.reteg := ITRjkrec.reteg;

          jrec.x     := ITRjkrec.y/100;

          jrec.y     := ITRjkrec.x/100;

          jrec.meret := 100;

          jrec.szog  := ITRjkrec.jkszog;

          jrec.obj   := 0;

          jrec.jelzo := 0;

          If ITRjkrec.jkkod>0 then tm[4].Write(jrec,SizeOf(jrec));

          hol := hol + Sizeof(ITRJkrec);

          If csik<>nil then csik.Progress:=Trunc(100*hol/fs);

     end;

   Until Resu<>SizeOf(ITRjkrec);

   CloseFile(f);

 

   { Szövegek beolvasása }

   AssignFile(f,fn+'TX');

   fs:=Filesize(f);

   Reset(f,1);

     BlockRead(f,ITRtHeader,Sizeof(ITRtHeader),Resu);

   Repeat

     BlockRead(f,ITRtREC,Sizeof(ITRtrec),Resu);

     If Resu=SizeOf(ITRtrec) then

     begin

          szrec.reteg := ITRtrec.reteg;

          szrec.x     := ITRtrec.y1/100;

          szrec.y     := ITRtrec.x1/100;

          szrec.szoveg:= CsakBetu(ITRtrec.Text);

          szrec.font  := 0;

          szrec.szeles:= 0;

          szrec.stilus:= 0;

          szrec.szog  := 10 * Trunc(ITRtrec.szog / 91);

          szrec.obj   := 0;

          If ITRtrec.azonosito=0 then szrec.jelzo:=1 else

          szrec.jelzo:=0;

          If szrec.szoveg<>'' then

          tm[3].Write(szrec,SizeOf(szrec));

          hol := hol + Sizeof(ITRtrec);

          If csik<>nil then csik.Progress:=Trunc(100*hol/fs);

     end;

   Until Resu<>SizeOf(ITRtrec);

   CloseFile(f);

 

   {Rétegek beolvasása}

 

   RtgStream.Seek(0,0);

   AssignFile(f,fn+'LAY');

   Reset(f,1);

     BlockRead(f,ITRrHeader,Sizeof(ITRrHeader),Resu);

   Repeat

     BlockRead(f,ITRrREC,Sizeof(ITRrrec),Resu);

     If Resu=SizeOf(ITRrrec) then

     begin

          RtgStream.Read(rrec,SizeOf(rrec));

          RtgStream.Seek(-SizeOf(rrec),1);

          rrec.retegszam := ITRrrec.reteg;

          rrec.retegnev  := CsakBetu(ITRrrec.retegnev);

          RtgStream.Write(rrec,SizeOf(rrec));

     end;

   Until Resu<>SizeOf(ITRrrec);

   RtgStream.SaveToFile(fn+'RTG');

   CloseFile(f);

end;

 

{ StellaMAP LISTA-file beolvasása }

If (filetipus = 'LST') then

begin

AssignFile(ft,fn+'LST');

AssignFile(f,fn+'LST'); Reset(f); fs:=Filesize(f); CloseFile(f);

Reset(ft);

While not EOF(Ft) do begin

    ReadLn(ft,sor);

    hol := hol + Length(sor);

    If csik<>nil then csik.Progress:=Trunc(100*hol/fs);

    If Pos('PONTLISTA',sor)>0 then rmuj:=pont;

    If Pos('VONALLISTA',sor)>0 then rmuj:=vonal;

    If Pos('FELIRATLISTA',sor)>0 then rmuj:=szoveg;

    If Pos('JELKULCSLISTA',sor)>0 then rmuj:=jelkulcs;

    If Copy(sor,1,1)<>'*' then

    CASE rmuj OF

    pont:

       begin

          With prec do begin

               reteg := StrToInt(Szo(sor,2));

               No    := StrToInt(Szo(sor,3));

               x     := StrToFloat(Szo(sor,4));

               y     := StrToFloat(Szo(sor,5));

               z     := StrToFloat(Szo(sor,6));

               pkod  := StrToInt(Szo(sor,7));

               info  := StrToInt(Szo(sor,8));

               obj   := StrToInt(Szo(sor,9));

               jelzo := 0;

          end;

          tm[1].Write(prec,SizeOf(prec));

       end;

    vonal:

       begin

          With vrec do begin

               reteg := StrToInt(Szo(sor,2));

               x1    := StrToFloat(Szo(sor,3));

               y1    := StrToFloat(Szo(sor,4));

               z1    := StrToFloat(Szo(sor,5));

               x2    := StrToFloat(Szo(sor,6));

               y2    := StrToFloat(Szo(sor,7));

               z2    := StrToFloat(Szo(sor,8));

               vastag:= StrToInt(Szo(sor,9));

               tipus := StrToInt(Szo(sor,10));

               obj1  := StrToInt(Szo(sor,11));

               jelzo := 0;

          end;

          tm[2].Write(vrec,SizeOf(vrec));

       end;

    szoveg:

       begin

          With szrec do begin

               reteg := StrToInt(Szo(sor,2));

               szoveg:= Szo(sor,3);

               kozsegkod:= StrToInt(Szo(sor,4));

               x     := StrToFloat(Szo(sor,5));

               y     := StrToFloat(Szo(sor,6));

               font  := StrToInt(Szo(sor,7));

               szeles:= StrToInt(Szo(sor,8));

               stilus:= StrToInt(Szo(sor,9));

               szog  := StrToInt(Szo(sor,10));

               obj   := StrToInt(Szo(sor,11));

               jelzo := 0;

          end;

          tm[3].Write(szrec,SizeOf(szrec));

       end;

    jelkulcs:

{        begin

          With szrec do begin

          end;

          tm[4].Write(szrec,SizeOf(szrec));

       end;}

    END;

end;

CloseFile(ft);

END;

 

If filetipus = 'DXF' then

    DXFTRKconverter(tm,rtgstream,fnev,fnev,False,csik);

 

Result := True;

except

   Raise Exception.Create('Filenyitási hiba!');

   If (filetipus = 'LST') or (filetipus = 'DXF') then

   CloseFile(ft) else CloseFile(f);

   Screen.Cursor := oldCur;

   Result := False;

end;

Screen.Cursor := oldCur;

if csik<>nil then csik.Visible:=False;

end;

 

procedure ViewMegnyit(fnev:string;var lreteg:array of boolean);

var f: file of boolean;

   van : boolean;

   resu: word;

   I: integer;

   meret: longint;

begin

Try

      van:=FileExists(fnev);

      {$I-}

      AssignFile(f,fnev);

      If van then Reset(f) else Rewrite(f);

      For i:=0 to 255 do

        If van then Read(f,lreteg[i])

        else Write(f,lreteg[i]);

finally

      CloseFile(f);

      {$I+}

end;

end;

 

Procedure MAPForgat(var tm:TRajzelemStream;cent:TPoint2D;szog:real);

var pppp: TPoint2D;

   meret,i: longint;

begin

tm[1].Seek(0,0);

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

For i:=1 to meret do begin

    tm[1].Read(prec,SizeOf(prec));

    pppp := Elforgatas(Point2D(pRec.x,pRec.y),cent,szog);

    pRec.x := pppp.x;

    pRec.y := pppp.y;

    tm[1].Seek(-SizeOf(prec),1);

    tm[1].Write(prec,SizeOf(prec));

end;

tm[2].Seek(0,0);

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

For i:=1 to meret do begin

    tm[2].Read(vrec,SizeOf(vrec));

    pppp := Elforgatas(Point2D(vRec.x1,vRec.y1),cent,szog);

    vRec.x1 := pppp.x;

    vRec.y1 := pppp.y;

    pppp := Elforgatas(Point2D(vRec.x2,vRec.y2),cent,szog);

    vRec.x2 := pppp.x;

    vRec.y2 := pppp.y;

    tm[2].Seek(-SizeOf(vrec),1);

    tm[2].Write(vrec,SizeOf(vrec));

end;

tm[3].Seek(0,0);

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

For i:=1 to meret do begin

    tm[3].Read(szrec,SizeOf(szrec));

    pppp := Elforgatas(Point2D(szRec.x,szRec.y),cent,szog);

    szRec.x := pppp.x;

    szRec.y := pppp.y;

    szRec.szog := Trunc(szRec.szog-10*Fok(szog));

    tm[3].Seek(-SizeOf(szrec),1);

    tm[3].Write(szrec,SizeOf(szrec));

end;

end;

 

procedure AktretegMent(tm:TRajzelemStream; filename:string; aktreteg:byte);

var ii,i: integer; fnev,fpath: string;

   f: file; resu: word;

Const kit: Array[1..4] of string[3] = ('trk','lin','szv','jlk');

begin

  Try

       fnev := F_Name(filename);

       fpath:= F_Path(filename);

       For ii:=1 to 4 do begin

           tm[ii].Seek(0,0);

           AssignFile(f,fpath+'\'+fnev+'.'+kit[ii]);

           Rewrite(f,1);

           Case ii of

           1:   For i:=1 to (tm[1].Size div SizeOf(prec)) do begin

                    tm[1].Read(prec,SizeOf(prec));

                    BlockWrite(f,prec,SizeOf(prec),resu);

                end;

           2:   For i:=1 to (tm[2].Size div SizeOf(vrec)) do begin

                    tm[2].Read(vrec,SizeOf(vrec));

                    If vrec.reteg=aktreteg then

                    BlockWrite(f,vrec,SizeOf(vrec),resu);

                end;

           3:   For i:=1 to (tm[3].Size div SizeOf(szrec)) do begin

                    tm[3].Read(szrec,SizeOf(szrec));

                    If szrec.reteg=aktreteg then

                    BlockWrite(f,szrec,SizeOf(szrec),resu);

                end;

           4:   For i:=1 to (tm[4].Size div SizeOf(jrec)) do begin

                    tm[4].Read(jrec,SizeOf(jrec));

                    If jrec.reteg=aktreteg then

                    BlockWrite(f,jrec,SizeOf(jrec),resu);

                end;

           end;

           CloseFile(f);

       end;

except

   Raise Exception.Create('Mentési hiba!');

   CloseFile(f);

end;

end;

 

{Minden alakzat adott bitjét ertek=0/1-re állítja}

procedure SetJelzok(tm:TRajzelemStream;bit:integer;ertek:integer);

var ii,i: longint;

   bi: real;

begin

   bi:=bit;

   bit:=Trunc(Power(2,bi));

   For ii:=1 to 3 do begin

       tm[ii].Seek(0,0);

       Case ii of

       1:  For i:=1 to (tm[1].Size div SizeOf(prec)) do begin

               tm[1].Read(prec,SizeOf(prec));

               prec.jelzo := prec.jelzo and (255-bit);

               If ertek=1 then prec.jelzo := prec.jelzo or bit;

               tm[1].Seek(-SizeOf(prec),1);

               tm[1].Write(prec,SizeOf(prec));

           end;

       2:  For i:=1 to (tm[2].Size div SizeOf(vrec)) do begin

               tm[2].Read(vrec,SizeOf(vrec));

               vrec.jelzo := vrec.jelzo and (255-bit);

               If ertek=1 then vrec.jelzo := vrec.jelzo or bit;

               tm[2].Seek(-SizeOf(vrec),1);

               tm[2].Write(vrec,SizeOf(vrec));

           end;

       3:  For i:=1 to (tm[3].Size div SizeOf(szrec)) do begin

               tm[3].Read(szrec,SizeOf(szrec));

               szrec.jelzo := szrec.jelzo and (255-bit);

               If ertek=1 then szrec.jelzo := szrec.jelzo or bit;

               tm[3].Seek(-SizeOf(szrec),1);

               tm[3].Write(szrec,SizeOf(szrec));

           end;

       4:  For i:=1 to (tm[4].Size div SizeOf(jrec)) do begin

               tm[4].Read(jrec,SizeOf(jrec));

               jrec.jelzo := jrec.jelzo and (255-bit);

               If ertek=1 then jrec.jelzo := jrec.jelzo or bit;

               tm[4].Seek(-SizeOf(jrec),1);

               tm[4].Write(jrec,SizeOf(jrec));

           end;

       end;

   end;

end;

 

 

{Minden alakzat jelzojenek bit2 értékét bit1-re állítja

pl: SetCopyJelzok(7,0) Minden 0. törlési bitet 0 7. kijelölés bitnek megfelőre

                      állítja: 10010010  ->  10010011}

procedure SetCopyJelzok(tm:TRajzelemStream;bit1,bit2:integer);

var ii,i: longint;

   bi1,bi2: real;

begin

   For ii:=1 to 4 do begin

       tm[ii].Seek(0,0);

       Case ii of

       1:  For i:=1 to (tm[1].Size div SizeOf(prec)) do begin

               tm[1].Read(prec,SizeOf(prec));

               prec.jelzo := SetBit(prec.jelzo,bit2,GetBit(prec.jelzo,bit1));

               tm[1].Seek(-SizeOf(prec),1);

               tm[1].Write(prec,SizeOf(prec));

           end;

       2:  For i:=1 to (tm[2].Size div SizeOf(vrec)) do begin

               tm[2].Read(vrec,SizeOf(vrec));

               vrec.jelzo := SetBit(vrec.jelzo,bit2,GetBit(vrec.jelzo,bit1));

               tm[2].Seek(-SizeOf(vrec),1);

               tm[2].Write(vrec,SizeOf(vrec));

           end;

       3:  For i:=1 to (tm[3].Size div SizeOf(szrec)) do begin

               tm[3].Read(szrec,SizeOf(szrec));

               szrec.jelzo := SetBit(szrec.jelzo,bit2,GetBit(szrec.jelzo,bit1));

               tm[3].Seek(-SizeOf(szrec),1);

               tm[3].Write(szrec,SizeOf(szrec));

           end;

       4:  For i:=1 to (tm[4].Size div SizeOf(jrec)) do begin

               tm[4].Read(jrec,SizeOf(jrec));

               jrec.jelzo := SetBit(jrec.jelzo,bit2,GetBit(jrec.jelzo,bit1));

               tm[4].Seek(-SizeOf(jrec),1);

               tm[4].Write(jrec,SizeOf(jrec));

           end;

       end;

   end;

end;

 

{A kijelölt elemekkel műveletet végez, a többi elemet nem bántja}

procedure Jeloltek(tm:TRajzelemStream;jm:Tjelolesmod;aktReteg:byte);

var ii,i: longint;

   Action: boolean;

 

   Function GetAction(jelzo:byte; r1,r2:byte):boolean;

   begin

      Result := False;

      Case jm of

           jmNincs         : Result:=False;

           jmUndo,jmJelDel : Result:=GetBit(jelzo,7)=1;

           jmTorles        : Result:=GetBit(jelzo,0)=0;

           jmReaktiv       : Result:=GetBit(jelzo,0)=1;

           jmAllDel,jmInvers,jmAll : Result:=True;

           jmFilter        : Result:=GetBit(jelzo,4)=0;

           jmDelFilter     : Result:=GetBit(jelzo,4)=1;

           jmActReteg      : Result:=r1=r2;

      end;

   end;

 

begin

If jm<>jmNincs then begin

   For ii:=1 to 4 do begin

       tm[ii].Seek(0,0);

       Case ii of

       1:  For i:=1 to (tm[1].Size div SizeOf(prec)) do begin

               tm[1].Read(prec,SizeOf(prec));

               If GetAction(prec.jelzo,aktReteg,prec.reteg) then begin

                  Jelzobeallit(jm,prec.jelzo);

                  tm[1].Seek(-SizeOf(prec),1);

                  tm[1].Write(prec,SizeOf(prec));

               end;

           end;

       2:  For i:=1 to (tm[2].Size div SizeOf(vrec)) do begin

               tm[2].Read(vrec,SizeOf(vrec));

               If GetAction(vrec.jelzo,aktReteg,vrec.reteg) then begin

                  Jelzobeallit(jm,vrec.jelzo);

                  tm[2].Seek(-SizeOf(vrec),1);

                  tm[2].Write(vrec,SizeOf(vrec));

               end;

           end;

       3:  For i:=1 to (tm[3].Size div SizeOf(szrec)) do begin

               tm[3].Read(szrec,SizeOf(szrec));

               If GetAction(szrec.jelzo,aktReteg,szrec.reteg) then begin

                  Jelzobeallit(jm,szrec.jelzo);

                  tm[3].Seek(-SizeOf(szrec),1);

                  tm[3].Write(szrec,SizeOf(szrec));

               end;

           end;

       4:  For i:=1 to (tm[4].Size div SizeOf(jrec)) do begin

               tm[4].Read(jrec,SizeOf(jrec));

               If GetAction(jrec.jelzo,aktReteg,jrec.reteg) then begin

                  Jelzobeallit(jm,jrec.jelzo);

                  tm[4].Seek(-SizeOf(jrec),1);

                  tm[4].Write(jrec,SizeOf(jrec));

               end;

           end;

       end;

   end;

end;

end;

 

procedure Jelzobeallit(jm:Tjelolesmod;var jelzo:byte);

begin

  Case jm of

    jmUndo   : jelzo:=SetBit(jelzo,7,0);

    jmAll,jmActReteg : jelzo:=SetBit(jelzo,7,1);

    jmAllDel : jelzo:=0;

    jmTorles : jelzo:=SetBit(jelzo,0,1);

    jmReaktiv: jelzo:=SetBit(jelzo,0,0);

    jmInvers : jelzo:=InversBit(jelzo,7);

    jmJelDel : jelzo:=SetBit(jelzo,0,GetBit(jelzo,7));

    jmFilter : jelzo:=SetBit(jelzo,4,0);    {Filter jelzők törlése}

  end;

end;

 

function IsVedett(tm:TStream;reteg,jelzo:byte;uzenet:boolean):boolean;

var r:TRetegrecord;

begin

Result := False;

ReadRec(tm,reteg,r,SizeOf(TRetegrecord));

If ((reteg=r.retegszam) and r.vedett) then begin

    Result := True;

    If uzenet then

       MessaGeDlg('VÉDETT RÉTEG : '+IntToStr(r.retegszam),mtError,[mbOk],0);

end;

If (GetBit(jelzo,1)=1) then begin

    Result := True;

    If uzenet then MessaGeDlg('ZÁROLT rajzelem!',mtError,[mbOk],0);

end;

end;

 

Function ConfigSave(fnev:string;cw:TMapConfig):boolean;

var fPath: string;

   resu: word;

   f : file;

begin

Try

    Result:=True;

    AssignFile(f,fnev);

    Rewrite(f,1);

    BlockWrite(f,cw,Sizeof(cw),Resu);

    CloseFile(f);

except

    Result:=False;

end;

end;

 

Function ConfigLoad(fnev:string;var cw:TMapConfig):boolean;

var fPath: string;

   resu: word;

   f : file;

begin

Try

If FileExists(fnev) then begin

    Try

      Result:=True;

      AssignFile(f,fnev);

      Reset(f,1);

      BlockRead(f,cw,Sizeof(cw),Resu);

    finally

      CloseFile(f);

    end;

end;

except

    Result:=False;

end;

end;

 

{Minden réteg védelmét a vedett paraméter alapján beállítja}

procedure MindenRetegVedett(var tm:TMemoryStream;vedett:boolean);

var i: integer;

begin

tm.Seek(0,0);

For i:=0 to 255 do begin

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

   rrec.vedett:=vedett;

   tm.Seek(-SizeOf(rrec),1);

   tm.Write(rrec,SizeOf(rrec));

end;

end;

 

{ *************  BETRANSZFORMÁLÁSI RUTINOK ******************}

 

{ TRANSFormTo(mem.stream,Move,Rot,Flex,Origo,dx,dy eltolás, jelző byte jbit sorszámú bitje jelzi)

Move,Rot,Flex = logikai változók mutatják mely transzformációkat kell elvégezni;

dx,dy         = eltolás értékek;

dfi           = elforgatás szöge rad-ban;

nyujtás       = nyujtási szorzó; (1=nincs nyujtás)

A térkép minden kijelölt elemét betranszformálja.

}

procedure TransFormTo(var tm:TRajzelemStream;

                         Move,Rot,Flex:boolean;  {Eltolás,forgatás,nyujtás?}

                         POrigo:TPoint2d;        {elforgatás centruma}

                         dx,dy,                  {eltolási vektorok}

                         dfi,                    {elforgatás szöge}

                         nyujtas:real;           {nyujtási tényező}

                         jbit:integer);          {ez a jelző bit aktív}

var ii,i: longint;

   p1,p2: TPoint2d;

begin

   For ii:=1 to 4 do begin

       tm[ii].Seek(0,0);

       Case ii of

       1:  For i:=1 to (tm[1].Size div SizeOf(prec)) do begin

               tm[1].Read(prec,SizeOf(prec));

               If GetBit(prec.jelzo,jbit)=1 then begin

                  p1:=Point2D(prec.x,prec.y);

                  If Move then p1:=Point2D(p1.x+dx,p1.y+dy);

                  If Rot then p1:=Elforgatas(p1,POrigo,dfi);

                  If Flex then p1:=RelNyujtas(p1,POrigo,nyujtas,nyujtas);

                  prec.x:=p1.x;

                  prec.y:=p1.y;

                  tm[1].Seek(-SizeOf(prec),1);

                  tm[1].Write(prec,SizeOf(prec));

               end;

           end;

       2:  For i:=1 to (tm[2].Size div SizeOf(vrec)) do begin

               tm[2].Read(vrec,SizeOf(vrec));

               If GetBit(vrec.jelzo,jbit)=1 then begin

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

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

                  If Move then begin

                     p1:=Point2D(vrec.x1+dx,vrec.y1+dy);

                     p2:=Point2D(vrec.x2+dx,vrec.y2+dy);

                  end;

                  If Rot then begin

                     p1:=Elforgatas(p1,POrigo,dfi);

                     p2:=Elforgatas(p2,POrigo,dfi);

                  end;

                  If Flex then begin

                     p1:=RelNyujtas(p1,POrigo,nyujtas,nyujtas);

                     p2:=RelNyujtas(p2,POrigo,nyujtas,nyujtas);

                  end;

                  vrec.x1:=p1.x; vrec.y1:=p1.y; vrec.z1:=vrec.z1;

                  vrec.x2:=p2.x; vrec.y2:=p2.y; vrec.z2:=vrec.z2;

                  tm[2].Seek(-SizeOf(vrec),1);

                  tm[2].Write(vrec,SizeOf(vrec));

               end;

           end;

       3:  For i:=1 to (tm[3].Size div SizeOf(szrec)) do begin

               tm[3].Read(szrec,SizeOf(szrec));

               If GetBit(szrec.jelzo,jbit)=1 then begin

                  p1:=Point2D(szrec.x,szrec.y);

                  If Move then p1:=Point2D(szrec.x+dx,szrec.y+dy);

                  If Rot then p1:=Elforgatas(p1,POrigo,dfi);

                  If Flex then p1:=RelNyujtas(p1,POrigo,nyujtas,nyujtas);

                  szrec.x:=p1.x; szrec.y:=p1.y;

                  tm[3].Seek(-SizeOf(szrec),1);

                  tm[3].Write(szrec,SizeOf(szrec));

               end;

           end;

       4:  For i:=1 to (tm[4].Size div SizeOf(jrec)) do begin

               tm[4].Read(jrec,SizeOf(jrec));

               If GetBit(jrec.jelzo,jbit)=1 then begin

                  p1:=Point2D(jrec.x,jrec.y);

                  If Move then p1:=Point2D(jrec.x+dx,jrec.y+dy);

                  If Rot then p1:=Elforgatas(p1,POrigo,dfi);

                  If Flex then p1:=RelNyujtas(p1,POrigo,nyujtas,nyujtas);

                  jrec.x:=p1.x; jrec.y:=p1.y;

                  tm[4].Seek(-SizeOf(jrec),1);

                  tm[4].Write(jrec,SizeOf(jrec));

               end;

           end;

       end;

   end;

end;

 

{ RelNyujtas(pont,origo,nyujtási tényező):ujpont;

A orióhoz viszonyított középpontos nyujtás

}

function RelNyujtas(p,POrigo:TPoint2D;nyujtasx,nyujtasy:real):TPoint2D;

begin

Result.x := POrigo.x + nyujtasx * (p.x - POrigo.x);

Result.y := POrigo.y + nyujtasy * (p.y - POrigo.y);

end;

 

{Egy pp1 pontot rávetít merőlegesen a vonalra, és a metszéspontot,

valamint a két vonaldarabot el is menti}

procedure PontBeillesztVonalra(var tm:TStream;vr:TVonalrecord;pp1:TPoint2d);

begin

end;

 

procedure RegioFestes(PoliStream:TStream;ca:TCanvas;cw:TMapConfig);

var i: longint;

   pr,kiindulo: Tpontrecord;

   x,y,meret: integer;

   t: TRect;

   Rgn: HRgn;

   LBR : TLogBrush;

   HB: HBrush;

   pTomb: Array[0..2000] of TPoint;

begin

  If PoliStream.Size>0 then begin

     meret := (PoliStream.Size div SizeOf(pr));

     PoliStream.seek(0,0);

     t:=Ca.Cliprect;

     For i:=0 to meret do begin

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

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

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

         pTomb[i]:=Point(x,y);

     end;

     Rgn:=CreatePolygonRgn(pTomb,meret,ALTERNATE);

{      LBR.lbStyle:=BS_SOLID; LBR.lbColor:=CLBLUE; LBR.lbHatch:=HS_BDIAGONAL;

     HB:=CreateBrushIndirect(LBR);}

     HB:=CreateSolidBrush(clBlue);

     FillRgn(Ca.Handle,Rgn,HB);

     DeleteObject(Rgn);

  end;

end;

 

Function RetegSzamKap(rtgStream:TMemoryStream;rnev: string): word;

var i: integer;

   r: TRetegRecord;

   meret: longint;

begin

Result:=0;

meret:=rtgStream.Size div SizeOf(r);

with rtgstream do begin

      Seek(0,0);

   For i:=0 to 255 do begin

       Read(r,SizeOf(r));

       If r.retegnev=Copy(rnev,1,Length(r.retegnev)) then begin

          Result:=i; exit;

       end;

   end;

end;

end;

 

Function DXFTRKconverter(var tm: TRajzelemStream;var rtgstream:TMemoryStream;

        dxffn,trkfn:string;mentes:boolean;csik:TGauge):boolean;

Type Tdxfmod = (dxfNONSEC,dxfHEADER,dxfTABLES,dxfBLOCKS,dxfENTITIES,dxfEOF);

    TdxfTable = (dxfNONTABLE,dxfLTYPE,dxfLAYER,dxfSTYLE,dxfUCS);

    Tdxfelozo = (semmi,pont,vonal,szoveg,sokszog,kor);

    lTypeRec = record

      linetypename : string[40];

      linewidth    : byte;

    end;

var dxfmod: Tdxfmod;

    dxfTable: TdxfTable;

    dxfelozo,rmuj: Tdxfelozo;

    FontList:TStringList;

    fn,fpath,sor: string;

    f,f1: file; ft: TEXTFILE;

    resu: word;

    retegszam: integer;

    p3d,op3d: TPoint3d;

    vertexdb: integer;    {a polyline oldalszáma}

    fs,hol,maxpontszam: longint;

    i: longint;

    cw: TMapconfig;

    oldvrec : TVonalrecord;

    zartpolygon : boolean;

    tTypeStream: TMemoryStream;

 

    Function RetegKinyer(s:string):byte;

    begin

           Try

              If IsNum(sor) then

                 Result:=StrToInt(Alltrim(sor))-1

              else

                 Result:=RetegszamKap(rtgstream,sor);

              If Result<0 then vrec.reteg:=0;

           except

                 On Exception do vrec.reteg:=0;

           end;

    end;

begin

{DXF FILE feldolgozás}

Try

If FileExists(dxffn) then

begin

   Decimalseparator:='.';

   FontList:=TStringList.Create;

   FontList.AddStrings(Screen.Fonts);

   tTypeStream:= TMemoryStream.Create;

{    cw.vonalszam:=0; cw.szovegszam:=0;}

   if csik<>nil then begin csik.Progress:=0; hol:=0; end;

   maxpontszam := MaxPontszamKeres(tm[1]);

   AssignFile(ft,dxffn); Reset(ft);

   AssignFile(f1,dxffn); Reset(f1);

   fs:=Filesize(f1); CloseFile(f1);

   dxfelozo:=semmi;

   While not EOF(ft) do

   begin

     If (sor='ENDSEC') then dxfMod:=dxfNONSEC;

     ReadLn(ft,sor); hol:=hol+Length(sor);

     IF sor='HEADER' then dxfmod := dxfHEADER;

     IF sor='TABLES' then dxfmod := dxfTABLES;

     IF sor='BLOCKS' then dxfmod := dxfBLOCKS;

     IF sor='ENTITIES' then dxfmod := dxfENTITIES;

     Case dxfmod of

     dxfHEADER:

     begin

{      If sor='$EXTMIN' then begin

        ReadLn(ft,sor); hol:=hol+Length(sor);

        ReadLn(ft,sor); cw.minx:=StrToFloat(sor); hol:=hol+Length(sor);

        ReadLn(ft,sor); hol:=hol+Length(sor);

        ReadLn(ft,sor); cw.miny:=StrToFloat(sor); hol:=hol+Length(sor);

     end;

     If sor='$EXTMAX' then begin

        ReadLn(ft,sor); hol:=hol+Length(sor);

        ReadLn(ft,sor); cw.maxx:=StrToFloat(sor); hol:=hol+Length(sor);

        ReadLn(ft,sor); hol:=hol+Length(sor);

        ReadLn(ft,sor); cw.maxy:=StrToFloat(sor); hol:=hol+Length(sor);

     end;}

     end;

 

     dxfTABLES:

     repeat

        ReadLn(ft,sor); hol:=hol+Length(sor);

        IF sor='TABLE' then begin

           ReadLn(ft,sor); hol:=hol+Length(sor);

           ReadLn(ft,sor); hol:=hol+Length(sor);

           If sor='LTYPE' then dxfTable:=dxfLTYPE;

           If sor='LAYER' then dxfTable:=dxfLAYER;

           If sor='STYLE' then dxfTable:=dxfSTYLE;

           If sor='UCS'   then dxfTable:=dxfUCS;

 

           Case dxfTable of

 

           dxfLTYPE:

           begin

{              ReadLn(ft,sor); hol:=hol+Length(sor);

             If sor=' 70' then begin

                ReadLn(ft,sor); hol:=hol+Length(sor);

             end;

             While sor<>'ENDTAB' do begin

                 If sor='LTYPE' then begin

                    Repeat

                    ReadLn(ft,sor); hol:=hol+Length(sor);

                    If sor='  2' then begin

                      ReadLn(ft,sor); hol:=hol+Length(sor);

                      lTypeRec.linetypename := sor;

                    end;

                    Until sor='  0';

                 end;

             end;}

             dxfTable:=dxfNONTABLE;

           end;

 

           dxfSTYLE:

           begin

             dxfTable:=dxfNONTABLE;

           end;

 

           dxfUCS:

           begin

             dxfTable:=dxfNONTABLE;

           end;

 

           dxfLAYER:

           begin

             RetegstreamNull(rtgStream);

             rtgStream.Seek(0,0);

             retegszam:=0;

             ReadLn(ft,sor); hol:=hol+Length(sor);

             While sor<>'ENDTAB' do begin

                 ReadLn(ft,sor); hol:=hol+Length(sor);

                 RrecNull(rrec);

                 If sor='LAYER' then begin

                    Repeat

                          ReadLn(ft,sor); hol:=hol+Length(sor);

                          If sor='  2' then begin   {Rétegnév}

                             ReadLn(ft,sor); hol:=hol+Length(sor);

                             rrec.retegszam:=retegszam;

                             rrec.retegnev :=sor;

                          end;

                          If sor=' 62' then begin   {vonalszín}

                             ReadLn(ft,sor); hol:=hol+Length(sor);

                             rrec.vonalszin:=StandardColor(strtoint(sor));

                             rrec.szovegszin:=StandardColor(strtoint(sor));

                          end;

                          If sor='  6' then begin   {vonaltipus}

                             ReadLn(ft,sor); hol:=hol+Length(sor);

                             rrec.vonalstylus:=0;

                          end;

                    Until sor='  0';

                    if rrec.retegnev<>'0' then begin

                       rtgStream.Write(rrec,SizeOf(rrec));

                       retegszam:=retegszam+1;

                    end;

                 end;

             end;

             dxfTable:=dxfNONTABLE;

           end;

 

           end;

        end;

 

     until (sor='ENDSEC') or EOF(ft);

 

     dxfENTITIES:

     begin

     If sor='POINT' then begin

        recNull(prec);

        repeat

        dxfelozo:=pont;

        ReadLn(ft,sor); hol:=hol+Length(sor);

        If sor = ' 10' then begin

           ReadLn(ft,sor); prec.x:=StrToFloat(sor); hol:=hol+Length(sor);

        end;

        If sor = ' 20' then begin

           ReadLn(ft,sor); prec.y:=StrToFloat(sor); hol:=hol+Length(sor);

        end;

        If sor = ' 30' then begin

           ReadLn(ft,sor); prec.z:=StrToFloat(sor); hol:=hol+Length(sor);

        end;

        If sor = '  1' then begin

           ReadLn(ft,sor); prec.no:=StrToInt(sor); hol:=hol+Length(sor);

        end;

        Until (sor='  0') or EOF(ft);

        inc(Maxpontszam);prec.No:=Maxpontszam;

        tm[1].Write(prec,SizeOf(prec));

        Inc(cw.pontszam);

     end;

 

     If sor='LINE' then begin

        recnull(vrec);

        repeat

        dxfelozo:=vonal;

        ReadLn(ft,sor); hol:=hol+Length(sor);

        If sor = '  8' then begin

           ReadLn(ft,sor); hol:=hol+Length(sor);

           vrec.reteg := RetegKinyer(sor);

        end;

        If sor=' 62' then begin