StGlobe

Top  Previous  Next

A tovább fejlesztett naprendszer égitestjeinek megjelenítő programja.

Képes beolvasni a holdakról készült képeket is.

 

unit Unit1;

 

interface

 

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, ExtCtrls, AL_OpenGl, Opengl, DGLut, Buttons, ComCtrls, Math,

GraphicEx, ExtDlgs, FileCtrl, RzPanel, RzSplit, LMDCustomComponent,

LMDWndProcComponent, lmdregion, BUNotitle;

 

type

    PPixelArray = ^TPixelArray;

    TPixelArray = array [0..0] of Byte;

 

TForm1 = class(TForm)

   Panel1: TPanel;

   ALO: TALOpenGL;

   Timer1: TTimer;

   SpeedButton1: TSpeedButton;

   SpeedButton2: TSpeedButton;

   SpeedButton3: TSpeedButton;

   SpeedButton4: TSpeedButton;

   SpeedButton5: TSpeedButton;

   SpeedButton6: TSpeedButton;

   SpeedButton7: TSpeedButton;

   MeretCheckBox: TCheckBox;

   TrackBar1: TTrackBar;

   TrackBar2: TTrackBar;

   TrackBar3: TTrackBar;

   CheckBox1: TCheckBox;

   SpeedButton8: TSpeedButton;

   SpeedButton9: TSpeedButton;

   SpeedButton10: TSpeedButton;

   OpenPictureDialog1: TOpenPictureDialog;

   RzSizePanel1: TRzSizePanel;

   DirectoryListBox1: TDirectoryListBox;

   FileListBox1: TFileListBox;

   Panel2: TPanel;

   DriveComboBox1: TDriveComboBox;

   BUNoTitle1: TBUNoTitle;

   procedure ALOPaint(Sender: TObject);

   procedure FormCreate(Sender: TObject);

   procedure FormKeyDown(Sender: TObject; var Key: Word;

     Shift: TShiftState);

   procedure ALOInitGL(Sender: TObject);

   procedure Timer1Timer(Sender: TObject);

   procedure SpeedButton1Click(Sender: TObject);

   procedure MeretCheckBoxClick(Sender: TObject);

   procedure TrackBar1Change(Sender: TObject);

   procedure TrackBar2Change(Sender: TObject);

   procedure TrackBar3Change(Sender: TObject);

   procedure ALOMouseWheel(Sender: TObject; Shift: TShiftState;

     WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);

   procedure ALOMouseDown(Sender: TObject; Button: TMouseButton;

     Shift: TShiftState; X, Y: Integer);

   procedure ALOMouseMove(Sender: TObject; Shift: TShiftState; X,

     Y: Integer);

   procedure CheckBox1Click(Sender: TObject);

   procedure SpeedButton9Click(Sender: TObject);

   procedure TrackBar2KeyDown(Sender: TObject; var Key: Word;

     Shift: TShiftState);

   procedure FileListBox1DblClick(Sender: TObject);

   procedure FormActivate(Sender: TObject);

private

   FPlanet: integer;

   FPlanetAxis: double;

   FCoordVisible: boolean;

   FFullScreen: boolean;

 

   procedure DrawSphereCoords;

 

   procedure SetPlanet(const Value: integer);

   procedure SetPlanetAxis(const Value: double);

   procedure SetCoordVisible(const Value: boolean);

   procedure SetFullScreen(const Value: boolean);

public

   property Planet: integer read FPlanet write SetPlanet;

   property PlanetAxis: double read FPlanetAxis write SetPlanetAxis;

   property CoordVisible: boolean read FCoordVisible write SetCoordVisible;

   property FullScreen: boolean read FFullScreen write SetFullScreen;     

end;

 

var

Form1: TForm1;

xrot: GLfloat;

yrot: GLfloat;

zrot: GLfloat;

xspeed: GLfloat;

yspeed: GLfloat;

Mode:GLenum;

Radius:GLFloat;

Origin,movept: TPoint;

