AL_MapGL

Top  Previous  Next

(*  StOpenGl  Delphi 5 komponens

 

   TCustomControl descendant OpenGL component for fast graphic

 

   Windowed kontrol, OpenGl tulajdonságokkal

   grafika megjelenitésére.

 

   By: Agócs László StellaSOFT

*)

 

unit AL_MapGL;

 

interface

 

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, ExtCtrls,

Forms, Dialogs, ClipBrd, Math, OpenGL, AL_OpenGL, NewGeom, StMapType;

 

Type

 

TSzin = record

   R,G,B : double;

   width : integer;

end;

 

TShadeModel = (smFlat,smSmooth);

 

pMapFontRec = ^MapFontRec;

MapFontRec = record

    FType   : byte;        // 0=MoveTo = begin of poyigon;

                           // 1=LineTo; 255=End of Polygon

    Fx,Fy   : GLdouble;     // Coordinates

end;

 

TNewMapFile      = procedure(Sender: TObject; MapFile:string) of object;

TChangeWindow    = procedure(Sender: TObject; Cent: TPoint2D;  Zoom: Double) of object;

 

// Base OpenGL komponent

TCustomOpenGL = class(TCustomControl)

private

   FCentralCross: boolean;

   FZoom: double;

   FRotAngle: double;

   FClearColor: TColor;

   FShadeModel: TShadeModel;

   FCentrum: TPoint2d;

   FChangeWindow: TChangeWindow;

   FOnPaint: TNotifyEvent;

   Procedure CMChildkey( Var msg: TCMChildKey ); message CM_CHILDKEY;

   procedure CMMouseEnter(var msg: TMessage); message CM_MOUSEENTER;

   procedure CMMouseLeave(var msg: TMessage); message CM_MOUSELEAVE;

   procedure WMEraseBkGnd(var Message:TWMEraseBkGnd); message WM_ERASEBKGND;

   procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;

   procedure WMSize(var Msg: TWMSize); message WM_SIZE;

   procedure SetCentralCross(const Value: boolean);

   procedure SetClearColor(const Value: TColor);

   procedure SetRotAngle(const Value: double);

   procedure SetShadeModel(const Value: TShadeModel);

   procedure SetZoom(const Value: double);

//    function GetCanvas: TCanvas;

   procedure SetCentrum(const Value: TPoint2d);

   procedure glInit;

//    procedure Idle(Sender: TObject; var Done: Boolean);

protected

   OpenGL_OK: boolean;           // OpenGL initialized

   procedure StartOpengl;

   procedure SetDCPixelFormat;

   procedure MouseDown(Button: TMouseButton; Shift: TShiftState;

     X, Y: Integer); override;

   procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;

   procedure MouseUp(Button: TMouseButton; Shift: TShiftState;

     X, Y: Integer); override;

   function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;

     MousePos: TPoint): Boolean; override;

   function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override;

   function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;

   procedure KeyDown(var Key: Word;Shift: TShiftState); override;

   procedure KeyPress(var Key: Char); override;

   procedure DblClick;  override;

public

   DC: HDC;

   hrc : HGLRC;

   BackBMP: TBitmap;      // For drawing in back

   OrtoLeft,OrtoRight,OrtoBottom,OrtoTop: double;

   origin,movept,oldmovept: TPoint;

   Origo : TPoint2d;

   SelRect : TRect;

   base: GLuint;          // Base for font list

   rSIN,rCOS : double;    // sin and cos of RotAngle;

   constructor Create(AOwner: TComponent); override;

   destructor Destroy; override;

   procedure Paint; override;

   procedure ReDraw;

   procedure Demo;

   procedure DrawCentralCross;

   procedure CopyToClipboard;

 

   // Coordinate functions

   function XToW(x: integer): double;

   function YToW(y: integer): double;

   function XToS(x: double): integer;

   function YToS(y: double): integer;

   function WToS(p: TPoint2d): TPoint;

   function SToW(p: TPoint): TPoint2d;

   // Rotate funtions

   // Rotating p point around the porigo with szog-angle

   Function Rot(p,porigo:TPoint2d;szog:double):TPoint2d; overload;

   // Rotating p point around the Centrum with RotAngle-angle

   Function Rot(p:TPoint2d): TPoint2d; overload;

 

   function GetWorkArea:TRect2d;

   function GetTotalMapArea:TRect2d;

 

   procedure MoveWindow(x, y: double);

   procedure ShiftWindow(x, y: double);

 

   // Drawing primitives

   procedure glRectangle(p1,p2,p3,p4: TPoint2d);  overload;

   procedure glRectangle(p: TPoint2d; a,b: double); overload;

   procedure glCircle(u,v,r: double);

   procedure glPrint(text : string);

 

   // Font routines

   function BuildFont(fntName: string): GLuint;

   procedure KillFont(fntBase: GLuint);                     // Delete The Font

   procedure Print(x,y: double; text : string);                      // Custom GL "Print" Routine

 

//    property Canvas        : TCanvas  read GetCanvas;

   property Centrum       : TPoint2d read FCentrum write SetCentrum;

published

   property CentralCross  : boolean   read FCentralCross write SetCentralCross;

   Property ClearColor    : TColor    read FClearColor write SetClearColor;

   property RotAngle      : double    read FRotAngle write SetRotAngle;

   property ShadeModel    : TShadeModel read FShadeModel write SetShadeModel;

   property Zoom          : double    read FZoom write SetZoom;

   property OnPaint       : TNotifyEvent read FOnPaint write FOnPaint;

   property OnChangeWindow: TChangeWindow read FChangeWindow write FChangeWindow;

end;

 

 

// On character's outline

TMapChar = class(TObject)

private

   FCharCode: byte;

   FFontName: string;

   procedure SetCharCode(const Value: byte);

   procedure SetFontName(const Value: string);

public

   p        : pMapFontRec;

   MF       : MapFontRec;

   OutLine  : TList;

   constructor Create;

   destructor Destroy; override;

   procedure ClearPoints;

   procedure AddPoint(MFR: MapFontRec); overload;

   procedure AddPoint(Atype: byte; Ax,Ay: integer); overload;

   procedure GetPoint(AIndex: Integer; var MFR: MapFontRec);

   procedure ChangePoint(AIndex: Integer; MFR: MapFontRec);

   procedure InsertPoint(AIndex: Integer; MFR: MapFontRec);

   procedure DeletePoint(AIndex: Integer);

   function GetPolyCount: integer;

   function SetTTFChar(CharCode: byte): boolean;

   property CharCode : byte   read FCharCode write SetCharCode;

   property FontName : string read FFontName write SetFontName;

end;

 

// Specified ttf font outlines object

TMapFont = class(TObject)

private

   FFontName: string;

   FFontFile: string;

   FAutoFill: boolean;

   procedure SetFontFile(const Value: string);

   procedure SetFontName(const Value: string);

   procedure SetAutoFill(const Value: boolean);

public

   // 256 character's outlines

   Chars      : array[0..255] of TMapChar;

   constructor Create;

   destructor Destroy; override;

   procedure ClearChars;

   procedure LoadMapFontFile(fntName: string);

   procedure SaveMapFontFile(fntName: string);

   // If AutoFill=Treu then get a windows TTF characters by FontName

   property AutoFill : boolean read FAutoFill write SetAutoFill;

   property FontFile : string read FFontFile write SetFontFile;

   property FontName : string read FFontName write SetFontName;

end;

 

 

TMapFontList = class(TList)

private

public

   constructor Create(AOwner: TComponent);

   destructor Destroy; override;

   procedure ClearFonts;

   procedure AddFont(fntName: string);

   procedure DeleteFont(AIndex: Integer);

end;

 

TALMapViewGL = class(TALBaseOpenGL)

