diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/displays.adb | 50 | ||||
| -rw-r--r-- | src/displays.ads | 24 | ||||
| -rw-r--r-- | src/moves.adb | 44 | ||||
| -rw-r--r-- | src/moves.ads | 62 | ||||
| -rw-r--r-- | src/sokoban.adb | 168 |
5 files changed, 330 insertions, 18 deletions
diff --git a/src/displays.adb b/src/displays.adb index dcb3932..03a0d43 100644 --- a/src/displays.adb +++ b/src/displays.adb @@ -2,7 +2,8 @@ with - FLTK.Screen; + FLTK.Screen, + FLTK.Event; package body Displays is @@ -32,11 +33,6 @@ package body Displays is 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 @@ -44,8 +40,9 @@ package body Displays is (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 + (0, 0, Message_Box_Width, Message_Box_Height, "")), + Current_Grid => null, + Key_Func => null) do This.Add (This.Message_Box); This.Message_Box.Set_Label_Size (Text_Size); @@ -131,5 +128,42 @@ package body Displays is end Centre_On_Screen; + + + procedure Set_Message + (This : in out Display; + Msg : in String) is + begin + This.Message_Box.Set_Label (Msg); + end Set_Message; + + + + + procedure Set_Keyboard_Callback + (This : in out Display; + Func : in Keyboard_Callback) is + begin + This.Key_Func := Func; + end Set_Keyboard_Callback; + + + + + function Handle + (This : in out Display; + Event : in FLTK.Event_Kind) + return FLTK.Event_Outcome + is + use type FLTK.Event_Kind; + begin + if This.Key_Func /= null and Event = FLTK.Keydown then + return This.Key_Func (FLTK.Event.Last_Keypress); + else + return WD.Double_Window (This).Handle (Event); + end if; + end Handle; + + end Displays; diff --git a/src/displays.ads b/src/displays.ads index 8d592e1..e8b04d8 100644 --- a/src/displays.ads +++ b/src/displays.ads @@ -16,6 +16,11 @@ 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; + + function Create (X, Y, W, H : in Integer; Text : in String) @@ -49,16 +54,33 @@ package Displays is (This : in out Display); + procedure Set_Message + (This : in out Display; + Msg : in String); + + + procedure Set_Keyboard_Callback + (This : in out Display; + Func : in Keyboard_Callback); + + + function Handle + (This : in out Display; + Event : in FLTK.Event_Kind) + return FLTK.Event_Outcome; + + 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; + Key_Func : Keyboard_Callback; end record; - Text_Size : constant FLTK.Widgets.Font_Size := 12; + Text_Size : constant FLTK.Font_Size := 12; Message_Box_Width : constant Integer := 500; Message_Box_Height : constant Integer := 100; diff --git a/src/moves.adb b/src/moves.adb new file mode 100644 index 0000000..e9bffc1 --- /dev/null +++ b/src/moves.adb @@ -0,0 +1,44 @@ + + +package body Moves is + + + procedure Add + (This : in out Path; + Item : in Move) is + begin + This.Append (Item); + end Add; + + + + + procedure Add + (This : in out Path; + List : in Path) is + begin + This.Append (List); + end Add; + + + + + function Latest + (This : in Path) + return Move is + begin + return This.Last_Element; + end Latest; + + + + + procedure Drop_Latest + (This : in out Path) is + begin + This.Delete_Last; + end Drop_Latest; + + +end Moves; + diff --git a/src/moves.ads b/src/moves.ads new file mode 100644 index 0000000..ebf2bb1 --- /dev/null +++ b/src/moves.ads @@ -0,0 +1,62 @@ + + +private with + + Ada.Containers.Vectors; + + +package Moves is + + + type Move is record + Delta_X, Delta_Y : Integer; + Push : Boolean; + end record; + + + Null_Move : constant Move; + + + + + type Path is tagged private; + + + Empty_Path : constant Path; + + + procedure Add + (This : in out Path; + Item : in Move); + + + procedure Add + (This : in out Path; + List : in Path); + + + function Latest + (This : in Path) + return Move; + + + procedure Drop_Latest + (This : in out Path); + + +private + + + package Move_Vectors is new Ada.Containers.Vectors + (Index_Type => Positive, Element_Type => Move); + + + type Path is new Move_Vectors.Vector with null record; + + + Null_Move : constant Move := (Delta_X => 0, Delta_Y => 0, Push => False); + Empty_Path : constant Path := (Move_Vectors.Empty_Vector with null record); + + +end Moves; + diff --git a/src/sokoban.adb b/src/sokoban.adb index 9c3e490..b58874b 100644 --- a/src/sokoban.adb +++ b/src/sokoban.adb @@ -2,10 +2,12 @@ with + FLTK.Widgets, Displays, Grids, Squares, Things, + Moves, Ada.Command_Line, Ada.Directories, Ada.Text_IO, @@ -26,24 +28,53 @@ package body Sokoban is (X, Y : in Natural; Char : in Character); + procedure Move_Man + (Delta_X, Delta_Y : in Integer); + procedure Undo_Movement; - -- Global state of the game. - - My_Display : Displays.Display := Displays.Create; - My_Grid : Grids.Grid := Grids.Create (0, 0); - Current_Level : LevelID; + -- Miscellaneous game data. - - -- Miscellaneous. + type Game_State is (Loading, Play, Complete); Origin : String := Ada.Directories.Containing_Directory (Ada.Directories.Full_Name (Ada.Command_Line.Command_Name)); Level_Dir : String := Origin & "/../share/sokoban/level"; + Loading_Message : String := "Loading..."; + + Play_Message : 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."; + + Complete_Message : String := "Level complete!" & ASCII.LF & + "Press enter to progress to the next level, or q to quit."; + + Fully_Complete_Message : String := "Congratulations! All levels complete!" & ASCII.LF & + "Press enter to start again at the first level, or q to quit."; + + U_Key : FLTK.Shortcut_Key := FLTK.Shortcut ('u'); + N_Key : FLTK.Shortcut_Key := FLTK.Shortcut ('n'); + R_Key : FLTK.Shortcut_Key := FLTK.Shortcut ('r'); + Q_Key : FLTK.Shortcut_Key := FLTK.Shortcut ('q'); + + + + + -- Global state of the game. + + My_Display : Displays.Display := Displays.Create; + My_Grid : Grids.Grid := Grids.Create (0, 0); + Current_Level : LevelID; + Level_State : Game_State := Loading; + Current_Man_X : Integer; + Current_Man_Y : Integer; + Move_Record : Moves.Path; + Goals_Remaining : Integer; + @@ -60,6 +91,9 @@ package body Sokoban is Rows, Cols : Natural; begin + Level_State := Loading; + My_Display.Set_Message (Loading_Message); + Goals_Remaining := 0; Open (Data_File, In_File, Filename); declare @@ -85,9 +119,12 @@ package body Sokoban is end loop; Close (Data_File); - Current_Level := Number; My_Display.Centre_On_Screen; + Move_Record := Moves.Empty_Path; + My_Display.Set_Message (Play_Message); + My_Grid.Redraw; + Level_State := Play; end Load_Level; @@ -109,7 +146,54 @@ package body Sokoban is - -- Callbacks for keyboard controls. + -- Keyboard and mouse control handling. + + function Keypress + (Key : in FLTK.Shortcut_Key) + return FLTK.Event_Outcome + is + use type FLTK.Shortcut_Key; + begin + if Key = Q_Key then + Hide; + return FLTK.Handled; + end if; + + if Level_State = Play then + if Key = FLTK.Up_Key then + Move_Man (0, -1); + elsif Key = FLTK.Down_Key then + Move_Man (0, 1); + elsif Key = FLTK.Left_Key then + Move_Man (-1, 0); + elsif Key = FLTK.Right_Key then + Move_Man (1, 0); + elsif Key = U_Key then + Undo_Movement; + elsif Key = N_Key then + if Current_Level = LevelID'Last then + My_Display.Set_Message (Fully_Complete_Message); + Level_State := Complete; + else + Load_Level (Current_Level + 1); + end if; + elsif Key = R_Key then + Load_Level (Current_Level); + else + return FLTK.Not_Handled; + end if; + return FLTK.Handled; + elsif Level_State = Complete and Key = FLTK.Enter_Key then + if Current_Level = LevelID'Last then + Load_Level (LevelID'First); + else + Load_Level (Current_Level + 1); + end if; + return FLTK.Handled; + else + return FLTK.Not_Handled; + end if; + end Keypress; @@ -144,11 +228,14 @@ package body Sokoban is when '.' => My_Grid.Set_Square (X, Y, Squares.Goal); + Goals_Remaining := Goals_Remaining + 1; when '@' => Temp := Squares.Empty; Temp.Set_Contents (Things.Man); My_Grid.Set_Square (X, Y, Temp); + Current_Man_X := X; + Current_Man_Y := Y; when others => raise Program_Error; @@ -157,10 +244,73 @@ package body Sokoban is end Add_New_Grid_Item; + + + procedure Move_Man + (Delta_X, Delta_Y : in Integer) + is + use type Squares.Square, Things.Thing; + + Current : Squares.Square := + My_Grid.Get_Square (Current_Man_X, Current_Man_Y); + Next : Squares.Square := + My_Grid.Get_Square (Current_Man_X + Delta_X, Current_Man_Y + Delta_Y); + Next_Next : Squares.Square := + My_Grid.Get_Square (Current_Man_X + Delta_X * 2, Current_Man_Y + Delta_Y * 2); + begin + if Next.Is_Walkable then + if Next.Get_Contents = Things.Nothing then + Current.Set_Contents (Things.Nothing); + My_Grid.Set_Square (Current_Man_X, Current_Man_Y, Current); + Current_Man_X := Current_Man_X + Delta_X; + Current_Man_Y := Current_Man_Y + Delta_Y; + Next.Set_Contents (Things.Man); + My_Grid.Set_Square (Current_Man_X, Current_Man_Y, Next); + Move_Record.Add ((Delta_X => Delta_X, Delta_Y => Delta_Y, Push => False)); + My_Grid.Redraw; + elsif + Next.Get_Contents = Things.Treasure and Next_Next.Is_Walkable and + Next_Next.Get_Contents = Things.Nothing + then + Current.Set_Contents (Things.Nothing); + My_Grid.Set_Square (Current_Man_X, Current_Man_Y, Current); + Current_Man_X := Current_Man_X + Delta_X; + Current_Man_Y := Current_Man_Y + Delta_Y; + Next.Set_Contents (Things.Man); + My_Grid.Set_Square (Current_Man_X, Current_Man_Y, Next); + Next_Next.Set_Contents (Things.Treasure); + My_Grid.Set_Square (Current_Man_X + Delta_X, Current_Man_Y + Delta_Y, Next_Next); + Move_Record.Add ((Delta_X => Delta_X, Delta_Y => Delta_Y, Push => True)); + My_Grid.Redraw; + + if Next = Squares.Goal and Next_Next /= Squares.Goal then + Goals_Remaining := Goals_Remaining + 1; + elsif Next /= Squares.Goal and Next_Next = Squares.Goal then + Goals_Remaining := Goals_Remaining - 1; + end if; + + if Goals_Remaining = 0 then + My_Display.Set_Message (Complete_Message); + Level_State := Complete; + end if; + end if; + end if; + end Move_Man; + + + + + procedure Undo_Movement is + begin + null; + end Undo_Movement; + + begin My_Display.Set_Grid (My_Grid); + My_Display.Set_Keyboard_Callback (Keypress'Access); end Sokoban; |