ujbolygo: string ='';

 

Tex : array[0..8] of Cardinal;

hatter: cardinal;

 

Const Bolygok : array[0..8] of string =

             ('Sun','Merkur','Venusz','Earth','Mars','Jupiter','Neptunusz','Moon','Új');

     BolygSugar : array[0..8] of double = (109,0.38,0.94,1,0.53,11.19,3.85,0.25,1);

 

function CreateTexture(Texture : String): cardinal;

 

implementation

 

uses Unit2;

 

{$R *.DFM}

 

function CreateTexture(Texture : String): cardinal;

var

bitmap: TBitmap;

BMInfo : TBitmapInfo;

I, ImageSize : Integer;

Temp : Byte;

MemDC : HDC;

Tex: PPixelArray;

begin

glenable(GL_TEXTURE_2D);

glGenTextures(1, @Result);

glBindTexture(GL_TEXTURE_2D, Result);

 

Bitmap:=TBitMap.Create;

Bitmap.LoadFromFile(Texture);

with BMinfo.bmiHeader do begin

   FillChar (BMInfo, SizeOf(BMInfo), 0);

   biSize := sizeof (TBitmapInfoHeader);

   biBitCount := 24;

   biWidth := Bitmap.Width;

   biHeight := Bitmap.Height;

   ImageSize := biWidth * biHeight;

   biPlanes := 1;

   biCompression := BI_RGB;

 

   MemDC := CreateCompatibleDC (0);

   GetMem (Tex, ImageSize *3);

   try

     GetDIBits (MemDC, Bitmap.Handle, 0, biHeight, Tex, BMInfo, DIB_RGB_COLORS);

     glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);

     glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);

     glTexImage2d(GL_TEXTURE_2D, 0, 3, biwidth, biheight, 0, GL_BGR_EXT, GL_UNSIGNED_BYTE, tex);

     For I := 0 to ImageSize - 1 do begin

         Temp := tex [I * 3];

         tex [I * 3] := tex [I * 3 + 2];

         tex [I * 3 + 2] := Temp;

     end;

    finally

     DeleteDC (MemDC);

     Bitmap.Free;

     FreeMem(tex);

  end;

end;

end;

 

procedure TForm1.FormCreate(Sender: TObject);

begin

Radius:=1;

xspeed := 0.4;

yspeed := 0.4;

xrot:=0;

yrot:=0;

zrot:=0;

FCoordVisible := False;

 

PlanetAxis:=90;

glEnable(GL_TEXTURE_GEN_S);

glEnable(GL_TEXTURE_GEN_T);

glTexEnvf(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE);

glTexGenf(GL_S, GL_TEXTURE_GEN_MODE, GL_OBJECT_LINEAR);

glTexGenf(GL_T, GL_TEXTURE_GEN_MODE, GL_OBJECT_LINEAR);

 

quadObj := gluNewQuadric;

gluQuadricDrawStyle(quadObj, GLU_FILL);

gluQuadricNormals(quadObj, GLU_SMOOTH);

gluQuadricTexture(quadObj,GL_TRUE);

end;

 

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;

Shift: TShiftState);

begin

if Key=VK_ADD then Radius:=Radius+0.1;

if Key=VK_SUBTRACT then Radius:=Radius-0.1;

 

IF Shift=[ssCtrl] then

Case Key of

VK_RETURN :

    begin

    FullScreen := not FullScreen;

    if FullScreen then begin

//        BUNoTitle1.HasTitle := False;

       WindowState:=wsMaximized;

       Panel1.Visible:=False;

       RzSizePanel1.Visible:=False;

//        BorderStyle:=bsNone;

    end else begin

       BorderStyle:=bsSizeable;

       WindowState:=wsMaximized;

       BUNoTitle1.HasTitle := True;

       Panel1.Visible:=True;

       RzSizePanel1.Visible:=False;

    end;

    end;

END;

ALO.Repaint;

end;

 

procedure TForm1.ALOPaint(Sender: TObject);

var w,h: double;

