1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
273:
274:
275:
276:
277:
278:
279:
280:
281:
282:
283:
284:
285:
286:
287:
288:
289:
290:
291:
292:
293:
294:
295:
296:
297:
298:
299:
300:
301:
302:
303:
304:
305:
306:
307:
308:
309:
310:
311:
312:
313:
314:
315:
316:
317:
318:
319:
320:
321:
322:
323:
324:
325:
326:
327:
328:
329:
330:
331:
332:
333:
334:
335:
336:
337:
338:
339:
340:
341:
342:
343:
344:
345:
346:
347:
348:
349:
350:
351:
352:
353:
354:
355:
356:
357:
358:
359:
360:
361:
362:
363:
364:
365:
366:
367:
368:
369:
370:
371:
372:
373:
374:
375:
376:
377:
378:
379:
380:
381:
382:
383:
384:
385:
386:
387:
388:
389:
390:
391:
392:
393:
394:
395:
396:
397:
398:
399:
400:
401:
402:
403:
404:
405:
406:
407:
408:
409:
410:
411:
412:
413:
414:
415:
416:
417:
418:
419:
420:
421:
422:
423:
424:
425:
426:
427:
428:
429:
430:
431:
432:
433:
434:
435:
436:
437:
438:
439:
440:
441:
442:
443:
444:
445:
446:
447:
448:
449:
450:
451:
452:
453:
454:
455:
456:
457:
458:
459:
460:
461:
462:
463:
464:
465:
466:
467:
468:
469:
470:
471:
472:
473:
474:
475:
476:
477:
478:
479:
480:
481:
482:
483:
484:
485:
486:
487:
488:
489:
490:
491:
492:
493:
494:
495:
496:
497:
498:
499:
500:
501:
502:
503:
504:
505:
506:
507:
508:
509:
510:
511:
512:
513:
514:
515:
516:
517:
518:
519:
520:
521:
522:
523:
524:
525:
526:
527:
528:
529:
530:
531:
532:
533:
534:
535:
536:
537:
538:
539:
540:
541:
542:
543:
544:
545:
546:
547:
548:
549:
550:
551:
552:
553:
554:
555:
556:
557:
558:
559:
560:
561:
562:
563:
564:
565:
566:
567:
568:
569:
570:
571:
572:
573:
574:
575:
576:
577:
578:
579:
580:
581:
582:
583:
584:
585:
586:
587:
588:
589:
590:
591:
592:
593:
594:
595:
596:
597:
598:
599:
600:
601:
602:
603:
604:
605:
606:
607:
608:
609:
610:
611:
612:
613:
614:
615:
616:
617:

{******************************************************************************}
{                                                                              }
{                   GraVis XT - Version 0.7 (2004-08-30)                       }
{                                                                              }
{                     Copyright (c) 2003-2004 Evocore                          }
{                                                                              }
{                          Programmer:  Erik Derr                              }
{                             Kontakt:  >> derr@evocore.de                     }
{                                                                              }
{                                                                              }
{      Unsere Codes sind wie moderne Kunst: Keiner kann sie einordnen,         }
{          und wenn man sie zu lange betrachtet, wird einem schlecht.  :-)     }
{                                                                              }
{                                                                              }
{******************************************************************************}

{*******************************************************************************
                               -=LICENSE=-

THIS Unit is OpenSource.

THIS SOURCE IS FREE OF CHARGE. THERE IS NO WARRANTY FOR IT.
THE PROGRAM IS PROVIDED 'AS IS' WITHOUT WARRANTY OF ANY KIND.

The source is provided under the above conditions. You are allowed to
change its origin, but then please send us a copy.
If there are any questions contact us.
*******************************************************************************}

unit GraVis;

interface

uses
   Classes, Graphics, Controls, ExtCtrls;

