aparler/RosettaCodeData
1
0
Fork 0
Code Issues 12 Pull requests 3 Projects Releases Packages Wiki Activity Actions

Data update

Browse source
This commit is contained in:
Ingy döt Net 2026-02-01 16:33:20 -08:00
parent 5150844a7d
commit 4bb20c9b71
7735 changed files with 38060 additions and 199180 deletions
Download patch file Download diff file Expand all files Collapse all files

205
Task/Honeycombs/Ada/honeycombs.ada
View file

@ -1,205 +0,0 @@
with Ada.Numerics.Elementary_Functions;
with Ada.Numerics.Discrete_Random;
with SDL.Video.Windows.Makers;
with SDL.Video.Renderers.Makers;
with SDL.Video.Surfaces;
with SDL.Video.Rectangles;
with SDL.TTFs.Makers;
with SDL.Events.Events;
with SDL.Events.Keyboards;
with SDL.Events.Mice;
procedure Honeycombs is
use SDL.Video.Rectangles;
use SDL.C;
Width : constant := 560;
Height : constant := 595;
Offset_X : constant := 10.0;
Offset_Y : constant := 40.0;
Radius : constant := 60.0;
Rows : constant := 4;
Cols : constant := 5;
TTF_File : constant String := "NotoSans-Bold.ttf";
TTF_Size_Cell : constant := 72;
TTF_Size_Sum : constant := 38;
Offset_Sum_X : constant := 35;
Offset_Sum_Y : constant := 530;
type Node_Id is mod 6;
type Shape_List is array (Node_Id) of Point;
type Cell_Info is record
Center : Point;
Marked : Boolean;
Label : String (1 .. 1);
end record;
type Cell_List is array (Positive range <>) of Cell_Info;
function Make_Shape return Shape_List is
use Ada.Numerics.Elementary_Functions;
Shape : Shape_List;
begin
for I in Shape'Range loop
Shape (I) := (X => int (Radius * Cos (Float (I), Cycle => 6.0)),
Y => int (Radius * Sin (Float (I), Cycle => 6.0)));
end loop;
return Shape;
end Make_Shape;
function Make_Cells (Rows, Cols : in Positive) return Cell_List is
subtype Label_Type is Character range 'A' .. 'Z';
package Randoms is new Ada.Numerics.Discrete_Random (Label_Type);
use Randoms;
Y_Scale : constant Float := Ada.Numerics.Elementary_Functions.Sqrt (3.0);
List : Cell_List (1 .. Rows * Cols);
Info : Cell_Info;
Gen : Generator;
begin
Reset (Gen);
for R in 1 .. Rows loop
for C in 1 .. Cols loop
Info.Center.X := int (Offset_X + Radius * 1.5 * Float (C));
Info.Center.Y := int (Offset_Y + Radius * Y_Scale * (Float (R) -
Float (C mod 2) / 2.0));
Info.Marked := False;
Info.Label (1) := Random (Gen);
List ((R - 1) * Cols + C) := Info;
end loop;
end loop;
return List;
end Make_Cells;
Window : SDL.Video.Windows.Window;
Win_Surf : SDL.Video.Surfaces.Surface;
Renderer : SDL.Video.Renderers.Renderer;
Font_Cell : SDL.TTFs.Fonts;
Font_Sum : SDL.TTFs.Fonts;
Cells : Cell_List := Make_Cells (Rows, Cols);
Shape : constant Shape_List := Make_Shape;
Sum_Text : String (1 .. Rows * Cols);
Sum_Last : Natural := Sum_Text'First - 1;
function Orient_2D (A, B, C : Point) return int is
((B.X - A.X) * (C.Y - A.Y) - (B.Y - A.Y) * (C.X - A.X));
function "+" (Left, Right : Point) return Point is
((Left.X + Right.X, Left.Y + Right.Y));
function Inside (P : Point; Cell : Cell_Info) return Boolean is
Count : Natural := 0;
begin
for Node in Shape'Range loop
Count := Count +
(if Orient_2D (Cell.Center + Shape (Node),
Cell.Center + Shape (Node + 1),
P) > 0 then 1 else 0);
end loop;
return Count = 6;
end Inside;
procedure Draw (Cell : Cell_Info) is
Surface : constant SDL.Video.Surfaces.Surface :=
Font_Cell.Render_Solid (Cell.Label, (30, 230, 230, 255));
Self_Area : SDL.Video.Rectangles.Rectangle;
Source_Area : SDL.Video.Rectangles.Rectangle := (0, 0, 0, 0);
begin
-- Fill
for Y in int (-Radius) .. int (Radius) loop
for X in int (-Radius) .. int (Radius) loop
if Inside (Cell.Center + (X, Y), Cell) then
Renderer.Draw (Point => Cell.Center + (X, Y));
end if;
end loop;
end loop;
-- Label
Self_Area := (Cell.Center.X - Surface.Size.Width / 2,
Cell.Center.Y - Surface.Size.Height / 2, 0, 0);
Win_Surf.Blit (Self_Area, Surface, Source_Area);
-- Outline
Renderer.Set_Draw_Colour ((0, 0, 0, 255));
for Id in Shape'Range loop
Renderer.Draw (Line => (Cell.Center + Shape (Id),
Cell.Center + Shape (Id + 1)));
end loop;
end Draw;
procedure Find_And_Mark (Click : Point; Key : String) is
Self_Area : SDL.Video.Rectangles.Rectangle;
Source_Area : SDL.Video.Rectangles.Rectangle := (0, 0, 0, 0);
begin
for Cell of Cells loop
if not Cell.Marked and then (Inside (Click, Cell) or Cell.Label = Key) then
Cell.Marked := True;
Sum_Last := Sum_Last + 1;
Sum_Text (Sum_Last) := Cell.Label (1);
Renderer.Set_Draw_Colour ((230, 20, 220, 255));
Draw (Cell);
-- Update sum text
Self_Area := (Offset_Sum_X, Offset_Sum_Y, 0, 0);
Win_Surf.Blit
(Self_Area, Font_Sum.Render_Solid (Sum_Text (Sum_Text'First .. Sum_Last),
(0, 200, 200, 255)), Source_Area);
Window.Update_Surface;
exit;
end if;
end loop;
end Find_And_Mark;
procedure Wait is
use type SDL.Events.Event_Types;
use SDL.Events.Keyboards;
Event : SDL.Events.Events.Events;
begin
loop
SDL.Events.Events.Wait (Event);
case Event.Common.Event_Type is
when SDL.Events.Quit => return;
when SDL.Events.Mice.Button_Down =>
Find_And_Mark
((Event.Mouse_Button.X,
Event.Mouse_Button.Y), "");
when SDL.Events.Keyboards.Key_Down =>
Find_And_Mark
((0, 0), Image (Event.Keyboard.Key_Sym.Key_Code));
null;
when others => null;
end case;
end loop;
end Wait;
begin
if not SDL.Initialise (Flags => SDL.Enable_Screen) then
return;
end if;
if not SDL.TTFs.Initialise then
null;
end if;
SDL.TTFs.Makers.Create (Font_Cell, TTF_File, TTF_Size_Cell);
SDL.TTFs.Makers.Create (Font_Sum, TTF_File, TTF_Size_Sum);
SDL.Video.Windows.Makers.Create (Win => Window,
Title => "Honeycombs",
Position => SDL.Natural_Coordinates'(X => 10, Y => 10),
Size => SDL.Positive_Sizes'(Width, Height),
Flags => 0);
Win_Surf := Window.Get_Surface;
SDL.Video.Renderers.Makers.Create (Renderer, Window.Get_Surface);
Renderer.Set_Draw_Colour ((0, 0, 0, 255));
Renderer.Fill (Rectangle => (0, 0, Width, Height));
for Cell of Cells loop
Renderer.Set_Draw_Colour ((230, 230, 0, 255));
Draw (Cell);
end loop;
Window.Update_Surface;
Wait;
Window.Finalize;
SDL.Finalise;
end Honeycombs;