From 051ddb2a265dda897bce72edc318beadd111eba2 Mon Sep 17 00:00:00 2001 From: Jed Barber Date: Sun, 6 Aug 2017 21:55:23 +1000 Subject: Mouseclick pathing now implemented --- src/displays.adb | 39 ++++++----- src/displays.ads | 28 ++++++-- src/grids.adb | 60 +++++++++------- src/grids.ads | 29 ++++++-- src/moves.adb | 25 +++++++ src/moves.ads | 10 +++ src/pathfinding.adb | 193 ++++++++++++++++++++++++++++++++++++++++++++++++++++ src/pathfinding.ads | 23 +++++++ src/sokoban.adb | 35 ++++++++++ 9 files changed, 388 insertions(+), 54 deletions(-) create mode 100644 src/pathfinding.adb create mode 100644 src/pathfinding.ads 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; -- cgit