type
  TTriangle_Dir = (links, rechts);

  TCircle = class
  private
   { Private-Deklarationen }
   fx: Integer;
   fy: Integer;
   fWidth: Integer;
   fFarbe: TColor;
   fText: String;
   fImage: TImage;
    function get_int (index: integer): integer;
    procedure set_int (index: integer; value: integer);
    procedure set_col (value: tcolor);
    procedure set_str (value: string);
    procedure set_img (value: Timage);
    procedure paint; overload; virtual;
    procedure p_Circle;
  public
   { Public-Deklarationen }          
   constructor create;
   procedure paint (pImage: TImage); overload; virtual;
   procedure paint (px,py,pWidth: Integer; pImage: TImage); overload;
  published
   property x: integer index 0 read get_int write set_int;
   property y: integer index 1 read get_int write set_int;
   property width: integer index 2 read get_int write set_int;
   property farbe: tcolor read fFarbe write set_col;
   property text: string read fText write set_str;
   property image: TImage read fImage write set_img;
  end;


  TRectangle = class (TCircle)
  private
   { Private-Deklarationen }
   fHeight: Integer;
    procedure paint; overload; override;
    procedure set_HInt (value: integer);
    procedure p_Rectangle;
  public
   { Public-Deklarationen }
   constructor create;
   procedure paint (pImage: TImage); overload; override;
   procedure paint (px,py,pWidth,pHeight: Integer; pImage: TImage); overload;
  published
   { Published-Deklarationen }
   property height: integer read fHeight write set_HInt;
  end;


  TRRectangle = class (TRectangle)
  private
   { Private-Deklarationen }
   fRundung: cardinal;
    procedure set_card (value: cardinal);
    procedure paint; overload; override;
    procedure p_RRectangle;
  public
   { Public-Deklarationen }
   constructor create;
   procedure paint (pImage: TImage); overload; override;
   procedure paint (px,py,pWidth,pHeight: Integer; pImage: TImage); overload;
  published
   { Published-Deklarationen }
   property rundung: cardinal read fRundung write set_card;
  end;


  TLine = class
  private
   { Private-Deklarationen }
   fx: Integer;
   fy: Integer;
   fWidth: Integer;
   fHeight: Integer;
   fFarbe: TColor;
   fImage: TImage;
    function get_int (index: integer): integer;
    procedure set_int (index: integer; value: integer);
    procedure set_col (value: tcolor);
    procedure set_img (value: Timage);
    procedure paint; overload;
    procedure p_Line;
  public
   { Public-Deklarationen }
   constructor create;
   procedure paint (pImage: TImage); overload;
   procedure paint (px,py,pWidth,pHeight: Integer; pImage: TImage); overload;
  published
   property x: integer index 0 read get_int write set_int;
   property y: integer index 1 read get_int write set_int;
   property width: integer index 2 read get_int write set_int;
   property height: integer index 3 read get_int write set_int;
   property farbe: tcolor read fFarbe write set_col;
   property image: TImage read fImage write set_img;
  end;

  TTriangle = class
  private
   { Private-Deklarationen }
   fx: integer;
   fy: integer;
   fheight: integer;
   fwidth: integer;
   fcolor: TColor;
   frichtung: TTriangle_Dir;
   fImage: TImage;
    function get_int (index: integer): integer;
    procedure set_int (index: integer; value: integer);
    procedure set_col (value: tcolor);
    procedure set_img (value: Timage);
    procedure set_dir (value: TTriangle_Dir);
    procedure paint; overload;
    procedure p_Triangle;
  public
   { Public-Deklarationen }
   constructor create;
   procedure paint (pImage: TImage); overload;
   procedure paint (px,py: Integer); overload;
   procedure paint (px,py: Integer; pImage: TImage); overload;
  published
   property x: integer index 0 read get_int write set_int;
   property y: integer index 1 read get_int write set_int;
   property height: integer index 2 read get_int write set_int;
   property width: integer index 3 read get_int write set_int;
   property color: TColor read fcolor write set_col;
   property richtung: TTriangle_dir read frichtung write set_dir;
   property image: TImage read fimage write set_img;
  end;

procedure Refresh_Img (image: Timage);

implementation

{-----------------------------------------------------------------}
{-----  Class TCircle  -------------------------------------------}
{-----------------------------------------------------------------}

constructor TCircle.create;
begin
 fx:= 50;
 fy:= 50;
 fwidth:= 70;
 ffarbe:= clWhite;
 ftext:= '';
end;

function TCircle.get_int (index: integer): integer;
begin
 case index of
  0: result:= fx;
  1: result:= fy;
  2: result:= fWidth;
 else result:= 0;
 end;
end;

procedure TCircle.set_int (index: integer; value: integer);
begin
 case index of
  0: fx:= value;
  1: fy:= value;
  2: fWidth:= value;
 else ;
 end;
paint;
end;

procedure TCircle.set_col (value: tcolor);
begin
 fFarbe:= value;
 paint;
end;

procedure TCircle.set_str (value: string);
begin
 fText:= value;
 paint;
end;

procedure TCircle.set_img (value: Timage);
begin
 fImage:= value;
 paint;
end;

