From 051ddb2a265dda897bce72edc318beadd111eba2 Mon Sep 17 00:00:00 2001
From: Jed Barber <jjbarber@y7mail.com>
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
(limited to 'src')
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