All keyboard controls now working except undo

5 files changed, 330 insertions, 18 deletions

diff --git a/src/displays.adb b/src/displays.adb
index dcb3932..03a0d43 100644
--- a/src/displays.adb
+++ b/src/displays.adb
@@ -2,7 +2,8 @@
 
 with
 
-    FLTK.Screen;
+    FLTK.Screen,
+    FLTK.Event;
 
 
 package body Displays is
@@ -32,11 +33,6 @@ package body Displays is
             Text       : in String)
         return Display
     is
-        Message_Text : String :=
-            "Move with the arrow keys. Press u for undo." & ASCII.LF &
-            "To move to a square where there is a clear path, click with the mouse." & ASCII.LF &
-            "Press n to skip this level, q to quit, and r to restart this level.";
-
         My_Width  : Integer := Max (Message_Box_Width, W);
         My_Height : Integer := Max (Message_Box_Height, H);
     begin
@@ -44,8 +40,9 @@ package body Displays is
                    (WD.Double_Window'(WD.Create (X, Y, My_Width, My_Height, Text)) with
 
                     Message_Box => B.Box'(B.Create
-                        (0, 0, Message_Box_Width, Message_Box_Height, Message_Text)),
-                    Current_Grid => null) do
+                        (0, 0, Message_Box_Width, Message_Box_Height, "")),
+                    Current_Grid => null,
+                    Key_Func => null) do
 
             This.Add (This.Message_Box);
             This.Message_Box.Set_Label_Size (Text_Size);
@@ -131,5 +128,42 @@ package body Displays is
     end Centre_On_Screen;
 
 
+
+
+    procedure Set_Message
+           (This : in out Display;
+            Msg  : in     String) is
+    begin
+        This.Message_Box.Set_Label (Msg);
+    end Set_Message;
+
+
+
+
+    procedure Set_Keyboard_Callback
+           (This : in out Display;
+            Func : in     Keyboard_Callback) is
+    begin
+        This.Key_Func := Func;
+    end Set_Keyboard_Callback;
+
+
+
+
+    function Handle
+           (This  : in out Display;
+            Event : in     FLTK.Event_Kind)
+        return FLTK.Event_Outcome
+    is
+        use type FLTK.Event_Kind;
+    begin
+        if This.Key_Func /= null and Event = FLTK.Keydown then
+            return This.Key_Func (FLTK.Event.Last_Keypress);
+        else
+            return WD.Double_Window (This).Handle (Event);
+        end if;
+    end Handle;
+
+
 end Displays;
 
diff --git a/src/displays.ads b/src/displays.ads
index 8d592e1..e8b04d8 100644
--- a/src/displays.ads
+++ b/src/displays.ads
@@ -16,6 +16,11 @@ package Displays is
     type Display is new FLTK.Widgets.Groups.Windows.Double.Double_Window with private;
 
 
+    type Keyboard_Callback is access function
+           (Key : in FLTK.Shortcut_Key)
+        return FLTK.Event_Outcome;
+
+
     function Create
            (X, Y, W, H : in Integer;
             Text       : in String)
@@ -49,16 +54,33 @@ package Displays is
            (This : in out Display);
 
 
+    procedure Set_Message
+           (This : in out Display;
+            Msg  : in     String);
+
+
+    procedure Set_Keyboard_Callback
+           (This : in out Display;
+            Func : in     Keyboard_Callback);
+
+
+    function Handle
+           (This  : in out Display;
+            Event : in     FLTK.Event_Kind)
+        return FLTK.Event_Outcome;
+
+
 private
 
 
     type Display is new FLTK.Widgets.Groups.Windows.Double.Double_Window with record
         Message_Box  : FLTK.Widgets.Boxes.Box;
         Current_Grid : access Grids.Grid;
+        Key_Func     : Keyboard_Callback;
     end record;
 
 
-    Text_Size : constant FLTK.Widgets.Font_Size := 12;
+    Text_Size : constant FLTK.Font_Size := 12;
     Message_Box_Width  : constant Integer := 500;
     Message_Box_Height : constant Integer := 100;
 