procedure TCircle.p_Circle;
var zen_x, zen_y: integer;
begin
 with fImage.Canvas do
 begin
  Pen.Width:= 1;
  Brush.Color:= fFarbe;
  Ellipse (fx,fy-(fWidth div 2),fx+fWidth,fy+(fWidth div 2));
 end;

 if fText <> '' then
 begin
  zen_x:= ((fWidth div 2) + fx) - (fImage.Canvas.Textwidth (fText) div 2);
  zen_y:= fy - (fImage.Canvas.Textheight (fText) div 2);
  fImage.Canvas.Textout (zen_x, zen_y, fText);
 end;
end;


procedure TCircle.paint;
begin
Refresh_img (fImage);
p_Circle;
end;

procedure TCircle.paint (pImage: TImage);
begin
 if image <> pImage then
  fImage:= pImage;
p_Circle;
end;

procedure TCircle.paint (px,py,pWidth: Integer; pImage: TImage);
begin
 if x <> px then
  fx:= px;
 if y <> py then
  fy:= py;
 if width <> pWidth then
  fWidth:= pWidth;
 if image <> pImage then
  fImage:= pImage;
p_Circle;
end;

{-----------------------------------------------------------------}
{-----  Class TRectangle  ----------------------------------------}
{-----------------------------------------------------------------}

constructor TRectangle.create;
begin
 fx:= 50;
 fy:= 50;
 fHeight:= 40;
 fWidth:= 50;
 fFarbe:= clWhite;
 fText:= '';
end;

procedure TRectangle.set_HInt (value: Integer);
begin
 fHeight:= value;
 paint;
end;

procedure TRectangle.p_Rectangle;
var zen_x, zen_y: integer;
begin
 with fImage.Canvas do
 begin
  Pen.Width:= 1;
  Brush.Color:= ffarbe;
  Rectangle (fx,fy -(fHeight div 2),fx+fWidth,fy + (fHeight div 2));
 end;

 if fText <> '' then
 begin
  zen_x:= ((fWidth div 2) + fx) - (fImage.Canvas.Textwidth (fText) div 2);
  zen_y:= fy - (fImage.Canvas.Textheight (fText) div 2);
  fImage.Canvas.Textout (zen_x, zen_y, fText);
 end;
end;

procedure TRectangle.paint (px,py,pWidth,pHeight: integer; pImage: TImage);
begin
 if x <> px then
  fx:= px;
 if y <> py then
  fy:= py;
 if width <> pWidth then
  fWidth:= pWidth;
 if height <> pHeight then
  fHeight:= pHeight;
 if image <> pImage then
  fImage:= pImage;
p_Rectangle;
end;

procedure TRectangle.paint (pImage: TImage);
begin
 if image <> pImage then
  fImage:= pImage;
p_Rectangle;
end;

procedure TRectangle.paint;
begin
Refresh_img (fImage);
p_Rectangle;
end;


{---------------------------------------------------------------}
{-----  Class TRRectangle  -------------------------------------}
{---------------------------------------------------------------}

constructor TRRectangle.create;
begin
 fx:= 50;
 fy:= 50;
 fHeight:= 35;
 fWidth:= 70;
 fFarbe:= clWhite;
 fText:= '';
 fRundung:= 35;
end;

procedure TRRectangle.set_card (value: cardinal);
begin
 fRundung:= value;
 paint;
end;

procedure TRRectangle.p_RRectangle;
var zen_x, zen_y: integer;
begin
 with fImage.Canvas do
 begin
  Pen.Width:= 1;
  Brush.Color:= fFarbe;
  RoundRect (fx,fy-(fHeight div 2),fx+fWidth,fy + (fHeight div 2),fRundung,fRundung);
 end;

 if fText <> '' then
 begin
  zen_x:= ((fWidth div 2) + fx) - (fImage.Canvas.Textwidth (fText) div 2);
  zen_y:= fy - (fImage.Canvas.Textheight (ftext) div 2);
  fImage.Canvas.Textout (zen_x, zen_y, fText);
 end;
end;

procedure TRRectangle.paint;
begin
Refresh_img (fImage);
p_RRectangle;
end;

procedure TRRectangle.paint (pImage: TImage);
begin
 if image <> pImage then
  fImage:= pImage;
p_RRectangle;
end;

procedure TRRectangle.paint (px,py,pWidth,pHeight: Integer; pImage: TImage);
begin
 if x <> px then
  fx:= px;
 if y <> py then
  fy:= py;
 if width <> pWidth then
  fWidth:= pWidth;
 if height <> pHeight then
  fHeight:= pHeight;
 if image <> pImage then
  fImage:= pImage;
p_RRectangle;
end;


{---------------------------------------------------------------}
{-----  Class TLine  -------------------------------------------}
{---------------------------------------------------------------}

