Mouseclick pathing now implemented

9 files changed, 388 insertions, 54 deletions

diff --git a/src/displays.adb b/src/displays.adb
index 4f3da3d..6931db9 100644
--- a/src/displays.adb
+++ b/src/displays.adb
@@ -46,7 +46,8 @@ package body Displays is
                     Move_Box => B.Box'(B.Create
                         (Stat_Box_Width, Message_Box_Height, Stat_Box_Width, Stat_Box_Height, "")),
                     Current_Grid => null,
-                    Key_Func => null) do
+                    Key_Func => null,
+                    Mouse_Func => null) do
 
             This.Add (This.Message_Box);
             This.Add (This.Level_Box);
@@ -58,8 +59,6 @@ package body Displays is
     end Create;
 
 
-
-
     function Create
            (W, H : in Integer)
         return Display is
@@ -68,8 +67,6 @@ package body Displays is
     end Create;
 
 
-
-
     function Create
         return Display is
     begin
@@ -92,8 +89,6 @@ package body Displays is
     end Set_Grid;
 
 
-
-
     procedure Adjust_Grid
            (This       : in out Display;
             Cols, Rows : in     Natural) is
@@ -104,8 +99,6 @@ package body Displays is
     end Adjust_Grid;
 
 
-
-
     procedure Ensure_Correct_Size
            (This : in out Display)
     is
@@ -127,8 +120,6 @@ package body Displays is
     end Ensure_Correct_Size;
 
 
-
-
     procedure Centre_On_Screen
            (This : in out Display)
     is
@@ -150,8 +141,6 @@ package body Displays is
     end Set_Message;
 
 
-
-
     procedure Set_Level_Number
            (This : in out Display;
             To   : in     Natural) is
@@ -160,8 +149,6 @@ package body Displays is
     end Set_Level_Number;
 
 
-
-
     procedure Set_Move_Number
            (This : in out Display;
             To   : in     Natural) is
@@ -180,6 +167,14 @@ package body Displays is
     end Set_Keyboard_Callback;
 
 
+    procedure Set_Mouse_Callback
+           (This : in out Display;
+            Func : in     Mouse_Callback) is
+    begin
+        This.Mouse_Func := Func;
+    end Set_Mouse_Callback;
+
+
 
 
     function Handle
@@ -187,10 +182,18 @@ package body Displays is
             Event : in     FLTK.Event_Kind)
         return FLTK.Event_Outcome
     is
-        use type FLTK.Event_Kind;
+        use type FLTK.Event_Kind, FLTK.Event_Outcome;
     begin
-        if This.Key_Func /= null and Event = FLTK.Keydown then
-            return This.Key_Func (FLTK.Event.Last_Keypress);
+        if  This.Key_Func /= null and then Event = FLTK.Keydown and then
+            This.Key_Func (FLTK.Event.Last_Keypress) = FLTK.Handled
+        then
+            return FLTK.Handled;
+
+        elsif This.Mouse_Func /= null and then Event = FLTK.Release and then
+            This.Mouse_Func (FLTK.Event.Mouse_X, FLTK.Event.Mouse_Y) = FLTK.Handled
+        then
+            return FLTK.Handled;
+
         else
             return WD.Double_Window (This).Handle (Event);
         end if;
diff --git a/src/displays.ads b/src/displays.ads
index d029dac..c52a058 100644
--- a/src/displays.ads
+++ b/src/displays.ads
@@ -16,63 +16,76 @@ 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;
 
+    type Mouse_Callback is access function
+           (X, Y : in Integer)
+        return FLTK.Event_Outcome;
+
+
+
 
     function Create
            (X, Y, W, H : in Integer;
             Text       : in String)
         return Display;
 
-
     function Create
            (W, H : in Integer)
         return Display;
 
-
     function Create
         return Display;
 
 
+
+
     procedure Set_Grid
            (This : in out Display;
             To   : in out Grids.Grid);
 
-
     procedure Adjust_Grid
            (This       : in out Display;
             Cols, Rows : in     Natural);
 