private

   Hint1   : THintWindow;

   HintActive : boolean;

   oldHintStr: string;

   FHRSZReteg: byte;

   FRetegFile: string;

   FMapFile: string;

   FLatszik: TVisibleSet;

   FMAPAppend: boolean;

   fFitting: boolean;

   FAkcio: TAlakzatmod;

   fHinted: boolean;

   FMouseLeave: TNotifyEvent;

   FMouseEnter: TNotifyEvent;

   FNewMapFile: TNewMapFile;

   FOnPaint: TNotifyEvent;

   FOnAfterPaint: TNotifyEvent;

   FOnBeforePaint: TNotifyEvent;

   FHomogen: boolean;

   procedure CMMouseEnter(var msg: TMessage); message CM_MOUSEENTER;

   procedure CMMouseLeave(var msg: TMessage); message CM_MOUSELEAVE;

   procedure SetHRSZReteg(const Value: byte);

   procedure SetLatszik(const Value: TVisibleSet);

   procedure SetMapFile(const Value: string);

   procedure SetRetegFile(const Value: string);

   procedure SetFitting(const Value: boolean);

   procedure SetAkcio(const Value: TAlakzatmod);

   function GetCount(Idx: integer): integer;

   procedure SetHinted(const Value: boolean);

   procedure SetHomogen(const Value: boolean);

protected

   Cur,oldCur    : TCursor;

   Hintstr: string;

   HintRect: TRect;

 

   procedure MouseDown(Button: TMouseButton; Shift: TShiftState;

     X, Y: Integer); override;

   procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;

   procedure MouseUp(Button: TMouseButton; Shift: TShiftState;

     X, Y: Integer); override;

   procedure KeyDown(var Key: Word;Shift: TShiftState); override;

 

public

   fChar         : TMapChar;

   newGraphic    : boolean;

   tm            : TRajzelemStream;

   Layer         : TMAPLayer;

   Layers        : TMAPLayers;

   GlobalLayers  : TMAPLayers;

   rPen          : array[0..255] of TPen;  // Rétegek tollai

   rFont         : array[0..255] of TFont; // Rétegek fontjai

   lreteg        : TLreteg;         // Rétegek láthatóságának tömbje

   MapHeader     : TMapHeader;

   FontList      : TMapFontList;

   LayerStatistic: array[0..255] of integer;

 

   constructor Create(AOwner: TComponent); override;

   destructor Destroy; override;

   procedure Paint; override;

   procedure ShowHintPanel(Show: Boolean);

 

   procedure GenerateMap(ms: TRajzelemStream; method: integer);

   procedure On_Paint(Sender: TObject);

   procedure On_AfterPaint(Sender: TObject);

 

   procedure NewMap;

   function LoadMapFile(fnev: string): boolean;

   function SaveMapFile(fnev: string): boolean;

   function LoadNewMapFile(fnev: string): boolean;

   function SaveNewMapFile(fnev: string): boolean;

   function Load_TRK(fnev: string): boolean;

   function Load_ITR(fnev: string): boolean;

   function Load_DXF(FileName: string): boolean;

 

   // Read/Write methods for Streams

   procedure SaveToStream(stm: TStream);

   procedure LoadFromStream(stm: TStream);

 

   // Layers

   procedure LayerInit(IDx: byte);

   procedure LayersInit;

   procedure LayersRefresh;

   procedure LayerDestroy(IDx: byte);

   procedure LayersDestroy;

   function LoadOldLayers(fnev: string): boolean;

   function LoadLayers(fnev: string): boolean;

   function SaveLayers(fnev: string): boolean;

   procedure GetLayerStatistic;

 

   procedure MinMaxKeres;

   procedure FitToScreen;

 

   { Transformations }

   procedure Translate(dx,dy: double);

   procedure Scale(Cent: TPoint2d; ScaleFactor:double);

   procedure Rotate(Cent: TPoint2d; Angle:double);

 

   function Feliratkeres(x, y: Integer; var szrec: Tszovegrecord; var ap: Integer): boolean;

 

   property Count[Idx: integer] : integer read GetCount;

published

   property Akcio         : TAlakzatmod read FAkcio write SetAkcio;

   property Fitting       : boolean read fFitting write SetFitting;

   property Hinted        : boolean read fHinted write SetHinted;

   property HRSZReteg     : byte read FHRSZReteg write SetHRSZReteg default 10;

   property Homogen       : boolean read FHomogen write SetHomogen default False;

   property Latszik       : TVisibleSet read FLatszik write SetLatszik

                            default [vVonal, vFelirat];

   property MAPAppend     : boolean read FMAPAppend write FMAPAppend default False;

   property MapFile       : string read FMapFile write SetMapFile;

   property RetegFile     : string read FRetegFile write SetRetegFile;

   property OnNewMapFile  : TNewMapFile read FNewMapFile write FNewMapFile;

   property OnMouseEnter  : TNotifyEvent read FMouseEnter write FMouseEnter;

   property OnMouseLeave  : TNotifyEvent read FMouseLeave write FMouseLeave;

   property OnBeforePaint : TNotifyEvent read FOnBeforePaint write FOnBeforePaint;

   property OnAfterPaint  : TNotifyEvent read FOnAfterPaint write FOnAfterPaint;

   property CentralCross;

   Property ClearColor;

   property RotAngle;

   property ShadeModel;

   property Zoom;

   property Align;

   property Enabled;

   property OnChangeWindow;

   property OnClick;

   property OnDblClick;

   property OnDockDrop;

   property OnDockOver;

   property OnEnter;

   property OnExit;

   property OnGetSiteInfo;

   property OnKeyDown;

   property OnKeyPress;

   property OnKeyUp;

   property OnMouseDown;

   property OnMouseMove;

   property OnMouseUp;

   property OnMouseWheel;

   property OnMouseWheelDown;

   property OnMouseWheelUp;

   property OnResize;

   property OnUnDock;

end;

 

procedure Register;

function ColorToSzin(c:TColor):TSzin;

function CorrectAngle(Angle: double): double;

 

implementation

 

procedure Register;

begin

RegisterComponents('StellaMAP', [TCustomOpenGL,TALMapViewGL]);

end;

 

function ColorToSzin(c:TColor):TSzin;

begin

With Result do begin

R:=GetRValue(c)/255;

G:=GetGValue(c)/255;

B:=GetBValue(c)/255;

end;

end;

 

function CorrectAngle(Angle: double): double;

begin

   Result := 360*Frac(Angle/360);

end;

 

{ ELFORGATAS( pont,elforgatás centruma,szöge )}

Function Elforgatas(p,porigo:TPoint2d;szog:double):TPoint2d;

var c,s : double;

begin

c := COS(szog); s := SIN(szog);  {szög radiánban}

p.x := p.x - porigo.x;

p.y := p.y - porigo.y;

Result.x := p.x * c + p.y * s + porigo.x;

Result.y := p.y * c - p.x * s + porigo.y;

end;

 

{ TCustomOpenGL

  ========================================================================

  Base OpenGL component with basic effects: Mouse,key,.., and event.

}

 

constructor TCustomOpenGL.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

InitOpenGL;

BackBMP        := TBitmap.Create;

OpenGL_OK      := False;

width          := 200;

height         := 200;

OrtoLeft       := -100;

OrtoRight      := 100;

OrtoBottom     := -100;

OrtoTop        := 100;

fClearColor    := clBlack;

FCentralCross  := True;

FCentrum       := Point2d(0,0);

FZoom          := 2.0;

FShadeModel    := smSmooth;

RotAngle       := 0;

DoubleBuffered := True;

base           := 0;

Origo          := Point2d(0,0);

TabStop        := True;

end;

 

destructor TCustomOpenGL.Destroy;

begin

BackBMP.free;

if base<>0 then

    KillFont(base);

wglMakeCurrent(0, 0);

wglDeleteContext(hrc);

inherited Destroy;

end;

 

procedure TCustomOpenGL.StartOpengl;

begin

Try

DC := GetDC(Handle);

 

//  DC := GetDC(BackBMP.Canvas.Handle);

 

SetDCPixelFormat;

hrc := wglCreateContext(DC);

wglMakeCurrent(DC, hrc);

 

glShadeModel(GL_SMOOTH);

//  glEnable(GL_LINE_SMOOTH);

glEnable(GL_TEXTURE_2D);

glEnable(GL_ALPHA_TEST);

glEnable(GL_BLEND);

glBlendFunc(GL_SRC_COLOR,GL_SRC_COLOR);

 

glMatrixMode(GL_PROJECTION);

//   glFrustum(-0.1, 0.1, -0.1, 0.1, 0.3, 25.0);

glViewport(0, 0, Width, Height);

 

OpenGL_OK  := True;

ClearColor := fClearColor;

except

OpenGL_OK  := False;

Application.MessageBox('OpenGL cannot initialised!','OpenGl Error',IDOK);

exit;

end;

