RASVEC

Top  Previous  Next

{ VEKTORIZÁLÁS - Vektorization }

 

{ Raszter-vektor konverziós rutinok}

unit Rasvec;

 

interface

uses

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

Geom, Gauges;

 

Type

 

TRajz_elem = record               {Sablon file *.SBL adatblokk rekord}

No           : Longint;         {Sorszám}

ObjCode      : Longint;         {Objektum kód}

torolt       : boolean;

FuncCode     : byte;            {0,1=Toll fel,pozicionálás,2=vonal,3=kör,4=köriv}

X            : Longint;         {1000*x, 1/1000 mm = 1}

Y            : Longint;

Z            : Longint;

R            : Longint;

kijelolt     : boolean;

end;

 

TLine      = record

x1,y1,x2,y2 : integer;

end;

 

{A Canvas kontúrvonalakat a tm stream-en TPoint rekordokkal helyezi el}

procedure ScanImage(Ca:TCanvas;var tm:TMemoryStream);

{A scane-elt képet megjeleníti a szkennelt pontokkal}

procedure ScanDraw(Ca:TCanvas;tm:TMemoryStream;color:TColor;vonal:boolean;sebesseg:longint);

{A scannelt terület befoglaló téglalapját adja}

function  ScanRect(tm:TMemoryStream):Trect;

{A legközelebbi pont megkeresése a streamen}

Function FollowPoint(tm:TMemoryStream;p0:TPoint;var newPoz:longint;var tav:extended):TPoint;

{A scannelt pontokat sorbarendezi = Uj vonalak száma}

function ScanSort(var tm:TMemoryStream):longint;

{A scannelt pontokat összefüggő vonalakká rendezi = Uj vonalak száma}

procedure GetContour(var tm:TMemoryStream;csik: TGauge);

procedure Rajzelem_Null(var r:TRajz_elem);

procedure ContourToSablon(tm,sblSTM:TMemoryStream);

procedure ContourTopologia(tm,sblSTM:TMemoryStream);

 

Function SetLineRec(x1,y1,x2,y2:integer):TLine;

{A tmTopol stream n. TLine rekordját adja vissza, vagy TLine()=nil rekordot}

function LoadLineRec(tm:TMemoryStream;n:longint):TLine;

{A tmTopol stream n. TLine rekordját elmenti; ha a stream kisebb, akkor a végére}

procedure SaveLineRec(var tm:TMemoryStream;linRec:TLine;n:longint);

{A sorbarendezett kontúr pontokat tartalmazó tm stream-en megkeresi a sarokpontokat}

function GetContourCorners(Ca:TCanvas;tm,tmTopol:TMemoryStream;color:TColor):longint;

procedure CornerCorrections(Ca:TCanvas;tm,tmTopol:TMemoryStream;color:TColor);

 

function LinearRegressionPoint(tm:TMemoryStream; var a,b : double):boolean;

{Lineáris regresszió A-B pozíciók között a tm streamen tárolt Point adatokra}

function LinRegAB(tm:TMemoryStream; posA,posB:longint; var a,b : double):boolean;

function VektorLinearRegression(tm:TMemoryStream; var a,b : double):TRect;

function GetRectPointStream(tm:TMemoryStream):TRect;

 

Var tmVectors : TMemoryStream;

 

implementation

 

{A Canvas kontúrvonalakat a tm stream-en TPoint rekordokkal helyezi el}

{procedure ScanImage(Ca:TCanvas;var tm:TMemoryStream);

var x,y,meret,i:longint;

  pc,oldPixel,upPixel,DownPixel: TColor;

  p: TPoint;

  t        : TRect;

begin

tm.Clear;

oldPixel:=clWhite;

t:=ca.Cliprect;

With Ca do begin

  Pen.Mode:=pmNotXor;

  For y:=1 to t.Bottom-1 do begin

      For x:=1 to t.Right-1 do begin

          upPixel:=Pixels[x,y-1];

          pc:=Pixels[x,y];

          DownPixel:=Pixels[x,y+1];

          If (pc=clBlack) then Pixels[x,y]:=clYellow;

          if (pc<>oldPixel)

          or ((pc=clBlack) and ((UpPixel=clWhite) or (DownPixel=clWhite)))

          then

          begin

              Pixels[x,y]:=clBlue;

              oldPixel:=pc;

              p:=Point(x,y);

              tm.Write(p,SizeOf(TPoint));

          end else

      end;

      If (y mod 64)=0 then begin

         Ca.Refresh;

         Application.ProcessMessages;

      end;

  end;

end;

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

      exit;

end;

}

 