begin

glViewport(0, 0, Width, Height);

 

glMatrixMode(GL_PROJECTION);

glLoadIdentity();

gluPerspective(20.0,Width/Height,0.1,100.0);

glMatrixMode(GL_MODELVIEW);

 

glEnable(GL_TEXTURE_2D);

 

glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);

glLoadIdentity();

 

 

glpushmatrix;

w:=100; h:=10;

glBindTexture(GL_TEXTURE_2D, hatter);

glBegin(GL_QUADS);

    {Háttér kép rajzolás}

    glTexCoord2f(0.0,0.0);  glVertex3f(w,2*w,h);

    glTexCoord2f(0.0,1.0);  glVertex3f(-w,2*w,h);

    glTexCoord2f(1.0,1.0);  glVertex3f(-w,-2*w,h);

    glTexCoord2f(1.0,0.0);  glVertex3f(w,-2*w,h);

glEnd;

glpopmatrix;

 

 

glTranslatef(0,0,-5);

gltranslatef(0,0,Radius);

glpushmatrix;

 

glScalef(Radius/2,radius/2,Radius/2);

glRotatef(-PlanetAxis,1.0,0.0,0.0);

glRotatef(zrot,0.0,0.0,1.0);

 

glBindTexture(GL_TEXTURE_2D,tex[FPlanet]);

gluSphere(quadObj,1,36,18);

 

glDisable(GL_TEXTURE_2D);

if FCoordVisible then DrawSphereCoords;

 

glpopmatrix;

end;

 

procedure TForm1.ALOInitGL(Sender: TObject);

var i:Integer;

begin

  glEnable(GL_LIGHTING);

  glEnable(GL_LIGHT0);

  glLightf(GL_MAX_LIGHTS,GL_AMBIENT,0);

  glEnable(GL_DEPTH_TEST);

//   glEnable(GL_LINE_SMOOTH);

 

  for i:=0 to 7 do

      Tex[i]:=alo.CreateTexture(Bolygok[i]+'.jpg');

  FPlanet := 3;

  IF FileExists('hatter.jpg') then

     hatter:=alo.CreateTexture('hatter.jpg');

end;

 

procedure TForm1.Timer1Timer(Sender: TObject);

begin

xrot := xrot + xspeed;

yrot := yrot + yspeed;

zrot := zrot + yspeed;

alo.repaint;

end;

 

procedure TForm1.SetPlanet(const Value: integer);

begin

FPlanet := Value;

if FPlanet=8 then

    Caption := 'NAPRENDSZER BOLYGÓI  -  '+ujbolygo

else

    Caption := 'NAPRENDSZER BOLYGÓI  -  '+Bolygok[FPlanet];

end;

 

procedure TForm1.SpeedButton1Click(Sender: TObject);

begin

Planet := TComponent(Sender).Tag;

if MeretCheckBox.Checked then

    Radius := 1

else

    Radius := 0.1*BolygSugar[Planet];

end;

 

procedure TForm1.MeretCheckBoxClick(Sender: TObject);

begin

if MeretCheckBox.Checked then

    Radius := 1

else

    Radius := 0.1*BolygSugar[Planet];

end;

 

procedure TForm1.SetPlanetAxis(const Value: double);

begin

FPlanetAxis := Value;

alo.Repaint;

end;

 

procedure TForm1.TrackBar1Change(Sender: TObject);

begin

PlanetAxis := TrackBar1.Position;

end;

 

procedure TForm1.TrackBar2Change(Sender: TObject);

begin

xspeed := 0.1*TrackBar2.Position;

yspeed := 0.1*TrackBar2.Position;

end;

 

procedure TForm1.TrackBar3Change(Sender: TObject);

begin

Radius := TrackBar3.Position/50;

end;

 

procedure TForm1.ALOMouseWheel(Sender: TObject; Shift: TShiftState;

WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);

begin

if WheelDelta>0 then Radius:=1.05*Radius else Radius:=0.95*Radius;

end;

 