end;

 

procedure TCustomOpenGL.glInit;

var pfd : TPIXELFORMATDESCRIPTOR;

   pf  : Integer;

begin

Try

OpenGL_OK := True;

dc:=GetDC( Self.Handle );

pfd.nSize:=sizeof(pfd);

pfd.nVersion:=1;

pfd.dwFlags:=PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL or PFD_DOUBLEBUFFER;

pfd.iPixelType:=PFD_TYPE_RGBA;

pfd.cColorBits:=32;

pf :=ChoosePixelFormat(dc, @pfd);

SetPixelFormat(dc, pf, @pfd);

hrc :=wglCreateContext(dc);

wglMakeCurrent(dc,hrc);

 

glClearColor(0.0, 0.0, 0.0, 0.0);

glShadeModel(GL_SMOOTH);

glClearDepth(1.0);

glEnable(GL_DEPTH_TEST);

glDepthFunc(GL_LESS);

glHint(GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST);

 

// Tunnel

glClearColor(0.0, 0.0, 0.0, 0.0);                       // Black Background

glShadeModel(GL_SMOOTH);                             // Enables Smooth Color Shading

glClearDepth(1.0);                                   // Depth Buffer Setup

glEnable(GL_DEPTH_TEST);                             // Enable Depth Buffer

glDepthFunc(GL_LESS);

glDepthMask(1);

glHint(GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST);   //Realy Nice perspective calculations

glBlendFunc(GL_SRC_ALPHA, GL_SRC_COLOR);

glEnable(GL_TEXTURE_2D);

 

//  Application.OnIdle := Idle;

except

OpenGL_OK  := False;

Application.MessageBox('OpenGL cannot initialised!','OpenGl Error',IDOK);

exit;

end;

end;

(*

procedure TCustomOpenGL.Idle(Sender: TObject; var Done: Boolean);

begin

SwapBuffers(DC);

Done := False;

end;

*)

procedure TCustomOpenGL.SetDCPixelFormat;

var

nPixelFormat: Integer;

pfd: TPixelFormatDescriptor;

begin

FillChar(pfd, SizeOf(pfd), 0);

 

with pfd do begin

   nSize     := sizeof(pfd);

   nVersion  := 1;

   dwFlags   := PFD_DRAW_TO_WINDOW or

                PFD_DOUBLEBUFFER or

                PFD_SUPPORT_OPENGL;

   iPixelType:= PFD_TYPE_RGBA;

   cColorBits:= 16;

   cDepthBits:= 32;

   iLayerType:= PFD_MAIN_PLANE;

end;

 

nPixelFormat := ChoosePixelFormat(DC, @pfd);

SetPixelFormat(DC, nPixelFormat, @pfd);

end;

 

 

procedure TCustomOpenGL.CMChildkey(var msg: TCMChildKey);

var dx,dy: double;

   k:integer;

begin

k:=16;

dx := 0; dy:=0;

msg.result := 1; // declares key as handled

Case msg.charcode of

   VK_ADD     : Zoom:=1.2*FZoom;

   VK_SUBTRACT: Zoom:=0.8*FZoom;

   VK_LEFT    : dx:=-k;

   VK_RIGHT   : dx:=k;

   VK_UP      : dy:=k;

   VK_DOWN    : dy:=-k;

Else

   msg.result:= 0;

   inherited;

End;

if (dx<>0) or (dy<>0) then

    ShiftWindow(dx,dy);

end;

 

procedure TCustomOpenGL.CMMouseEnter(var msg: TMessage);

begin

TabStop:=True;

Setfocus;

end;

 

procedure TCustomOpenGL.CMMouseLeave(var msg: TMessage);

begin

TabStop:=False;

end;

 

procedure TCustomOpenGL.CopyToClipboard;

begin

Clipboard.Assign(BackBMP);

end;

 

procedure TCustomOpenGL.DblClick;

begin

Centrum := SToW(Point(Origin.x,Height-Origin.y));

inherited;

end;

 

procedure TCustomOpenGL.Demo;

begin

     glBegin(GL_POLYGON);

       glColor3d(1.0,0.0,0.0);

       glVertex2d(-30.0,-30.0);

 

       glColor3d(0.0,1.0,0.0);

       glVertex2d(30.0,-30.0);

 

       glColor3d(0.0,0.0,1.0);

       glVertex2d(30.0,30.0);

 

       glColor3d(1.0,1.0,1.0);

       glVertex2d(-30.0,30.0);

    glEnd;

    glBegin(GL_POLYGON);

       glColor4d(1.0,0.0,0.0,1.0);

       glVertex2d(0.0,-30.0);

 

       glColor4d(0.0,0.0,1.0,1.0);

       glVertex2d(30.0,0.0);

 

       glColor4d(1.0,1.0,0.0,1.0);

       glVertex2d(10.0,10.0);

 

       glColor4d(1.0,0.0,1.0,1.0);

       glVertex2d(0.0,30.0);

 

       glColor4d(0.0,0.5,1.0,1.0);

       glVertex2d(-10.0,10.0);

 

       glColor4d(5.0,0.5,0.0,1.0);

       glVertex2d(-30.0,0.0);

    glEnd;

       //INNEN LESZ A KIRAJZOLAS

    glFlush;

end;

 

function TCustomOpenGL.DoMouseWheel(Shift: TShiftState;

WheelDelta: Integer; MousePos: TPoint): Boolean;

begin

Result := inherited DoMouseWheel(Shift, WheelDelta, MousePos);

if Focused then

if WheelDelta<0 then Zoom:=0.9*Zoom  else Zoom:=1.1*Zoom;

end;

 

function TCustomOpenGL.DoMouseWheelDown(Shift: TShiftState;

MousePos: TPoint): Boolean;

begin

Result := inherited DoMouseWheelDown(Shift, MousePos);

end;

 

function TCustomOpenGL.DoMouseWheelUp(Shift: TShiftState;

MousePos: TPoint): Boolean;

begin

Result := inherited DoMouseWheelUp(Shift, MousePos);

end;

 

procedure TCustomOpenGL.DrawCentralCross;

begin

    glLineWidth(1);

       glBegin(GL_LINES);

         glColor3d(1.0,0.0,0.0);

         glVertex2d(FCentrum.x,OrtoTop);

         glVertex2d(FCentrum.x,OrtoBottom);

         glVertex2d(OrtoLeft,FCentrum.y);

         glVertex2d(OrtoRight,FCentrum.y);

       glEnd;

end;

 

function TCustomOpenGL.GetTotalMapArea: TRect2d;

begin

With Result do begin

      x1:=OrtoLeft;

      x2:=OrtoRight;

      y1:=OrtoBottom;

      y2:=OrtoTop;

end;

end;

 

function TCustomOpenGL.GetWorkArea: TRect2d;

begin

 

end;

 

procedure TCustomOpenGL.KeyDown(var Key: Word; Shift: TShiftState);

begin

Case Key of

VK_ADD     : begin Zoom:=2*Zoom;end;

VK_SUBTRACT: begin Zoom:=0.5*Zoom;end;

end;

inherited KeyDown(Key,Shift);

end;

 

procedure TCustomOpenGL.KeyPress(var Key: Char);

begin

Case Key of

^C : CopyToClipboard;

end;

inherited KeyPress(Key);

end;

 

procedure TCustomOpenGL.MouseDown(Button: TMouseButton; Shift: TShiftState;

X, Y: Integer);

begin

origin:=Point(x,y);

oldmovept:=origin;

inherited MouseDown(Button, Shift, X, Height-Y);

end;

 

procedure TCustomOpenGL.MouseMove(Shift: TShiftState; X, Y: Integer);

var

dx,dy: GLDouble;

S: string;

begin

MovePt:=Point(x,y);

 

{ Moving graphic with pressed left mouse button }

IF Shift=[ssLeft] then

begin

   dx := (oldMovePt.x-MovePt.x)/FZoom;

   dy := (oldMovePt.y-MovePt.y)/FZoom;

   IF FRotAngle<>0 then begin

   dx := dx / COS(DegToRad(FRotAngle));

   dy := dy / SIN(DegToRad(FRotAngle));

   end;

   Centrum := Point2d(FCentrum.x+dx,FCentrum.y-dy);

end;

 

{ Magnifying graphic with pressed right mouse button }

IF Shift=[ssRight] then