procedure ScanImage(Ca:TCanvas;var tm:TMemoryStream);

var x,y,meret,x0:longint;

  pc,oldPixel,upPixel,DownPixel: TColor;

  p: TPoint;

  t        : TRect;

begin

tm.Clear;

oldPixel:=clWhite;

t:=ca.Cliprect;

With Ca do begin

  Pen.Mode:=pmCopy;

  For y:=1 to t.Bottom-1 do begin

      For x:=1 to t.Right-1 do begin

          upPixel:=Pixels[x,y-1];

          pc:=Pixels[x,y];

          DownPixel:=Pixels[x,y+1];

              p:=Point(x,y);

          If (pc=clBlack) then Pixels[x,y]:=clYellow;

          if (pc<>oldPixel) then

          begin

              If oldPixel<>clBlack then begin

                 tm.Write(p,SizeOf(TPoint));

                 x0:=x;

              end else

              If x>x0+1 then begin

                 p:=Point(x-1,y);

                 tm.Write(p,SizeOf(TPoint));

              end;

              Pixels[p.x,p.y]:=clBlue;

          end

          else

          If ((pc=clBlack) and ((UpPixel=clWhite) or (DownPixel=clWhite))) then

          begin

              tm.Write(p,SizeOf(TPoint));

              Pixels[p.x,p.y]:=clBlue;

              x0:=x;

          end;

          oldPixel:=pc;

      end;

      If (y mod 64)=0 then begin

         Ca.Refresh;

         Application.ProcessMessages;

      end;

  end;

end;

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

      exit;

end;

 

{procedure ScanImage(Ca:TCanvas;var tm:TMemoryStream);

var x,y,meret,i,ii:longint;

  BlackPixel :longint;

  pc,oldPixel,NextPixel,upPixel,DownPixel: TColor;

  p : TPoint;

  t : TRect;

begin

tm.Clear;

oldPixel:=clWhite;

t:=ca.Cliprect;

With Ca do begin

  Pen.Mode:=pmCopy;

  BlackPixel := 0;

  For y:=1 to t.Bottom-1 do begin

      For x:=1 to t.Right-1 do begin

          upPixel:=Pixels[x,y-1];

          pc:=Pixels[x,y];

          nextPixel:=Pixels[x+1,y];

          DownPixel:=Pixels[x,y+1];

          If (pc=clBlack) then begin

             Pixels[x,y]:=clYellow;

             Inc(BlackPixel);

          end;

          if (pc<>oldPixel) then begin

              p:=Point(x,y);

              If BlackPixel=1 then begin

                 tm.Write(p,SizeOf(TPoint));

                 ii:=x;

              end else

              If x>ii+1 then begin

                 p:=Point(x-1,y);

                 tm.Write(p,SizeOf(TPoint));

              end;

              Pixels[p.x,p.y]:=clBlue;

              BlackPixel := 0;

              oldPixel:=pc;

          end else

          If ((pc=clBlack) and ((UpPixel=clWhite) or (DownPixel=clWhite))) then

          begin

              p:=Point(x,y);

              Pixels[x,y]:=clBlue;

              tm.Write(p,SizeOf(TPoint));

              oldPixel:=pc;

              BlackPixel := 0;

          end;

      end;

      If (y mod 64)=0 then begin

         Ca.Refresh;

         Application.ProcessMessages;

      end;

  end;

end;

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

      exit;

end;

}

 

{A scane-elt képet megjeleníti a szkennelt pontokkal}

procedure ScanDraw(Ca:TCanvas;tm:TMemoryStream;color:TColor;vonal:boolean;sebesseg:longint);

var meret,i:longint;

  p,po: TPoint;

  d: extended;

  DC : HDC;

begin

DC := SaveDC(ca.Handle);

Ca.FillRect(Ca.ClipRect);

Application.ProcessMessages;

Ca.Pen.Mode:=pmCopy;

Ca.Pen.Color:=color;

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

tm.Seek(0,0);

d:=1;