procedure TForm1.ALOMouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

Origin:=Point(x,y);

MovePt:=Origin;

end;

 

procedure TForm1.ALOMouseMove(Sender: TObject; Shift: TShiftState; X,

Y: Integer);

Var pa: double;

begin

if Shift=[ssRight] then begin

    if (y-MovePt.y)>0 then Radius:=1.01*Radius else Radius:=0.99*Radius;

end;

if Shift=[ssLeft] then begin

    if (y-MovePt.y)<0 then pa:=PlanetAxis+0.5*(y-MovePt.y)

       else pa:=PlanetAxis-0.5*(MovePt.y-y);

    if pa>180 then pa:=180;

    if pa<0 then pa:=0;

    PlanetAxis := pa;

    if (x-MovePt.x)<0 then zrot:=zrot+Radius*(x-MovePt.x)/5

       else zrot:=zrot+Radius*(x-MovePt.x)/5;

end;

MovePt:=Point(x,y);

end;

 

procedure TForm1.SetCoordVisible(const Value: boolean);

begin

FCoordVisible := Value;

invalidate;

end;

 

// Gömbi fokhálózat kirajzolása: szélesség, hosszúaág 10 fokonként

procedure TForm1.DrawSphereCoords;

var szKor,hKor: integer;

   dx,dy: double;

begin

glColor3d(1,0,0);

for szKor:=0 to 9 do begin

     dx := cos(DegToRad(10*szKor));

     dy := sin(DegToRad(10*szKor));

     glPushMatrix;

     gltranslatef(0,0,dy);

     glCircle(0,0,dx);

     glPopMatrix;

     glPushMatrix;

     gltranslatef(0,0,-dy);

     glCircle(0,0,dx);

     glPopMatrix;

end;

for hKor:=0 to 36 do begin

     glPushMatrix;

     glRotatef(90,1,0,0);

     glRotatef(10*hKor,0,1,0);

     glCircle(0,0,1);

     glPopMatrix;

end;

end;

 

procedure TForm1.CheckBox1Click(Sender: TObject);

begin

FCoordVisible:= CheckBox1.Checked;

end;

 

procedure TForm1.SpeedButton9Click(Sender: TObject);

begin

if not RzSizePanel1.Visible then

FileListBox1.FileName:=FileListBox1.Items.Strings[0];

RzSizePanel1.Visible := not RzSizePanel1.Visible;

(*

if OpenPictureDialog1.Execute then begin

      Tex[8]:=alo.CreateTexture(OpenPictureDialog1.FileName);

      ujbolygo:=ExtractFileName(OpenPictureDialog1.FileName);

      Caption := 'NAPRENDSZER BOLYGÓI  -  '+ujbolygo;

      Planet := 8;

end;*)

end;

 

procedure TForm1.TrackBar2KeyDown(Sender: TObject; var Key: Word;

Shift: TShiftState);

begin

if Key=VK_RETURN then

    if TrackBar2.Position=0 then

       TrackBar2.Position:=4

    else

       TrackBar2.Position:=0;

end;

 

procedure TForm1.FileListBox1DblClick(Sender: TObject);

begin

      Tex[8]:=alo.CreateTexture(FileListBox1.FileName);

      ujbolygo:=ExtractFileName(FileListBox1.FileName);

      Caption := 'NAPRENDSZER BOLYGÓI  -  '+ujbolygo;

      Planet := 8;

end;

 

procedure TForm1.FormActivate(Sender: TObject);

begin

DirectoryListBox1.Directory := 'images';

end;

 

procedure TForm1.SetFullScreen(const Value: boolean);

begin

FFullScreen := Value;

(*

if Value then begin

    ALO.Parent:=Form2;

    ALO.ParentWindow:=Form2.Handle;

    ALO.Align := alClient;

    Form2.Show;

end else begin

    ALO.Parent:=Form1;

    ALO.ParentWindow:=Form1.Handle;

    ALO.Align := alClient;

    Form2.Close;

end;

*)

end;

 

end.