begin

   if oldMovePt.y<>MovePt.y then

      if oldMovePt.y>MovePt.y then

         Zoom := Zoom*1.1

      else

         Zoom := Zoom*0.9;

end;

 

oldMovePt := MovePt;

 

inherited MouseMove(Shift,x,Height-y);

end;

 

procedure TCustomOpenGL.MouseUp(Button: TMouseButton; Shift: TShiftState;

X, Y: Integer);

begin

Inherited MouseUp(Button,Shift,X, Y);

end;

 

procedure TCustomOpenGL.MoveWindow(x, y: double);

begin

Centrum := Point2d(Centrum.x-x,Centrum.y-y);

end;

 

procedure TCustomOpenGL.Paint;

var

ps : TPaintStruct;

begin

BeginPaint(Handle, ps);

If componentstate=[csDesigning] then

Demo;

 

if Assigned(FOnPaint) then

    FOnPaint(Self)

else

    inherited;

if FCentralCross then DrawCentralCross;

SwapBuffers(DC);

EndPaint(Handle, ps);

end;

 

procedure TCustomOpenGL.ReDraw;

begin

if not OpenGL_OK then glInit;

    glViewport(0,0,width ,height);

    glMatrixMode(GL_PROJECTION);

    glLoadIdentity;

    gluOrtho2D(OrtoLeft, OrtoRight, OrtoBottom, OrtoTop);

    glMatrixMode(GL_MODELVIEW);

glClear (GL_DEPTH_BUFFER_BIT or GL_COLOR_BUFFER_BIT);

Paint;

end;

 

procedure TCustomOpenGL.SetCentralCross(const Value: boolean);

begin

FCentralCross := Value;

invalidate;

end;

 

procedure TCustomOpenGL.SetClearColor(const Value: TColor);

Var szin: TSzin;

begin

FClearColor := Value;

If not OpenGL_OK then exit;

szin:=ColorToSzin(Value);

glClearcolor(szin.R,szin.G,szin.B,0);

glClear (GL_DEPTH_BUFFER_BIT or GL_COLOR_BUFFER_BIT);

invalidate;

end;

 

procedure TCustomOpenGL.SetRotAngle(const Value: double);

begin

FRotAngle := Value; //CorrectAngle(Value);

rSIN := SIN(DegToRad(FRotAngle)); rCOS := COS(DegToRad(FRotAngle));

//  Centrum  := Elforgatas(FCentrum,Origo,DegToRad(FRotAngle));

invalidate;

end;

 

procedure TCustomOpenGL.SetShadeModel(const Value: TShadeModel);

begin

if OpenGL_OK then

Try

FShadeModel := Value;

Case Value of

smFlat   : glShadeModel(GL_FLAT);

smSmooth : glShadeModel(GL_SMOOTH);

end;

invalidate;

except

end;

end;

 

procedure TCustomOpenGL.SetZoom(const Value: double);

var wx,hx: GLDouble;

begin

//  IF Value>16000 then FZoom:=16000 else

FZoom := Value;

if OpenGL_OK then

Try

wx := (Width/2)/FZoom;

hx := (Height/2)/FZoom;

OrtoLeft   := FCentrum.x - wx;

OrtoRight  := FCentrum.x + wx;

OrtoBottom := FCentrum.y - hx;

OrtoTop    := FCentrum.y + hx;

If Assigned(FChangeWindow) then FChangeWindow(Self,FCentrum,FZoom);

invalidate;

EXCEPT

end;

end;

 

procedure TCustomOpenGL.ShiftWindow(x, y: double);

begin

Centrum := Point2d(FCentrum.x+(x/FZoom),FCentrum.y+(y/FZoom));

end;

 

procedure TCustomOpenGL.WMEraseBkGnd(var Message: TWMEraseBkGnd);

begin

Message.Result := 0

end;

 

procedure TCustomOpenGL.WMPaint(var Msg: TWMPaint);

begin

ReDraw;

inherited;

end;

 

procedure TCustomOpenGL.WMSize(var Msg: TWMSize);

var w,h: GLDouble;

   wx,hx: GLDouble;

begin

Try

w  := Msg.Width;

h  := Msg.Height;

wx := (w/2)/FZoom;

hx := (h/2)/FZoom;

OrtoLeft   := FCentrum.x - wx;

OrtoRight  := FCentrum.x + wx;

OrtoBottom := FCentrum.y - hx;

OrtoTop    := FCentrum.y + hx;

BackBMP.Width := Msg.Width;

BackBMP.height := Msg.Height;

ReDraw;

inherited;

except

end;

end;

 

function TCustomOpenGL.Rot(p, porigo: TPoint2d; szog: double): TPoint2d;

begin

 

end;

 

function TCustomOpenGL.Rot(p:TPoint2d): TPoint2d;

begin

p.x := p.x - FCentrum.x;

p.y := p.y - FCentrum.y;

Result.x := p.x * rCOS + p.y * rSIN + FCentrum.x;

Result.y := p.y * rCOS - p.x * rSIN + FCentrum.y;

end;

 

function TCustomOpenGL.SToW(p: TPoint): TPoint2d;

begin

Result := Point2d(XToW(p.x),YToW(p.y));

RelRotate2D(Result,FCentrum,DegToRad(-FRotAngle));

end;

 

function TCustomOpenGL.WToS(p: TPoint2d): TPoint;

var pp: TPoint2d;

begin

pp := Rot(p);

Result := Point(XToS(pp.x),YToS(pp.y));

//  Result := Point(XToS(p.x),YToS(p.y));

end;

 

function TCustomOpenGL.XToS(x: double): integer;

begin

Result := Round(Width/2+(x-FCentrum.x)*FZoom);

end;

 

function TCustomOpenGL.YToS(y: double): integer;

begin

Result := Round(Height/2+(y-FCentrum.y)*FZoom);

end;

 

function TCustomOpenGL.XToW(x: integer): double;

begin

Result := FCentrum.x+(x-Width/2)/FZoom;

end;

 

function TCustomOpenGL.YToW(y: integer): double;

begin

Result := FCentrum.y+(y-Height/2)/FZoom;

end;

(*

function TCustomOpenGL.GetCanvas: TCanvas;

begin

Result := inherited Canvas;

end;

*)

procedure TCustomOpenGL.SetCentrum(const Value: TPoint2d);

var wx,hx: GLDouble;

begin

FCentrum := Value;

wx := (Width/2)/FZoom;

hx := (Height/2)/FZoom;

OrtoLeft   := Value.x - wx;

OrtoRight  := Value.x + wx;

OrtoBottom := Value.y - hx;

OrtoTop    := Value.y + hx;

ReDraw;

If Assigned(FChangeWindow) then FChangeWindow(Self,FCentrum,FZoom);

end;

 

function TCustomOpenGL.BuildFont(fntName: string): GLuint;

var

font: HFONT;                                 // Windows Font ID

begin

base := glGenLists(255);

font := CreateFont(-24,                                      // Height Of Font

                    0,                                                            // Width Of Font

                    0,                                                            // Angle Of Escapement

                    0,                                                            // Orientation Angle

                    FW_BOLD,                                       // Font Weight

                    0,                                                       // Italic

                    0,                                                       // Underline

                    0,                                                       // Strikeout

                    ANSI_CHARSET,                                 // Character Set Identifier

                    OUT_TT_PRECIS,                            // Output Precision

                    CLIP_DEFAULT_PRECIS,                      // Clipping Precision

                    ANTIALIASED_QUALITY,                           // Output Quality

                    FF_DONTCARE or DEFAULT_PITCH,       // Family And Pitch

                    pchar(Screen.Fonts[12]));                     // Font Name

 

SelectObject(DC, font);                                   // Selects The Font We Want

wglUseFontBitmaps(DC, 0, 255, base);             // Builds 96 Characters Starting At Character 32

//  DeleteObject(font);                                   // Selects The Font We Want

Result := base;

end;

 

procedure TCustomOpenGL.KillFont(fntBase: GLuint);                                     // Delete The Font

begin

glDeleteLists(fntBase, 255);                              // Delete All 96 Characters

end;

 

procedure TCustomOpenGL.Print(x,y: double; text : string);

var s: Array[0..255] of char;

   p :PChar;

begin

If text<>'' then

