1. ----------------------------------------------------------------------------- 
  2.  --  This file contains the body, please refer to specification (.ads file) 
  3.  ----------------------------------------------------------------------------- 
  4.  
  5. with Interfaces; 
  6. with GLUT.Windows;              use GLUT.Windows; 
  7. with Ada.Characters.Handling;   use Ada.Characters.Handling; 
  8. with System; 
  9. with Ada.Unchecked_Conversion; 
  10.  
  11. package body GLUT.Devices is 
  12.  
  13.    -- current_Window  : - for accessing the current GLUT window 
  14.    --                  - used by GLUT callbacks to determine the Window to which a callback event relates. 
  15.    -- 
  16.  
  17.    function current_Window return Windows.Window_view is 
  18.  
  19.       function to_Window is new Ada.Unchecked_Conversion (System.Address, Windows.Window_view); 
  20.  
  21.    begin 
  22.       return to_Window (GLUT.GetWindowData); 
  23.    end current_Window; 
  24.  
  25.    -- Keyboard 
  26.    -- 
  27.  
  28.    function current_Keyboard return p_Keyboard is 
  29.  
  30.       the_current_Window  : constant Windows.Window_view := current_Window; 
  31.  
  32.    begin 
  33.       case the_current_Window = null is 
  34.          when True  => return default_Keyboard'Access; 
  35.          when False => return GLUT.Windows.Keyboard (the_current_Window); 
  36.       end case; 
  37.    end current_Keyboard; 
  38.  
  39.    procedure Affect_modif_key (modif_code : Integer) is 
  40.  
  41.       use Interfaces; 
  42.       m : constant Unsigned_32 := Unsigned_32 (modif_code); 
  43.  
  44.    begin 
  45.       current_Keyboard.all.modif_set (GLUT.Active_Shift)   := (m and GLUT.Active_Shift)   /= 0; 
  46.       current_Keyboard.all.modif_set (GLUT.Active_Control) := (m and GLUT.Active_Control) /= 0; 
  47.       current_Keyboard.all.modif_set (GLUT.Active_Alt)     := (m and GLUT.Active_Alt)     /= 0; 
  48.    end Affect_modif_key; 
  49.  
  50.    procedure Update_modifier_keys is 
  51.  
  52.    begin 
  53.       Affect_modif_key (GLUT.GetModifiers); 
  54.       --  During a callback, GetModifiers may be called 
  55.       --  to determine the state of modifier keys 
  56.       --  when the keystroke generating the callback occurred. 
  57.    end Update_modifier_keys; 
  58.  
  59.    -- GLUT Callback procedures -- 
  60.  
  61.    procedure Key_Pressed (k : GLUT.Key_type; x, y : Integer) is 
  62.  
  63.    begin 
  64.       pragma Unreferenced (x, y); 
  65.       current_Keyboard.all.normal_set (To_Upper (Character'Val (k))) := True;   -- key k is pressed 
  66.       Update_modifier_keys; 
  67.    end Key_Pressed; 
  68.  
  69.    procedure Key_Unpressed (k : GLUT.Key_type; x, y : Integer) is 
  70.  
  71.    begin 
  72.       pragma Unreferenced (x, y); 
  73.       current_Keyboard.all.normal_set (To_Upper (Character'Val (k))) := False;  -- key k is unpressed 
  74.       Update_modifier_keys; 
  75.    end Key_Unpressed; 
  76.  
  77.    procedure Special_Key_Pressed (k : Integer; x, y : Integer) is 
  78.  
  79.    begin 
  80.       pragma Unreferenced (x, y); 
  81.       current_Keyboard.all.special_set (k) := True;  -- key k is pressed 
  82.       Update_modifier_keys; 
  83.    end Special_Key_Pressed; 
  84.  
  85.    procedure Special_Key_Unpressed (k : Integer; x, y : Integer) is 
  86.  
  87.    begin 
  88.       pragma Unreferenced (x, y); 
  89.       current_Keyboard.all.special_set (k) := False; -- key k is unpressed 
  90.       Update_modifier_keys; 
  91.    end Special_Key_Unpressed; 
  92.  
  93.    -- Mouse 
  94.    -- 
  95.  
  96.    function current_Mouse return p_Mouse is 
  97.  
  98.       the_current_Window  : constant Windows.Window_view := current_Window; 
  99.  
  100.    begin 
  101.       case the_current_Window = null is 
  102.          when True  => return default_Mouse'Access; 
  103.          when False => return GLUT.Windows.Mouse (the_current_Window); 
  104.       end case; 
  105.    end current_Mouse; 
  106.  
  107.    procedure Mouse_Event (button, state, x, y : Integer) is 
  108.       -- When a user presses and releases mouse buttons in the window, 
  109.       -- each press and each release generates a mouse callback. 
  110.    begin 
  111.       current_Mouse.all.mx := x; 
  112.       current_Mouse.all.my := y; 
  113.       if button in current_Mouse.all.button_state'Range then -- skip extra buttons (wheel, etc.) 
  114.          current_Mouse.all.button_state (button) := state = GLUT.DOWN; -- Joli, non ? 
  115.       end if; 
  116.       Update_modifier_keys; 
  117.    end Mouse_Event; 
  118.  
  119.    procedure Motion (x, y : Integer) is 
  120.       --  The motion callback for a window is called when the mouse moves within the 
  121.       --  window while one or more mouse buttons are pressed. 
  122.    begin 
  123.       current_Mouse.all.mx := x; 
  124.       current_Mouse.all.my := y; 
  125.    end Motion; 
  126.  
  127.    procedure Passive_Motion (x, y : Integer) is 
  128.       --  The passive motion callback for a window is called when 
  129.       --  the mouse moves within the window while no mouse buttons are pressed. 
  130.    begin 
  131.       current_Mouse.all.mx := x; 
  132.       current_Mouse.all.my := y; 
  133.    end Passive_Motion; 
  134.  
  135.    -- Initialize 
  136.    -- 
  137.  
  138.    procedure Initialize is 
  139.  
  140.       use GLUT; 
  141.  
  142.    begin 
  143.       IgnoreKeyRepeat (1); 
  144.       KeyboardFunc (Key_Pressed'Address); 
  145.       KeyboardUpFunc (Key_Unpressed'Address); 
  146.       SpecialFunc (Special_Key_Pressed'Address); 
  147.       SpecialUpFunc (Special_Key_Unpressed'Address); 
  148.       MouseFunc (Mouse_Event'Address); 
  149.       MotionFunc (Motion'Address); 
  150.       PassiveMotionFunc (Passive_Motion'Address); 
  151.    end Initialize; 
  152.  
  153.    -- User input management 
  154.    -- 
  155.  
  156.    function Strike_once (c  :        Character; 
  157.                          kb : access Keyboard := default_Keyboard'Access) return Boolean is 
  158.  
  159.    begin 
  160.       kb.all.normal_set_mem (c) := kb.all.normal_set (c); 
  161.       return kb.all.normal_set (c) and then not kb.all.normal_set_mem (c); 
  162.    end Strike_once; 
  163.  
  164.    function Strike_once (special :        Integer; 
  165.                          kb      : access Keyboard := default_Keyboard'Access) return Boolean is 
  166.  
  167.    begin 
  168.       kb.all.special_set_mem (special) := kb.all.special_set (special); 
  169.       return special in Special_key_set'Range 
  170.         and then kb.all.special_set (special) and then not kb.all.special_set_mem (special); 
  171.    end Strike_once; 
  172.  
  173. end GLUT.Devices;