-- -----------------------------------------------------
-- Copyright (C) by:
-- Antonio F. Vargas - Ponta Delgada - Azores - Portugal
-- avargas@adapower.net
-- www.adapower.net/~avargas
-- -----------------------------------------------------
-- This program is in the public domain
-- -----------------------------------------------------
-- Command line options:
-- -info Print GL implementation information
-- (this is the original option).
-- -slow To slow down velocity under acelerated
-- hardware.
-- -window GUI window. Fullscreen is the default.
-- -nosound To play without sound.
-- -800x600 To create a video display of 800 by 600
-- the default mode is 640x480
-- -1024x768 To create a video display of 1024 by 768
-- -----------------------------------------------------
with Interfaces.C;
with Ada.Numerics.Generic_Elementary_Functions;
with Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.OS_Lib;
with SDL.Video;
with SDL.Error;
with SDL.Events;
with SDL.Keyboard;
with SDL.Keysym;
with SDL.Types; use SDL.Types;
with gl_h; use gl_h;
with AdaGL; use AdaGL;
with Double_Sprogs; use Double_Sprogs;
procedure Double is
package CL renames Ada.Command_Line;
package C renames Interfaces.C;
use type C.unsigned;
use type C.int;
use type SDL.Init_Flags;
package Vd renames SDL.Video;
use type Vd.Surface_ptr;
use type Vd.Surface_Flags;
package Er renames SDL.Error;
package Ev renames SDL.Events;
package Kb renames SDL.Keyboard;
package Ks renames SDL.Keysym;
use type Ks.SDLMod;
-- ===================================================================
procedure Display (Surface : Vd.Surface_ptr) is
begin
-- Clear all pixels
glClear (GL_COLOR_BUFFER_BIT);
glPushMatrix;
glRotatef (spin, 0.0, 0.0, 1.0);
glColor3f (1.0, 1.0, 1.0);
glRectf (-25.0, -25.0, 25.0, 25.0);
glPopMatrix;
-- don't wait!
-- start processing bufferd OpenGL routines.
-- glFlush;
-- glFinish;
Vd.GL_SwapBuffers;
end Display;
-- ===================================================================
procedure init (info : Boolean) is
begin
-- Set clearing color.
glClearColor (0.0, 0.0, 0.0, 0.0);
glShadeModel (GL_FLAT);
end init;
-- ===================================================================
type Idle_Proc_Type is access procedure;
Idle : Idle_Proc_Type := Null_Spin'Access;
-- ===================================================================
-- New window size of exposure
procedure reshape (Surface : Vd.Surface_ptr) is
h : GLdouble := GLdouble (Surface.h) / GLdouble (Surface.w);
begin
glViewport (0, 0, GLsizei (Surface.w), GLsizei (Surface.h));
glMatrixMode (GL_PROJECTION);
glLoadIdentity;
glOrtho (-50.0, 50.0, -50.0, 50.0, -1.0, 1.0);
glMatrixMode (GL_MODELVIEW);
glLoadIdentity;
-- draw (Surface);
end reshape;
-- ===================================================================
screen : Vd.Surface_ptr;
done : Boolean;
keys : Uint8_ptr;
Screen_Width : C.int := 1024;
Screen_Hight : C.int := 768;
Slowly : Boolean := False;
Info : Boolean := False;
Full_Screen : Boolean := True;
argc : Integer := CL.Argument_Count;
Video_Flags : Vd.Surface_Flags := 0;
Initialization_Flags : SDL.Init_Flags := 0;
-- ===================================================================
procedure Manage_Command_Line is
begin
while argc > 0 loop
if (argc >= 1) and then CL.Argument (argc) = "-slow" then
Slowly := True;
argc := argc - 1;
elsif CL.Argument (argc) = "-window" then
Full_Screen := False;
argc := argc - 1;
elsif CL.Argument (argc) = "-1024x768" then
Screen_Width := 1024;
Screen_Hight := 768;
argc := argc - 1;
elsif CL.Argument (argc) = "-800x600" then
Screen_Width := 800;
Screen_Hight := 600;
argc := argc - 1;
elsif CL.Argument (argc) = "-640x480" then
Screen_Width := 640;
Screen_Hight := 480;
argc := argc - 1;
elsif CL.Argument (argc) = "-info" then
Info := True;
argc := argc - 1;
else
Put_Line ("Usage: " & CL.Command_Name & " " &
"[-slow] [-window] [-h] [[-640x480] | [-800x600] | [-1024x768]]");
argc := argc - 1;
GNAT.OS_Lib.OS_Exit (0);
end if;
end loop;
end Manage_Command_Line;
-- ===================================================================
procedure mouse (Button : Uint8; x, y : Uint16) is
begin
case Button is
when 1 =>
Idle := Spin_Display'Access;
when others =>
Idle := Null_Spin'Access;
end case;
end mouse;
-- ===================================================================
procedure Main_System_Loop (Surface : Vd.Surface_ptr) is
begin
while not done loop
declare
event : Ev.Event;
PollEvent_Result : C.int;
begin
Idle.all;
loop
Ev.PollEventVP (PollEvent_Result, event);
exit when PollEvent_Result = 0;
case event.the_type is
when Ev.MOUSEBUTTONDOWN =>
mouse (event.button.button, event.button.x, event.button.y);
when Ev.VIDEORESIZE =>
screen := Vd.SetVideoMode (
event.resize.w,
event.resize.h,
16,
Vd.OPENGL or Vd.RESIZABLE);
if screen /= null then
reshape (screen);
else
-- Couldn't set the new video mode
null;
end if;
when Ev.QUIT =>
done := True;
when others => null;
end case;
end loop;
keys := Kb.GetKeyState (null);
if Kb.Is_Key_Pressed (keys, Ks.K_ESCAPE) then
done := True;
end if;
if Slowly then
delay (1.0/1000);
end if;
Display (Surface);
end; -- declare
end loop;
end Main_System_Loop;
-- ===================================================================
-- 'Double' Procedure body
-- ===================================================================
begin
Manage_Command_Line;
Initialization_Flags := SDL.INIT_VIDEO;
if SDL.Init (Initialization_Flags) < 0 then
Put_Line ("Couldn't load SDL: " & Er.Get_Error);
GNAT.OS_Lib.OS_Exit (1);
end if;
Video_Flags := Vd.OPENGL or Vd.RESIZABLE;
if Full_Screen then
Video_Flags := Video_Flags or Vd.FULLSCREEN;
end if;
screen := Vd.SetVideoMode (Screen_Width, Screen_Hight, 16, Video_Flags);
if screen = null then
Put_Line ("Couldn't set " & C.int'Image (Screen_Width) & "x" &
C.int'Image (Screen_Hight) & " GL video mode: " & Er.Get_Error);
SDL.SDL_Quit;
GNAT.OS_Lib.OS_Exit (2);
end if;
Vd.WM_Set_Caption ("Generic GL", "Generic");
init (Info);
reshape (screen);
done := False;
Main_System_Loop (screen);
SDL.SDL_Quit;
end Double;
syntax highlighted by Code2HTML, v. 0.9.1