begin

  if base=0 then base:=BuildFont('Arial');

  glPushAttrib(GL_LIST_BIT);

  glRasterPos2f(x,y);

  glListBase(base);

  p:=StrPCopy(s,Text);

  glCallLists(length(p), GL_UNSIGNED_BYTE, p);

  glPopAttrib;

end;

end;

 

 

{  TALMapViewGL

  ========================================================================

  MapView Component in OpenGL

}

 

constructor TALMapViewGL.Create(AOwner: TComponent);

var i: integer;

begin

inherited;

fChar          := TMapChar.Create;

fChar.FontName := 'Algerian';

fChar.CharCode := 67;

FontList := TMapFontList.Create(Self);

for i:=1 to High(tm) do

     tm[i] := TMemoryStream.Create;

Hint1              := THintWindow.Create(Self);

Hinted             := True;

LayersInit;

newGraphic         := True;

FMapFile           := '';

FHRSZReteg         := 10;

FMAPAppend         := False;

FLatszik           := [vVonal, vFelirat];

end;

 

destructor TALMapViewGL.Destroy;

var i: integer;

begin

Try

for i:=0 to 10000 do begin

     if glIsList(i)<>0 then

           glDeleteLists(i,1);

end;

for i:=1 to High(tm) do

     if tm[i]<>nil then tm[i].Free;

FontList.Free;

fChar.free;

Hint1.Free;

inherited Destroy;

except

end;

end;

 

procedure TALMapViewGL.SetHRSZReteg(const Value: byte);

begin

FHRSZReteg := Value;

end;

 

procedure TALMapViewGL.SetLatszik(const Value: TVisibleSet);

begin

FLatszik := Value;

end;

 

procedure TALMapViewGL.SetMapFile(const Value: string);

begin

FMapFile := Value;

newGraphic := True;

LoadMapFile(FMapFile);

end;

 

procedure TALMapViewGL.SetRetegFile(const Value: string);

Var Ext: string;

begin

    FRetegFile := Value;

    Ext := ExtractFileExt(UpperCase(FRetegFile));

    if Ext='.LAY' then

       LoadLayers(FRetegFile);

    if Ext='.RTG' then

       LoadOldLayers(FRetegFile);

//     If RetegCombo<>nil then RetegCombo:=RetegCombo;

    Invalidate;

end;

 

function TALMapViewGL.LoadMapFile(fnev: string): boolean;

var fn        : string;

   filetipus : string;

   i         : integer;

   ures      : boolean;

begin

   Result := False;

   For i:=1 to High(tm) do

      If not FMAPappend then

         tm[i].Clear

      else

         tm[i].Seek(0,2);

 

   fn := UpperCase(fnev);

   If not FileExists(fn) then begin

      MessageDlg('Nem létező file!',mtError,[mbOk],0);

      exit;

   end;

 

   oldCur := Screen.Cursor;

   filetipus := Copy(fn,Pos('.',fn)+1,3);

//    fn:= Copy(fn,1,Pos('.',fn));

 

  Screen.Cursor := crHourGlass;

  invalidate;

  { StellaMAP térképek beolvasása }

  If filetipus = 'TRK' then Load_TRK(fn);

  If filetipus = 'PT' then Load_ITR(fn);

  If filetipus = 'DXF' then Load_DXF(fn);

  If filetipus = 'MAP' then LoadNewMapFile(fn);

 

  if Fitting then FittoScreen

//   If (not MAPappend) or ures then

  else

     MinMaxKeres;

if Assigned(FNewMapFile) then FNewMapFile(Self,fn);

Screen.Cursor := oldCur;

invalidate;

end;

 

{ StellaMap memóriastream mentése STMAP file-okba}

function TALMapViewGL.SaveMapFile(fnev: string): boolean;

var fn: string;

   hol: longint;

   ext: string;

begin

Try

   fn:= Copy(fnev,1,Pos('.',fnev));

   tm[1].SaveToFile(fn+'trk');

   tm[2].SaveToFile(fn+'lin');

   tm[3].SaveToFile(fn+'szv');

   tm[4].SaveToFile(fn+'jlk');

   Result := True;

   SaveLayers(fn+'lay');

except

   Result := False;

end;

end;

 

 

function TALMapViewGL.Load_DXF(FileName: string): boolean;

begin

 

end;

 

function TALMapViewGL.Load_ITR(fnev: string): boolean;

begin

 

end;

 

function TALMapViewGL.Load_TRK(fnev: string): boolean;

var fn: string;

   f: file;

   resu,k: integer;

begin

Try

   Result := True;

   fn:= Copy(fnev,1,Pos('.',fnev));

 

 

   If FileExists(fn+'TRK') then begin

      AssignFile(f,fn+'TRK');

      Reset(f,1);

      Repeat

            BlockRead(f,prec,Sizeof(prec),Resu);

            If Resu=SizeOf(prec) then

               tm[1].Write(prec,SizeOf(prec));

      Until Resu<>SizeOf(prec);

      CloseFile(f);

   end;

 

   If FileExists(fn+'LIN') then begin

      AssignFile(f,fn+'LIN');

      Reset(f,1);

       Repeat

            BlockRead(f,vrec,SizeOf(vrec),Resu);

            If Resu=SizeOf(vrec) then

               tm[2].Write(vrec,SizeOf(vrec));

      Until Resu<>SizeOf(vrec);

      CloseFile(F);

    end;

 

   If FileExists(fn+'SZV') then begin

      AssignFile(f,fn+'SZV');

      Reset(f,1);

      Repeat

            BlockRead(f,szrec,Sizeof(szrec),Resu);

            If Resu=SizeOf(szrec) then tm[3].Write(szrec,SizeOf(szrec));

      Until Resu<>SizeOf(szrec);

      CloseFile(f);

   end;

   If FileExists(fn+'JLK') then begin

      AssignFile(f,fn+'JLK');

      Reset(f,1);

      Repeat

            BlockRead(f,jrec,Sizeof(jrec),Resu);

            If Resu=SizeOf(jrec) then tm[4].Write(jrec,SizeOf(jrec));

      Until Resu<>SizeOf(jrec);

      CloseFile(f);

   end;

 

   If FileExists(fn+'LAY') then

      RetegFile := fn+'LAY'

   else

      RetegFile := RetegFile;

except

Result := False;

end;

end;

 

function TALMapViewGL.LoadNewMapFile(fnev: string): boolean;

Var

f: TFileStream;

begin

Try

f:= TFileStream.Create(fnev,fmOpenRead);

LoadFromStream(f);

finally

f.free;

end;

end;

 

function TALMapViewGL.SaveNewMapFile(fnev: string): boolean;

Var

f: TFileStream;

begin

Try

f:= TFileStream.Create(fnev,fmCreate);

SaveToStream(f);

finally

f.free;

end;

end;

 

procedure TALMapViewGL.LoadFromStream(stm: TStream);

Var

Lay: TMapLayer;

i,j,meret: integer;

 

(*

procedure SetGraphData(MapHeader: TMapHeader);

begin

   IF not FileExists(MapHeader.ImageFile) then

            MapHeader.ImageFile := ExtractFilePath(FMapFile)+ExtractFileName(MapHeader.ImageFile);

   DigitImage     := MapHeader.ImageFile;

   sCent          := MapHeader.ImageCent;

   FZoomDigit     := MapHeader.ImageZoom;

   FCentrum       := MapHeader.MapCent;

   FZoom          := MapHeader.MapZoom;

   FRotAngle      := MapHeader.MapRotAngle;

   ImageRotAngle  := MapHeader.ImageRotAngle;

end;

*)

begin

Try

if not FMapAppend then

    NewMap

else

    for i:=1 to 4 do tm[i].seek(0,2);

 

// Fejblokk betöltése

stm.Seek(0,0);

stm.Read(MapHeader,SizeOf(TMapHeader));

//  SetGraphData(MapHeader);

 

// Rétegtábla betöltése

For i:=0 to 255 do begin

     stm.Read(Lay,SizeOf(Lay));

     Layers[i]:=Lay;

end;

LayersRefresh;

 

// Rajzelemek betöltése

For i:=1 to 4 do begin

       Case i of

       1: meret:=MapHeader.PointCount*SizeOf(prec);

       2: meret:=MapHeader.LineCount*SizeOf(vrec);

       3: meret:=MapHeader.TextCount*SizeOf(szrec);

       4: meret:=MapHeader.SignCount*SizeOf(jrec);

       end;

       Try

       if meret>0 then

         tm[i].CopyFrom(stm,meret);

       except

       end;