For i:=1 to meret do begin

    po := p;

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

    Try

    If i>1 then

       d:=KetPontTavolsaga(po.x,po.y,p.x,p.y);

    except

       d:=1;

    end;

    If vonal then begin

       If (i=1) or (d>2) then

          Ca.MoveTo(p.x,p.y)

       else Ca.LineTo(p.x,p.y);

    end else Ca.Pixels[p.x,p.y]:=color;

    If sebesseg>=1 then

    IF (i mod sebesseg)=0 then Application.ProcessMessages;

end;

RestoreDC(ca.Handle,DC);

end;

 

{A scannelt terület befoglaló téglalapját adja}

function ScanRect(tm:TMemoryStream):Trect;

var meret,i:longint;

  p: TPoint;

  r: TRect;

begin

Result := Rect(10000,10000,-10000,-10000);

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

tm.Seek(0,0);

For i:=1 to meret do begin

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

    If p.x<result.Left then result.Left:=p.x;

    If p.x>result.Right then result.Right:=p.x;

    If p.y<result.Top then result.Top:=p.y;

    If p.y>result.Bottom then result.Bottom:=p.y;

end;

end;

 

{A legközelebbi pont megkeresése a streamen:

 NewPoz = a keresett TPoint rekord sorszáma;

          Ha nem talált = -1}

Function FollowPoint(tm:TMemoryStream;p0:TPoint;var newPoz:longint;var tav:extended):TPoint;

var i, meret, poz: longint;

  d: extended;

  p: TPoint;

begin

Try

poz := tm.position;

NewPoz := -1;

tav := 10e+6;

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

If meret>0 then begin

   tm.Seek(0,0);

   For i:=0 to meret-1 do begin

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

       if (p.x>Low(integer)) then begin

       If (p0.x<>p.x) then

       If (p0.y<>p.y) then

       begin

         d := KetPontTavolsaga(p0.x,p0.y,p.x,p.y);

         If d<tav then begin

            newPoz := i;

            tav    := d;

            Result := p;

         end;

       end;

       end;

   end;

end;

finally

tm.position:=poz;

end;

end;

 

{A scannelt pontokat sorbarendezi}

function ScanSort(var tm:TMemoryStream):longint;

var meret,i,ii:integer;

  p,pAct,pNext: TPoint;

  cStream: TMemoryStream;

  pos    : longint;

  d      : extended;

  van    : boolean;

label 111,112;

begin

Try

Result := 0;

cStream:= TMemoryStream.Create;

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

{ Uj vonalkezdet megkeresése}

111: tm.Seek(0,0);

   For i:=0 to meret-1 do begin

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

       if (p.x>Low(integer)) then begin

          pos := i;

          result := result+1;

          break;

       end;

       IF (i=meret) then goto 112;

   end;

   Repeat

      pAct := p;

      cStream.Write(p,SizeOf(TPoint));

      p:=Point(Low(integer),Low(integer));

      tm.Seek(pos*SizeOf(TPoint),0);

      tm.Write(p,SizeOf(TPoint));

      {A legközelebbi pont megkeresése}

      p:=FollowPoint(tm,pAct,pos,d);

      If (meret<=(cStream.Size div SizeOf(TPoint))) then break;

   Until d>2;

112:  If (meret>(cStream.Size div SizeOf(TPoint))) then goto 111;

finally

tm.LoadFromStream(cStream);

cStream.Free;

end;

end;

 

 

{A scannelt pontokat összefüggő vonalakká rendezi = Uj vonalak száma}

procedure GetContour(var tm:TMemoryStream;csik: TGauge);

var meret,i,ii,hol:longint;

  p,pAct,pNext: TPoint;

  cStream: TMemoryStream;

  pos    : longint;

  d      : extended;

  van    : boolean;

label 111,112;

begin

Try

cStream:= TMemoryStream.Create;

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

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

111: tm.Seek(0,0);

   For i:=1 to meret do begin

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

       if (p.x<>Low(integer)) then break;

       IF (i=meret) then goto 112;

   end;

Repeat

    van := False;

    pAct := p;

    cStream.Write(p,SizeOf(TPoint));

    p:=Point(Low(integer),Low(integer));

    tm.Seek(-SizeOf(TPoint),1);

    tm.Write(p,SizeOf(TPoint));

    Inc(hol);

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

    tm.Seek(4*i,0);

    For ii:=i to meret do begin

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

        if p.x>Low(integer) then

        If (Abs(pAct.x-p.x)=1) and (Abs(pAct.y-p.y)=1) then

        begin

           van:=True;

           Break;

        end;

    end;

Until not van;

