ViewVC Help
View File | Revision Log | Show Annotations | Root Listing
root/JDesigner/uNetUtils.pas
Revision: 1.1.1.1 (vendor branch)
Committed: Mon Dec 10 19:29:12 2001 UTC (14 years, 5 months ago) by hsauro
Branch: MAIN, hsauro
CVS Tags: V10, HEAD_NEW, HEAD
Changes since 1.1: +0 -0 lines
Log Message:
no message

Line File contents
1 unit uNetUtils;
2
3 // Computation routines required by the network drawing logic
4
5 interface
6
7 Uses Windows, Classes, Graphics, Math;
8
9 const
10 MAXSEGS = 29; // Number of segments used to construct bezier
11
12 type
13 TLineSeg = record p, q : TPoint; end; // A line segment
14 TArcSeg = record h1, h2 : TPoint; Merged : Boolean; end; // Bezier segment info
15 TSquareSegs = array[1..4] of TLineSeg; // A Square
16 TCurrentSelectedHandle = -1..2; { -1 = no handle, 1 or 2 = handle 1 or 2 ! }
17 TCurrentSubArc = 1..5;
18
19 function Line (pt1, pt2 : TPoint) : TLineSeg;
20 function Angle (x, y : double) : Double;
21 function LineLength (p, q : TPoint) : integer;
22 function MinusOrigin (const Pt, Origin : TPoint) : TPoint;
23 procedure DrawArrow (Canvas : TCanvas; tip : TPoint; Scale : Double; dxdt, dydt : double);
24 function PtOnLine (p1, p2 : TPoint; pt : TPoint) : boolean;
25 function PtOnBezier (p : array of TPoint; pt : TPoint; var t : double) : Boolean;
26 function PointWithinCircle (x, y : integer; pt : TPoint) : boolean;
27 function SegmentIntersects (v1, v2 : TLineSeg; var v : TPoint) : Boolean;
28
29 procedure ComputeBezierBlendingFuncs;
30 procedure ComputeBezPoints (p : array of TPoint);
31 procedure DrawBezier (Canvas : TCanvas; p : array of TPoint);
32 procedure DrawControlPoint (Canvas : TCanvas; p : TPoint);
33
34 procedure WriteFont (s : TStream; Font : TFont);
35 procedure ReadFont (s : TStream; Font : TFont);
36 procedure WriteInteger (s : TStream; i : integer);
37 function ReadInt (s : TStream) : integer;
38 procedure WriteString (s : TStream; str : string);
39 function ReadStr (sin : TStream) : string;
40 procedure WriteDouble (sin : TStream; value : double);
41 function ReadDouble (sin : TStream) : double;
42
43 var
44 BezPoints : array[0..MAXSEGS] of TPoint;
45 BezJ, BezJPrime : array[0..MAXSEGS, 0..4] of double;
46
47
48 implementation
49
50 Uses uNodeList;
51
52 // Given two points, pt1 and pt2, Lin returns the LineSegment
53 function Line (pt1, pt2 : TPoint) : TLineSeg;
54 begin
55 Result.p.x := pt1.x;
56 Result.p.y := pt1.y;
57
58 Result.q.x := pt2.x;
59 Result.q.y := pt2.y;
60 end;
61
62
63 // Draw a control point at a given coordinate, p
64 procedure DrawControlPoint (Canvas : TCanvas; p : TPoint);
65 begin
66 Canvas.ellipse (p.x-3, p.y-3, p.x+3, p.y+3);
67 end;
68
69
70 // Check if the target line (v2) intersects the SEGMENT line (v1). Returns
71 // true if lines intersect with intersection coordinate returned in v, else
72 // returns false
73 function SegmentIntersects (v1, v2 : TLineSeg; var v : TPoint) : Boolean;
74 var xlk, ylk, xnm, ynm, xmk, ymk, det : longint;
75 detinv, s, t : double;
76 begin
77 xlk := v2.q.x - v2.p.x;
78 ylk := v2.q.y - v2.p.y;
79 xnm := v1.p.x - v1.q.x;
80 ynm := v1.p.y - v1.q.y;
81 xmk := v1.q.x - v2.p.x;
82 ymk := v1.q.y - v2.p.y;
83
84 det := xnm*ylk - ynm*xlk;
85 if abs (det) < 1e-6 then
86 result := false
87 else
88 begin
89 detinv := 1.0/det;
90 s := (xnm*ymk - ynm*xmk)*detinv;
91 t := (xlk*ymk - ylk*xmk)*detinv;
92 if (s < 0.0) or (s > 1.0) or (t < 0.0) or (t > 1.0) then
93 result := false
94 else
95 begin
96 v.x := v2.p.x + trunc (xlk*s);
97 v.y := v2.p.y + trunc (ylk*s);
98 result := true;
99 end;
100 end;
101 end;
102
103
104 // Find angle between x and y
105 function Angle (x, y : double) : Double;
106 begin
107 if abs (x) < 1e-5 then
108 if abs (y) < 1e-5 then begin result := 0.0; exit; end
109 else if (y > 0.0) then begin result := 3.1415*0.5; exit; end
110 else begin result := 3.1415*1.5; exit; end
111 else if (x < 0.0) then begin result := arctan (y/x) + 3.1415; exit; end
112 else result := arctan (y/x);
113 end;
114
115
116 // Find the length of a line between points p and q
117 function LineLength (p, q : TPoint) : integer;
118 var dx, dy : longint;
119 begin
120 dx := q.x - p.x; dy := q.y - p.y;
121 result := trunc (sqrt (dx*dx + dy*dy));
122 end;
123
124
125 // Translate Pt by the Origin
126 function MinusOrigin (const Pt, Origin : TPoint) : TPoint;
127 begin
128 Result.x := Pt.x - Origin.x;
129 Result.y := Pt.y - Origin.y;
130 end;
131
132
133 // Check if pt is within a circle with centre x,y.
134 // Bit of a fudge, assumes a circle is a square!
135 // Circle is assumed to have a 'diameter' of three units
136 function PointWithinCircle (x, y : integer; pt : TPoint) : boolean;
137 begin
138 if PtinRect (rect(pt.x-3, pt.y-3, pt.x+3, pt.y+3), point (x, y)) then
139 result := true
140 else
141 result := false;
142 end;
143
144
145
146 // Draw an arrow at position 'tip' and at an angle defined by dxdt and dydt
147 procedure DrawArrow (Canvas : TCanvas; tip : TPoint; Scale : Double; dxdt, dydt : double);
148 var S, T, Q : TPoint; // S, T and Q define the vertices of an arrow
149 dx, dy : integer;
150 alpha, cosine, sine : double;
151 begin
152 // Given a slope, work out the angle }
153 alpha := -Angle (dxdt, dydt);
154 // The following lines define the coordinates of the arrow when it is
155 // rotated by an amount, 'angle'. The arrow has coords (1,11), (1,1), (8,6).
156 // Once rotated I can translate the arrow head to the tip of the line.
157 // Note, 6 is half way between 11 and 1.
158 // S
159 // | .
160 // | . Q
161 // |.
162 // R
163 // Construct the arrow and rotate it by given angle
164 cosine := cos (alpha); sine := sin (alpha);
165 S.x := trunc (1*Scale*cosine + 11*Scale*sine);
166 S.y := trunc(-1*Scale*sine + 11*Scale*cosine);
167
168 T.x := trunc(1*Scale*cosine + 1*Scale*sine);
169 T.y := trunc(-1*Scale*sine + 1*Scale*cosine);
170
171 Q.x := trunc(8*Scale*cosine + 6*Scale*sine);
172 Q.y := trunc(-8*Scale*sine + 6*Scale*cosine);
173
174 // Compute the distance of the tip of the arrow to the end point on the line
175 // where the arrow should be placed. Then use this distance to translate S and T
176 dx := tip.x - Q.x;
177 dy := tip.y - Q.y;
178
179 // Translate the remaining coordinates of the arrow, note tip = Q
180 S.x := S.x + dx; S.y := S.y + dy;
181 T.x := T.x + dx; T.y := T.y + dy;
182
183 Canvas.Polygon ([S, T, tip]); // Draw the arrow head and colour it in
184 end;
185
186
187
188 // Returns true if pt is on the line p1 to p2. The constant ERR
189 // is the slack on either side of the line
190 function PtOnLine (p1, p2 : TPoint; pt : TPoint) : boolean;
191 const ERR = 5;
192 var Deltax, Deltay, t, x, y : double;
193 begin
194 Deltax := p2.x - p1.x;
195 Deltay := p2.y - p1.y;
196
197 if (abs (Deltax) > 0) and (abs (Deltay) < abs (Deltax)) then
198 begin
199 t := (pt.x - p1.x)/(p2.x - p1.x);
200 if (t >= 0) and (t <= 1) then
201 begin
202 y := p1.y + (p2.y - p1.y)*t;
203 if (y - ERR <= pt.y) and (pt.y <= y + ERR) then
204 begin
205 result := True;
206 exit;
207 end;
208 end
209 else
210 begin
211 result := False;
212 exit;
213 end;
214 end
215 else
216 begin
217 if abs (Deltay) > 0 then
218 begin
219 t := (pt.y - p1.y)/(p2.y - p1.y);
220 if (t >= 0) and (t <= 1) then
221 begin
222 x := p1.x + (p2.x - p1.x)*t;
223 if (x - ERR <= pt.x) and (pt.x <= x + ERR) then
224 begin
225 result := True;
226 exit;
227 end;
228 end
229 else
230 begin
231 result := False;
232 exit;
233 end;
234 end
235 else
236 begin
237 result := False;
238 exit;
239 end;
240 end;
241 result := False;
242 end;
243
244
245 // Compute factorial of n. I know, there is a better way but this will do for
246 // now, in any case it only has to be computed once
247 function fact (n : integer) : integer;
248 var i : integer;
249 begin
250 result := 1;
251 if n = 0 then
252 exit
253 else
254 for i := 1 to n do
255 result := result * i;
256 end;
257
258
259 // Combination function
260 function Comb (n, i : integer) : integer;
261 begin
262 result := fact (n) div (fact (i) * fact (n-i));
263 end;
264
265
266 // Compute the Bezier blending functions here, ready for when we need them
267 // Assume 2 control points, MAXSEGS is number of steps to draw bezier curve
268 procedure ComputeBezierBlendingFuncs;
269 var t, tm : double; ti, i : integer;
270 begin
271 for ti := 0 to MAXSEGS do
272 begin
273 t := ti/MAXSEGS;
274 for i := 0 to 3 do
275 BezJ[ti,i] := Comb(3, i) * power (t, i) * power (1-t, 3-i);
276 // At the moment hard-wired for n = 3
277 tm := 1 - t;
278 BezJPrime[ti, 0] := -3*tm*tm;
279 BezJPrime[ti, 1] := 3*tm*tm - 6*t*tm;
280 BezJPrime[ti, 2] := 6*t*tm - 3*t*t;
281 BezJPrime[ti, 3] := 3*t*t;
282 end;
283 end;
284
285
286 // Compute points along bezier curve and store in global var BezPoints
287 procedure ComputeBezPoints (p : array of TPoint);
288 type TLongPoint = record x, y : longint end;
289 var i, j : integer;
290 lpoints : array[0..MAXSEGS] of TLongPoint;
291 lp : array[0..3] of TLongPoint;
292 begin
293 // Scale up dimensions to get a smooth curve
294 for i := 0 to 3 do
295 begin
296 lp[i].x := longint (p[i].x) * 1000;
297 lp[i].y := longint (p[i].y) * 1000;
298 end;
299
300 // Now compute the bezier points
301 for i := 0 to MAXSegs do
302 begin
303 lpoints[i].x := 0; lpoints[i].y := 0;
304 for j := 0 to 3 do
305 begin
306 lpoints[i].x := lpoints[i].x + trunc (lp[j].x*BezJ[i, j]);
307 lpoints[i].y := lpoints[i].y + trunc (lp[j].y*BezJ[i, j]);
308 end;
309 BezPoints[i].x := lpoints[i].x div 1000; // and scale back down again
310 BezPoints[i].y := lpoints[i].y div 1000;
311 end;
312 end;
313
314 procedure DrawBezier (Canvas : TCanvas; p : array of TPoint);
315 begin
316 ComputeBezPoints (p); canvas.Polyline (BezPoints);
317 end;
318
319
320 { Determine whether the point 'pt' is on the bezier curved defined by the
321 control points 'p'. This brute force method works through each segment
322 making up the bezier checking to see if pt in on one of the segments
323 - seems to be quick enough. t is the parametric distance along the bezier }
324 function PtOnBezier (p : array of TPoint; pt : TPoint; var t : double) : Boolean;
325 type TLongPoint = record x, y : longint; end;
326 var i, j : integer;
327 points : array[0..MAXSEGS] of TPoint;
328 lpoints : array[0..MAXSEGS] of TLongPoint;
329 lp : array[0..3] of TLongPoint;
330 begin
331 // Scale up dimensions to get smooth curve
332 for i := 0 to 3 do
333 begin
334 lp[i].x := longint (p[i].x) * 1000;
335 lp[i].y := longint (p[i].y) * 1000;
336 end;
337
338 // Compute the first point because later on I pass i-1 point to PtOnLine
339 lpoints[0].x := 0; lpoints[0].y := 0;
340 for j := 0 to 3 do
341 begin
342 lpoints[0].x := lpoints[0].x + trunc (lp[j].x*BezJ[0, j]);
343 lpoints[0].y := lpoints[0].y + trunc (lp[j].y*BezJ[0, j]);
344 end;
345 points[0].x := lpoints[0].x div 1000;
346 points[0].y := lpoints[0].y div 1000;
347 for i := 1 to MAXSEGS do
348 begin
349 lpoints[i].x := 0; lpoints[i].y := 0;
350 for j := 0 to 3 do
351 begin
352 lpoints[i].x := lpoints[i].x + trunc (lp[j].x*BezJ[i, j]);
353 lpoints[i].y := lpoints[i].y + trunc (lp[j].y*BezJ[i, j]);
354 end;
355 points[i].x := lpoints[i].x div 1000;
356 points[i].y := lpoints[i].y div 1000;
357 // Check if pt in on the line segment, i-1 to i
358 if PtOnLine (points[i-1], points[i], pt) then
359 begin
360 result := true;
361 t := i/MAXSegs;
362 exit;
363 end;
364 end;
365 result := false;
366 end;
367
368
369 // Compute the derivative of the current bezier at segment segn. Do it this way
370 // rather that computing the slope directly from the segment end points as its more accurate,
371 // returns the slope in terms of change in x and change in y, makes computing angle easier
372 procedure ComputeBezDeriv (p : array of TPoint; segn : integer; var dxdt, dydt : double);
373 begin
374 dxdt := BezJPrime[segn, 0]*p[0].x + BezJPrime[segn, 1]*p[1].x +
375 BezJPrime[segn, 2]*p[2].x + BezJPrime[segn, 3]*p[3].x;
376 dydt := BezJPrime[segn, 0]*p[0].y + BezJPrime[segn, 1]*p[1].y +
377 BezJPrime[segn, 2]*p[2].y + BezJPrime[segn, 3]*p[3].y;
378 end;
379
380
381 // Save the font to the stream
382 procedure WriteFont (s : TStream; Font : TFont);
383 var AStyle : TFontStyles;
384 begin
385 WriteString (s, Font.Name);
386 WriteInteger (s, Font.Size);
387 AStyle := Font.Style; s.Write (AStyle, sizeof (AStyle));
388 s.Write (Font.Color, Sizeof (TColor));
389 end;
390
391
392 procedure ReadFont (s : TStream; Font : TFont);
393 var AStyle : TFontStyles; AColor : TColor;
394 begin
395 Font.Name := ReadStr (s);
396 Font.Size := ReadInt (s);
397 s.Read (AStyle, Sizeof (Font.Style)); Font.Style := AStyle;
398 s.Read (AColor, Sizeof (TColor)); Font.Color := AColor;
399 end;
400
401
402 procedure WriteInteger (s : TStream; i : integer);
403 begin
404 s.Write (i, sizeof (integer));
405 end;
406
407
408 function ReadInt (s : TStream) : integer;
409 begin
410 s.Read (result, sizeof (integer));
411 end;
412
413
414 procedure WriteString (s : TStream; str : string);
415 var w : LongWord;
416 begin
417 w := Length (str);
418 s.Write (w, SizeOf (w));
419 if w > 0 then
420 s.Write(PChar(str)^, Length(str));
421 end;
422
423
424 // Read a pmb string: length; text bytes;
425 function ReadStr (sin : TStream) : string;
426 var L : Longword;
427 begin
428 sin.read (L, SizeOf(L));
429 if L > 0 then
430 begin
431 SetLength (Result, L);
432 sin.read (Result[1], L);
433 end
434 else
435 Result := '';
436 end;
437
438
439 procedure WriteDouble (sin : TStream; value : double);
440 begin
441 sin.Write (value, sizeof (value));
442 end;
443
444
445 function ReadDouble (sin : TStream) : double;
446 begin
447 sin.read (result, sizeof (double));
448 end;
449
450
451 end.