end;

 

except

exit;

end;

end;

 

procedure TALMapViewGL.SaveToStream(stm: TStream);

begin

 

end;

 

procedure TALMapViewGL.LayersInit;

Var i: integer;

begin

For i:=0 to 255 do

     LayerInit(i);

end;

 

procedure TALMapViewGL.LayersDestroy;

Var i: integer;

begin

For i:=0 to 255 do

     LayerDestroy(i);

end;

 

procedure TALMapViewGL.LayersRefresh;

Var i: integer;

begin

       For i:=0 to 255 do begin

           rPen[i].Color := Layers[i].vonalszin;

           rPen[i].Width := Layers[i].vonalvastag;

           rPen[i].Style := TPenStyle(Layers[i].vonalstylus);

           rFont[i].Name := Layers[i].fontnev;

           rFont[i].Color:= Layers[i].szovegszin;

           rFont[i].Size := Layers[i].fontmeret;

       end;

       invalidate;

end;

 

procedure TALMapViewGL.LayerDestroy(IDx: byte);

begin

If rPen[IDx]<>nil then

    rPen[IDx].Free;

if rFont[IDx]<>nil then

    rFont[IDx].Free;

end;

 

procedure TALMapViewGL.LayerInit(IDx: byte);

begin

With Layers[IDx] do begin

ID        := IDx;

FillChar(Name, 20, Ord(' '));

Active    := True;

Homogen   := False;

Visible   := True;

vedett    := False;

vonalszin := DefaultLayer[Idx][0];

vonalvastag:=DefaultLayer[Idx][1];

end;

If rPen[IDx]=nil then

    rPen[IDx]       := TPen.Create;

    rPen[IDx].Color := DefaultLayer[Idx][0];

    rPen[IDx].Width := DefaultLayer[Idx][1];

if rFont[IDx]=nil then

    rFont[IDx]      := TFont.Create;

    rFont[IDx].Name := 'Arial CE';

    rFont[IDx].Color:= DefaultLayer[Idx][0];

    rFont[IDx].Size := 8;

end;

 

procedure TALMapViewGL.SetFitting(const Value: boolean);

begin

fFitting := Value;

end;

 

procedure TALMapViewGL.FitToScreen;

begin

MinMaxKeres;

end;

 

procedure TALMapViewGL.MinMaxKeres;

var x1,x2,y1,y2 : real;

   p: TPoint2d;

   i: longint;

begin

x1:=MaxInt;

x2:=-MaxInt;

y1:=MaxInt;

y2:=-MaxInt;

tm[1].Seek(0,0);

tm[2].Seek(0,0);

For i:=1 to Count[1] do begin

   tm[1].Read(prec,SizeOf(prec));

   If (prec.jelzo AND 1)=0 then begin

      If x1>prec.x then x1:=prec.x;

      If x2<prec.x then x2:=prec.x;

      If y1>prec.y then y1:=prec.y;

      If y2<prec.y then y2:=prec.y;

   end;

end;

For i:=1 to Count[2] do begin

   tm[2].Read(vrec,SizeOf(vrec));

   If (vrec.jelzo AND 1)=0 then begin

      If x1>vrec.x1 then x1:=vrec.x1;

      If x2<vrec.x2 then x2:=vrec.x2;

      If y1>vrec.y1 then y1:=vrec.y1;

      If y2<vrec.y2 then y2:=vrec.y2;

   end;

end;

Centrum := Point2d((x2+x1)/2,(y2+y1)/2);

IF (x2-x1)>(Y2-Y1) then

    Zoom := (Width-10)/(x2-x1)

else

    Zoom := (Height-10)/(y2-y1);

 

end;

 

function TALMapViewGL.SaveLayers(fnev: string): boolean;

Var i: integer;

   f: File of TMapLayer;

   Resu: integer;

begin

Try

    Result := True;

       AssignFile(f,fnev);

       Rewrite(f);

       For i:=0 to 255 do begin

           Layers[i].vonalszin     := rPen[i].Color;

           Layers[i].vonalvastag   := rPen[i].Width;

           Layers[i].vonalstylus   := Ord(rPen[i].Style);

           Layers[i].fontnev       := rFont[i].Name;

           Layers[i].szovegszin    := rFont[i].Color;

           Layers[i].fontmeret     := rFont[i].Size;

           Write(f,Layers[i]);

       end;

       CloseFile(f);

except

    CloseFile(f);

    Result := False;

end;

end;

 

procedure TALMapViewGL.NewMap;

var i: integer;

begin

for i:=1 to 4 do tm[i].Clear;

end;

 

procedure TALMapViewGL.SetAkcio(const Value: TAlakzatmod);

begin

FAkcio := Value;

end;

 

function TALMapViewGL.GetCount(Idx: integer): integer;

begin

case Idx of

1: Result := tm[1].Size div SizeOf(prec);

2: Result := tm[2].Size div SizeOf(vrec);

3: Result := tm[3].Size div SizeOf(szrec);

4: Result := tm[4].Size div SizeOf(jrec);

end;

end;

 

procedure TALMapViewGL.On_AfterPaint(Sender: TObject);

begin

with BackBMP.Canvas do begin

      TextOut(200,200,'123.2.12');

end;

//  If Assigned(FOnAfterPaint) then FOnAfterPaint(Self);

inherited;

end;

 

procedure TALMapViewGL.GenerateMap(ms: TRajzelemStream; method: integer);

VAR i,j,r    : integer;

   sz: TSzin;

   x1,y1,x2,y2: GLDouble;

   MF1,MF2: MapFontRec;

begin

CASE method of

0:

begin

    // Lines

    GetLayerStatistic;

    for r:=0 to 255 do begin

        I:=glIsList(r+1);

        if I=0 then

           glDeleteLists(r+1,1);

        if LayerStatistic[r]>0 then begin

           sz := ColorToSzin(Layers[r].vonalszin);

           tm[2].Seek(0,0);

           glNewList(r+1,GL_COMPILE);

           glLineWidth(Layers[r].vonalvastag);

           glBegin(GL_LINES);

             glColor3f(0.8,0.8,0.8);

             For i:=0 to Pred(Count[2]) do begin

               tm[2].Read(vrec,SizeOf(vrec));

               if vrec.reteg=r then begin

                  if not Homogen then

                     glColor3f(sz.R,sz.G,sz.B);

                  glVertex2d(vrec.x1,vrec.y1);

                  glVertex2d(vrec.x2,vrec.y2);

               end;

             end;

           glEnd();

           glEndList();

        end;

    end;

 

    // Points

    glNewList(1000,GL_COMPILE);

    glPointSize(4);

    glBegin(GL_POINTS);

    tm[1].Seek(0,0);

    For i:=0 to Pred(Count[1]) do begin

       tm[1].Read(prec,SizeOf(prec));

       sz := ColorToSzin(clWhite);

       glColor3f(sz.R,sz.G,sz.B);

       glVertex2d(prec.x,prec.y);

//        glCircle(prec.x,prec.y,10);

    end;

    glEnd();

    glEndList();

 

    // Text

    glNewList(2000,GL_COMPILE);

    glPointSize(4);

    glBegin(GL_POINTS);

    tm[3].Seek(0,0);

    For i:=0 to Pred(Count[3]) do begin

       tm[3].Read(szrec,SizeOf(szrec));

       if szrec.reteg=10 then

          sz := ColorToSzin(clRed)

       else

          sz := ColorToSzin(clGray);

       glColor3f(sz.R,sz.G,sz.B);

       glVertex2d(szrec.x,szrec.y);

    end;

    glEnd();

    glEndList();

(*

    // 'B' karakter

    glNewList(4000,GL_COMPILE);

    glBegin(GL_LINES);

    tm[3].Seek(0,0);

    For i:=0 to Pred(Count[3]) do begin

       tm[3].Read(szrec,SizeOf(szrec));

       sz := ColorToSzin(clRed);

       glColor3f(sz.R,sz.G,sz.B);

           fChar.GetPoint(0,MF1);

           x1:=szrec.x+MF1.Fx/128;

           y1:=szrec.y-MF1.Fy/128;

       for j:=1 to fChar.OutLine.Count-1 do begin

           fChar.GetPoint(j,MF2);

           x2:=szrec.x+MF2.Fx/128;

           y2:=szrec.y-MF2.Fy/128;

           glVertex2d(x1,y1);

           if MF2.FType=0 then

              glVertex2f(x1,y1)

           else

              glVertex2f(x2,y2);

              x1:=x2; y1:=y2;

       end;

    end;

    glEnd();

    glEndList();

*)

