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

259
Task/Word-search/Ada/word-search.ada
View file

@ -1,259 +0,0 @@
pragma Ada_2022;
with Ada.Containers; use Ada.Containers;
with Ada.Containers.Vectors;
with Ada.Numerics.Discrete_Random;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Text_IO.Unbounded_IO; use Ada.Text_IO.Unbounded_IO;
procedure Word_Search is
MIN_WORDS : constant Positive := 25;
MIN_WORD_LEN : constant Positive := 3;
MAX_WORD_LEN : constant Positive := 9;
SIDE_LEN : constant Positive := 10;
MESSAGE : constant String := "ROSETTACODE";
DICT_FILENAME : constant String := "unixdict.txt";
type Directions is (N, NE, E, SE, S, SW, W, NW);
type Move is record
DX, DY : Integer;
end record;
type Moves_Arr is array (Directions) of Move;
Moves : constant Moves_Arr := [
N => (0, -1), NE => (1, -1), E => (1, 0), SE => (1, 1),
S => (0, 1), SW => (-1, 1), W => (-1, 0), NW => (-1, -1)
];
subtype Grid_Dimension is Positive range 1 .. SIDE_LEN;
type Matrix is array (Grid_Dimension, Grid_Dimension) of Character;
subtype LC_Chars is Character range 'a' .. 'z';
subtype Valid_Lengths is Positive range MIN_WORD_LEN .. MAX_WORD_LEN;
package Word_Vectors is new Ada.Containers.Vectors (Positive, Unbounded_String);
type Dictionary is array (Valid_Lengths) of Word_Vectors.Vector;
Dict : Dictionary;
type Placement is record
Word : Unbounded_String;
Start : Unbounded_String;
end record;
package Placement_Vectors is new Ada.Containers.Vectors (Positive, Placement);
Placings : Placement_Vectors.Vector;
subtype Ten_K is Positive range 1 .. 10000;
package Rand_Dimension is new Ada.Numerics.Discrete_Random (Grid_Dimension);
package Rand_Dir is new Ada.Numerics.Discrete_Random (Directions);
package Rand_Len is new Ada.Numerics.Discrete_Random (Valid_Lengths);
package Rand_10k is new Ada.Numerics.Discrete_Random (Ten_K);
Dimension_Gen : Rand_Dimension.Generator;
Dir_Gen : Rand_Dir.Generator;
Len_Gen : Rand_Len.Generator;
Ten_K_Gen : Rand_10k.Generator;
procedure Load_Dictionary (Filename : String) is
Dict_File : File_Type;
Dict_Word : Unbounded_String;
Dict_Word_Len : Positive;
Word_OK : Boolean;
begin
Open (File => Dict_File, Mode => In_File, Name => Filename);
while not End_Of_File (Dict_File) loop
Dict_Word := Get_Line (Dict_File);
Dict_Word_Len := Length (Dict_Word);
if Dict_Word_Len >= MIN_WORD_LEN and then
Dict_Word_Len <= MAX_WORD_LEN
then
Word_OK := True;
for C of To_String (Dict_Word) loop
if C not in LC_Chars then
Word_OK := False;
exit;
end if;
end loop;
if Word_OK then
Dict (Dict_Word_Len).Append (Dict_Word);
end if;
end if;
end loop;
end Load_Dictionary;
function Pick_Random_Word return Unbounded_String is
Word_Length : Positive := Rand_Len.Random (Len_Gen);
Rand : constant Natural := Rand_10k.Random (Ten_K_Gen);
Word_Ix : Positive;
begin
Word_Length := Rand_Len.Random (Len_Gen);
if Word_Length > 4 then -- Reduce number of words > 4 chars
Word_Length := Rand_Len.Random (Len_Gen);
end if;
Word_Ix := Positive (Rand) mod (Positive (Dict (Word_Length).Length) - 1) + 1;
return Dict (Word_Length) (Word_Ix);
end Pick_Random_Word;
function Not_Too_Long (X, Y : Grid_Dimension; Len : Positive; Dir : Directions) return Boolean is
begin
case Dir is
when N => return Y - Len > 0;
when S => return Y + Len <= SIDE_LEN;
when E => return X + Len <= SIDE_LEN;
when W => return X - Len > 0;
when NE => return X + Len <= SIDE_LEN and then Y - Len > 0;
when SW => return Y + Len <= SIDE_LEN and then X - Len > 0;
when SE => return Y + Len <= SIDE_LEN and then X + Len <= SIDE_LEN;
when NW => return Y - Len > 0 and then X - Len > 0;
end case;
end Not_Too_Long;
function Is_Empty (G : Matrix; Row, Col : Positive) return Boolean is
(G (Row, Col) = ' ');
function Count_Empties (G : Matrix) return Natural is
Count : Natural := 0;
begin
for Row in Grid_Dimension loop
for Col in Grid_Dimension loop
Count := Count + (if Is_Empty (G, Row, Col) then 1 else 0);
end loop;
end loop;
return Count;
end Count_Empties;
function Can_Place (G : Matrix; X, Y : Grid_Dimension; Word : Unbounded_String; Dir : Directions)
return Boolean is
GX : Grid_Dimension := X;
GY : Grid_Dimension := Y;
Len : constant Positive := Length (Word);
begin
for C in 1 .. Len loop
if not Is_Empty (G, GX, GY) and then
G (GX, GY) /= Element (Word, C)
then
return False;
else
GX := GX + Moves (Dir).DX;
GY := GY + Moves (Dir).DY;
end if;
end loop;
return True;
end Can_Place;
procedure Insert_Word (G : in out Matrix;
X, Y : Grid_Dimension;
Dir : Directions;
Word : Unbounded_String) is
-- We assume it fits. You've checked first haven't you!
GX : Grid_Dimension := X;
GY : Grid_Dimension := Y;
begin
for C in 1 .. Length (Word) loop
G (GX, GY) := Element (Word, C);
GX := GX + Moves (Dir).DX;
GY := GY + Moves (Dir).DY;
end loop;
end Insert_Word;
function Try_To_Place_Word (G : in out Matrix; Word : Unbounded_String; Max_Tries : Positive)
return Boolean is
-- Attempt to place the given word in the grid, return success or failure.
X1, Y1 : Grid_Dimension;
Dir : Directions;
Try : Positive := 1;
Place : Placement;
begin
while Try <= Max_Tries loop
X1 := Rand_Dimension.Random (Dimension_Gen);
Y1 := Rand_Dimension.Random (Dimension_Gen);
Dir := Rand_Dir.Random (Dir_Gen);
if Not_Too_Long (X1, Y1, Length (Word), Dir) and then
Can_Place (G, X1, Y1, Word, Dir)
then
Insert_Word (G, X1, Y1, Dir, Word);
Place.Word := Word;
Place.Start := To_Unbounded_String (X1'Image & LC_Chars'Val (Integer (Y1) + 64));
Placings.Append (Place);
return True;
end if;
Try := Try + 1;
end loop;
return False;
end Try_To_Place_Word;
procedure Print_Matrix (M : Matrix) is
begin
Put_Line (" A B C D E F G H I J"); New_Line;
for Row in Grid_Dimension loop
Put (Row'Image);
Set_Col (6);
for Col in Grid_Dimension loop
Put (M (Row, Col) & " ");
end loop;
New_Line;
end loop;
New_Line;
end Print_Matrix;
function Place_Message (G : in out Matrix; Msg : String) return Boolean is
-- Attempt to put message in grid, return False if unable.
Msg_Posn : Positive := 1;
begin
for Row in Grid_Dimension loop
for Col in Grid_Dimension loop
if Is_Empty (G, Row, Col) then
G (Row, Col) := Msg (Msg_Posn);
if Msg_Posn = Msg'Length then
return True;
else
Msg_Posn := Msg_Posn + 1;
end if;
end if;
end loop;
end loop;
return False;
end Place_Message;
Grid : Matrix;
Words_Placed : Natural;
Message_Placed : Boolean;
A_Word : Unbounded_String;
Attempt : Positive;
Col : Positive_Count := 1;
begin
Load_Dictionary (DICT_FILENAME);
Rand_Dimension.Reset (Dimension_Gen);
Rand_Dir.Reset (Dir_Gen);
Rand_Len.Reset (Len_Gen);
Rand_10k.Reset (Ten_K_Gen);
loop
Grid := [others => [others => ' ']];
Words_Placed := 0; Message_Placed := False; Placings.Clear;
Attempt := 1;
Builder :
loop
A_Word := Pick_Random_Word;
if Try_To_Place_Word (Grid, A_Word, 50) then
Words_Placed := @ + 1;
end if;
if Count_Empties (Grid) = MESSAGE'Length then
if Place_Message (Grid, MESSAGE) then
Message_Placed := True;
exit Builder;
end if;
elsif Count_Empties (Grid) < MESSAGE'Length then
-- Put_Line ("No room for message, giving up.");
exit Builder;
elsif Attempt > 1000 then
Put_Line ("Giving up after 1000 tries.");
exit Builder;
end if;
Attempt := Attempt + 1;
end loop Builder;
exit when Words_Placed >= MIN_WORDS and then Message_Placed;
end loop;
Print_Matrix (Grid);
Put_Line ("Words placed:" & Words_Placed'Image);
for P of Placings loop
Set_Col (Col); Put (P.Word);
Set_Col (Col + 9); Put (P.Start);
Col := (if Col < 61 then Col + 20 else 1);
end loop;
end Word_Search;