-- ----------------------------------------------------------------- --
-- --
-- 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 Interfaces.C.Strings;
with Ada.Text_IO; use Ada.Text_IO;
with SDL.Error;
with SDL.Active;
with SDL.Keysym;
with SDL.Mouse;
with SDL.Timer;
package body ThreadWin_Sprogs is
package It renames Interfaces;
package CS renames Interfaces.C.Strings;
use type C.int;
use type V.Surface_ptr;
use type V.Palette_ptr;
package Er renames SDL.Error;
use type Ev.Event_Mask;
package A renames SDL.Active;
use type A.Active_State;
package Ks renames SDL.Keysym;
use type Ks.Key;
package M renames SDL.Mouse;
use type M.Mouse_Button_State;
package Tm renames SDL.Timer;
use Uint8_Ptrs;
use Uint8_PtrOps;
-- Is the cursor visible
visible : Boolean := True;
type Mask_Array is
array (Integer range <>) of aliased Uint8;
pragma Convention (C, Mask_Array);
type Mask_Array_Access is access Mask_Array;
-- ======================================
procedure LoadIconSurface (
file : in string;
maskp : in out Icon_Mask_Array_Access;
icon : out V.Surface_ptr)
is
use type Interfaces.Unsigned_8;
mlen : C.int;
i : Integer;
pixels : Uint8_PtrOps.Pointer;
use V.Color_PtrOps;
begin
-- Load the icon surface
icon := V.LoadBMP (CS.New_String (file));
if icon = null then
Put_Line ("Couldn't load " & file & Er.Get_Error);
return;
end if;
-- Check width and height
if icon.w mod 8 /= 0 then
Put_Line ("Icon width must be a multiple of 8!");
V.FreeSurface (icon);
icon := null;
return;
end if;
if icon.format.palette = null then
Put_Line ("Icon must have a palette!");
V.FreeSurface (icon);
icon := null;
return;
end if;
-- Set the colorkey
V.SetColorKey (icon, V.SRCCOLORKEY,
Uint32(To_Pointer (icon.pixels).all));
-- Create the mask
pixels := Uint8_PtrOps.Pointer (To_Pointer (icon.pixels));
Put_Line ("Transparent pixel: (" &
Uint8'Image (
V.Color_ptr (
V.Color_PtrOps.Pointer (
icon.format.palette.colors) + C.ptrdiff_t (pixels.all)
).all.r
)
& "," &
Uint8'Image (
V.Color_ptr (
V.Color_PtrOps.Pointer (
icon.format.palette.colors) + C.ptrdiff_t (pixels.all)
).all.g
)
& "," &
Uint8'Image (
V.Color_ptr (
V.Color_PtrOps.Pointer (
icon.format.palette.colors) + C.ptrdiff_t (pixels.all)
).all.b
)
& ")");
mlen := icon.w * icon.h;
maskp := new V.Icon_Mask_Array (0 .. Integer(mlen/8 - 1));
maskp.all := (others => 0);
i := 0;
while i < Integer (mlen) loop
if Uint8_PtrOps.Pointer
(pixels + C.ptrdiff_t (i)
).all /= pixels.all
then
maskp (i / 8) := Uint8 (
It.Unsigned_8 (maskp (i / 8)) or 16#01#);
end if;
i := i + 1;
if i mod 8 /= 0 then
maskp (i / 8) := Shift_Left (maskp (i / 8), 1);
end if;
end loop;
end LoadIconSurface;
-- ======================================
reallyquit : Boolean := False;
-- ======================================
function FilterEvents (event : Ev.Event_ptr) return C.int is
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 ");
end if;
if (event.active.state and A.APPMOUSEFOCUS) /= 0 then
Put ("mouse ");
end if;
Put_Line ("input");
-- See if we are iconified or restored
if (event.active.state and A.APPACTIVE) /= 0 then
Put ("App has been ");
if event.active.gain /= 0 then
Put_Line ("restored");
else
Put_Line ("iconified");
end if;
end if;
return 0;
-- This is important! Queue it if we want to quit.
when Ev.QUIT =>
if not reallyquit then
reallyquit := True;
Put_Line ("Quit requested");
return 0;
end if;
Put_Line ("Quit demanded");
return 1;
-- Mouse and keyboard events go to threads
when Ev.MOUSEMOTION
| Ev.MOUSEBUTTONDOWN
| Ev.MOUSEBUTTONUP
| Ev.KEYDOWN
| Ev.KEYUP =>
return 1;
-- Drop all other events
when others =>
return 0;
end case;
end FilterEvents;
-- ======================================
function HandleMouse (unused : System.Address) return C.int
is
events : Ev.Events_Array (0 .. 9);
found : C.int;
mask : Ev.Event_Mask;
begin
-- Handle mouse events here
mask := (Ev.MOUSEMOTIONMASK or Ev.MOUSEBUTTONDOWNMASK or Ev.MOUSEBUTTONUPMASK);
while not done loop
Ev.PeepEventsVP (found, events, 10, Ev.GETEVENT, mask);
for i in Natural range 0 .. Natural (found) - 1 loop
case events (i).the_type is
-- We want to toggle visibility on buttonpress
when Ev.MOUSEBUTTONDOWN | Ev.MOUSEBUTTONUP =>
if events (i).button.state = SDL_PRESSED then
visible := not visible;
M.ShowCursor (Boolean'Pos(visible));
end if;
Put ("Mouse button '" & Uint8'Image (events (i).button.button));
if events (i).button.state = M.Mouse_Button_State (SDL_PRESSED) then
Put_Line ("' pressed");
else
Put_Line ("' released");
end if;
when Ev.MOUSEMOTION =>
Put_Line ("Mouse relative motion: {" &
Sint16'Image (events (i).motion.xrel) &
"," & Sint16'Image (events (i).motion.yrel) & "}");
when others => null;
end case;
end loop;
-- Give up some CPU to allow events to arrive
Tm.SDL_Delay (20);
end loop;
return 0;
end HandleMouse;
-- ======================================
function HandleKeyboard (unused : System.Address) return C.int
is
events : Ev.Events_Array (0 .. 9);
found : C.int;
mask : Ev.Event_Mask;
begin
-- Handle mouse events here
mask := (Ev.KEYDOWNMASK or Ev.KEYUPMASK);
while not done loop
Ev.PeepEventsVP (found, events, 10, Ev.GETEVENT, mask);
for i in Natural range 0 .. Natural (found) - 1 loop
case events (i).the_type is
-- We want to toggle visibility on buttonpress
when Ev.KEYDOWN | Ev.KEYUP =>
-- Allow hitting <ESC> to quit the app
if events (i).key.keysym.sym = Ks.K_ESCAPE then
done := True;
end if;
Put ("Key '" &
C.wchar_t'Image (C.wchar_t'Val (events (i).key.keysym.unicode)) &
"' has been ");
if events (i).key.state = Uint8 (SDL_PRESSED) then
Put_Line (" pressed");
else
Put_Line (" released");
end if;
when others => null;
end case;
end loop;
-- Give up some CPU to allow events to arrive
Tm.SDL_Delay (20);
end loop;
return 0;
end HandleKeyboard;
-- ======================================
end ThreadWin_Sprogs;
syntax highlighted by Code2HTML, v. 0.9.1