end;

1:

begin

end;

END;

end;

 

 

procedure TALMapViewGL.On_Paint(Sender: TObject);

var i,j,r: integer;

   sz: TSzin;

   x1,y1,x2,y2: GLDouble;

   MF1,MF2: MapFontRec;

   HwglDevice: HDC;

   f: GLDouble;

   ps : TPaintStruct;

   c,cr: TPoint2d;

begin

Try

 

BeginPaint(Handle, ps);

glClear(GL_COLOR_BUFFER_BIT);

glPushMatrix;

 

glLoadIdentity;

 

If Assigned(FOnBeforePaint) then FOnBeforePaint(Self);

 

If newGraphic then GenerateMap(tm, 0);

 

glTranslated(Centrum.x,Centrum.y,0);

glRotated(RotAngle,0,0,1);

glTranslated(-Centrum.x,-Centrum.y,0);

 

if vVonal in Latszik then

begin

    for r:=0 to 255 do

        if LayerStatistic[r]>0 then glCallList(r+1);

end;

if vPont in Latszik then

    glCallList(1000);

if (vFelirat in Latszik) and (Zoom>0.4) then

    glCallList(2000);

//  glCallList(4000);

 

if newGraphic then

    newGraphic:=False;

 

If Assigned(FOnAfterPaint) then FOnAfterPaint(Self);

 

if CentralCross then DrawCentralCross;

 

glPopMatrix;

SwapBuffers(DC);

EndPaint(Handle, ps);

 

except

exit;

end;

end;

 

function TALMapViewGL.LoadLayers(fnev: string): boolean;

Var i: integer;

   f: File of TMapLayer;

   Resu: integer;

begin

Try

    Result := True;

    If FileExists(fnev) then begin

       AssignFile(f,fnev);

       Reset(f);

       For i:=0 to 255 do begin

           Read(f,Layers[i]);

           rPen[i].Color := Layers[i].vonalszin;

           rPen[i].Width := Layers[i].vonalvastag;

           rPen[i].Style := TPenStyle(Layers[i].vonalstylus);

           rFont[i].Name := Layers[i].fontnev;

           rFont[i].Color:= Layers[i].szovegszin;

           rFont[i].Size := Layers[i].fontmeret;

       end;

       CloseFile(f);

//        AktReteg := AktReteg;

       FRetegfile := fnev;

    end;

except

    CloseFile(f);

    LayersRefresh;

    Result := False;

end;

end;

 

function TALMapViewGL.LoadOldLayers(fnev: string): boolean;

begin

 

end;

 

procedure TALMapViewGL.KeyDown(var Key: Word; Shift: TShiftState);

begin

Case Key of

VK_RETURN : FitToScreen;

end;

inherited;

end;

 

function TALMapViewGL.Feliratkeres(x, y: Integer;

var szrec: Tszovegrecord; var ap: Integer): boolean;

var x1,y1,x2,y2: double;

   tures      : double;

   szog       : double;

   szr: Tszovegrecord;

   i,meret: longint;

   t: tagSize;

   s: string;

   p: TPoint2d;

   R: TRect;

   tt: TRect2d;

   pp: TPoint;

begin

Result:=False;

//  streammeretek(cw);

//  tt:=GetMapArea(Canvas.Cliprect);

p := SToW(Point(x,y));

tures := {Tentativtures}12 / Zoom;

tm[3].Seek(0,0);

For i:=0 to Count[3]-1 do begin

    tm[3].Read(szr,SizeOf(szrec));

//     if PontInKep(szr.x,szr.y,tt) then begin

    x1 := szr.x - tures;

    x2 := szr.x + tures;

    y1 := szr.y - tures;

    y2 := szr.y + tures;

    If (p.x > x1) And (p.x < x2) Then

       If (p.y > y1) And (p.y < y2) Then

//           If (GetBit(szr.jelzo,0)=0) or cw.toroltek then

            begin

             ap := i;

             szrec:=szr;

             Result := True;

             Exit;

          end;

//     end;

end;

end;

{ TMapFont }

 

constructor TMapFont.Create;

var i: integer;

begin

For i:=0 to 255 do begin

   Chars[i] := TMapChar.Create;

   Chars[i].CharCode := i;

end;

FAutoFill := False;

FFontFile := '';

FFontName := '';

end;

 

destructor TMapFont.Destroy;

var i: integer;

begin

For i:=0 to 255 do

   Chars[i].Free;

inherited;

end;

 

 

procedure TMapFont.LoadMapFontFile(fntName: string);

begin

 

end;

 

procedure TMapFont.SaveMapFontFile(fntName: string);

begin

 

end;

 

procedure TMapFont.ClearChars;

begin

 

end;

 

 

procedure TMapFont.SetAutoFill(const Value: boolean);

begin

FAutoFill := Value;

if FAutoFill then begin

end;

end;

 

procedure TMapFont.SetFontFile(const Value: string);

begin

 

end;

 

procedure TMapFont.SetFontName(const Value: string);

var i: integer;

begin

FFontName := Value;

if FAutoFill then begin

    For i:=0 to 255 do begin

        Chars[i].FontName := Value;

        Chars[i].CharCode := i;

        Chars[i].SetTTFChar(i);

    end;

end;

end;

 

{ TMapFontList }

 

constructor TMapFontList.Create(AOwner: TComponent);

begin

end;

 

destructor TMapFontList.Destroy;

begin

ClearFonts;

inherited;

end;

 

procedure TMapFontList.AddFont(fntName: string);

begin

Pack;

end;

 

procedure TMapFontList.ClearFonts;

begin

end;

 

procedure TMapFontList.DeleteFont(AIndex: Integer);

begin

end;

 

{ TMapChar }

 

constructor TMapChar.Create;

begin

OutLine:=TList.Create;

end;

 

destructor TMapChar.Destroy;

begin

ClearPoints;

OutLine.Free;

inherited;

end;

 

procedure TMapChar.AddPoint(MFR: MapFontRec);

begin

GetMem(P,SizeOf(MapFontRec));

p^.FType := MFR.FType;

p^.Fx := MFR.Fx;

p^.Fy := MFR.Fy;

end;

 

procedure TMapChar.AddPoint(Atype: byte; Ax, Ay: integer);

begin

GetMem(P,SizeOf(MapFontRec));

p^.FType := AType;

p^.Fx := Ax;

p^.Fy := Ay;

OutLine.Add(p);

end;

 

procedure TMapChar.ChangePoint(AIndex: Integer; MFR: MapFontRec);

begin

p := OutLine.Items[AIndex];

MF.FType := p^.FType;

MF.Fx := p^.Fx;

MF.Fy := p^.Fy;

OutLine.Items[AIndex]:=p;

end;

 

procedure TMapChar.ClearPoints;

var i: integer;

begin

for i:=Pred(OutLine.Count) downto 0 do

     DeletePoint(i);

OutLine.Clear;

end;

 

procedure TMapChar.DeletePoint(AIndex: Integer);

begin

if (AIndex>=0) and (AIndex<=Pred(OutLine.Count)) then

begin

   FreeMem(OutLine.Items[AIndex],SizeOf(MapFontRec));

   OutLine.Delete(AIndex);

end;

end;

 

procedure TMapChar.GetPoint(AIndex: Integer; var MFR: MapFontRec);

begin

if (AIndex>-1) and (AIndex<OutLine.Count) then begin

p := OutLine.Items[AIndex];

MFR := MapFontRec(p^);

end;

end;

 

procedure TMapChar.InsertPoint(AIndex: Integer; MFR: MapFontRec);

begin

   GetMem(P,SizeOf(MapFontRec));

   P^.FType:=MFR.FType;

   P^.Fx:=MFR.Fx;

   P^.Fy:=MFR.FY;

   OutLine.Insert(AIndex,P);

end;

 

procedure TMapChar.SetCharCode(const Value: byte);

begin

FCharCode := Value;