diff --git a/src/moves.adb b/src/moves.adb
new file mode 100644
index 0000000..e9bffc1
--- /dev/null
+++ b/src/moves.adb
@@ -0,0 +1,44 @@
+
+
+package body Moves is
+
+
+    procedure Add
+           (This : in out Path;
+            Item : in     Move) is
+    begin
+        This.Append (Item);
+    end Add;
+
+
+
+
+    procedure Add
+           (This : in out Path;
+            List : in     Path) is
+    begin
+        This.Append (List);
+    end Add;
+
+
+
+
+    function Latest
+           (This : in Path)
+        return Move is
+    begin
+        return This.Last_Element;
+    end Latest;
+
+
+
+
+    procedure Drop_Latest
+           (This : in out Path) is
+    begin
+        This.Delete_Last;
+    end Drop_Latest;
+
+
+end Moves;
+
diff --git a/src/moves.ads b/src/moves.ads
new file mode 100644
index 0000000..ebf2bb1
--- /dev/null
+++ b/src/moves.ads
@@ -0,0 +1,62 @@
+
+
+private with
+
+    Ada.Containers.Vectors;
+
+
+package Moves is
+
+
+    type Move is record
+        Delta_X, Delta_Y : Integer;
+        Push : Boolean;
+    end record;
+
+
+    Null_Move : constant Move;
+
+
+
+
+    type Path is tagged private;
+
+
+    Empty_Path : constant Path;
+
+
+    procedure Add
+           (This : in out Path;
+            Item : in     Move);
+
+
+    procedure Add
+           (This : in out Path;
+            List : in     Path);
+
+
+    function Latest
+           (This : in Path)
+        return Move;
+
+
+    procedure Drop_Latest
+           (This : in out Path);
+
+
+private
+
+
+    package Move_Vectors is new Ada.Containers.Vectors
+        (Index_Type => Positive, Element_Type => Move);
+
+
+    type Path is new Move_Vectors.Vector with null record;
+
+
+    Null_Move : constant Move := (Delta_X => 0, Delta_Y => 0, Push => False);
+    Empty_Path : constant Path := (Move_Vectors.Empty_Vector with null record);
+
+
+end Moves;
+
diff --git a/src/sokoban.adb b/src/sokoban.adb
index 9c3e490..b58874b 100644
--- a/src/sokoban.adb
+++ b/src/sokoban.adb
@@ -2,10 +2,12 @@
 
 with
 
+    FLTK.Widgets,
     Displays,
     Grids,
     Squares,
     Things,
+    Moves,
     Ada.Command_Line,
     Ada.Directories,
     Ada.Text_IO,
@@ -26,24 +28,53 @@ package body Sokoban is
            (X, Y : in Natural;
             Char : in Character);
 
+    procedure Move_Man
+           (Delta_X, Delta_Y : in Integer);
 
+    procedure Undo_Movement;
 
 
-    --  Global state of the game.
-
-    My_Display    : Displays.Display := Displays.Create;
-    My_Grid       : Grids.Grid       := Grids.Create (0, 0);
-    Current_Level : LevelID;
 
 
+    --  Miscellaneous game data.
 
-
-    --  Miscellaneous.
+    type Game_State is (Loading, Play, Complete);
 
     Origin : String := Ada.Directories.Containing_Directory
         (Ada.Directories.Full_Name (Ada.Command_Line.Command_Name));
     Level_Dir : String := Origin & "/../share/sokoban/level";
 
+    Loading_Message : String := "Loading...";
+
+    Play_Message : String := "Move with the arrow keys. Press u for undo." & ASCII.LF &
+        "To move to a square where there is a clear path, click with the mouse." & ASCII.LF &
+        "Press n to skip this level, q to quit, and r to restart this level.";
+
+    Complete_Message : String := "Level complete!" & ASCII.LF &
+        "Press enter to progress to the next level, or q to quit.";
+
+    Fully_Complete_Message : String := "Congratulations! All levels complete!" & ASCII.LF &
+        "Press enter to start again at the first level, or q to quit.";
+
+    U_Key : FLTK.Shortcut_Key := FLTK.Shortcut ('u');
+    N_Key : FLTK.Shortcut_Key := FLTK.Shortcut ('n');
+    R_Key : FLTK.Shortcut_Key := FLTK.Shortcut ('r');
+    Q_Key : FLTK.Shortcut_Key := FLTK.Shortcut ('q');
+
+
+
+
+    --  Global state of the game.
+
+    My_Display      : Displays.Display := Displays.Create;
+    My_Grid         : Grids.Grid       := Grids.Create (0, 0);
+    Current_Level   : LevelID;
+    Level_State     : Game_State       := Loading;
+    Current_Man_X   : Integer;
+    Current_Man_Y   : Integer;
+    Move_Record     : Moves.Path;
+    Goals_Remaining : Integer;
+
 
 
 
@@ -60,6 +91,9 @@ package body Sokoban is
 
         Rows, Cols : Natural;
     begin
+        Level_State := Loading;
+        My_Display.Set_Message (Loading_Message);
+        Goals_Remaining := 0;
         Open (Data_File, In_File, Filename);
 
         declare
@@ -85,9 +119,12 @@ package body Sokoban is
         end loop;
 
         Close (Data_File);
-
         Current_Level := Number;
         My_Display.Centre_On_Screen;
+        Move_Record := Moves.Empty_Path;
+        My_Display.Set_Message (Play_Message);
+        My_Grid.Redraw;
+        Level_State := Play;
     end Load_Level;
 
 
@@ -109,7 +146,54 @@ package body Sokoban is
 
 
 