-
     procedure Ensure_Correct_Size
            (This : in out Display);
 
-
     procedure Centre_On_Screen
            (This : in out Display);
 
 
+
+
     procedure Set_Message
            (This : in out Display;
             Msg  : in     String);
 
-
     procedure Set_Level_Number
            (This : in out Display;
             To   : in     Natural);
 
-
     procedure Set_Move_Number
            (This : in out Display;
             To   : in     Natural);
 
 
+
+
     procedure Set_Keyboard_Callback
            (This : in out Display;
             Func : in     Keyboard_Callback);
 
+    procedure Set_Mouse_Callback
+           (This : in out Display;
+            Func : in     Mouse_Callback);
+
+
+
 
     function Handle
            (This  : in out Display;
@@ -89,6 +102,7 @@ private
         Move_Box     : FLTK.Widgets.Boxes.Box;
         Current_Grid : access Grids.Grid;
         Key_Func     : Keyboard_Callback;
+        Mouse_Func   : Mouse_Callback;
     end record;
 
 
diff --git a/src/grids.adb b/src/grids.adb
index 64f0c34..3da212b 100644
--- a/src/grids.adb
+++ b/src/grids.adb
@@ -15,8 +15,6 @@ package body Grids is
     end Create;
 
 
-
-
     function Create
            (X, Y : in Integer)
         return Grid is
@@ -27,21 +25,6 @@ package body Grids is
 
 
 
-    procedure Draw
-           (This : in out Grid) is
-    begin
-        for Y in Integer range 1 .. This.Rows loop
-            for X in Integer range 1 .. This.Cols loop
-                This.Cells.Reference (X).Reference (Y).Draw
-                   (This.Get_X + (X - 1) * Step,
-                    This.Get_Y + (Y - 1) * Step);
-            end loop;
-        end loop;
-    end Draw;
-
-
-
-
     procedure Set_Cols
            (This : in out Grid;
             To   : in     Natural) is
@@ -59,8 +42,6 @@ package body Grids is
     end Set_Cols;
 
 
-
-
     procedure Set_Rows
            (This : in out Grid;
             To   : in     Natural) is
@@ -87,8 +68,6 @@ package body Grids is
     end In_Bounds;
 
 
-
-
     function Get_Square
            (This : in Grid;
             X, Y : in Integer)
@@ -102,8 +81,6 @@ package body Grids is
     end Get_Square;
 
 
-
-
     procedure Set_Square
            (This : in out Grid;
             X, Y : in     Integer;
@@ -113,5 +90,42 @@ package body Grids is
     end Set_Square;
 
 
+
+
+    procedure Pixel_To_Colrow
+           (This : in     Grid;
+            X, Y : in     Integer;
+            C, R :    out Integer) is
+    begin
+        C := X / Step + 1;
+        R := Y / Step + 1;
+    end Pixel_To_Colrow;
+
+
+    procedure Colrow_To_Pixel
+           (This : in     Grid;
+            C, R : in     Integer;
+            X, Y :    out Integer) is
+    begin
+        X := (C - 1) * Step;
+        Y := (R - 1) * Step;
+    end Colrow_To_Pixel;
+
+
+
+
+    procedure Draw
+           (This : in out Grid) is
+    begin
+        for Y in Integer range 1 .. This.Rows loop
+            for X in Integer range 1 .. This.Cols loop
+                This.Cells.Reference (X).Reference (Y).Draw
+                   (This.Get_X + (X - 1) * Step,
+                    This.Get_Y + (Y - 1) * Step);
+            end loop;
+        end loop;
+    end Draw;
+
+
 end Grids;
 
diff --git a/src/grids.ads b/src/grids.ads
index af2971b..98230f8 100644
--- a/src/grids.ads
+++ b/src/grids.ads
@@ -16,21 +16,20 @@ package Grids is
     type Grid is new FLTK.Widgets.Widget with private;
 
 
+
+
     --  Don't use this.
     function Create
            (X, Y, W, H : in Integer;
             Text       : in String)
         return Grid;
 
-
     --  Use this instead.
     function Create
            (X, Y : in Integer)
         return Grid;
 
 
-    procedure Draw
-           (This : in out Grid);
 
 
     --  Meant for Displays to adjust the Grid.
@@ -38,25 +37,24 @@ package Grids is
            (This : in out Grid;
             To   : in     Natural);
 
-
     --  Meant for Displays to adjust the Grid.
     procedure Set_Rows
            (This : in out Grid;
             To   : in     Natural);
 
 
+
+
     function In_Bounds
            (This : in Grid;
             X, Y : in Integer)
         return Boolean;
 
-
     function Get_Square
            (This : in Grid;
             X, Y : in Integer)
         return Squares.Square;
 
-
     procedure Set_Square
            (This : in out Grid;
             X, Y : in     Integer;
@@ -64,6 +62,25 @@ package Grids is
         with Pre => This.In_Bounds (X, Y);
 
 
+
+
+    procedure Pixel_To_Colrow
+           (This : in     Grid;
+            X, Y : in     Integer;
+            C, R :    out Integer);
+
+    procedure Colrow_To_Pixel
+           (This : in     Grid;
+            C, R : in     Integer;
+            X, Y :    out Integer);
+
+
+
+
+    procedure Draw
+           (This : in out Grid);
+
+
 private
 
 
diff --git a/src/moves.adb b/src/moves.adb
index 11f92b4..391b35c 100644
--- a/src/moves.adb
+++ b/src/moves.adb
@@ -23,6 +23,16 @@ package body Moves is
 
 
 
+    procedure Prefix
+           (This : in out Path;
+            Item : in     Move) is
+    begin
+        This.Insert (1, Item);
+    end Prefix;
+
+
+
+
     function Latest
            (This : in Path)
         return Move is
@@ -50,5 +60,20 @@ package body Moves is
     end Length;
 
 
+
+
+    procedure Total_Delta
+           (This   : in     Path;
+            DX, DY :    out Integer) is
+    begin
+        DX := 0;
+        DY := 0;
+        for M of This loop
+            DX := DX + M.Delta_X;
+            DY := DY + M.Delta_Y;
+        end loop;
+    end Total_Delta;
+
+
 end Moves;
 
diff --git a/src/moves.ads b/src/moves.ads
index 1462847..728526c 100644
--- a/src/moves.ads
+++ b/src/moves.ads
@@ -32,6 +32,11 @@ package Moves is
             List : in     Path);
 
 
+    procedure Prefix
+           (This : in out Path;
+            Item : in     Move);
+
+
     function Latest
            (This : in Path)
         return Move;
@@ -46,6 +51,11 @@ package Moves is
         return Natural;
 
 
+    procedure Total_Delta
+           (This   : in     Path;
+            DX, DY :    out Integer);
+
+
 private
 
 
diff --git a/src/pathfinding.adb b/src/pathfinding.adb
new file mode 100644
index 0000000..1435ecf
--- /dev/null
+++ b/src/pathfinding.adb
@@ -0,0 +1,193 @@
+
+
+with
+
+    Things,
+    Ada.Containers.Ordered_Sets,
+    Ada.Containers.Ordered_Maps;
+
+
+package body Pathfinding is
+
+
+    type Node is record
+        X, Y : Integer;
+    end record;
+
+    function "<" (A, B : in Node) return Boolean is
+    begin
+        return A.X < B.X or (A.X = B.X and A.Y < B.Y);
+    end "<";
+
+    package Node_Sets is new Ada.Containers.Ordered_Sets
+        (Element_Type => Node);
+    package Node_To_Node_Maps is new Ada.Containers.Ordered_Maps
+        (Key_Type => Node, Element_Type => Node);
+
+
+
+
+    subtype G_Score is Integer;
+    subtype F_Score is Integer;
+
+    package G_Score_Maps is new Ada.Containers.Ordered_Maps
+        (Key_Type => Node, Element_Type => G_Score);
+    package F_Score_Maps is new Ada.Containers.Ordered_Maps
+        (Key_Type => Node, Element_Type => F_Score);
+
+    G_Scores : G_Score_Maps.Map := G_Score_Maps.Empty_Map;
+    F_Scores : F_Score_Maps.Map := F_Score_Maps.Empty_Map;
+
+
+
+
+    function F_Min
+           (N_Set : in Node_Sets.Set)
+        return Node
+    is
+        Result : Node := N_Set.First_Element;
+    begin
+        for N of N_Set loop
+            if F_Scores.Contains (N) then
+                if  not F_Scores.Contains (Result) or else
+                    F_Scores.Element (N) < F_Scores.Element (Result)
+                then
+                    Result := N;
+                end if;
+            end if;
+        end loop;
+        return Result;
+    end F_Min;
+
+
+
+
+    function Reconstruct_Path
+           (Came_From : in Node_To_Node_Maps.Map;
+            Current   : in Node)
+        return Moves.Path
+    is
+        Result : Moves.Path := Moves.Empty_Path;
+        Working : Node := Current;
+        Next : Node;
+    begin
+        while Came_From.Contains (Working) loop
+            Next := Came_From.Element (Working);
+            Result.Prefix
+                ((Delta_X => Working.X - Next.X, Delta_Y => Working.Y - Next.Y, Push => False));
+            Working := Next;
+        end loop;
+        return Result;
+    end Reconstruct_Path;
+
+
+
+
+    function Heuristic
+           (A, B : in Node)
+        return Integer is
+    begin
+        return abs (A.X - B.X) + abs (A.Y - B.Y);
+    end Heuristic;
+
+
+
+
+    function Neighbours
+           (My_Grid : in Grids.Grid;
+            Current : in Node)
+        return Node_Sets.Set
+    is
+        use type Things.Thing;
+
+        function Valid (X, Y : in Integer) return Boolean is
+        begin
+            return My_Grid.In_Bounds (X, Y) and then
+                My_Grid.Get_Square (X, Y).Is_Walkable and then
+                My_Grid.Get_Square (X, Y).Get_Contents = Things.Nothing;
+        end Valid;
+
+        Result : Node_Sets.Set := Node_Sets.Empty_Set;
+    begin
+        if Valid (Current.X - 1, Current.Y) then
+            Result.Insert ((Current.X - 1, Current.Y));
+        end if;
+        if Valid (Current.X + 1, Current.Y) then
+            Result.Insert ((Current.X + 1, Current.Y));
+        end if;
+        if Valid (Current.X, Current.Y - 1) then
+            Result.Insert ((Current.X, Current.Y - 1));
+        end if;
+        if Valid (Current.X, Current.Y + 1) then
+            Result.Insert ((Current.X, Current.Y + 1));
+        end if;
+        return Result;
+    end Neighbours;
+
+
+
+
+    function A_Star
+           (My_Grid : in Grids.Grid;
+            SX, SY  : in Integer;
+            FX, FY  : in Integer)
+        return Moves.Path
+    is
+        use type Node_Sets.Set;
+
+        Start   : Node := (X => SX, Y => SY);
+        Goal    : Node := (X => FX, Y => FY);
+        Current : Node;
+
+        Closed_Set : Node_Sets.Set := Node_Sets.Empty_Set;
+        Open_Set   : Node_Sets.Set := Node_Sets.To_Set (Start);
+
+        Came_From : Node_To_Node_Maps.Map := Node_To_Node_Maps.Empty_Map;
+    begin
+        G_Scores := G_Score_Maps.Empty_Map;
+        G_Scores.Insert (Start, 0);
+        F_Scores := F_Score_Maps.Empty_Map;
+        F_Scores.Insert (Start, Heuristic (Start, Goal));
+
+        --  This is a textbook implementation of A* search.
+        while Open_Set /= Node_Sets.Empty_Set loop
+            Current := F_Min (Open_Set);
+            if Current = Goal then
+                return Reconstruct_Path (Came_From, Current);
+            end if;
+            Open_Set.Delete (Current);
+            Closed_Set.Insert (Current);
+            for N of Neighbours (My_Grid, Current) loop
+                if not Closed_Set.Contains (N) then
+                    if not Open_Set.Contains (N) then
+                        Open_Set.Insert (N);
+                    end if;
+                    declare
+                        New_G_Score : G_Score := G_Scores.Element (Current) + 1;
+                        New_F_Score : F_Score := New_G_Score + Heuristic (N, Goal);
+                    begin
+                        if  not G_Scores.Contains (N) or else
+                            New_G_Score < G_Scores.Element (N)
+                        then
+                            Came_From.Insert (N, Current);
+                            G_Scores.Insert (N, New_G_Score);
+                            F_Scores.Insert (N, New_F_Score);
+                        end if;
+                    end;
+                end if;
+            end loop;
+        end loop;
+
+        --  And this is a modification to get as close as possible
+        --  if the goal is out of reach.
+        for N of Closed_Set loop
+            if Heuristic (N, Goal) < Heuristic (Current, Goal) then
+                Current := N;
+            end if;
+        end loop;
+        return Reconstruct_Path (Came_From, Current);
+    end A_Star;
+
+
+end Pathfinding;
+
diff --git a/src/pathfinding.ads b/src/pathfinding.ads
new file mode 100644
index 0000000..624c5d6
--- /dev/null
+++ b/src/pathfinding.ads
@@ -0,0 +1,23 @@
+
+
+with
+
+    Grids,
+    Moves;
+
+
+package Pathfinding is
+
+
+    --  Result path will get as close to the finish coordinates
+    --  as possible without pushing anything or going out of bounds.
+    function A_Star
+           (My_Grid : in Grids.Grid;
+            SX, SY  : in Integer;
+            FX, FY  : in Integer)
+        return Moves.Path
+        with Pre => My_Grid.In_Bounds (SX, SY);
+
+
+end Pathfinding;
+
diff --git a/src/sokoban.adb b/src/sokoban.adb
index 16b646e..e70d1d6 100644
--- a/src/sokoban.adb
+++ b/src/sokoban.adb
@@ -8,6 +8,7 @@ with
     Squares,
     Things,
     Moves,
+    Pathfinding,
     Ada.Command_Line,
     Ada.Directories,
     Ada.Text_IO,
@@ -202,6 +203,39 @@ package body Sokoban is
 
 
 
+    function Mouseclick
+           (X, Y : in Integer)
+        return FLTK.Event_Outcome
+    is
+        Col, Row, DX, DY : Integer;
+        Movement : Moves.Path;
+        Temp : Squares.Square;
+    begin
+        My_Grid.Pixel_To_Colrow (X, Y, Col, Row);
+        if My_Grid.In_Bounds (Col, Row) then
+            Movement := Pathfinding.A_Star (My_Grid, Current_Man_X, Current_Man_Y, Col, Row);
+            Movement.Total_Delta (DX, DY);
+
+            Temp := My_Grid.Get_Square (Current_Man_X, Current_Man_Y);
+            Temp.Set_Contents (Things.Nothing);
+            My_Grid.Set_Square (Current_Man_X, Current_Man_Y, Temp);
+            Current_Man_X := Current_Man_X + DX;
+            Current_Man_Y := Current_Man_Y + DY;
+            Temp := My_Grid.Get_Square (Current_Man_X, Current_Man_Y);
+            Temp.Set_Contents (Things.Man);
+            My_Grid.Set_Square (Current_Man_X, Current_Man_Y, Temp);
+
+            Move_Record.Add (Movement);
+            My_Display.Set_Move_Number (Move_Record.Length);
+            My_Grid.Redraw;
+            return FLTK.Handled;
+        end if;
+        return FLTK.Not_Handled;
+    end Mouseclick;
+
+
+
+
     --  Helper functions.
 
     procedure Add_New_Grid_Item
@@ -342,6 +376,7 @@ begin
 
     My_Display.Set_Grid (My_Grid);
     My_Display.Set_Keyboard_Callback (Keypress'Access);
+    My_Display.Set_Mouse_Callback (Mouseclick'Access);
 
 
 end Sokoban;