SetTTFChar(FCharCode);

end;

 

procedure TMapChar.SetFontName(const Value: string);

begin

FFontName := Value;

end;

 

function TMapChar.GetPolyCount: integer;

var i: integer;

begin

Result := 0;

For i:=0 to Pred(Outline.Count) do begin

     if OutLine.Items[i]<>nil then begin

        p := OutLine.Items[i];

        if p^.FType=0 then Inc(Result);

     end;

end;

end;

 

//

function TMapChar.SetTTFChar(CharCode: byte): boolean;

// A Fontnév alapján feltölti az OutLine listát a kar. körvonalaval

var BMP: TBitmap;

   FPathPoints: array of TPoint;

   FPathTypes: array of Byte;

   FNumber: Integer;

   PointIdx: integer;

begin

Try

Try

Result := True;

BMP := TBitmap.Create;

BMP.Width := 1000;

BMP.Height := 1000;

With BMP.Canvas.Font do begin

      if FFontName='' then FFontName:='Arial';

      Name := FFontName;

      Size := 255;

end;

SetBkMode(BMP.Canvas.Handle, TRANSPARENT);

BeginPath(BMP.Canvas.Handle);

BMP.Canvas.TextOut(0, 0, CHR(CharCode));

EndPath(BMP.Canvas.Handle);

FlattenPath(BMP.Canvas.Handle);

 

FNumber := GetPath(BMP.Canvas.Handle, Pointer(nil^), Pointer(nil^), 0);

 

IF FNumber>0 then begin

    SetLength(FPathPoints, FNumber);

    SetLength(FPathTypes, FNumber);

    FNumber := GetPath(BMP.Canvas.Handle, FPathPoints[0], FPathTypes[0], FNumber);

 

    PointIdx := 0;

 

   while PointIdx < FNumber do begin

 

       CASE FPathTypes[PointIdx] of

       PT_MOVETO:

       begin

           AddPoint(0,FPathPoints[PointIdx].x,FPathPoints[PointIdx].y);

           inc(PointIdx, 1);

       end;

       PT_LINETO:

       begin

           AddPoint(1,FPathPoints[PointIdx].x,FPathPoints[PointIdx].y);

           inc(PointIdx, 1);

       end;

       PT_BEZIERTO:

       begin

           AddPoint(1,FPathPoints[PointIdx].x,FPathPoints[PointIdx].y);

           AddPoint(1,FPathPoints[PointIdx+1].x,FPathPoints[PointIdx+1].y);

           AddPoint(1,FPathPoints[PointIdx+2].x,FPathPoints[PointIdx+2].y);

           inc(PointIdx, 3);

       end;

       PT_LINETO or PT_CLOSEFIGURE:

       begin

           AddPoint(255,FPathPoints[PointIdx].x,FPathPoints[PointIdx].y);

           inc(PointIdx, 1);

       end;

       END;

 

   end;

END;

finally

BMP.Free;

end;

except

Result := False;

if BMP<>nil then BMP.Free;

exit;

end;

end;

 

procedure TALMapViewGL.MouseDown(Button: TMouseButton; Shift: TShiftState;

X, Y: Integer);

begin

inherited;

 

end;

 

procedure TALMapViewGL.MouseMove(Shift: TShiftState; X, Y: Integer);

var ap: integer;

   p: TPoint;

   w,he: integer;

begin

{Hint ablak rajzolása}

if FeliratKeres(x,Height-y,szrec,ap) then begin

    Cursor := crHandPoint;

    If Hinted then

    begin

      Hint1.Canvas.Font.Size:=8;

      if szrec.reteg=10 then begin

         Hint1.Canvas.Font.Style := [fsBold];

         Hint1.Canvas.Font.Color := clRed;

      end else begin

         Hint1.Canvas.Font.Style := [];

         Hint1.Canvas.Font.Color := clBlack;

      end;

      Hintstr := ' '+szrec.szoveg+'    ';

      p := ClientToScreen(point(x+8,y-18));

      w := Hint1.Canvas.TextWidth(Hintstr);

      he := Hint1.Canvas.TextHeight(Hintstr)+2;

      HintRect := Rect(p.x,p.y,p.x+w,p.y+he);

      ShowHintPanel(True);

//      If (not HintActive) or (Hintstr<>oldHintstr) then begin

//       end;

    end;

end

else begin

    ShowHintPanel(False);

    Cursor := crDefault;

end;

 

inherited;

end;

 

procedure TALMapViewGL.MouseUp(Button: TMouseButton; Shift: TShiftState; X,

Y: Integer);

begin

 

invalidate;  

inherited;

end;

 

procedure TALMapViewGL.ShowHintPanel(Show: Boolean);

begin

If Show then begin

    Hint1.ActivateHint(HintRect,Hintstr);

    oldHintstr := Hintstr;

    HintActive:=True;

end else begin

    If HintActive then begin

       Hint1.ReleaseHandle;

       HintActive := False;

    end;

end;

end;

 

procedure TALMapViewGL.Paint;

begin

On_Paint(Self);

inherited;

end;

 

procedure TALMapViewGL.GetLayerStatistic;

// Kigyüjti egy LayerStatistic tömbbe a rétegekben lévő vonalak számát

Var i,j: integer;

begin

for i:=0 to 255 do

     LayerStatistic[i]:=0;

     tm[2].Seek(0,0);

     for j:=0 to Pred(Count[2]) do begin

         tm[2].Read(vrec,SizeOf(vrec));

         Inc(LayerStatistic[vrec.reteg]);

     end;

end;

 

procedure TALMapViewGL.CMMouseEnter(var msg: TMessage);

begin

TabStop := True;

if Assigned(FMouseEnter) then FMouseEnter(Self);

invalidate;

inherited;

end;

 

procedure TALMapViewGL.CMMouseLeave(var msg: TMessage);

begin

TabStop := False;

ShowHintPanel(False);

if Assigned(FMouseLeave) then FMouseLeave(Self);

Screen.Cursor := crDefault;

invalidate;

inherited;

end;

 

procedure TALMapViewGL.SetHinted(const Value: boolean);

begin

fHinted := Value;

if not Value then ShowHintPanel(False);

end;

 

procedure TCustomOpenGL.glCircle(u, v, r: double);

var i:integer;

   x,y: GLDouble;

   RadAngle: double;

begin

glBegin(GL_LINES);

   For i:=0 to 360 do begin

       glColor3d(1.0,1.0,1.0);

       RadAngle := DegToRad(i);

       x := u+r*cos(RadAngle);

       y := v+r*sin(RadAngle);

       glVertex2d(x,y);

       RadAngle := DegToRad(i+1);

       x := u+r*cos(RadAngle);

       y := v+r*sin(RadAngle);

       glVertex2d(x,y);

   end;

glEnd;

end;

 

procedure TCustomOpenGL.glRectangle(p1, p2, p3, p4: TPoint2d);

begin

glBegin(GL_LINES);

   glVertex2d(p1.x,p1.y);

   glVertex2d(p2.x,p2.y);

   glVertex2d(p3.x,p3.y);

   glVertex2d(p4.x,p4.y);

glEnd;

end;

 

procedure TCustomOpenGL.glRectangle(p: TPoint2d; a, b: double);

begin

glBegin(GL_LINE_STRIP);

   glVertex2d(p.x-a/2,p.y+b/2);

   glVertex2d(p.x+a/2,p.y+b/2);

   glVertex2d(p.x+a/2,p.y-b/2);

   glVertex2d(p.x-a/2,p.y-b/2);

   glVertex2d(p.x-a/2,p.y+b/2);

glEnd;

end;

 

procedure TCustomOpenGL.glPrint(text: string);

begin

 

end;

 

// Translate of all Map elements phisicaly

procedure TALMapViewGL.Translate(dx, dy: double);

begin

 

end;

 

// Scale of all Map elements phisicaly

procedure TALMapViewGL.Scale(Cent: TPoint2d; ScaleFactor: double);

begin

 

end;

 

// Rotate of all Map elements phisicaly

procedure TALMapViewGL.Rotate(Cent: TPoint2d; Angle: double);

begin

 

end;

 

 

procedure TALMapViewGL.SetHomogen(const Value: boolean);

begin

if FHomogen <> Value then begin

FHomogen := Value;

newGraphic := True;

invalidate;

end;

end;

 

end.