From 2950872300a419344b39b9174f4b371a240272c6 Mon Sep 17 00:00:00 2001 From: Jed Barber Date: Sun, 30 Jul 2017 22:23:20 +1000 Subject: Basic game framework done, lacking any user input --- src/displays.adb | 135 ++++++++++++++++++++++++++++++++++++++++++++ src/displays.ads | 67 ++++++++++++++++++++++ src/grids.adb | 117 ++++++++++++++++++++++++++++++++++++++ src/grids.ads | 91 ++++++++++++++++++++++++++++++ src/main.adb | 16 ++++++ src/sokoban.adb | 167 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/sokoban.ads | 20 +++++++ src/squares.adb | 58 +++++++++++++++++++ src/squares.ads | 96 ++++++++++++++++++++++++++++++++ src/things.adb | 27 +++++++++ src/things.ads | 63 +++++++++++++++++++++ 11 files changed, 857 insertions(+) create mode 100644 src/displays.adb create mode 100644 src/displays.ads create mode 100644 src/grids.adb create mode 100644 src/grids.ads create mode 100644 src/main.adb create mode 100644 src/sokoban.adb create mode 100644 src/sokoban.ads create mode 100644 src/squares.adb create mode 100644 src/squares.ads create mode 100644 src/things.adb create mode 100644 src/things.ads (limited to 'src') diff --git a/src/displays.adb b/src/displays.adb new file mode 100644 index 0000000..dcb3932 --- /dev/null +++ b/src/displays.adb @@ -0,0 +1,135 @@ + + +with + + FLTK.Screen; + + +package body Displays is + + + package WD renames FLTK.Widgets.Groups.Windows.Double; + package B renames FLTK.Widgets.Boxes; + + + + + function Max (A, B : in Integer) return Integer is + begin + if B > A then return B; else return A; end if; + end Max; + + function Min (A, B : in Integer) return Integer is + begin + if B < A then return B; else return A; end if; + end Min; + + + + + function Create + (X, Y, W, H : in Integer; + 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 + return This : Display := + (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 + + This.Add (This.Message_Box); + This.Message_Box.Set_Label_Size (Text_Size); + end return; + end Create; + + + + + function Create + (W, H : in Integer) + return Display is + begin + return Create (0, 0, W, H, "Sokoban"); + end Create; + + + + + function Create + return Display is + begin + return Create (0, 0, Message_Box_Width, Message_Box_Height, "Sokoban"); + end Create; + + + + + procedure Set_Grid + (This : in out Display; + To : in out Grids.Grid) is + begin + if This.Current_Grid /= null then + This.Remove (This.Current_Grid.all); + end if; + This.Current_Grid := To'Unchecked_Access; + This.Add (To); + This.Ensure_Correct_Size; + end Set_Grid; + + + + + procedure Adjust_Grid + (This : in out Display; + Cols, Rows : in Natural) is + begin + This.Current_Grid.Set_Cols (Cols); + This.Current_Grid.Set_Rows (Rows); + This.Ensure_Correct_Size; + end Adjust_Grid; + + + + + procedure Ensure_Correct_Size + (This : in out Display) + is + New_Width : Integer := + Max (Message_Box_Width, This.Current_Grid.Get_W); + New_Height : Integer := + Message_Box_Height + This.Current_Grid.Get_H; + Grid_X : Integer := + Max (0, (Message_Box_Width - This.Current_Grid.Get_W) / 2); + begin + This.Current_Grid.Reposition (Grid_X, 0); + This.Message_Box.Resize (New_Width, This.Message_Box.Get_H); + This.Message_Box.Reposition (This.Message_Box.Get_X, This.Current_Grid.Get_H); + This.Resize (New_Width, New_Height); + end Ensure_Correct_Size; + + + + + procedure Centre_On_Screen + (This : in out Display) + is + use FLTK.Screen; + begin + This.Reposition + (Get_X + (Get_W - This.Get_W) / 2, + Get_Y + (Get_H - This.Get_H) / 2); + end Centre_On_Screen; + + +end Displays; + diff --git a/src/displays.ads b/src/displays.ads new file mode 100644 index 0000000..8d592e1 --- /dev/null +++ b/src/displays.ads @@ -0,0 +1,67 @@ + + +with + + FLTK.Widgets.Groups.Windows.Double, + Grids; + +private with + + FLTK.Widgets.Boxes; + + +package Displays is + + + type Display is new FLTK.Widgets.Groups.Windows.Double.Double_Window with private; + + + 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); + + +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; + end record; + + + Text_Size : constant FLTK.Widgets.Font_Size := 12; + Message_Box_Width : constant Integer := 500; + Message_Box_Height : constant Integer := 100; + + +end Displays; + diff --git a/src/grids.adb b/src/grids.adb new file mode 100644 index 0000000..64f0c34 --- /dev/null +++ b/src/grids.adb @@ -0,0 +1,117 @@ + + +package body Grids is + + + function Create + (X, Y, W, H : in Integer; + Text : in String) + return Grid is + begin + return This : Grid := + (FLTK.Widgets.Widget'(FLTK.Widgets.Create (X, Y, W, H, Text)) with + Cells => Square_Vector_Vectors.Empty_Vector, + Rows => 0, Cols => 0); + end Create; + + + + + function Create + (X, Y : in Integer) + return Grid is + begin + return Create (X, Y, 0, 0, "Sokoban Grid"); + end Create; + + + + + 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 + begin + This.Cells.Set_Length (Ada.Containers.Count_Type (To)); + for X in Integer range This.Cols + 1 .. To loop + This.Cells.Replace_Element (X, Square_Vectors.Empty_Vector); + This.Cells.Reference (X).Set_Length (Ada.Containers.Count_Type (This.Rows)); + for Y in Integer range 1 .. This.Rows loop + This.Cells.Reference (X).Replace_Element (Y, Squares.Void); + end loop; + end loop; + This.Cols := To; + This.Resize (Step * This.Cols, This.Get_H); + end Set_Cols; + + + + + procedure Set_Rows + (This : in out Grid; + To : in Natural) is + begin + for X in Integer range 1 .. This.Cols loop + This.Cells.Reference (X).Set_Length (Ada.Containers.Count_Type (To)); + for Y in Integer range This.Rows + 1 .. To loop + This.Cells.Reference (X).Replace_Element (Y, Squares.Void); + end loop; + end loop; + This.Rows := To; + This.Resize (This.Get_W, Step * This.Rows); + end Set_Rows; + + + + + function In_Bounds + (This : in Grid; + X, Y : in Integer) + return Boolean is + begin + return X in 1 .. This.Cols and Y in 1 .. This.Rows; + end In_Bounds; + + + + + function Get_Square + (This : in Grid; + X, Y : in Integer) + return Squares.Square is + begin + if not This.In_Bounds (X, Y) then + return Squares.Void; + else + return This.Cells.Element (X).Element (Y); + end if; + end Get_Square; + + + + + procedure Set_Square + (This : in out Grid; + X, Y : in Integer; + Item : in Squares.Square) is + begin + This.Cells.Reference (X).Reference (Y) := Item; + end Set_Square; + + +end Grids; + diff --git a/src/grids.ads b/src/grids.ads new file mode 100644 index 0000000..af2971b --- /dev/null +++ b/src/grids.ads @@ -0,0 +1,91 @@ + + +with + + FLTK.Widgets, + Squares; + +private with + + Ada.Containers.Vectors; + + +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. + procedure Set_Cols + (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; + Item : in Squares.Square) + with Pre => This.In_Bounds (X, Y); + + +private + + + Empty_Square : aliased Squares.Square := Squares.Void; + Step : constant Natural := 40; + + + package Square_Vectors is new Ada.Containers.Vectors + (Index_Type => Positive, + Element_Type => Squares.Square, + "=" => Squares."="); + package Square_Vector_Vectors is new Ada.Containers.Vectors + (Index_Type => Positive, + Element_Type => Square_Vectors.Vector, + "=" => Square_Vectors."="); + + + type Grid is new FLTK.Widgets.Widget with record + Cells : Square_Vector_Vectors.Vector; + Rows, Cols : Integer; + end record; + + +end Grids; + diff --git a/src/main.adb b/src/main.adb new file mode 100644 index 0000000..41b106e --- /dev/null +++ b/src/main.adb @@ -0,0 +1,16 @@ + + +with + + FLTK, + Sokoban; + + +function Main + return Integer is +begin + Sokoban.Load_Level (Sokoban.LevelID'First); + Sokoban.Show; + return FLTK.Run; +end Main; + diff --git a/src/sokoban.adb b/src/sokoban.adb new file mode 100644 index 0000000..9c3e490 --- /dev/null +++ b/src/sokoban.adb @@ -0,0 +1,167 @@ + + +with + + Displays, + Grids, + Squares, + Things, + Ada.Command_Line, + Ada.Directories, + Ada.Text_IO, + Ada.Strings.Fixed, + Ada.Strings.Maps; + +use + + Ada.Text_IO; + + +package body Sokoban is + + + -- Forward declarations of helper functions. + + procedure Add_New_Grid_Item + (X, Y : in Natural; + Char : in Character); + + + + + -- Global state of the game. + + My_Display : Displays.Display := Displays.Create; + My_Grid : Grids.Grid := Grids.Create (0, 0); + Current_Level : LevelID; + + + + + -- Miscellaneous. + + Origin : String := Ada.Directories.Containing_Directory + (Ada.Directories.Full_Name (Ada.Command_Line.Command_Name)); + Level_Dir : String := Origin & "/../share/sokoban/level"; + + + + + -- Main program interface. + + procedure Load_Level + (Number : in LevelID) + is + use Ada.Strings, Ada.Strings.Fixed, Ada.Strings.Maps; + + Data_File : File_Type; + Filename : String := + Level_Dir & "/level" & Trim (LevelID'Image (Number), Both) & ".data"; + + Rows, Cols : Natural; + begin + Open (Data_File, In_File, Filename); + + declare + Row_Line : String := Get_Line (Data_File); + Col_Line : String := Get_Line (Data_File); + Start, Finish : Natural; + begin + Find_Token (Row_Line, To_Set ("0123456789"), 1, Inside, Start, Finish); + Rows := Natural'Value (Row_Line (Start .. Finish)); + Find_Token (Col_Line, To_Set ("0123456789"), 1, Inside, Start, Finish); + Cols := Natural'Value (Col_Line (Start .. Finish)); + end; + My_Display.Adjust_Grid (Cols, Rows); + + for Y in Integer range 1 .. Rows loop + declare + Working_Line : String := Get_Line (Data_File); + begin + for X in Integer range 1 .. Cols loop + Add_New_Grid_Item (X, Y, Working_Line (X)); + end loop; + end; + end loop; + + Close (Data_File); + + Current_Level := Number; + My_Display.Centre_On_Screen; + end Load_Level; + + + + + procedure Show is + begin + My_Display.Show; + end Show; + + + + + procedure Hide is + begin + My_Display.Hide; + end Hide; + + + + + -- Callbacks for keyboard controls. + + + + + -- Helper functions. + + procedure Add_New_Grid_Item + (X, Y : in Natural; + Char : in Character) + is + Temp : Squares.Square; + begin + case Char is + when '#' => + My_Grid.Set_Square (X, Y, Squares.Wall); + + when ' ' => + My_Grid.Set_Square (X, Y, Squares.Empty); + + when '$' => + Temp := Squares.Empty; + Temp.Set_Contents (Things.Treasure); + My_Grid.Set_Square (X, Y, Temp); + + when '*' => + Temp := Squares.Goal; + Temp.Set_Contents (Things.Treasure); + My_Grid.Set_Square (X, Y, Temp); + + when '!' => + My_Grid.Set_Square (X, Y, Squares.Space); + + when '.' => + My_Grid.Set_Square (X, Y, Squares.Goal); + + when '@' => + Temp := Squares.Empty; + Temp.Set_Contents (Things.Man); + My_Grid.Set_Square (X, Y, Temp); + + when others => + raise Program_Error; + + end case; + end Add_New_Grid_Item; + + +begin + + + My_Display.Set_Grid (My_Grid); + + +end Sokoban; + diff --git a/src/sokoban.ads b/src/sokoban.ads new file mode 100644 index 0000000..ec88cc6 --- /dev/null +++ b/src/sokoban.ads @@ -0,0 +1,20 @@ + + +package Sokoban is + + + type LevelID is new Integer range 0 .. 50; + + + procedure Load_Level + (Number : in LevelID); + + + procedure Show; + + + procedure Hide; + + +end Sokoban; + diff --git a/src/squares.adb b/src/squares.adb new file mode 100644 index 0000000..673f425 --- /dev/null +++ b/src/squares.adb @@ -0,0 +1,58 @@ + + +package body Squares is + + + function Is_Walkable + (This : in Square) + return Boolean is + begin + return This.Walkable; + end Is_Walkable; + + + + + function Get_Contents + (This : in Square) + return Things.Thing is + begin + return This.Contents; + end Get_Contents; + + + + + procedure Set_Contents + (This : in out Square; + Item : in Things.Thing) is + begin + This.Contents := Item; + end Set_Contents; + + + + + procedure Draw + (This : in Square; + X, Y : in Integer) is + begin + This.Self_Image.Draw (X, Y); + This.Contents.Draw (X, Y); + end Draw; + + + + + function "=" + (A, B : in Square) + return Boolean is + begin + return + A.Walkable = B.Walkable and + A.Self_Image = B.Self_Image; + end "="; + + +end Squares; + diff --git a/src/squares.ads b/src/squares.ads new file mode 100644 index 0000000..7f9b090 --- /dev/null +++ b/src/squares.ads @@ -0,0 +1,96 @@ + + +with + + Things; + +private with + + FLTK.Images.RGB.PNG, + Ada.Command_Line, + Ada.Directories; + + +package Squares is + + + type Square is tagged private; + + + Void : constant Square; + + + Wall : constant Square; + Space : constant Square; + Empty : constant Square; + Goal : constant Square; + + + function Is_Walkable + (This : in Square) + return Boolean; + + + function Get_Contents + (This : in Square) + return Things.Thing + with Pre => Is_Walkable (This); + + + procedure Set_Contents + (This : in out Square; + Item : in Things.Thing) + with Pre => Is_Walkable (This); + + + procedure Draw + (This : in Square; + X, Y : in Integer); + + + function "=" + (A, B : in Square) + return Boolean; + + +private + + + type Square is tagged record + Walkable : Boolean; + Contents : Things.Thing; + Self_Image : access FLTK.Images.RGB.PNG.PNG_Image; + end record; + + + Origin : String := Ada.Directories.Containing_Directory + (Ada.Directories.Full_Name (Ada.Command_Line.Command_Name)); + Image_Dir : String := Origin & "/../share/sokoban/img"; + + + Wall_Image : aliased FLTK.Images.RGB.PNG.PNG_Image := + FLTK.Images.RGB.PNG.Create (Image_Dir & "/wall.png"); + Space_Image : aliased FLTK.Images.RGB.PNG.PNG_Image := + FLTK.Images.RGB.PNG.Create (Image_Dir & "/space.png"); + Empty_Image : aliased FLTK.Images.RGB.PNG.PNG_Image := + FLTK.Images.RGB.PNG.Create (Image_Dir & "/empty.png"); + Goal_Image : aliased FLTK.Images.RGB.PNG.PNG_Image := + FLTK.Images.RGB.PNG.Create (Image_Dir & "/goal.png"); + + + Void : constant Square := + (Walkable => False, Contents => Things.Nothing, Self_Image => null); + + + Wall : constant Square := + (Walkable => False, Contents => Things.Nothing, Self_Image => Wall_Image'Access); + Space : constant Square := + (Walkable => False, Contents => Things.Nothing, Self_Image => Space_Image'Access); + Empty : constant Square := + (Walkable => True, Contents => Things.Nothing, Self_Image => Empty_Image'Access); + Goal : constant Square := + (Walkable => True, Contents => Things.Nothing, Self_Image => Goal_Image'Access); + + +end Squares; + diff --git a/src/things.adb b/src/things.adb new file mode 100644 index 0000000..efd8b63 --- /dev/null +++ b/src/things.adb @@ -0,0 +1,27 @@ + + +package body Things is + + + procedure Draw + (This : in Thing; + X, Y : in Integer) is + begin + if This.Self_Image /= null then + This.Self_Image.Draw (X, Y); + end if; + end Draw; + + + + + function "=" + (A, B : in Thing) + return Boolean is + begin + return A.Self_Image = B.Self_Image; + end "="; + + +end Things; + diff --git a/src/things.ads b/src/things.ads new file mode 100644 index 0000000..c8da450 --- /dev/null +++ b/src/things.ads @@ -0,0 +1,63 @@ + + +private with + + FLTK.Images.RGB.PNG, + Ada.Command_Line, + Ada.Directories; + + +package Things is + + + type Thing is tagged private; + + + Nothing : constant Thing; + + + Man : constant Thing; + Treasure : constant Thing; + + + procedure Draw + (This : in Thing; + X, Y : in Integer); + + + function "=" + (A, B : in Thing) + return Boolean; + + +private + + + type Thing is tagged record + Self_Image : access FLTK.Images.RGB.PNG.PNG_Image; + end record; + + + Origin : String := Ada.Directories.Containing_Directory + (Ada.Directories.Full_Name (Ada.Command_Line.Command_Name)); + Image_Dir : String := Origin & "/../share/sokoban/img"; + + + Man_Image : aliased FLTK.Images.RGB.PNG.PNG_Image := + FLTK.Images.RGB.PNG.Create (Image_Dir & "/man.png"); + Treasure_Image : aliased FLTK.Images.RGB.PNG.PNG_Image := + FLTK.Images.RGB.PNG.Create (Image_Dir & "/treasure.png"); + + + Nothing : constant Thing := + (Self_Image => null); + + + Man : constant Thing := + (Self_Image => Man_Image'Access); + Treasure : constant Thing := + (Self_Image => Treasure_Image'Access); + + +end Things; + -- cgit