constructor TLine.create;
begin
 fx:= 10;
 fy:= 10;
 fWidth:= 20;
 fHeight:= 0;
 fFarbe:= clBlack;
end;

function TLine.get_int (index: integer): integer;
begin
 case index of
  0: result:= fx;
  1: result:= fy;
  2: result:= fWidth;
  3: result:= fHeight;
 else result:= 0;
 end;
end;

procedure TLine.set_int (index: integer; value: integer);
begin
 case index of
  0: fx:= value;
  1: fy:= value;
  2: fWidth:= value;
  3: fHeight:= value;
 else ;
 end;
paint;
end;

procedure TLine.set_col (value: TColor);
begin
 fFarbe:= value;
 paint;
end;

procedure TLine.set_img (value: TImage);
begin
 fImage:= value;
 paint;
end;

procedure TLine.p_Line;
begin
 with fImage.Canvas do
 begin
  Pen.Color:= fFarbe;
  MoveTo (fx,fy);
  LineTo (fx+fWidth,fy+fHeight);
  Pen.Color:= clblack;
 end;
end;

procedure TLine.paint;
begin
Refresh_Img (fImage);
p_Line;
end;

procedure TLine.paint (pImage: TImage);
begin
 if Image <> pImage then
  fImage:= pImage;
p_Line;
end;

procedure TLine.paint (px,py,pWidth,pHeight: Integer; pImage: TImage);
begin
 if x <> px then
  fx:= px;
 if y <> py then
  fy:= py;
 if width <> pWidth then
  fWidth:= pWidth;
 if height <> pHeight then
  fHeight:= pHeight;
 if image <> pImage then
  fImage:= pImage;
p_Line;
end;


{---------------------------------------------------------------}
{-----  Class TTriangle  ---------------------------------------}
{---------------------------------------------------------------}

constructor TTriangle.create;
begin
 fx:= 50;
 fy:= 50;
 fheight:= 40;
 fwidth:= 24;
 fcolor:= clred;
 frichtung:= rechts;
 fImage:= nil;
end;

function TTriangle.get_int (index: integer): integer;
begin
 case index of
  0: result:= fx;
  1: result:= fy;
  2: result:= fHeight;
  3: result:= fWidth;
 else result:= 0;
 end;
end;

procedure TTriangle.set_int (index: integer; value: integer);
begin
 case index of
  0: fx:= value;
  1: fy:= value;
  2: fHeight:= value;
  3: fWidth:= value;
 else ;
 end;
paint;
end;

procedure TTriangle.set_col (value: tcolor);
begin
 fcolor:= value;
 paint;
end;

procedure TTriangle.set_img (value: Timage);
begin
 fImage:= value;
 paint;
end;

procedure TTriangle.set_dir (value: TTriangle_Dir);
begin
 frichtung:= value;
 paint;
end;

procedure TTriangle.paint;
begin
Refresh_img (fImage);
p_Triangle;
end;

procedure TTriangle.paint (pImage: TImage);
begin
 if image <> pImage then
  fImage:= pImage;
p_Triangle;
end;

procedure TTriangle.paint (px,py: Integer);
begin
 if x <> px then
  fx:= px;
 if y <> py then
  fy:= py;
p_Triangle;
end;

procedure TTriangle.paint (px,py: Integer; pImage: TImage);
begin
 if x <> px then
  fx:= px;
 if y <> py then
  fy:= py;
 if image <> pImage then
  fImage:= pImage;
p_Triangle;
end;

procedure TTriangle.p_Triangle;
begin
 with fImage.Canvas do
 begin
  Pen.Width:= 1;
  Brush.Color:= fcolor;

  if (richtung = rechts) then
   Polygon ([Point(fx,fy+(fheight div 2)), Point(fx,fy-(fheight div 2)), Point (fx+fwidth, fy)])
  else if (richtung = links) then
   Polygon ([Point(fx,fy+(fheight div 2)), Point(fx,fy-(fheight div 2)), Point (fx-fwidth, fy)]);
 end;
end;

{---------------------------------------------------------------}
{-----  General Procedures  ------------------------------------}
{---------------------------------------------------------------}

procedure Refresh_Img (image: Timage);
var Bitmap : TBitmap;
begin
  begin
    with Image do
     Bitmap := nil;
      try
        Bitmap:= TBitmap.Create;
        Bitmap.Width := image.width;
        Bitmap.Height := image.height;
        Image.Picture.Graphic := Bitmap;
      finally
        Bitmap.Free;
     end;
  end;
end;

end.