112:  If (meret>(cStream.Size div SizeOf(TPoint))) then goto 111;

tm.LoadFromStream(cStream);

finally

cStream.Free;

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

end;

end;

 

 

{procedure GetContour(var tm:TMemoryStream;csik: TGauge);

var meret,i,ii,hol:longint;

  p,pAct,pNext: TPoint;

  cStream: TMemoryStream;

  pos    : longint;

  d      : extended;

  van    : boolean;

label 111,112;

begin

Try

cStream:= TMemoryStream.Create;

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

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

pos := 0;

111: tm.Seek(0,0);

   For i:=0 to meret-1 do begin

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

       if (p.x<>Low(integer)) then break;

       IF (i=meret) then goto 112;

   end;

   pos := i;

Repeat

    van := False;

    pAct := p;

    cStream.Write(p,SizeOf(TPoint));

    p:=Point(Low(integer),Low(integer));

    tm.Seek(-SizeOf(TPoint),1);

    tm.Write(p,SizeOf(TPoint));

    Inc(hol);

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

    tm.Seek(4*i,0);

    For ii:=i to meret-1 do begin

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

        if p.x>Low(integer) then

        If (Abs(pAct.x-p.x)<2) and (Abs(pAct.y-p.y)<2) then

        begin

           van:=True;

           Break;

        end;

    end;

Until not van;

112:  If (meret>(cStream.Size div SizeOf(TPoint))) then goto 111;

tm.LoadFromStream(cStream);

finally

cStream.Free;

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

end;

end;}

 

{procedure GetContour(var tm:TMemoryStream;csik: TGauge);

var meret,i,ii,hol:longint;

  p,pAct,pNext: TPoint;

  cStream: TMemoryStream;

  pos    : longint;

  d      : extended;

  van    : boolean;

label 111,112;

begin

Try

cStream:= TMemoryStream.Create;

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

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

111: tm.Seek(0,0);

   For i:=1 to meret do begin

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

       if (p.x>Low(integer)) then break;

       IF (i=meret) then goto 112;

   end;

Repeat

    van := False;

    pAct := p;

    Inc(hol);

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

    tm.Seek(0,0);

    For ii:=1 to meret do begin

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

        if p.x>Low(integer) then

        If (Abs(pAct.x-p.x)>1) or (Abs(pAct.y-p.y)>1) then

        begin

           van:=True;

           Break;

        end else begin

           pAct := p;

           cStream.Write(p,SizeOf(TPoint));

           p:=Point(Low(integer),Low(integer));

           tm.Seek(-SizeOf(TPoint),1);

           tm.Write(p,SizeOf(TPoint));

        end;

    end;

Until not van;

112:  If (meret>(cStream.Size div SizeOf(TPoint))) then goto 111;

tm.LoadFromStream(cStream);

finally

cStream.Free;

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

end;

end;}

 

{procedure GetContour(var tm:TMemoryStream;csik: TGauge);

var meret,i,ii,hol,rec:longint;

  p,pAct,pNext: TPoint;

  cStream: TMemoryStream;

  pos    : longint;

  d      : extended;

  van    : boolean;

label 111,112;

begin

Try

cStream:= TMemoryStream.Create;

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

rec := SizeOf(TPoint);

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

pos := 0;

van := meret>0;

 

While van do begin

    tm.Seek(pos*rec,0);

    While tm.Position < tm.Size do begin

       tm.Read(p,rec);

       if (p.x<>Low(integer)) then break;

    end;

    pos := tm.Position div rec;

    If pos=meret then break;

    pAct := p;

    For ii:=pos to meret-1 do begin

        if p.x>Low(integer) then

        If (Abs(pAct.x-p.x)<=1) and (Abs(pAct.y-p.y)<=1) then

        begin

            pAct := p;

            cStream.Write(p,rec);

            p:=Point(Low(integer),Low(integer));

            tm.Seek(-rec,1);

            tm.Write(p,rec);

            If csik<>nil then begin

               Inc(hol);

               csik.Progress:=Trunc(100*hol/meret);

            end;

        end;

        tm.Read(p,rec);

    end;

    If (meret<=(cStream.Size div rec)) then break;

end;

 

finally

tm.LoadFromStream(cStream);

cStream.Free;

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

end;

end;}

 

procedure Rajzelem_Null(var r:TRajz_elem);

begin

r.No        := 0;

r.ObjCode   := 0;

r.torolt    := False;

r.FuncCode  := 0;

