pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

fpvviewer: Starts the contour line code

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@2365 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
sekelsenmat
2012-03-27 07:23:43 +00:00
parent 1d62d1e9f3
commit 3d8de9876b
5 changed files with 375 additions and 16 deletions
Download Patch File Download Diff File Expand all files Collapse all files

292
applications/fpvviewer/coreconrec.pas Normal file
View File

@ -0,0 +1,292 @@
//------------------------------------------------------------------------------
{
IMPLEMENTATION BY 2000-2001 Alexander Weidauer for the Delphi/V Code.
This software is only IMPLEMENTED by Alexander Weidauer.
This code is based on the work of Nicholas Yue CONREC.C
and the Paul D. Bourke CONREC.F routine.
The authors hereby grant permission to use, copy, and distribute this
software and its documentation for any purpose, provided that existing
copyright notices are retained in all copies and that this notice is included
verbatim in any distributions. Additionally, the authors grant permission to
modify this software and its documentation for any purpose, provided that
such modifications are not distributed without the explicit consent of the
authors and that existing copyright notices are retained in all copies. Some
of the algorithms implemented by this software are patented, observe all
applicable patent law.
IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY FOR
DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF,
EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, INCLUDING,
BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A
PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN
"AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE
MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
}
//------------------------------------------------------------------------------
//==============================================================================
//
// CONREC is a contouring subroutine for rectangularily spaced data.
//
// It emits calls to a line drawing subroutine supplied by the user
// which draws a contour map corresponding to float (4 byte) on a randomly
// spaced rectangular grid. The coordinates emitted are in the same
// units given in the x[] and y[] arrays as sample:
//
// x[0]:=0; x[1]:=1;..x[dimx-1]:=dimx-1; and
// y[0]:=0; y[1]:=1;..y[dimy-1]:=dimy-1;.
//
//
// Any number of contour levels may be specified but they must be
// in order of increasing value as sample:
// z[0]:=-100; z[1]:=-50;..z[dimh-1]:=100;
// and the number of contur levels must be given as sample dimh.
//
//
// As this code is ported as from FORTRAN-77, ANSI C, Delphi and the
// procedural is of course a PASCALIAN
// please be very careful of the various indices like ilb,iub,jlb and jub,
// remeber that C/C++ and for dynamic arrays in delphi indices
// starts from zero (0)
//
//==============================================================================
unit CoreConRec;
interface
uses
SysUtils, Math;
//------------------------------------------------------------------------------
type
TMatrix = Array Of Array of Double;
TVector = Array Of Double;
TVectorL4D = Array [0..4] of Double;
TVectorL4I = Array [0..4] of Integer;
TCastArray = Array [0..2,0..2,0..2] of Integer;
Procedure Conrec(D: TMatrix ; // 2D - Data field
ilb,iub, // west - east ilb lower bound
// iub upper bound
jlb,jub : Integer; // north - south jlb lower bound
// jub upper bound
x : TVector; // coord. vector west - east
y : TVector; // coord. vector north - south
nc: Integer; // nc number of cut levels
z : TVector); // values of cut levels
implementation
Procedure Conrec(D: TMatrix ; // 2D - Data field
ilb,iub, // west - east ilb lower bound
// iub upper bound
jlb,jub : Integer; // north - south jlb lower bound
// jub upper bound
x : TVector; // coord. vector west - east
y : TVector; // coord. vector north - south
nc: Integer; // nc number of cut levels
z : TVector); // values of cut levels
const
im : Array [0..3] of Integer = (0,1,1,0); // coord. cast array west - east
jm : Array [0..3] of Integer = (0,0,1,1); // coord. cast array north - south
var
m1,m2,m3,deside:Integer;
dmin,dmax,x1,x2,y1,y2:Double;
lcnt,i,j,k,m:Integer;
casttab : TCastArray;
h : TVectorL4D;
sh : TVectorL4I;
xh,yh : TVectorL4D;
temp1,temp2:Double ;
r:Byte;
// ------- service xsec west east lin. interpol -------------------------------
Function xsec(p1,p2:Integer):Double;
Begin
result:=(h[p2]*xh[p1]-h[p1]*xh[p2])/(h[p2]-h[p1]);
End;
//------- service ysec north south lin interpol -------------------------------
Function ysec(p1,p2:Integer):Double;
Begin
result := (h[p2]*yh[p1]-h[p1]*yh[p2])/(h[p2]-h[p1]);
End;
begin
// set casting array
casttab[0,0,0]:=0;casttab[0,0,1]:=0;casttab[0,0,2]:=8;
casttab[0,1,0]:=0;casttab[0,1,1]:=2;casttab[0,1,2]:=5;
casttab[0,2,0]:=7;casttab[0,2,1]:=6;casttab[0,2,2]:=9;
casttab[1,0,0]:=0;casttab[1,0,1]:=3;casttab[1,0,2]:=4;
casttab[1,1,0]:=1;casttab[1,1,1]:=3;casttab[1,1,2]:=1;
casttab[1,2,0]:=4;casttab[1,2,1]:=3;casttab[1,2,2]:=0;
casttab[2,0,0]:=9;casttab[2,0,1]:=6;casttab[2,0,2]:=7;
casttab[2,1,0]:=5;casttab[2,1,1]:=2;casttab[2,1,2]:=0;
casttab[2,2,0]:=8;casttab[2,2,1]:=0;casttab[2,2,2]:=0;
// set line counter
lcnt:=0;
//-----------------------------------------------------------------------------
For j:=jub-1 DownTo jlb Do Begin // over all north - south and +For j
For i:=ilb To iub-1 Do Begin // east - west coordinates of datafield +For i
// set casting bounds from array
temp1 := min(D[i , j],D[i ,j+1]);
temp2 := min(D[i+1, j],D[i+1,j+1]);
dmin := min(temp1, temp2);
temp1 := max(D[i , j],D[i ,j+1]);
temp2 := max(D[i+1, j],D[i+1,j+1]);
dmax := max(temp1, temp2);
If (dmax>=z[0]) And (dmin<=z[nc-1]) Then Begin // ask horzintal cut avail. +If dmin && dmax in z[0] .. z[nc-1]
For k:=0 To nc-1 Do Begin // over all possible cuts ---- +For k
If (z[k]>dmin) And (z[k]<=dmax) Then Begin // aks for cut intervall ----- +If z[k] in dmin .. dmax
//-----------------------------------------------------------------------
For m:=4 Downto 0 Do Begin // deteriening the cut casts and set the ---- +For m
If (m>0) Then Begin // height and coordinate vectors
h[m] := D[i+im[m-1],j+jm[m-1]]-z[k];
xh[m] := x[i+im[m-1]];
yh[m] := y[j+jm[m-1]];
End Else Begin
h[0] := (h[1]+h[2]+h[3]+h[4])/4;
xh[0] := (x[i]+x[i+1])/2;
yh[0] := (y[j]+y[j+1])/2;
End; // If m>0 then Else
If h[m]>0 Then sh[m]:=1
Else If h[m]<0 Then sh[m]:=-1
Else sh[m]:=0;
End; // ----------------------------------------------------------------- -For m
//-----------------------------------------------------------------------
For m:=1 to 4 Do Begin // set directional casttable
//
// Note: at this stage the relative heights of the corners and the
// centre are in the h array, and the corresponding coordinates are
// in the xh and yh arrays. The centre of the box is indexed by 0
// and the 4 corners by 1 to 4 as shown below.
// Each triangle is then indexed by the parameter m, and the 3
// vertices of each triangle are indexed by parameters m1,m2,and
// m3.
// It is assumed that the centre of the box is always vertex 2
// though this isimportant only when all 3 vertices lie exactly on
// the same contour level, in which case only the side of the box
// is drawn.
//
// AS ANY BODY NOWS IST FROM THE ORIGINAL
//
// vertex 4 +-------------------+ vertex 3
// | \ / |
// | \ m-3 / |
// | \ / |
// | \ / |
// | m=2 X m=2 | the centre is vertex 0
// | / \ |
// | / \ |
// | / m=1 \ |
// | / \ |
// vertex 1 +-------------------+ vertex 2
//
//
//
// Scan each triangle in the box
//
m1 := m; m2 := 0;
If NOT(m=4) Then m3 := m+1 Else m3 :=1;
deside := casttab[sh[m1]+1 ,sh[m2]+1, sh[m3]+1];
If NOT(deside=0) Then Begin // ask is there a desition available -------- +If If NOT(deside=0)
Case deside Of // ------- determin the by desided cast cuts ------------ +Case deside;
1: Begin x1:=xh[m1]; y1:=yh[m1]; x2:=xh[m2]; y2:=yh[m2]; End;
2: Begin x1:=xh[m2]; y1:=yh[m2]; x2:=xh[m3]; y2:=yh[m3]; End;
3: Begin x1:=xh[m3]; y1:=yh[m3]; x2:=xh[m1]; y2:=yh[m1]; End;
4: Begin x1:=xh[m1]; y1:=yh[m1]; x2:=xsec(m2,m3); y2:=ysec(m2,m3);
End;
5: Begin x1:=xh[m2]; y1:=yh[m2]; x2:=xsec(m3,m1); y2:=ysec(m3,m1);
End;
6: Begin x1:=xh[m3]; y1:=yh[m3]; x2:=xsec(m1,m2); y2:=ysec(m1,m2);
End;
7: Begin x1:=xsec(m1,m2); y1:=ysec(m1,m2);
x2:=xsec(m2,m3); y2:=ysec(m2,m3);
End;
8: Begin x1:=xsec(m2,m3); y1:=ysec(m2,m3);
x2:=xsec(m3,m1); y2:=ysec(m3,m1);
End;
9: Begin x1:=xsec(m3,m1); y1:=ysec(m3,m1);
x2:=xsec(m1,m2); y2:=ysec(m1,m2);
End;
End; // --------------------------------------------------------------- -Case deside;
// ----------Do someting with the results ----------------------------
// Writeln(Format('%2.2f %2.2f %2.2f %2.2f %2.2f',
// [z[k],x1,y1,x2,y2]));
//DrawingProc(z[k],x1,y1,x2,y2);
// -------------------------------------------------------------------
end; // ----------------------------------------------------------------- -If Not(deside=0)
end; // ------------------------------------------------------------------ -For m
end; // ------------------------------------------------------------------- -If z[k] in dmin .. dmax
end; // -------------------------------------------------------------------- -For k
end; // --------------------------------------------------------------------- -If dmin && dmax in z[0] .. z[nc-1]
end; // ---------------------------------------------------------------------- -For i
end; // ----------------------------------------------------------------------- -For j
end;
(*
//------------------------------------------------------------------------------
// TestProcedure
//------------------------------------------------------------------------------
Const dimx = 100; // dimension west - east
dimy = 100; // dimenstion north west
dimh = 10; // dimension for contour levels
//------------------------------------------------------------------------------
Var
Mat:TMatrix; // 2D - Datafield
scx:TVector; // scaling vector west - east
scy:TVector; // scaling vector north - west
hgt:TVector; // vector for the countur levels
i,j:Integer; // adress indexes
x,y:Double; // coord. values
mi,ma:Double; // for minimum & maximum
//------------------------------------------------------------------------------
Begin
setlength(scx,dimx); // create dynamicly the vectors and datafield
setlength(scy,dimy);
setlength(hgt,dimh);
setlength(mat,dimx);
For i:=0 to dimx-1 Do Setlength(mat[i],dimy);
For i:=0 to dimx-1 Do scx[i]:= i * 10; // set scaling vector west - east
For i:=0 to dimy-1 Do scy[i]:= i * 10; // set scaling vector north - south
For i:=0 to dimx-1 Do // ----------------------------------- set 2d data field
For j:=0 to dimy-1 Do Begin
x:=i-dimx/2;
y:=j-dimy/2;
mat[i,j]:= (sin(x/dimx*4*pi) * cos(y/dimy*4*pi)) +
(sin(x/dimx*2*pi) * cos(y/dimy*2*pi)) +
(sin(x/dimx*1*pi) * cos(y/dimy*1*pi)) +
(sin(x/dimx*0.5*pi) * cos(y/dimy*0.5*pi))+
(sin(x/dimx*0.25*pi) * cos(y/dimy*0.25*pi));
End; // -----------------------------------------------------------------------
mi:=1e16; // ------------ Set the minimunm and maximum fof the data field
ma:=-1e16;
For i:=0 to dimx-1 Do
For j:=0 to dimy-1 Do Begin
if mat[i,j]<mi then mi:=mat[i,j];
if mat[i,j]>ma then ma:=mat[i,j];
End; //----------------------------------------------------------------
For i:=0 to dimh-1 Do hgt[i]:=mi+i*(ma-mi)/(dimh-1); // ----- create cut levels
conrec(mat,0,dimx-1,0,dimy-1,scx,scy,dimh,hgt); // call the contour algorithm*)
end.

23
applications/fpvviewer/fpvv_mainform.lfm
View File

@ -1,7 +1,7 @@
object frmFPVViewer: TfrmFPVViewer
Left = 318
Left = 322
Height = 473
Top = 299
Top = 143
Width = 485
Caption = 'Free Pascal Vectorial Viewer'
ClientHeight = 473
@ -11,7 +11,7 @@ object frmFPVViewer: TfrmFPVViewer
LCLVersion = '0.9.31'
object editFileName: TFileNameEdit
Left = 8
Height = 25
Height = 22
Top = 8
Width = 304
DialogOptions = []
@ -33,7 +33,7 @@ object frmFPVViewer: TfrmFPVViewer
end
object spinScale: TFloatSpinEdit
Left = 72
Height = 25
Height = 16
Top = 72
Width = 168
DecimalPlaces = 6
@ -46,9 +46,9 @@ object frmFPVViewer: TfrmFPVViewer
end
object Label1: TLabel
Left = 8
Height = 18
Height = 17
Top = 79
Width = 58
Width = 56
Caption = 'Scale by:'
ParentColor = False
end
@ -77,8 +77,6 @@ object frmFPVViewer: TfrmFPVViewer
object pageViewer: TPage
end
object Page2: TPage
ClientWidth = 135
ClientHeight = 159
object DXFTreeView: TTreeView
Left = 8
Height = 313
@ -107,4 +105,13 @@ object frmFPVViewer: TfrmFPVViewer
OnClick = Button1Click
TabOrder = 6
end
object btnContourLines: TButton
Left = 256
Height = 25
Top = 71
Width = 224
Caption = 'Generate Contour Lines'
OnClick = btnContourLinesClick
TabOrder = 7
end
end

62
applications/fpvviewer/fpvv_mainform.pas
View File

@ -6,8 +6,8 @@ interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, EditBtn,
StdCtrls, Spin, ExtCtrls, ComCtrls,
fpvv_drawer, fpimage, fpcanvas;
StdCtrls, Spin, ExtCtrls, ComCtrls, Grids,
fpvv_drawer, fpimage, fpcanvas, coreconrec;
type
@ -17,6 +17,7 @@ type
btnVisualize: TButton;
btnViewDXFTokens: TButton;
Button1: TButton;
btnContourLines: TButton;
buttonRenderingTest: TButton;
editFileName: TFileNameEdit;
notebook: TNotebook;
@ -25,6 +26,7 @@ type
spinScale: TFloatSpinEdit;
Label1: TLabel;
DXFTreeView: TTreeView;
procedure btnContourLinesClick(Sender: TObject);
procedure btnVisualizeClick(Sender: TObject);
procedure btnViewDXFTokensClick(Sender: TObject);
procedure Button1Click(Sender: TObject);
@ -45,7 +47,7 @@ var
implementation
uses
fpvectorial, cdrvectorialreader, svgvectorialwriter,
fpvectorial, lasvectorialreader, svgvectorialwriter,
dxfvectorialreader, epsvectorialreader,
fpvtocanvas,
dxftokentotree;
@ -105,6 +107,60 @@ begin
end;
end;
procedure TfrmFPVViewer.btnContourLinesClick(Sender: TObject);
const
dimx = 100; // dimension west - east
dimy = 100; // dimenstion north west
dimh = 10; // dimension for contour levels
var
Mat:TMatrix; // 2D - Datafield
scx:TVector; // scaling vector west - east
scy:TVector; // scaling vector north - west
hgt:TVector; // vector for the countur levels
i,j:Integer; // adress indexes
x,y:Double; // coord. values
mi,ma:Double; // for minimum & maximum
begin
setlength(scx,dimx); // create dynamicly the vectors and datafield
setlength(scy,dimy);
setlength(hgt,dimh);
setlength(mat,dimx);
For i:=0 to dimx-1 Do Setlength(mat[i],dimy);
For i:=0 to dimx-1 Do scx[i]:= i * 10; // set scaling vector west - east
For i:=0 to dimy-1 Do scy[i]:= i * 10; // set scaling vector north - south
For i:=0 to dimx-1 Do // ----------------------------------- set 2d data field
For j:=0 to dimy-1 Do Begin
x:=i-dimx/2;
y:=j-dimy/2;
mat[i,j]:= (sin(x/dimx*4*pi) * cos(y/dimy*4*pi)) +
(sin(x/dimx*2*pi) * cos(y/dimy*2*pi)) +
(sin(x/dimx*1*pi) * cos(y/dimy*1*pi)) +
(sin(x/dimx*0.5*pi) * cos(y/dimy*0.5*pi))+
(sin(x/dimx*0.25*pi) * cos(y/dimy*0.25*pi));
end; // -----------------------------------------------------------------------
mi:=1e16; // ------------ Set the minimunm and maximum fof the data field
ma:=-1e16;
For i:=0 to dimx-1 Do
For j:=0 to dimy-1 do
begin
if mat[i,j]<mi then mi:=mat[i,j];
if mat[i,j]>ma then ma:=mat[i,j];
End; //----------------------------------------------------------------
For i:=0 to dimh-1 Do hgt[i]:=mi+i*(ma-mi)/(dimh-1); // ----- create cut levels
conrec(mat,0,dimx-1,0,dimy-1,scx,scy,dimh,hgt); // call the contour algorithm*)
// Finalization of allocated memory
setlength(scx, 0);
setlength(scy, 0);
setlength(hgt, 0);
For i:=0 to dimx-1 Do Setlength(mat[i], 0);
setlength(mat, 0);
end;
procedure TfrmFPVViewer.btnViewDXFTokensClick(Sender: TObject);
var
Reader: TvDXFVectorialReader;

12
applications/fpvviewer/fpvviewer.lpi
View File

@ -21,7 +21,7 @@
<Macro1 Name="LCLWidgetType" Value="qt"/>
</MacroValues>
<CompilerOptions>
<Version Value="10"/>
<Version Value="11"/>
<Target>
<Filename Value="fpvviewer"/>
</Target>
@ -69,7 +69,7 @@
<PackageName Value="LCL"/>
</Item3>
</RequiredPackages>
<Units Count="4">
<Units Count="5">
<Unit0>
<Filename Value="fpvviewer.lpr"/>
<IsPartOfProject Value="True"/>
@ -92,16 +92,20 @@
<IsPartOfProject Value="True"/>
<UnitName Value="fpvv_drawer"/>
</Unit3>
<Unit4>
<Filename Value="coreconrec.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="CoreConRec"/>
</Unit4>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="10"/>
<Version Value="11"/>
<Target>
<Filename Value="fpvviewer"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<OtherUnitFiles Value="fpvectorialsrc"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>

2
applications/fpvviewer/fpvviewer.lpr
View File

@ -7,7 +7,7 @@ uses
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, fpvv_mainform, dxftokentotree, fpvv_drawer, fpvectorialpkg
Forms, fpvv_mainform, dxftokentotree, fpvv_drawer, fpvectorialpkg, CoreConRec
{ you can add units after this };
{$R *.res}