-    --  Callbacks for keyboard controls.
+    --  Keyboard and mouse control handling.
+
+    function Keypress
+           (Key : in FLTK.Shortcut_Key)
+        return FLTK.Event_Outcome
+    is
+        use type FLTK.Shortcut_Key;
+    begin
+        if Key = Q_Key then
+            Hide;
+            return FLTK.Handled;
+        end if;
+
+        if Level_State = Play then
+            if Key = FLTK.Up_Key then
+                Move_Man (0, -1);
+            elsif Key = FLTK.Down_Key then
+                Move_Man (0, 1);
+            elsif Key = FLTK.Left_Key then
+                Move_Man (-1, 0);
+            elsif Key = FLTK.Right_Key then
+                Move_Man (1, 0);
+            elsif Key = U_Key then
+                Undo_Movement;
+            elsif Key = N_Key then
+                if Current_Level = LevelID'Last then
+                    My_Display.Set_Message (Fully_Complete_Message);
+                    Level_State := Complete;
+                else
+                    Load_Level (Current_Level + 1);
+                end if;
+            elsif Key = R_Key then
+                Load_Level (Current_Level);
+            else
+                return FLTK.Not_Handled;
+            end if;
+            return FLTK.Handled;
+        elsif Level_State = Complete and Key = FLTK.Enter_Key then
+            if Current_Level = LevelID'Last then
+                Load_Level (LevelID'First);
+            else
+                Load_Level (Current_Level + 1);
+            end if;
+            return FLTK.Handled;
+        else
+            return FLTK.Not_Handled;
+        end if;
+    end Keypress;
 
 
 
@@ -144,11 +228,14 @@ package body Sokoban is
 
             when '.' =>
                 My_Grid.Set_Square (X, Y, Squares.Goal);
+                Goals_Remaining := Goals_Remaining + 1;
 
             when '@' =>
                 Temp := Squares.Empty;
                 Temp.Set_Contents (Things.Man);
                 My_Grid.Set_Square (X, Y, Temp);
+                Current_Man_X := X;
+                Current_Man_Y := Y;
 
             when others =>
                 raise Program_Error;
@@ -157,10 +244,73 @@ package body Sokoban is
     end Add_New_Grid_Item;
 
 
+
+
+    procedure Move_Man
+           (Delta_X, Delta_Y : in Integer)
+    is
+        use type Squares.Square, Things.Thing;
+
+        Current : Squares.Square :=
+            My_Grid.Get_Square (Current_Man_X, Current_Man_Y);
+        Next : Squares.Square :=
+            My_Grid.Get_Square (Current_Man_X + Delta_X, Current_Man_Y + Delta_Y);
+        Next_Next : Squares.Square :=
+            My_Grid.Get_Square (Current_Man_X + Delta_X * 2, Current_Man_Y + Delta_Y * 2);
+    begin
+        if Next.Is_Walkable then
+            if Next.Get_Contents = Things.Nothing then
+                Current.Set_Contents (Things.Nothing);
+                My_Grid.Set_Square (Current_Man_X, Current_Man_Y, Current);
+                Current_Man_X := Current_Man_X + Delta_X;
+                Current_Man_Y := Current_Man_Y + Delta_Y;
+                Next.Set_Contents (Things.Man);
+                My_Grid.Set_Square (Current_Man_X, Current_Man_Y, Next);
+                Move_Record.Add ((Delta_X => Delta_X, Delta_Y => Delta_Y, Push => False));
+                My_Grid.Redraw;
+            elsif
+                Next.Get_Contents = Things.Treasure and Next_Next.Is_Walkable and
+                Next_Next.Get_Contents = Things.Nothing
+            then
+                Current.Set_Contents (Things.Nothing);
+                My_Grid.Set_Square (Current_Man_X, Current_Man_Y, Current);
+                Current_Man_X := Current_Man_X + Delta_X;
+                Current_Man_Y := Current_Man_Y + Delta_Y;
+                Next.Set_Contents (Things.Man);
+                My_Grid.Set_Square (Current_Man_X, Current_Man_Y, Next);
+                Next_Next.Set_Contents (Things.Treasure);
+                My_Grid.Set_Square (Current_Man_X + Delta_X, Current_Man_Y + Delta_Y, Next_Next);
+                Move_Record.Add ((Delta_X => Delta_X, Delta_Y => Delta_Y, Push => True));
+                My_Grid.Redraw;
+
+                if Next = Squares.Goal and Next_Next /= Squares.Goal then
+                    Goals_Remaining := Goals_Remaining + 1;
+                elsif Next /= Squares.Goal and Next_Next = Squares.Goal then
+                    Goals_Remaining := Goals_Remaining - 1;
+                end if;
+
+                if Goals_Remaining = 0 then
+                    My_Display.Set_Message (Complete_Message);
+                    Level_State := Complete;
+                end if;
+            end if;
+        end if;
+    end Move_Man;
+
+
+
+
+    procedure Undo_Movement is
+    begin
+        null;
+    end Undo_Movement;
+
+
 begin
 
 
     My_Display.Set_Grid (My_Grid);
+    My_Display.Set_Keyboard_Callback (Keypress'Access);
 
 
 end Sokoban;