r.x         := 0;

r.y         := 0;

r.z         := 0;

r.r         := 0;

r.kijelolt  := False;

end;

 

{Minden pontot átkonvertál sablonba:

      tm     : a TPoint rekordok stream-je;

      sblSTM : a TRajz_elem rekordok stream-je;

}

procedure ContourToSablon(tm,sblSTM:TMemoryStream);

var meret,i : integer;

  t       : TRect;

  p,po    : TPoint;

  x,y     : longint;

  d       : extended;

  re      : TRajz_elem;

begin

t := ScanRect(tm);

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

tm.Seek(0,0);

sblSTM.Clear;

p    := Point(0,0);

For i:=1 to meret do begin

    po := p;

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

    Try

      If i>1 then d:=KetPontTavolsaga(po.x,po.y,p.x,p.y)

      else d:=100;

    except

       d:=100;

    end;

    Rajzelem_Null(re);

    x        := p.x-t.left;

    y        := t.Bottom-p.y;

    re.FuncCode := 2;

    re.x:=100*(x+4); re.y:=100*(y+4);

    If (d>4) then begin

         re.FuncCode := 0;

         sblSTM.Write(re,SizeOf(re));

         re.FuncCode := 2;

         sblSTM.Write(re,SizeOf(re));

    end else begin

         sblSTM.Write(re,SizeOf(re));

    end;

end;

meret := sblSTM.Size div SizeOf(TRajz_elem);

end;

 

procedure ContourTopologia(tm,sblSTM:TMemoryStream);

var meret,i,ii:integer;

  p,po: TPoint;

  re,p_1,p_2 : TRajz_elem;

  x,y: longint;

  d  : extended;

  t  : TRect;

  dx,dy: integer;

  kiir : boolean;

begin

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

tm.Seek(0,0);

sblSTM.Clear;

d := 1;

kiir := False;

p    := Point(0,0);

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

For i:=1 to meret do begin

    po := p;

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

    Try

       d:=KetPontTavolsaga(po.x,po.y,p.x,p.y);

    except

       d:=100;

    end;

    Rajzelem_Null(re);

    x        := p.x-t.left;

    y        := t.Bottom-p.y;

    re.FuncCode := 2;

    re.x:=x+4; re.y:=y+4;

    If (d>2) or (i=2) then begin

         If i>=2 then begin

            re.x:=po.x-t.left+4;

            re.y:=t.Bottom-po.y+4;

            sblSTM.Write(re,SizeOf(re));

         end;

         re.FuncCode := 0;

         p_1 := re;

         dx:=p.x-po.x;

         dy:=p.y-po.y;

         sblSTM.Write(re,SizeOf(re));

         re.FuncCode := 2;

         sblSTM.Write(re,SizeOf(re));

    end else begin

         If (Abs(Abs(dx)-Abs(p.x-po.x))>1) or (Abs(Abs(dy)-Abs(p.y-po.y))>1) then begin

            re.FuncCode := 2;

            kiir := True;

            p_2   := re;

            sblSTM.Write(p_2,SizeOf(re));

            dx:=p.x-po.x;

            dy:=p.y-po.y;

         end;

    end;

end;

sblSTM.Write(re,SizeOf(re));

meret := sblSTM.Size div SizeOf(TRajz_elem);

end;

 

Function SetLineRec(x1,y1,x2,y2:integer):TLine;

begin

Result.x1:=x1;

Result.y1:=y1;

Result.x2:=x2;

Result.y2:=y2;

end;

 

{A sorbarendezett kontúr pontokat tartalmazó tm stream-en megkeresi a sarokpontokat.

 Ca    = Canvas rajzfelület;

 tm    = TPoint rendezett ponthalmaz stream-je;

 color = A sarokpont szine;}

function GetContourCorners(Ca:TCanvas;tm,tmTopol:TMemoryStream;color:TColor):longint;

var meret,i,ii : longint;

  posA,posB  : longint;

  p,po       : TPoint;

  p1,p2      : TPoint;

  d          : extended;

  egyenes    : TLine;

  alfa       : extended;

  alfaUj     : extended;

  a,b        : double;

  t          : TRect;

begin

Try

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

If meret < 0 then

   Result := 1

else

   Result := 0;

tmTopol.Clear;

tm.Seek(0,0);

Ca.Pen.Color:=color;

d:=100;

ii:=0;

posA := 0;

