Skip to content

Instantly share code, notes, and snippets.

@hqppyz

hqppyz/adasnake.adb

Last active March 11, 2026 23:00
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save hqppyz/e70b0d62badf7c16b2ca8da63bacaf30 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save hqppyz/e70b0d62badf7c16b2ca8da63bacaf30 to your computer and use it in GitHub Desktop.
Download ZIP
Vibecoded ncurses snake on adalang
Raw
adasnake.adb
with Ncurses;
with Interfaces.C;
with Interfaces.C.Strings;
with Ada.Numerics.Discrete_Random;
with Ada.Strings;
with Ada.Strings.Fixed;
with Ada.Strings.UTF_Encoding.Wide_Wide_Strings;
function Adasnake return Integer is
use Ncurses;
use Interfaces.C;
use Interfaces.C.Strings;
use Ada.Strings;
use Ada.Strings.Fixed;
subtype Index is Integer range 1 .. 4096;
type Point is record
Y : Integer;
X : Integer;
end record;
type Snake_Array is array (Index) of Point;
type Direction is record
Y : Integer;
X : Integer;
end record;
subtype Queue_Index is Integer range 1 .. 64;
type Direction_Queue is array (Queue_Index) of Direction;
type Text_Align is (Align_Left, Align_Center, Align_Right);
type Game_State is (Playing, Paused, Game_Over);
State : Game_State := Playing;
Previous_State : Game_State := Playing;
Turbo_Enabled : Boolean := False;
Turbo_Flash : Natural := 0;
Snake_Initial_Length : constant Positive := 5;
Snake_Body : Snake_Array;
Snake_Length : Integer := Snake_Initial_Length;
Snake_Y : Integer := 0;
Snake_X : Integer := 1;
Snake_Tail_Y : Integer := 0;
Snake_Tail_X : Integer := 1;
Apple : Point;
Apple_Width : constant Positive := 2;
Frame_Ms : constant C_Int := 80;
Turbo_Frame_Ms : constant C_Int := 27;
Input_Queue : Direction_Queue;
Queue_Head : Queue_Index := Queue_Index'First;
Queue_Tail : Queue_Index := Queue_Index'First;
Queue_Count : Natural := 0;
Last_Lines : Integer := 0;
Last_Columns : Integer := 0;
package Rand_Int is new Ada.Numerics.Discrete_Random (Integer);
Random : Rand_Int.Generator;
Margin_Block : constant Integer := 4;
Margin_Inline : constant Integer := 0;
Border_Size : constant Integer := 1;
Color_Canvas : constant C_Int := 0;
Color_Primary : constant C_Int := 5;
Color_Secondary : constant C_Int := 6;
Pair_Primary_Id : constant C_Int := 1;
Pair_Secondary_Id : constant C_Int := 2;
Pair_Primary : constant C_Int := Pair_Primary_Id * 256;
Pair_Secondary : constant C_Int := Pair_Secondary_Id * 256;
Key_Up : constant C_Int := 259;
Key_Down : constant C_Int := 258;
Key_Left : constant C_Int := 260;
Key_Right : constant C_Int := 261;
Key_Resize : constant C_Int := 410;
Key_None : constant C_Int := -1;
Locale_All : constant C_Int := 6;
function To_UTF8 (Glyph : Wide_Wide_String) return String is
begin
return UTF_Encoding.Wide_Wide_Strings.Encode (Glyph);
end To_UTF8;
Utf8_Up : constant String := To_UTF8 ("↑");
Utf8_Down : constant String := To_UTF8 ("↓");
Utf8_Left : constant String := To_UTF8 ("←");
Utf8_Right : constant String := To_UTF8 ("→");
Utf8_Box_TL : constant String := To_UTF8 ("┏");
Utf8_Box_TR : constant String := To_UTF8 ("┓");
Utf8_Box_BL : constant String := To_UTF8 ("┗");
Utf8_Box_BR : constant String := To_UTF8 ("┛");
Utf8_Box_H : constant String := To_UTF8 ("━");
Utf8_Box_V : constant Stwith Interfaces.C;
with Interfaces.C.Strings;
with System;
package Ncurses is
pragma Linker_Options ("-lncursesw");
pragma Linker_Options ("-ltinfo");
subtype C_Int is Interfaces.C.int;
subtype C_Chars_Ptr is Interfaces.C.Strings.chars_ptr;
procedure initscr
with Import, Convention => C, External_Name => "initscr";
procedure endwin
with Import, Convention => C, External_Name => "endwin";
procedure refresh
with Import, Convention => C, External_Name => "refresh";
procedure clear
with Import, Convention => C, External_Name => "clear";
procedure noecho
with Import, Convention => C, External_Name => "noecho";
procedure start_color
with Import, Convention => C, External_Name => "start_color";
procedure init_pair (Pair, Foreground, Background : C_Int)
with Import, Convention => C, External_Name => "init_pair";
procedure attrset (Attrs : C_Int)
with Import, Convention => C, External_Name => "attrset";
procedure bkgd (Ch : C_Int)
with Import, Convention => C, External_Name => "bkgd";
procedure curs_set (Visibility : C_Int)
with Import, Convention => C, External_Name => "curs_set";
procedure timeout (Millis : C_Int)
with Import, Convention => C, External_Name => "timeout";
function setlocale (Category : C_Int; Locale : C_Chars_Ptr) return C_Chars_Ptr
with Import, Convention => C, External_Name => "setlocale";
function keypad (Win : System.Address; Bf : C_Int) return C_Int
with Import, Convention => C, External_Name => "keypad";
function getch return C_Int
with Import, Convention => C, External_Name => "getch";
procedure napms (Ms : C_Int)
with Import, Convention => C, External_Name => "napms";
procedure move (Y : C_Int; X : C_Int)
with Import, Convention => C, External_Name => "move";
procedure addch (Ch : C_Int)
with Import, Convention => C, External_Name => "addch";
function addstr (Str : C_Chars_Ptr) return C_Int
with Import, Convention => C, External_Name => "addstr";
C_Lines : C_Int
with Import, Convention => C, External_Name => "LINES";
function Lines return Integer is (Integer (C_Lines));
C_Columns : C_Int
with Import, Convention => C, External_Name => "COLS";
function Columns return Integer is (Integer (C_Columns));
Stdscr : System.Address
with Import, Convention => C, External_Name => "stdscr";
end Ncurses;
ring := To_UTF8 ("┃");
Utf8_Snake_H : constant String := To_UTF8 ("─");
Utf8_Snake_V : constant String := To_UTF8 ("│");
Utf8_Snake_UL : constant String := To_UTF8 ("╭");
Utf8_Snake_UR : constant String := To_UTF8 ("╮");
Utf8_Snake_DL : constant String := To_UTF8 ("╰");
Utf8_Snake_DR : constant String := To_UTF8 ("╯");
Utf8_Head_Left : constant String := To_UTF8 ("◀");
Utf8_Head_Right : constant String := To_UTF8 ("▶");
Utf8_Head_Up : constant String := To_UTF8 ("▲");
Utf8_Head_Down : constant String := To_UTF8 ("▼");
Utf8_Apple : constant String := To_UTF8 ("🍎");
function Random_Pos_Y return Integer is
Playfield_Top : constant Integer := Margin_Block + Border_Size;
Playfield_Height : constant Integer :=
Lines - 2 * Margin_Block - 2 * Border_Size;
begin
return Rand_Int.Random (Random) mod Playfield_Height + Playfield_Top;
end;
function Random_Pos_X return Integer is
Playfield_Left : constant Integer := Margin_Inline + Border_Size;
Playfield_Width : constant Integer :=
Columns - 2 * Margin_Inline - 2 * Border_Size;
Spawn_Width : constant Integer :=
Integer'Max (1, Playfield_Width - Apple_Width + 1);
begin
return Rand_Int.Random (Random) mod Spawn_Width + Playfield_Left;
end;
function Wrapped_Delta (Other, Current, Span : Integer) return Integer is
Raw_Diff : constant Integer := Other - Current;
begin
if Span <= 1 or else abs Raw_Diff /= Span - 1 then
return Raw_Diff;
end if;
return -Raw_Diff / (Span - 1);
end;
procedure Draw_Char (Y, X : Integer; Ch : Character) is
begin
move (C_Int (Y), C_Int (X));
addch (C_Int (Character'Pos (Ch)));
end;
procedure Draw_Text
(Y, X : Integer; Text : String; Align : Text_Align := Align_Left)
is
Draw_X : Integer := X;
C_Text : chars_ptr;
Ignore : C_Int;
begin
case Align is
when Align_Left =>
null;
when Align_Center =>
Draw_X := X - Text'Length / 2;
when Align_Right =>
Draw_X := X - Text'Length + 1;
end case;
if Y < 0 or else Y >= Lines or else Draw_X < 0 or else Draw_X >= Columns
then
return;
end if;
move (C_Int (Y), C_Int (Draw_X));
C_Text := New_String (Text);
Ignore := addstr (C_Text);
Free (C_Text);
end;
procedure Clear_Row (Y : Integer) is
begin
if Y < 0 or else Y >= Lines then
return;
end if;
attrset (Pair_Primary);
for X in 0 .. Columns - 1 loop
Draw_Char (Y, X, ' ');
end loop;
end;
procedure Draw_HUD is
Score_Value_Int : constant Integer :=
Snake_Length - Snake_Initial_Length;
Score_Title_Text : constant String :=
"*" & (if State = Game_Over then "GAME OVER" else "SCORE") & "*";
Score_Value_Text : constant String :=
Trim (Integer'Image (Score_Value_Int), Both);
Controls_Line_1_Text : constant String :=
"Use <WASD> <" & Utf8_Up & Utf8_Down & Utf8_Left & Utf8_Right & ">";
Controls_Line_2_Text : constant String := "or <HJKL> to move";
Pause_Status_Text : constant String :=
"Press <SPACE> to " & (if State = Paused then "PLAY" else "PAUSE");
Turbo_Hint_Text : constant String := "Press <X> to TURBO";
Quit_Text : constant String := "Press <Q> to quit";
Horizontal_Margin : constant Integer := 2;
Hud_Center_X : constant Integer := Columns / 2;
Turbo_Hint_Right_X : constant Integer := Columns - 1 - Horizontal_Margin;
Score_Title_Row : constant Integer := 1;
Score_Value_Row : constant Integer := 2;
Controls_Line_1_Row : constant Integer := Lines - 3;
Controls_Line_2_Row : constant Integer := Lines - 2;
Turbo_Hint_Row : constant Integer := Lines - 2;
Pause_Status_Row : constant Integer := Lines - 2;
begin
attrset (Pair_Primary);
Clear_Row (0);
Clear_Row (1);
Clear_Row (2);
Clear_Row (Lines - 3);
Clear_Row (Lines - 2);
Clear_Row (Lines - 1);
Draw_Text
(Score_Title_Row,
Hud_Center_X,
Score_Title_Text,
Align => Align_Center);
Draw_Text
(Score_Value_Row,
Hud_Center_X,
Score_Value_Text,
Align => Align_Center);
if State = Game_Over then
Draw_Text
(Pause_Status_Row, Hud_Center_X, Quit_Text, Align => Align_Center);
else
Draw_Text
(Controls_Line_1_Row, Horizontal_Margin, Controls_Line_1_Text);
Draw_Text
(Controls_Line_2_Row, Horizontal_Margin, Controls_Line_2_Text);
Draw_Text
(Turbo_Hint_Row,
Turbo_Hint_Right_X,
Turbo_Hint_Text,
Align => Align_Right);
Draw_Text
(Pause_Status_Row,
Hud_Center_X,
Pause_Status_Text,
Align => Align_Center);
end if;
end;
procedure Draw_Apple is
begin
attrset (Pair_Primary);
Draw_Text (Apple.Y, Apple.X, Utf8_Apple);
end;
procedure Spawn_Apple is
begin
Apple.Y := Random_Pos_Y;
Apple.X := Random_Pos_X;
end;
procedure Draw_Border;
procedure Clear_Playfield;
procedure Redraw is
begin
clear;
Draw_Border;
Clear_Playfield;
Draw_HUD;
refresh;
end Redraw;
procedure Clamp_To_Playfield (P : in out Point) is
Playfield_Top : constant Integer := Margin_Block + Border_Size;
Playfield_Left : constant Integer := Margin_Inline + Border_Size;
Playfield_Bottom : constant Integer :=
Lines - 1 - Margin_Block - Border_Size;
Playfield_Right : constant Integer :=
Columns - 1 - Margin_Inline - Border_Size;
Playfield_Height : constant Integer :=
Playfield_Bottom - Playfield_Top + 1;
Playfield_Width : constant Integer :=
Playfield_Right - Playfield_Left + 1;
begin
if Playfield_Height <= 0 or else Playfield_Width <= 0 then
return;
end if;
if P.Y < Playfield_Top then
P.Y := Playfield_Top;
elsif P.Y > Playfield_Bottom then
P.Y := Playfield_Bottom;
end if;
if P.X < Playfield_Left then
P.X := Playfield_Left;
elsif P.X > Playfield_Right then
P.X := Playfield_Right;
end if;
end;
procedure Resize is
Playfield_Height : constant Integer :=
Lines - 2 * Margin_Block - 2 * Border_Size;
Playfield_Width : constant Integer :=
Columns - 2 * Margin_Inline - 2 * Border_Size;
begin
if Lines = Last_Lines and then Columns = Last_Columns then
return;
end if;
Last_Lines := Lines;
Last_Columns := Columns;
if Playfield_Height <= 0 or else Playfield_Width <= 0 then
return;
end if;
for I in 1 .. Snake_Length loop
Clamp_To_Playfield (Snake_Body (I));
end loop;
Clamp_To_Playfield (Apple);
Redraw;
end;
function Apple_Contains (P : Point) return Boolean is
begin
return
P.Y = Apple.Y
and then P.X >= Apple.X
and then P.X < Apple.X + Apple_Width;
end;
procedure Draw_Border is
Top_Row : constant Integer := Margin_Block;
Bottom_Row : constant Integer := Lines - 1 - Margin_Block;
Left_Col : constant Integer := Margin_Inline;
Right_Col : constant Integer := Columns - 1 - Margin_Inline;
begin
attrset (Pair_Secondary);
Draw_Text (Top_Row, Left_Col, Utf8_Box_TL);
Draw_Text (Top_Row, Right_Col, Utf8_Box_TR);
Draw_Text (Bottom_Row, Left_Col, Utf8_Box_BL);
Draw_Text (Bottom_Row, Right_Col, Utf8_Box_BR);
for X in Left_Col + 1 .. Right_Col - 1 loop
Draw_Text (Top_Row, X, Utf8_Box_H);
Draw_Text (Bottom_Row, X, Utf8_Box_H);
end loop;
for Y in Top_Row + 1 .. Bottom_Row - 1 loop
Draw_Text (Y, Left_Col, Utf8_Box_V);
Draw_Text (Y, Right_Col, Utf8_Box_V);
end loop;
end;
procedure Clear_Playfield is
Playfield_Top : constant Integer := Margin_Block + Border_Size;
Playfield_Left : constant Integer := Margin_Inline + Border_Size;
Playfield_Bottom : constant Integer :=
Lines - 1 - Margin_Block - Border_Size;
Playfield_Right : constant Integer :=
Columns - 1 - Margin_Inline - Border_Size;
begin
attrset (Pair_Primary);
for Y in Playfield_Top .. Playfield_Bottom loop
for X in Playfield_Left .. Playfield_Right loop
Draw_Char (Y, X, ' ');
end loop;
end loop;
end;
procedure Init_Snake is
Playfield_Top : constant Integer := Margin_Block + Border_Size;
Playfield_Left : constant Integer := Margin_Inline + Border_Size;
Playfield_Bottom : constant Integer :=
Lines - 1 - Margin_Block - Border_Size;
Playfield_Right : constant Integer :=
Columns - 1 - Margin_Inline - Border_Size;
Mid_Y : constant Integer :=
(Playfield_Top + Playfield_Bottom) / 2;
Mid_X : constant Integer :=
(Playfield_Left + Playfield_Right) / 2;
begin
for I in 1 .. Snake_Length loop
Snake_Body (I).Y := Mid_Y;
Snake_Body (I).X := Mid_X - I;
end loop;
end;
function Is_Opposite (A, B : Direction) return Boolean is
begin
return A.Y = -B.Y and then A.X = -B.X;
end;
procedure Enqueue_Direction (New_Dir : Direction) is
Last_Dir : Direction;
Next_Tail : Queue_Index;
begin
if Queue_Count > 0 then
if Queue_Tail = Queue_Index'First then
Last_Dir := Input_Queue (Queue_Index'Last);
else
Last_Dir := Input_Queue (Queue_Tail - 1);
end if;
else
Last_Dir := (Y => Snake_Y, X => Snake_X);
end if;
if New_Dir = Last_Dir then
return;
end if;
if Snake_Length > 1 and then Is_Opposite (New_Dir, Last_Dir) then
return;
end if;
if Queue_Count >= Input_Queue'Length then
return;
end if;
Input_Queue (Queue_Tail) := New_Dir;
if Queue_Tail = Queue_Index'Last then
Next_Tail := Queue_Index'First;
else
Next_Tail := Queue_Tail + 1;
end if;
Queue_Tail := Next_Tail;
Queue_Count := Queue_Count + 1;
end;
procedure Apply_Queued_Direction is
Next_Head : Queue_Index;
Next_Dir : Direction;
begin
if Queue_Count = 0 then
return;
end if;
Next_Dir := Input_Queue (Queue_Head);
if Queue_Head = Queue_Index'Last then
Next_Head := Queue_Index'First;
else
Next_Head := Queue_Head + 1;
end if;
Queue_Head := Next_Head;
Queue_Count := Queue_Count - 1;
Snake_Y := Next_Dir.Y;
Snake_X := Next_Dir.X;
end;
procedure Draw_Snake is
Playfield_Height : constant Integer :=
Lines - 2 * Margin_Block - 2 * Border_Size;
Playfield_Width : constant Integer :=
Columns - 2 * Margin_Inline - 2 * Border_Size;
function Segment_Glyph (I : Integer) return String is
Cur : constant Point := Snake_Body (I);
Dy_Prev : Integer;
Dx_Prev : Integer;
Dy_Next : Integer;
Dx_Next : Integer;
Dy_Tip : Integer;
Dx_Tip : Integer;
Has_Up : Boolean;
Has_Down : Boolean;
Has_Left : Boolean;
Has_Right : Boolean;
begin
if Snake_Length = 1 or else I = 1 then
if Snake_X > 0 then
return Utf8_Head_Right;
elsif Snake_X < 0 then
return Utf8_Head_Left;
elsif Snake_Y > 0 then
return Utf8_Head_Down;
else
return Utf8_Head_Up;
end if;
end if;
if I = Snake_Length then
Dy_Prev :=
Wrapped_Delta (Snake_Body (I - 1).Y, Cur.Y, Playfield_Height);
Dx_Prev :=
Wrapped_Delta (Snake_Body (I - 1).X, Cur.X, Playfield_Width);
Dy_Tip := -Snake_Tail_Y;
Dx_Tip := -Snake_Tail_X;
if Dy_Prev = 0 and then Dy_Tip = 0 then
return Utf8_Snake_H;
elsif Dx_Prev = 0 and then Dx_Tip = 0 then
return Utf8_Snake_V;
end if;
Has_Up := Dy_Prev = -1 or else Dy_Tip = -1;
Has_Down := Dy_Prev = 1 or else Dy_Tip = 1;
Has_Left := Dx_Prev = -1 or else Dx_Tip = -1;
Has_Right := Dx_Prev = 1 or else Dx_Tip = 1;
if Has_Up and then Has_Right then
return Utf8_Snake_DL;
elsif Has_Up and then Has_Left then
return Utf8_Snake_DR;
elsif Has_Down and then Has_Right then
return Utf8_Snake_UL;
else
return Utf8_Snake_UR;
end if;
end if;
Dy_Prev :=
Wrapped_Delta (Snake_Body (I - 1).Y, Cur.Y, Playfield_Height);
Dx_Prev :=
Wrapped_Delta (Snake_Body (I - 1).X, Cur.X, Playfield_Width);
Dy_Next :=
Wrapped_Delta (Snake_Body (I + 1).Y, Cur.Y, Playfield_Height);
Dx_Next :=
Wrapped_Delta (Snake_Body (I + 1).X, Cur.X, Playfield_Width);
if Dy_Prev = 0 and then Dy_Next = 0 then
return Utf8_Snake_H;
elsif Dx_Prev = 0 and then Dx_Next = 0 then
return Utf8_Snake_V;
end if;
Has_Up := Dy_Prev = -1 or else Dy_Next = -1;
Has_Down := Dy_Prev = 1 or else Dy_Next = 1;
Has_Left := Dx_Prev = -1 or else Dx_Next = -1;
Has_Right := Dx_Prev = 1 or else Dx_Next = 1;
if Has_Up and then Has_Right then
return Utf8_Snake_DL;
elsif Has_Up and then Has_Left then
return Utf8_Snake_DR;
elsif Has_Down and then Has_Right then
return Utf8_Snake_UL;
else
return Utf8_Snake_UR;
end if;
end;
begin
if State = Game_Over then
if Snake_Length >= 2 then
attrset (Pair_Secondary);
for I in 2 .. Snake_Length loop
Draw_Text
(Snake_Body (I).Y, Snake_Body (I).X, Segment_Glyph (I));
end loop;
end if;
if Snake_Length >= 1 then
attrset (Pair_Primary);
Draw_Text (Snake_Body (1).Y, Snake_Body (1).X, Segment_Glyph (1));
end if;
else
for I in 1 .. Snake_Length loop
if Turbo_Enabled then
if (I + Integer (Turbo_Flash)) mod 2 = 0 then
attrset (Pair_Secondary);
else
attrset (Pair_Primary);
end if;
else
attrset (Pair_Secondary);
end if;
Draw_Text (Snake_Body (I).Y, Snake_Body (I).X, Segment_Glyph (I));
end loop;
end if;
end;
procedure Update_Snake is
Playfield_Top : constant Integer := Margin_Block + Border_Size;
Playfield_Left : constant Integer := Margin_Inline + Border_Size;
Playfield_Bottom : constant Integer :=
Lines - 1 - Margin_Block - Border_Size;
Playfield_Right : constant Integer :=
Columns - 1 - Margin_Inline - Border_Size;
Playfield_Height : constant Integer :=
Playfield_Bottom - Playfield_Top + 1;
Playfield_Width : constant Integer :=
Playfield_Right - Playfield_Left + 1;
Old_Tail : constant Point := Snake_Body (Snake_Length);
begin
for I in reverse 2 .. Snake_Length loop
Snake_Body (I) := Snake_Body (I - 1);
end loop;
Snake_Body (1).Y := Snake_Body (1).Y + Snake_Y;
Snake_Body (1).X := Snake_Body (1).X + Snake_X;
if Snake_Body (1).Y < Playfield_Top then
Snake_Body (1).Y := Playfield_Bottom;
elsif Snake_Body (1).Y > Playfield_Bottom then
Snake_Body (1).Y := Playfield_Top;
end if;
if Snake_Body (1).X < Playfield_Left then
Snake_Body (1).X := Playfield_Right;
elsif Snake_Body (1).X > Playfield_Right then
Snake_Body (1).X := Playfield_Left;
end if;
Snake_Tail_Y :=
Wrapped_Delta
(Snake_Body (Snake_Length).Y, Old_Tail.Y, Playfield_Height);
Snake_Tail_X :=
Wrapped_Delta
(Snake_Body (Snake_Length).X, Old_Tail.X, Playfield_Width);
end;
procedure Handle_Input (Ch : C_Int) is
New_Dir : Direction := (Y => Snake_Y, X => Snake_X);
begin
case Ch is
when C_Int (Character'Pos ('h'))
| C_Int (Character'Pos ('a'))
| Key_Left =>
New_Dir := (Y => 0, X => -1);
when C_Int (Character'Pos ('l'))
| C_Int (Character'Pos ('d'))
| Key_Right =>
New_Dir := (Y => 0, X => 1);
when C_Int (Character'Pos ('k'))
| C_Int (Character'Pos ('w'))
| Key_Up =>
New_Dir := (Y => -1, X => 0);
when C_Int (Character'Pos ('j'))
| C_Int (Character'Pos ('s'))
| Key_Down =>
New_Dir := (Y => 1, X => 0);
when others =>
null;
end case;
if New_Dir /= (Y => Snake_Y, X => Snake_X) then
Enqueue_Direction (New_Dir);
end if;
end;
function Process_Input return Boolean is
Ch : C_Int := getch;
begin
while Ch /= Key_None loop
if Ch = C_Int (Character'Pos ('q'))
or else Ch = C_Int (Character'Pos ('Q'))
then
return True;
elsif Ch = Key_Resize then
Resize;
else
case State is
when Game_Over =>
null;
when Paused =>
if Ch = C_Int (Character'Pos (' ')) then
State := Playing;
end if;
when Playing =>
if Ch = C_Int (Character'Pos (' ')) then
State := Paused;
elsif Ch = C_Int (Character'Pos ('x'))
or else Ch = C_Int (Character'Pos ('X'))
then
Turbo_Enabled := not Turbo_Enabled;
else
Handle_Input (Ch);
end if;
end case;
end if;
Ch := getch;
end loop;
return False;
end;
function Collided return Boolean is
Head : Point := Snake_Body (1);
begin
for I in 2 .. Snake_Length loop
if Snake_Body (I) = Head then
return True;
end if;
end loop;
return False;
end;
function Run_Game return Integer is
begin
Rand_Int.Reset (Random);
declare
Locale_Empty : chars_ptr := New_String ("");
Ignore_Locale : chars_ptr := setlocale (Locale_All, Locale_Empty);
begin
pragma Unreferenced (Ignore_Locale);
Free (Locale_Empty);
end;
initscr;
noecho;
start_color;
init_pair (Pair_Primary_Id, Color_Primary, Color_Canvas);
init_pair (Pair_Secondary_Id, Color_Secondary, Color_Canvas);
attrset (Pair_Primary);
clear;
curs_set (0);
timeout (0);
declare
Ignore : constant C_Int := keypad (Stdscr, 1);
begin
null;
end;
bkgd (C_Int (Character'Pos (' ')) + Pair_Primary);
attrset (Pair_Primary);
if Lines - 2 * Margin_Block - 2 * Border_Size < 3
or else Columns - 2 * Margin_Inline - 2 * Border_Size < 3
then
endwin;
return 0;
end if;
Last_Lines := Lines;
Last_Columns := Columns;
Redraw;
Init_Snake;
Spawn_Apple;
loop
Resize;
exit when Process_Input;
if State = Playing then
declare
Tail_Before_Move : constant Point := Snake_Body (Snake_Length);
begin
Apply_Queued_Direction;
Update_Snake;
if Apple_Contains (Snake_Body (1)) then
if Snake_Length < Index'Last then
Snake_Length := Snake_Length + 1;
Snake_Body (Snake_Length) := Tail_Before_Move;
end if;
Spawn_Apple;
end if;
if Collided then
State := Game_Over;
end if;
end;
end if;
Clear_Playfield;
Draw_Snake;
Draw_Apple;
Draw_HUD;
refresh;
if State = Playing and then Turbo_Enabled then
Turbo_Flash := (Turbo_Flash + 1) mod 2;
elsif not Turbo_Enabled then
Turbo_Flash := 0;
end if;
if Turbo_Enabled then
napms (Turbo_Frame_Ms);
else
napms (Frame_Ms);
end if;
end loop;
endwin;
return Snake_Length - Snake_Initial_Length;
end Run_Game;
begin
return Run_Game;
end Adasnake;
Raw
ncurses.ads
with Interfaces.C;
with Interfaces.C.Strings;
with System;
package Ncurses is
pragma Linker_Options ("-lncursesw");
pragma Linker_Options ("-ltinfo");
subtype C_Int is Interfaces.C.int;
subtype C_Chars_Ptr is Interfaces.C.Strings.chars_ptr;
procedure initscr
with Import, Convention => C, External_Name => "initscr";
procedure endwin
with Import, Convention => C, External_Name => "endwin";
procedure refresh
with Import, Convention => C, External_Name => "refresh";
procedure clear
with Import, Convention => C, External_Name => "clear";
procedure noecho
with Import, Convention => C, External_Name => "noecho";
procedure start_color
with Import, Convention => C, External_Name => "start_color";
procedure init_pair (Pair, Foreground, Background : C_Int)
with Import, Convention => C, External_Name => "init_pair";
procedure attrset (Attrs : C_Int)
with Import, Convention => C, External_Name => "attrset";
procedure bkgd (Ch : C_Int)
with Import, Convention => C, External_Name => "bkgd";
procedure curs_set (Visibility : C_Int)
with Import, Convention => C, External_Name => "curs_set";
procedure timeout (Millis : C_Int)
with Import, Convention => C, External_Name => "timeout";
function setlocale
(Category : C_Int; Locale : C_Chars_Ptr) return C_Chars_Ptr
with Import, Convention => C, External_Name => "setlocale";
function keypad (Win : System.Address; Bf : C_Int) return C_Int
with Import, Convention => C, External_Name => "keypad";
function getch return C_Int
with Import, Convention => C, External_Name => "getch";
procedure napms (Ms : C_Int)
with Import, Convention => C, External_Name => "napms";
procedure move (Y : C_Int; X : C_Int)
with Import, Convention => C, External_Name => "move";
procedure addch (Ch : C_Int)
with Import, Convention => C, External_Name => "addch";
function addstr (Str : C_Chars_Ptr) return C_Int
with Import, Convention => C, External_Name => "addstr";
C_Lines : C_Int
with Import, Convention => C, External_Name => "LINES";
function Lines return Integer
is (Integer (C_Lines));
C_Columns : C_Int
with Import, Convention => C, External_Name => "COLS";
function Columns return Integer
is (Integer (C_Columns));
Stdscr : System.Address
with Import, Convention => C, External_Name => "stdscr";
end Ncurses;
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment