MathgeomGLS

1
unit Contour;
2
{Demonstrates contour drawing features of MathImage, as well as the use
3
 of the TSurface/TLevelSurface object. The routines marked by *********** use
4
 MathImage methods.
5
 The filled level lines routine is very memory intensive. I found
6
 Robert Lee's memory manager replacement (available from Code Central)
7
 to
8
 a) speed up things a lot,
9
 b) allow me to use more grid points.}
10

11
interface
12

13
uses
14
  Winapi.Windows,
15
  Winapi.Messages,
16
  System.Classes,
17
  System.SysUtils,
18
  Vcl.Graphics,
19
  Vcl.Controls,
20
  Vcl.Forms,
21
  Vcl.Dialogs,
22
  Vcl.StdCtrls,
23
  Vcl.ExtCtrls,
24
  Vcl.Menus,
25
  Vcl.Clipbrd,
26
  //
27
  MathImage,
28
  OverlayImage;
29

30
const
31
  gxmin = -3; gxmax = 6.5; gymin = -4; gymax = 4; {graph domain}
32
  xMesh = 100; yMesh = 100; {graph mesh}
33
  c = 4;
34
  colorarray: array[0..13] of TColor = ($00CB9F74, $00D8AD49, $00E6C986,
35
    $00F2E3C1, $00DAF0C4, $00A6E089, $0086D560, $0065CFB5, $008DC5FC, $0075D5FD,
36
    $0078E1ED, $00ACEDF4, $00D0F2F7, $00F2FBFD);
37
  levelsarray: array[0..13] of MathFloat = (-1, -0.7, -0.4, -0.2, 0, 0.2, 0.4,
38
    0.6, 0.8, 1.1, 1.4, 1.6, 2.2, 4);
39

40
type
41
  TContourform = class(TForm)
42
    Panel1: TPanel;
43
    ContourlinesButton: TButton;
44
    ColorDialog1: TColorDialog;
45
    Panel2: TPanel;
46
    FilledContoursButton: TButton;
47
    GraphImage: TMathImage;
48
    Label1: TLabel;
49
    procedure ContourlinesButtonClick(Sender: TObject);
50
    procedure GraphImageResize(Sender: TObject);
51
    procedure FormCreate(Sender: TObject);
52
    procedure FormDestroy(Sender: TObject);
53
    procedure FilledContoursButtonClick(Sender: TObject);
54
    procedure FormShow(Sender: TObject);
55
  private
56
    CurrentType: Integer;
57
    GraphSurface: TLevelSurface;
58
    LevelsMade: Boolean;
59
    procedure Graph(x, y: MathFloat; var z: MathFloat);
60
    procedure MakeGraphSurface;
61
  protected
62
    procedure CreateParams(var Params: TCreateParams); override;
63
  public
64
    values: array[0..13] of TLabel;
65
    Colors: array[0..13] of TLabel;
66
  end;
67

68
var
69
  ContourForm: TContourform;
70

71
implementation
72

73

74
uses
75
  MDemo1;
76

77

78
{$R *.DFM}
79

80
procedure TContourform.CreateParams(var Params: TCreateParams);
81
begin
82
  inherited CreateParams(Params);
83
  with Params do
84
  begin
85
    WndParent := Demoform.Handle;
86
    Parent := Demoform;
87
    Style := WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN;
88
    Align := alClient;
89
  end;
90
end;
91

92

93
{*************************************}
94

95
procedure TContourform.FormCreate(Sender: TObject);
96
var
97
  i: Integer;
98
begin
99
  makegraphsurface;
100
  ControlStyle := ControlStyle + [csOpaque];
101
  currenttype := 1;
102
  for i := 0 to 13 do
103
  begin
104
    values[i] := TLabel.Create(self);
105
    with values[i] do
106
    begin
107
      Top := Label1.Top + Label1.Height + 5 + i * Label1.Height;
108
      Left := Label1.Left;
109
      Parent := Panel1;
110
      Caption := FloatToStrf(levelsarray[i], ffgeneral, 4, 4);
111
    end;
112
    Colors[i] := TLabel.Create(self);
113
    with Colors[i] do
114
    begin
115
      autosize := False;
116
      Caption := '';
