-- ----------------------------------------------------------------- -- -- -- -- 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 SDL.Active; with SDL.Mouse; with SDL.Keysym; package body Testwm_Sprogs is package It renames Interfaces; package A renames SDL.Active; use type A.Active_State; package Ks renames SDL.Keysym; use type Ks.Key; use type Ks.SDLMod; use type C.int; use type V.Surface_Flags; use type V.Surface_ptr; use type V.Palette_ptr; use type V.GrabMode; package M renames SDL.Mouse; use type M.Mouse_Button_State; visible : C.int := 1; -- ============================================= 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; -- ============================================= procedure HotKey_ToggleFullScreen is screen : V.Surface_ptr; begin screen := V.GetVideoSurface; if V.WM_ToggleFullScreen (screen) /= 0 then Put ("Toggled 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 HotKey_Quit is event : Ev.Event; begin Put_Line ("Posting internal quit request"); event.the_type := Ev.ISUSEREVENT; Ev.PushEvent (event); end HotKey_Quit; -- ============================================= reallyquit : C.int := 0; 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 ("focus"); -- 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; -- We want to toggle visibility on buttonpress when Ev.MOUSEBUTTONDOWN | Ev.MOUSEBUTTONUP => if event.button.state = M.PRESSED then if visible /= 0 then visible := 0; else visible := 1; end if; M.ShowCursor (visible); end if; Put ("Mouse button " & Uint8'Image (event.button.button) & " has been"); if event.button.state = M.PRESSED then Put_Line (" pressed"); else Put_Line (" released"); end if; return 0; -- Show relative mouse motion when Ev.MOUSEMOTION => Put_Line ("Mouse relative motion: {" & Sint16'Image (event.motion.xrel) & ", " & Sint16'Image (event.motion.yrel) & "}"); return 0; when Ev.KEYDOWN => if event.key.keysym.sym = Ks.K_ESCAPE then HotKey_Quit; 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; return 0; -- this is important! Queue it if we want to quit. when Ev.QUIT => if reallyquit = 0 then reallyquit := 1; Put_Line ("Quit requested"); return 0; end if; Put_Line ("Quit demanded"); return 1; -- This will never happen because events queued directly -- to the event queue are not filtred. when Ev.ISUSEREVENT => return 1; -- Drop all other events when others => return 0; end case; end FilterEvents; end Testwm_Sprogs;