Basic game framework done, lacking any user input

11 files changed, 857 insertions, 0 deletions

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;
+