For i:=1 to meret do begin

    po := p;

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

    if i=1 then begin

       po:=p;

       p1:=p;

    end;

    Inc(ii);

    d:=KetPontTavolsaga(po.x,po.y,p.x,p.y);

    If d<4 then begin

       If (ii mod 16)=0 then begin

             p2:=p;

             egyenes := SetLineRec(p1.x,p1.y,p2.x,p2.y);

             tmTopol.Write(egyenes,sizeof(egyenes));

             p1:=p;

       end;

    end else begin

       p2:=po;

{         Ca.Ellipse(po.x-2,po.y-2,po.x+2,po.y+2);}

       egyenes := SetLineRec(p1.x,p1.y,p2.x,p2.y);

       tmTopol.Write(egyenes,sizeof(egyenes));

       p1:=p;

{         Ca.Ellipse(p.x-2,p.y-2,p.x+2,p.y+2);}

    end;

 

end;

{  Ca.Ellipse(p.x-2,p.y-2,p.x+2,p.y+2);}

p2:=p;

egyenes := SetLineRec(p1.x,p1.y,p2.x,p2.y);

tmTopol.Write(egyenes,sizeof(egyenes));

    ca.Pen.color := clGreen;

    tmTopol.Seek(0,0);

    repeat

       tmTopol.Read(egyenes,sizeof(egyenes));

       ca.MoveTo(egyenes.x1,egyenes.y1);

       ca.LineTo(egyenes.x2,egyenes.y2);

       Ca.Ellipse(egyenes.x1-1,egyenes.y1-1,egyenes.x1+1,egyenes.y1+1);

    Until tmTopol.Size=tmTopol.Position;

finally

{  tmTemp.Free;

tmTopol.Free;}

end;

end;

 

{A tmTopol stream n. TLine rekordját adja vissza, vagy TLine()=nil rekordot}

function LoadLineRec(tm:TMemoryStream;n:longint):TLine;

var pos: longint;

begin

If (tm.Size div SizeOf(TLine))>n then begin

   pos := tm.Position;

   tm.Seek(n*SizeOf(TLine),0);

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

   tm.Position := pos;

end else Result := SetLineRec(-1,-1,-1,-1);

end;

 

{A tmTopol stream n. TLine rekordját elmenti; ha a stream kisebb, akkor a végére}

procedure SaveLineRec(var tm:TMemoryStream;linRec:TLine;n:longint);

var pos: longint;

begin

pos := tm.Position;

If (tm.Size div SizeOf(TLine))>n then

   tm.Seek(n*SizeOf(TLine),0)

else

   tm.Seek(0,2);

tm.Write(linRec,SizeOf(TLine));

tm.Position := pos;

end;

 

{A 'lecsapott' sarkokat kiigazítja}

procedure CornerCorrections(Ca:TCanvas;tm,tmTopol:TMemoryStream;color:TColor);

var meret,i,ii : longint;

  tmTemp     : TMemoryStream;

  posA,posB  : longint;

  p1,p2,op   : TPoint;

  e          : TLine;

  ujvonal    : boolean;

  angleDif   : double;

  alfa,szog  : double;

  LineBegin  : boolean;

begin

Try

tmTemp := TMemoryStream.Create;

meret := tmTopol.Size div SizeOf(TPoint);

tmTopol.Seek(0,0);

e := SetLineRec(-1,-1,-1,-1);

ujvonal:=True;

LineBegin := False;

Ca.Pen.Color := clBlue;

repeat

    op := Point(e.x2,e.y2);

    tmTopol.Read(e,SizeOf(TLine));

    if (op.x<>e.x1) or (op.y<>e.y1) then begin

       If LineBegin then begin

          SaveLineRec(tmTemp,SetLineRec(p1.x,p1.y,op.x,op.y),1000000);

          ca.MoveTo(p1.x,p1.y); ca.LineTo(op.x,op.y);

{            Ca.Ellipse(op.x-2,op.y-2,op.x+2,op.y+2);}

       end;

       ujvonal:=True;

    end;

    szog := SzakaszSzog(e.x1,e.y1,e.x2,e.y2);

    If ujvonal then begin

       p1:=Point(e.x1,e.y1);

       alfa := szog;