117
      Left := Label1.Left + Label1.Width;
118
      Top := values[i].Top;
119
      Width := values[i].Height;
120
      Height := Width;
121
      Color := colorarray[i];
122
      Parent := Panel1;
123
    end;
124
  end;
125
end;
126

127
procedure TContourform.Graph(x, y: MathFloat; var z: MathFloat);
128
{graph formula}
129
begin
130

131
  //this first one is a real test, it looks crummy unless you
132
  //give it a mesh of about 200x200, in which case the filled level
133
  //curve drawing runs out of mem under Win2K on my machine...
134
  //****Cure: Use Robert Lee's memory manager replacement,
135
  //available from CodeCentral, it's awesome.****************
136
  //There isn't anything I can do about level
137
  //curves near intersection points looking bad,
138
  //other than increasing the mesh.
139

140
 // z := 2 * (cos(1.5 * (x - y)) + sin(1.6 * (x + 0.6 * y))) + 0.8;
141

142
  if (x <> c) or (y <> 0) then
143
    z := sin(sqrt(sqr(x) + sqr(y))) + 1 / sqrt(sqr(x - c) + sqr(y))
144
  else
145
    z := 1.0E10
146
end;
147

148
{**************************}
149

150
procedure TContourform.ContourlinesButtonClick(Sender: TObject);
151
var      SavePen: TPen;      i: Integer;
152
begin
153
  Screen.Cursor := CrHourGlass;
154
  currenttype := 1;
155
  with GraphImage do
156
  begin
157
    SetWorld(gxmin, gymin, gxmax, gymax);
158
    Clear;
159
    DrawAxes('x  ', 'y', False, clSilver, clSilver, False);
160
    SavePen := TPen.Create;
161
    SavePen.assign(Pen);
162
    for i := 0 to High(levelsarray) do
163
    begin
164
      Pen.Color := colorarray[i];
165
      DrawLevelCurves(graphsurface, levelsarray[i]);
166
    end;
167
    Pen.assign(SavePen);
168
    SavePen.Free;
169
  end;
170
  Screen.Cursor := crDefault;
171
end;
172

173
{******************************}
174

175
procedure TContourform.FilledContoursButtonClick(Sender: TObject);
176
begin
177
  Screen.Cursor := CrHourGlass;
178
  currenttype := 2;
179
  with GraphImage do
180
  begin
181
    if not LevelsMade then
182
    begin          //The following is what takes long
183
      graphsurface.SetLevels(levelsarray, colorarray);
184
      LevelsMade := True;
185
    end;
186
    SetWorld(gxmin, gymin, gxmax, gymax);
187
    Clear;
188
    DrawAxes('x  ', 'y', False, clSilver, clSilver, False);
189
    DrawFilledLevelCurves(graphsurface);
190
  end;
191
  Screen.Cursor := crDefault;
192
end;
193
{*****************************************}
194

195
procedure TContourform.MakeGraphSurface;
196
var
197
  i, j: Integer; x, y, z: MathFloat;
198
begin
199
  graphsurface := TLevelSurface.Create(xMesh, yMesh);
200
  for i := 0 to xMesh do
201
  begin
202
    x := gxmin + i * (gxmax - gxmin) / xMesh;
203
    for j := 0 to yMesh do
204
    begin
205
      y := gymin + j * (gymax - gymin) / yMesh;
206
      Graph(x, y, z);
207
      graphsurface.Make(i, j, x, y, z);
208
    end;
209
  end;
210
  LevelsMade := False;
211
end;
212

213

214
{****************************}
215

216
procedure TContourform.GraphImageResize(Sender: TObject);
217
begin
218
  if currenttype = 1 then
219
    ContourlinesButtonClick(self)
220
  else FilledContoursButtonClick(self);
221
end;
222

223

224
procedure TContourform.FormDestroy(Sender: TObject);
225
begin
226
  graphsurface.Free;
227
end;
228

229
procedure TContourform.FormShow(Sender: TObject);
230
begin
231
///  SaveasMetafile1.enabled := False;
232
  ContourlinesButtonClick(self); //Already done in GraphimageResize
233
end;
234

235

236
initialization
237

238

239

240
end.
241

242