-- ----------------------------------------------------------------- --
-- --
-- This is free software; you can redistribute it and/or --
-- modify it under the terms of the GNU General Public --
-- License as published by the Free Software Foundation; either --
-- version 2 of the License, or (at your option) any later version. --
-- --
-- This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of --
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --
-- General Public License for more details. --
-- --
-- You should have received a copy of the GNU General Public --
-- License along with this library; if not, write to the --
-- Free Software Foundation, Inc., 59 Temple Place - Suite 330, --
-- Boston, MA 02111-1307, USA. --
-- --
-- ----------------------------------------------------------------- --
-- ----------------------------------------------------------------- --
-- This is a translation, to the Ada programming language, of the --
-- original C test files written by Sam Lantinga - www.libsdl.org --
-- translation made by Antonio F. Vargas - www.adapower.net/~avargas --
-- ----------------------------------------------------------------- --
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Float_Text_IO; use Ada.Float_Text_IO;
with GNAT.OS_Lib;
with SDL.Video;
with SDL.Keysym;
with SDL.Keyboard;
with SDL.Active;
with SDL.Types; use SDL.Types;
with SDL.Timer;
with SDL.Error;
with gl_h; use gl_h;
with glu_h; use glu_h;
with AdaGL; use AdaGL;
package body TestGL_Sprogs is
use type C.unsigned;
use type C.int;
use type C.C_float;
package Ks renames SDL.Keysym;
use type Ks.Key;
use type Ks.SDLMod;
package Kb renames SDL.Keyboard;
package A renames SDL.Active;
use type A.Active_State;
package T renames SDL.Timer;
package Er renames SDL.Error;
use type V.Surface_Flags;
use type V.GrabMode;
use type V.Surface_ptr;
-- ======================================
procedure HotKey_ToggleFullScreen is
screen : V.Surface_ptr;
begin
screen := V.GetVideoSurface;
if V.WM_ToggleFullScreen (screen) /= 0 then
Put ("Toggle fullscreen mode - now ");
if (screen.flags and V.FULLSCREEN) /= 0 then
Put_Line (" fullscreen");
else
Put_Line ("windowed");
end if;
else
Put_Line ("Unable to toggle fullscreen mode");
end if;
end HotKey_ToggleFullScreen;
-- =============================================
procedure HotKey_ToggleGrab is
mode : V.GrabMode;
begin
Put_Line ("Ctrl-G: toggling input grab!");
mode := V.WM_GrabInput (V.GRAB_QUERY);
if mode = V.GRAB_ON then
Put_Line ("Grab was on");
else
Put_Line ("Grab was off");
end if;
if mode /= 0 then
mode := 0;
else
mode := 1;
end if;
mode := V.WM_GrabInput (mode);
if mode = V.GRAB_ON then
Put_Line ("Grab is now on");
else
Put_Line ("Grab is now off");
end if;
end HotKey_ToggleGrab;
-- ======================================
procedure HotKey_Iconify is
begin
Put_Line ("Ctrl-Z: iconifying window!");
V.WM_IconifyWindow;
end HotKey_Iconify;
-- ======================================
procedure HandleEvent (Result : out Boolean; event : in out Ev.Event) is
done : Boolean := False;
begin
case event.the_type is
when Ev.ISACTIVEEVENT =>
-- See what happened
Put ("App");
if event.active.gain /= 0 then
Put ("gained ");
else
Put ("lost ");
end if;
if (event.active.state and A.APPACTIVE) /= 0 then
Put ("active ");
elsif (event.active.state and A.APPMOUSEFOCUS) /= 0 then
Put ("mouse ");
elsif (event.active.state and A.APPINPUTFOCUS) /= 0 then
Put ("input ");
end if;
Put_Line ("focus");
when Ev.KEYDOWN =>
if event.key.keysym.sym = Ks.K_ESCAPE then
done := True;
end if;
if (event.key.keysym.sym = Ks.K_g) and
((event.key.keysym.the_mod and Ks.KMOD_CTRL) /= 0)
then
HotKey_ToggleGrab;
end if;
if (event.key.keysym.sym = Ks.K_z) and
((event.key.keysym.the_mod and Ks.KMOD_CTRL) /= 0)
then
HotKey_Iconify;
end if;
if (event.key.keysym.sym = Ks.K_RETURN) and
((event.key.keysym.the_mod and Ks.KMOD_ALT) /= 0)
then
HotKey_ToggleFullScreen;
end if;
Put_Line ("key '" &
CS.Value (Kb.GetKeyName (event.key.keysym.sym)) &
"' pressed");
when Ev.QUIT =>
done := True;
when others => null;
end case;
Result := done;
end HandleEvent;
-- ======================================
image : V.Surface_ptr := null;
x : C.int := 0;
y : C.int := 0;
delta_x : C.int := 1;
delta_y : C.int := 1;
last_moved : Uint32 := 0;
-- ======================================
procedure DrawSDLLogo is
dst : V.Rect;
screen : V.Surface_ptr;
begin
if image = null then
declare
temp : V.Surface_ptr;
begin
temp := V.LoadBMP (CS.New_String ("icon.bmp"));
if temp = null then
return;
end if;
image := V.CreateRGBSurface (
V.SWSURFACE,
temp.w, temp.h,
32,
-- BYTEORDER = LIL_ENDIAN
16#000000FF#,
16#0000FF00#,
16#00FF0000#,
16#FF000000#
-- BYTEORDER /= LILL_ENDIAN
-- 16#FF000000#,
-- 16#00FF0000#,
-- 16#0000FF00#,
-- 16#000000FF#
);
if image /= null then
V.BlitSurface (temp, null, image, null);
end if;
V.FreeSurface (temp);
if image = null then
return;
end if;
end;
end if;
screen := V.GetVideoSurface;
-- show the image on the screen
dst := (Sint16 (x), Sint16 (y),
Uint16 (image.w), Uint16 (image.h));
--
-- Move it around
-- Note that we do not clear the old position. This is because we
-- perform a glClear() which clears the framebuffer and then only
-- update the new area.
-- Note that you can also achieve interesting effects by modifying
-- the screen surface alpha channel. It's set to 255 by default..
if T.GetTicks - last_moved > 100 then
x := x + delta_x;
if x < 0 then
x := 0;
delta_x := -delta_x;
elsif x + image.w > screen.w then
x := screen.w - image.w;
delta_x := -delta_x;
end if;
y := y + delta_y;
if y < 0 then
y := 0;
delta_y := -delta_y;
elsif y + image.h > screen.h then
y := screen.h - image.h;
delta_y := -delta_y;
end if;
V.BlitSurface (image, null, screen, dst);
end if;
V.Update_Rect (screen, dst);
end DrawSDLLogo;
-- ======================================
procedure RunGLTest (video_flags : in out V.Surface_Flags;
logo : Boolean; slowly : Boolean;
bppixel : C.int; gamma : C.C_float)
is
bpp : C.int := bppixel;
type rgb_size_Array is array (0 .. 2) of C.int;
pragma Convention (C, rgb_size_Array);
rgb_size: rgb_size_Array;
w : C.int := 800; -- 1024; -- 640;
h : C.int := 600; -- 768; -- 480;
done : Boolean := False;
frames : C.int;
start_time, this_time : Uint32;
type Colors_Array is array (0 .. 7) of Three_GLfloat_Vector;
color : Colors_Array := ((1.0, 1.0, 0.0),
(1.0, 0.0, 0.0),
(0.0, 0.0, 0.0),
(0.0, 1.0, 0.0),
(0.0, 1.0, 1.0),
(1.0, 1.0, 1.0),
(1.0, 0.0, 1.0),
(0.0, 0.0, 1.0));
type Vertices_Array is array (0 .. 7) of Three_GLfloat_Vector;
cube : Vertices_Array := (( 0.5, 0.5, -0.5),
( 0.5, -0.5, -0.5),
(-0.5, -0.5, -0.5),
(-0.5, 0.5, -0.5),
(-0.5, 0.5, 0.5),
( 0.5, 0.5, 0.5),
( 0.5, -0.5, 0.5),
(-0.5, -0.5, 0.5));
value : aliased C.int;
use type C.char;
Poll_Event_Result : C.int;
begin
if SDL.Init (SDL.INIT_VIDEO) < 0 then
Put_Line ("Couldn't initialize SDl: " & Er.Get_Error);
GNAT.OS_Lib.OS_Exit (1);
end if;
-- See if we should detect the display depth
if bpp = 0 then
if V.GetVideoInfo.vfmt.BitsPerPixel <= 8 then
bpp := 8;
else
bpp := 16; -- More doesn seem to work
end if;
end if;
-- set the flags we want to use for setting the video mode
if logo then
video_flags := video_flags or V.OPENGLBLIT;
else
video_flags := video_flags or V.OPENGL;
end if;
-- if CL.Argument_Count > 0 then
-- if CL.Argument (1) = "-fullscreen" then
-- video_flags := video_flags or V.FULLSCREEN;
-- end if;
-- end if;
-- Initilize the display
case bpp is
when 8 => rgb_size := (2, 3, 3);
when 15 | 16 => rgb_size := (5, 5, 5);
when others => rgb_size := (8, 8, 8);
end case;
V.GL_SetAttribute (V.GL_RED_SIZE, rgb_size (0));
V.GL_SetAttribute (V.GL_GREEN_SIZE, rgb_size (1));
V.GL_SetAttribute (V.GL_BLUE_SIZE, rgb_size (2));
V.GL_SetAttribute (V.GL_DEPTH_SIZE, 16);
V.GL_SetAttribute (V.GL_DOUBLEBUFFER, 1);
if V.SetVideoMode (w, h, bpp, video_flags) = null then
Put_Line ("Couldn't set GL mode: " & Er.Get_Error);
SDL.SDL_Quit;
GNAT.OS_Lib.OS_Exit (1);
end if;
New_Line;
Put_Line ("Vendor :" & glGetString (GL_VENDOR));
Put_Line ("Renderer :" & glGetString (GL_RENDERER));
Put_Line ("Version :" & glGetString (GL_VERSION));
Put_Line ("Extensions :" & glGetString (GL_EXTENSIONS));
New_Line;
V.GL_GetAttribute (V.GL_RED_SIZE, value);
Put_Line ("GL_RED_SIZE: requested " &
C.int'Image (rgb_size (0)) & ", got" &
C.int'Image (value));
V.GL_GetAttribute (V.GL_GREEN_SIZE, value);
Put_Line ("GL_GREEN_SIZE: requested " &
C.int'Image (rgb_size (1)) & ", got" &
C.int'Image (value));
V.GL_GetAttribute (V.GL_BLUE_SIZE, value);
Put_Line ("GL_BLUE_SIZE: requested " &
C.int'Image (rgb_size (2)) & ", got" &
C.int'Image (value));
V.GL_GetAttribute (V.GL_DEPTH_SIZE, value);
Put_Line ("GL_DEPTH_SIZE: requested " &
C.int'Image (bpp) & ", got" &
C.int'Image (value));
V.GL_GetAttribute (V.GL_DOUBLEBUFFER, value);
Put_Line ("GL_DOUBLEBUFFER_SIZE: requested 1, got" &
C.int'Image (value));
-- Set the window manager title bar
V.WM_SetCaption (CS.New_String ("SDL GL test"),
CS.New_String ("testgl"));
-- Set the gamma for the window
if gamma /= 0.0 then
V.SetGamma (gamma, gamma, gamma);
end if;
glViewport (0, 0, GLsizei (w), GLsizei (h));
glMatrixMode (GL_PROJECTION);
glLoadIdentity;
glOrtho (-2.0, 2.0, -2.0, 2.0, -20.0, 20.0);
glMatrixMode (GL_MODELVIEW);
glLoadIdentity;
glEnable (GL_DEPTH_TEST);
glDepthFunc (GL_LESS);
glShadeModel (GL_SMOOTH);
-- Loop until done
start_time := T.GetTicks;
frames := 0;
while not done loop
declare
gl_error : GLenum;
sdl_error : CS.chars_ptr;
event : Ev.Event;
begin
-- Do our drawing, too
glClearColor (0.0, 0.0, 0.0, 1.0);
glClear (GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
glBegin (GL_QUADS);
-- SHADED_CUBE
glColor3fv (color (0));
glVertex3fv (cube (0));
glColor3fv (color (1));
glVertex3fv (cube (1));
glColor3fv (color (2));
glVertex3fv (cube (2));
glColor3fv (color (3));
glVertex3fv (cube (3));
glColor3fv (color (3));
glVertex3fv (cube (3));
glColor3fv (color (4));
glVertex3fv (cube (4));
glColor3fv (color (7));
glVertex3fv (cube (7));
glColor3fv (color (2));
glVertex3fv (cube (2));
glColor3fv (color (0));
glVertex3fv (cube (0));
glColor3fv (color (5));
glVertex3fv (cube (5));
glColor3fv (color (6));
glVertex3fv (cube (6));
glColor3fv (color (1));
glVertex3fv (cube (1));
glColor3fv (color (5));
glVertex3fv (cube (5));
glColor3fv (color (4));
glVertex3fv (cube (4));
glColor3fv (color (7));
glVertex3fv (cube (7));
glColor3fv (color (6));
glVertex3fv (cube (6));
glColor3fv (color (5));
glVertex3fv (cube (5));
glColor3fv (color (0));
glVertex3fv (cube (0));
glColor3fv (color (3));
glVertex3fv (cube (3));
glColor3fv (color (4));
glVertex3fv (cube (4));
glColor3fv (color (6));
glVertex3fv (cube (6));
glColor3fv (color (1));
glVertex3fv (cube (1));
glColor3fv (color (2));
glVertex3fv (cube (2));
glColor3fv (color (7));
glVertex3fv (cube (7));
-- FLAT CUBE
-- glColor3f(1.0, 0.0, 0.0);
-- glVertex3fv(cube (0));
-- glVertex3fv(cube (1));
-- glVertex3fv(cube (2));
-- glVertex3fv(cube (3));
-- glColor3f(0.0, 1.0, 0.0);
-- glVertex3fv(cube (3));
-- glVertex3fv(cube (4));
-- glVertex3fv(cube (7));
-- glVertex3fv(cube (2));
-- glColor3f(0.0, 0.0, 1.0);
-- glVertex3fv(cube (0));
-- glVertex3fv(cube (5));
-- glVertex3fv(cube (6));
-- glVertex3fv(cube (1));
-- glColor3f(0.0, 1.0, 1.0);
-- glVertex3fv(cube (5));
-- glVertex3fv(cube (4));
-- glVertex3fv(cube (7));
-- glVertex3fv(cube (6));
-- glColor3f(1.0, 1.0, 0.0);
-- glVertex3fv(cube (5));
-- glVertex3fv(cube (0));
-- glVertex3fv(cube (3));
-- glVertex3fv(cube (4));
-- glColor3f(1.0, 0.0, 1.0);
-- glVertex3fv(cube (6));
-- glVertex3fv(cube (1));
-- glVertex3fv(cube (2));
-- glVertex3fv(cube (7));
-- END CUBE
glEnd;
glMatrixMode (GL_MODELVIEW);
glRotatef (5.0, 1.0, 1.0, 1.0);
-- Draw 2D logo onto the 3D display
if logo then
DrawSDLLogo;
end if;
V.GL_SwapBuffers;
-- Check for errors conditions
gl_error := glGetError;
if gl_error /= GL_NO_ERROR then
Put_Line ("testgl: SDL error '" &
GLenum'Image(gl_error));
end if;
sdl_error := Er.GetError;
if CS.Value (sdl_error)(0) /= C.nul then
Put_Line ("testgl: SDL error '" &
CS.Value (sdl_error));
Er.ClearError;
end if;
-- Allow the user what's happening
if slowly then
T.SDL_Delay (20);
end if;
-- Check if there's a pending event
loop
Ev.PollEventVP (Poll_Event_Result, event);
exit when Poll_Event_Result = 0;
HandleEvent (done, event);
end loop;
frames := frames + 1;
end;
end loop;
-- Print out the frames per second
this_time := T.GetTicks;
if this_time /= start_time then
Put ((Float (frames) / Float (this_time - start_time)) * 1000.0,
3, 2, 0);
Put_Line (" FPS");
end if;
-- Destroy our GL context, etc
SDL.SDL_Quit;
end RunGLTest;
-- ======================================
end TestGL_Sprogs;
syntax highlighted by Code2HTML, v. 0.9.1