{         Ca.Ellipse(p1.x-2,p1.y-2,p1.x+2,p1.y+2);}

       ujvonal:=False;

       LineBegin := True;

    end

    else begin

       angleDif := Szogdiff(alfa,szog);

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

       p2:=Point(e.x1,e.y1);

       If (angleDif>0.1) or (tmTopol.Position=tmTopol.Size) then begin

          If (tmTopol.Position=tmTopol.Size) then p2:=Point(e.x2,e.y2);

          SaveLineRec(tmTemp,SetLineRec(p1.x,p1.y,p2.x,p2.y),1000000);

          ca.MoveTo(p1.x,p1.y); ca.LineTo(p2.x,p2.y);

{            Ca.Ellipse(p2.x-2,p2.y-2,p2.x+2,p2.y+2);}

          ujvonal:=True;

          LineBegin := False;

       end;

    end;

until tmTopol.Position=tmTopol.Size;

finally

tmTopol.LoadFromStream(tmTemp);

tmTemp.Free;

end;

end;

 

{ Lineáris regresszió :

   In:  a tm streamen tárolt p(x,y:double) = TPoint2d;

        a és b : az egyenes meredeksége és y tengely metszéspontja

   Result : False = ha az egyenes || az y tengellyel,

            True  = minden más esetben

        }

function LinearRegressionPoint(tm:TMemoryStream; var a,b : double):boolean;

var i,meret : longint;

  x,y     : double;

  SumX,SumX2,SumY,SumXY : double;

  p       : TPoint;

begin

Try

   Result := True;

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

   SumX:=0; SumX2:=0; SumY:=0; SumXY:=0;

   tm.Seek(0,0);

   For i:=0 to meret-1 do begin

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

       SumX  := SumX+p.x;

       SumX2 := SumX2+(p.x*p.x);

       SumY  := SumY+p.y;

       SumXY := SumXY+(p.x*p.y);

   end;

   a := (meret*SumXY-SumY*SumX)/(meret*SumX2-SumX*SumX);

   b := (SumY*SumX2-SumXY*SumX)/(meret*SumX2-SumX*SumX);

except

   Result := False;

end;

end;

 

{Lineáris regresszió A-B pozíciók között a tm streamen tárolt Point adatokra}

function LinRegAB(tm:TMemoryStream; posA,posB:longint; var a,b : double):boolean;

var i,meret : longint;

  x,y     : double;

  SumX,SumX2,SumY,SumXY : double;

  p       : TPoint2d;

begin

Try

   Result := True;

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

   SumX:=0; SumX2:=0; SumY:=0; SumXY:=0;

   tm.Seek(posA*SizeOf(TPoint),0);

   For i:=posA to posB do begin

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

       SumX  := SumX+p.x;

       SumX2 := SumX2+(p.x*p.x);

       SumY  := SumY+p.y;

       SumXY := SumXY+(p.x*p.y);

   end;

   a := (meret*SumXY-SumY*SumX)/(meret*SumX2-SumX*SumX);

   b := (SumY*SumX2-SumXY*SumX)/(meret*SumX2-SumX*SumX);

except

   Result := False;

end;

end;

 

{ A ponthalmaz középvonal vektorát adja meg }

function VektorLinearRegression(tm:TMemoryStream; var a,b : double):TRect;

var

  t : Trect2d;

  f,m1,m2 : TegyenesFGV;

  k,aa,bb : double;

  tmTemp  : TMemoryStream;

  p       : TPoint2d;

begin

Result := Rect(0,0,0,0);

If LinearRegressionPoint(tm,aa,bb) then begin

   a := aa; b := bb;

   Result := GetRectPointStream(tm);

end else begin

Try

  tmTemp := TMemoryStream.Create;

  tm.Seek(0,0);

  repeat

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

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

       tmTemp.Write(p,SizeOf(TPoint));

  Until tm.Position=tm.Size;

  If LinearRegressionPoint(tmTemp,a,b) then begin

     Result := GetRectPointStream(tm);

     a      := High(Integer);

  end;

finally

  tmTemp.Free;

end;

end;

end;

 

function GetRectPointStream(tm:TMemoryStream):TRect;

var meret,i:longint;

  p: TPoint;

  r: TRect;

begin

Result := Rect(High(integer),High(integer),Low(integer),Low(integer));

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

tm.Seek(0,0);

For i:=1 to meret do begin

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

    If p.x<result.left then result.left:=p.x;

    If p.x>result.right then result.right:=p.x;

    If p.y<result.top then result.top:=p.y;

    If p.y>result.bottom then result.bottom:=p.y;

end;

end;

 

end.