Library: Lumen

with Lumen.Binary;
package body Mandelbrot is
   function Create_Image (Width, Height : Natural) return Lumen.Image.Descriptor is
      use type Lumen.Binary.Byte;
      Result : Lumen.Image.Descriptor;
      X0, Y0 : Float;
      X, Y, Xtemp : Float;
      Iteration   : Float;
      Max_Iteration : constant Float := 1000.0;
      Color : Lumen.Binary.Byte;
   begin
      Result.Width := Width;
      Result.Height := Height;
      Result.Complete := True;
      Result.Values := new Lumen.Image.Pixel_Matrix (1 .. Width, 1 .. Height);
      for Screen_X in 1 .. Width loop
         for Screen_Y in 1 .. Height loop
            X0 := -2.5 + (3.5 / Float (Width) * Float (Screen_X));
            Y0 := -1.0 + (2.0 / Float (Height) * Float (Screen_Y));
            X := 0.0;
            Y := 0.0;
            Iteration := 0.0;
            while X * X + Y * Y <= 4.0 and then Iteration < Max_Iteration loop
               Xtemp := X * X - Y * Y + X0;
               Y := 2.0 * X * Y + Y0;
               X := Xtemp;
               Iteration := Iteration + 1.0;
            end loop;
            if Iteration = Max_Iteration then
               Color := 255;
            else
               Color := 0;
            end if;
            Result.Values (Screen_X, Screen_Y) := (R => Color, G => Color, B => Color, A => 0);
         end loop;
      end loop;
      return Result;
   end Create_Image;

end Mandelbrot;

with Lumen.Image;

package Mandelbrot is

   function Create_Image (Width, Height : Natural) return Lumen.Image.Descriptor;

end Mandelbrot;

with System.Address_To_Access_Conversions;
with Lumen.Window;
with Lumen.Image;
with Lumen.Events;
with GL;
with Mandelbrot;

procedure Test_Mandelbrot is

   Program_End : exception;

   Win : Lumen.Window.Handle;
   Image : Lumen.Image.Descriptor;
   Tx_Name : aliased GL.GLuint;
   Wide, High : Natural := 400;

   -- Create a texture and bind a 2D image to it
   procedure Create_Texture is
      use GL;

      package GLB is new System.Address_To_Access_Conversions (GLubyte);

      IP : GLpointer;
   begin  -- Create_Texture
      -- Allocate a texture name
      glGenTextures (1, Tx_Name'Unchecked_Access);

      -- Bind texture operations to the newly-created texture name
      glBindTexture (GL_TEXTURE_2D, Tx_Name);

      -- Select modulate to mix texture with color for shading
      glTexEnvi (GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE);

      -- Wrap textures at both edges
      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT);
      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT);

      -- How the texture behaves when minified and magnified
      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST);
      glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST);

      -- Create a pointer to the image.  This sort of horror show is going to
      -- be disappearing once Lumen includes its own OpenGL bindings.
      IP := GLB.To_Pointer (Image.Values.all'Address).all'Unchecked_Access;

      -- Build our texture from the image we loaded earlier
      glTexImage2D (GL_TEXTURE_2D, 0, GL_RGBA, GLsizei (Image.Width), GLsizei (Image.Height), 0,
                    GL_RGBA, GL_UNSIGNED_BYTE, IP);
   end Create_Texture;

   -- Set or reset the window view parameters
   procedure Set_View (W, H : in Natural) is
      use GL;
   begin  -- Set_View
      GL.glEnable (GL.GL_TEXTURE_2D);
      glClearColor (0.8, 0.8, 0.8, 1.0);

      glMatrixMode (GL_PROJECTION);
      glLoadIdentity;
      glViewport (0, 0, GLsizei (W), GLsizei (H));
      glOrtho (0.0, GLdouble (W), GLdouble (H), 0.0, -1.0, 1.0);

      glMatrixMode (GL_MODELVIEW);
      glLoadIdentity;
   end Set_View;

   -- Draw our scene
   procedure Draw is
      use GL;
   begin  -- Draw
      -- clear the screen
      glClear (GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
      GL.glBindTexture (GL.GL_TEXTURE_2D, Tx_Name);

      -- fill with a single textured quad
      glBegin (GL_QUADS);
      begin
         glTexCoord2f (1.0, 0.0);
         glVertex2i (GLint (Wide), 0);

         glTexCoord2f (0.0, 0.0);
         glVertex2i (0, 0);

         glTexCoord2f (0.0, 1.0);
         glVertex2i (0, GLint (High));

         glTexCoord2f (1.0, 1.0);
         glVertex2i (GLint (Wide), GLint (High));
      end;
      glEnd;

      -- flush rendering pipeline
      glFlush;

      -- Now show it
      Lumen.Window.Swap (Win);
   end Draw;

   -- Simple event handler routine for keypresses and close-window events
   procedure Quit_Handler (Event : in Lumen.Events.Event_Data) is
   begin  -- Quit_Handler
      raise Program_End;
   end Quit_Handler;

   -- Simple event handler routine for Exposed events
   procedure Expose_Handler (Event : in Lumen.Events.Event_Data) is
      pragma Unreferenced (Event);
   begin  -- Expose_Handler
      Draw;
   end Expose_Handler;

   -- Simple event handler routine for Resized events
   procedure Resize_Handler (Event : in Lumen.Events.Event_Data) is
   begin  -- Resize_Handler
      Wide := Event.Resize_Data.Width;
      High := Event.Resize_Data.Height;
      Set_View (Wide, High);
--        Image := Mandelbrot.Create_Image (Width => Wide, Height => High);
--        Create_Texture;
      Draw;
   end Resize_Handler;

begin
   -- Create Lumen window, accepting most defaults; turn double buffering off
   -- for simplicity
   Lumen.Window.Create (Win           => Win,
                        Name          => "Mandelbrot fractal",
                        Width         => Wide,
                        Height        => High,
                        Events        => (Lumen.Window.Want_Exposure  => True,
                                          Lumen.Window.Want_Key_Press => True,
                                          others                      => False));

   -- Set up the viewport and scene parameters
   Set_View (Wide, High);

   -- Now create the texture and set up to use it
   Image := Mandelbrot.Create_Image (Width => Wide, Height => High);
   Create_Texture;

   -- Enter the event loop
   declare
      use Lumen.Events;
   begin
      Select_Events (Win   => Win,
                     Calls => (Key_Press    => Quit_Handler'Unrestricted_Access,
                               Exposed      => Expose_Handler'Unrestricted_Access,
                               Resized      => Resize_Handler'Unrestricted_Access,
                               Close_Window => Quit_Handler'Unrestricted_Access,
                               others       => No_Callback));
   end;
exception
   when Program_End =>
      null;
end Test_Mandelbrot;

The code generates and draws the Mandelbrot set using various algorithms and functions. The code is written in Ada and is divided into three parts: mandelbrot.adb, mandelbrot.ads, and test_mandelbrot.adb. The content is sourced from the Wikipedia page on the Mandelbrot set.


type Int_Array is array(Integer range <>) of Integer;

array : Int_Array := (1,2,3,4,5,6,7,8,9,10);
Sum : Integer := 0;
for I in array'range loop
   Sum := Sum + array(I);
end loop;

function Product(Item : Int_Array) return Integer is
  Prod : Integer := 1;
begin
  for I in Item'range loop
     Prod := Prod * Item(I);
  end loop;
  return Prod;
end Product;

calculate the sum and product of an array of integers. If the product exceeds the maximum value of an integer, a Constraint_Error exception is raised.


-- Incomplete code, just a sniplet to do the task. Can be used in any package or method.
-- Adjust the type of Year if you use a different one.
function Is_Leap_Year (Year : Integer) return Boolean is
begin
   if Year rem 100 = 0 then
      return Year rem 400 = 0;
   else
      return Year rem 4 = 0;
   end if;
end Is_Leap_Year;

-- An enhanced, more efficient version:
-- This version only does the 2 bit comparison (rem 4) if false.
-- It then checks rem 16 (a 4 bit comparison), and only if those are not
-- conclusive, calls rem 100, which is the most expensive operation.
-- I failed to be convinced of the accuracy of the algorithm at first,
-- so I rephrased it below.
-- FYI: 400 is evenly divisible by 16 whereas 100,200 and 300 are not. Ergo, the
-- set of integers evenly divisible by 16 and 100 are all evenly divisible by 400.
-- 1. If a year is not divisible by 4 => not a leap year. Skip other checks.
-- 2. If a year is evenly divisible by 16, it is either evenly divisible by 400 or
--    not evenly divisible by 100 => leap year. Skip further checks.
-- 3. If a year evenly divisible by 100 => not a leap year.
-- 4. Otherwise a leap year.

function Is_Leap_Year (Year : Integer) return Boolean is
begin
   return (Year rem 4 = 0) and then ((Year rem 16 = 0) or else (Year rem 100 /= 0));
end Is_Leap_Year;

-- To improve speed a bit more, use with
pragma Inline (Is_Leap_Year);

"Determines if a specified year is a leap year in the Gregorian calendar."


package MD5 is

   type Int32 is mod 2 ** 32;
   type MD5_Hash is array (1 .. 4) of Int32;
   function MD5 (Input : String) return MD5_Hash;

   -- 32 hexadecimal characters + '0x' prefix
   subtype MD5_String is String (1 .. 34);
   function To_String (Item : MD5_Hash) return MD5_String;

end MD5;

with Ada.Unchecked_Conversion;

package body MD5 is
   type Int32_Array is array (Positive range <>) of Int32;

   function Rotate_Left (Value : Int32; Count : Int32) return Int32 is
      Bit    : Boolean;
      Result : Int32 := Value;
   begin
      for I in 1 .. Count loop
         Bit    := (2 ** 31 and Result) = 2 ** 31;
         Result := Result * 2;
         if Bit then
            Result := Result + 1;
         end if;
      end loop;
      return Result;
   end Rotate_Left;

   function Pad_String (Item : String) return Int32_Array is
      -- always pad positive amount of Bytes
      Padding_Bytes : Positive := 64 - Item'Length mod 64;
      subtype String4 is String (1 .. 4);
      function String4_To_Int32 is new Ada.Unchecked_Conversion
        (Source => String4,
         Target => Int32);
   begin
      if Padding_Bytes <= 2 then
         Padding_Bytes := Padding_Bytes + 64;
      end if;
      declare
         Result        : Int32_Array (1 .. (Item'Length + Padding_Bytes) / 4);
         Current_Index : Positive := 1;
      begin
         for I in 1 .. Item'Length / 4 loop
            Result (I)    :=
              String4_To_Int32 (Item (4 * (I - 1) + 1 .. 4 * I));
            Current_Index := Current_Index + 1;
         end loop;

         declare
            Last_String : String4          := (others => Character'Val (0));
            Chars_Left  : constant Natural := Item'Length mod 4;
         begin
            Last_String (1 .. Chars_Left) :=
              Item (Item'Last - Chars_Left + 1 .. Item'Last);
            Last_String (Chars_Left + 1)  := Character'Val (2#1000_0000#);
            Result (Current_Index)        := String4_To_Int32 (Last_String);
            Current_Index                 := Current_Index + 1;
         end;

         Result (Current_Index .. Result'Last) := (others => 0);
         -- append length as bit count
         Result (Result'Last - 1) := Item'Length * 2 ** 3; -- mod 2 ** 32;
         Result (Result'Last)     := Item'Length / 2 ** (32 - 3);
         return Result;
      end;
   end Pad_String;

   function Turn_Around (X : Int32) return Int32 is
      Result : Int32 := 0;
   begin
      for Byte in 1 .. 4 loop
         Result := Result * 16#100#;
         Result := Result + (X / (2 ** (8 * (Byte - 1)))) mod 16#100#;
      end loop;
      return Result;
   end Turn_Around;

   function MD5 (Input : String) return MD5_Hash is
      function F (X, Y, Z : Int32) return Int32 is
      begin
         return Z xor (X and (Y xor Z));
      end F;
      function G (X, Y, Z : Int32) return Int32 is
      begin
         return (X and Z) or (Y and (not Z));
      end G;
      function H (X, Y, Z : Int32) return Int32 is
      begin
         return X xor Y xor Z;
      end H;
      function I (X, Y, Z : Int32) return Int32 is
      begin
         return Y xor (X or (not Z));
      end I;
      T  : constant Int32_Array :=
        (16#d76aa478#, 16#e8c7b756#, 16#242070db#, 16#c1bdceee#,
         16#f57c0faf#, 16#4787c62a#, 16#a8304613#, 16#fd469501#,
         16#698098d8#, 16#8b44f7af#, 16#ffff5bb1#, 16#895cd7be#,
         16#6b901122#, 16#fd987193#, 16#a679438e#, 16#49b40821#,
         16#f61e2562#, 16#c040b340#, 16#265e5a51#, 16#e9b6c7aa#,
         16#d62f105d#, 16#02441453#, 16#d8a1e681#, 16#e7d3fbc8#,
         16#21e1cde6#, 16#c33707d6#, 16#f4d50d87#, 16#455a14ed#,
         16#a9e3e905#, 16#fcefa3f8#, 16#676f02d9#, 16#8d2a4c8a#,
         16#fffa3942#, 16#8771f681#, 16#6d9d6122#, 16#fde5380c#,
         16#a4beea44#, 16#4bdecfa9#, 16#f6bb4b60#, 16#bebfbc70#,
         16#289b7ec6#, 16#eaa127fa#, 16#d4ef3085#, 16#04881d05#,
         16#d9d4d039#, 16#e6db99e5#, 16#1fa27cf8#, 16#c4ac5665#,
         16#f4292244#, 16#432aff97#, 16#ab9423a7#, 16#fc93a039#,
         16#655b59c3#, 16#8f0ccc92#, 16#ffeff47d#, 16#85845dd1#,
         16#6fa87e4f#, 16#fe2ce6e0#, 16#a3014314#, 16#4e0811a1#,
         16#f7537e82#, 16#bd3af235#, 16#2ad7d2bb#, 16#eb86d391#);
      A : Int32 := 16#67452301#;
      B : Int32 := 16#EFCDAB89#;
      C : Int32 := 16#98BADCFE#;
      D : Int32 := 16#10325476#;
      Padded_String : constant Int32_Array := Pad_String (Input);
   begin
      for Block512 in 1 .. Padded_String'Length / 16 loop
         declare
            Words    : constant Int32_Array (1 .. 16) :=
              Padded_String (16 * (Block512 - 1) + 1 .. 16 * Block512);
            AA       : constant Int32                 := A;
            BB       : constant Int32                 := B;
            CC       : constant Int32                 := C;
            DD       : constant Int32                 := D;
         begin
            -- round 1
            A := B + Rotate_Left ((A + F (B, C, D) + Words (1) + T (1)),  7);
            D := A + Rotate_Left ((D + F (A, B, C) + Words (2) + T (2)), 12);
            C := D + Rotate_Left ((C + F (D, A, B) + Words (3) + T (3)), 17);
            B := C + Rotate_Left ((B + F (C, D, A) + Words (4) + T (4)), 22);
            A := B + Rotate_Left ((A + F (B, C, D) + Words (5) + T (5)),  7);
            D := A + Rotate_Left ((D + F (A, B, C) + Words (6) + T (6)), 12);
            C := D + Rotate_Left ((C + F (D, A, B) + Words (7) + T (7)), 17);
            B := C + Rotate_Left ((B + F (C, D, A) + Words (8) + T (8)), 22);
            A := B + Rotate_Left ((A + F (B, C, D) + Words (9) + T (9)),  7);
            D := A + Rotate_Left ((D + F (A, B, C) + Words (10) + T (10)), 12);
            C := D + Rotate_Left ((C + F (D, A, B) + Words (11) + T (11)), 17);
            B := C + Rotate_Left ((B + F (C, D, A) + Words (12) + T (12)), 22);
            A := B + Rotate_Left ((A + F (B, C, D) + Words (13) + T (13)),  7);
            D := A + Rotate_Left ((D + F (A, B, C) + Words (14) + T (14)), 12);
            C := D + Rotate_Left ((C + F (D, A, B) + Words (15) + T (15)), 17);
            B := C + Rotate_Left ((B + F (C, D, A) + Words (16) + T (16)), 22);
            -- round 2
            A := B + Rotate_Left ((A + G (B, C, D) + Words (2) + T (17)),  5);
            D := A + Rotate_Left ((D + G (A, B, C) + Words (7) + T (18)),  9);
            C := D + Rotate_Left ((C + G (D, A, B) + Words (12) + T (19)), 14);
            B := C + Rotate_Left ((B + G (C, D, A) + Words (1) + T (20)), 20);
            A := B + Rotate_Left ((A + G (B, C, D) + Words (6) + T (21)),  5);
            D := A + Rotate_Left ((D + G (A, B, C) + Words (11) + T (22)),  9);
            C := D + Rotate_Left ((C + G (D, A, B) + Words (16) + T (23)), 14);
            B := C + Rotate_Left ((B + G (C, D, A) + Words (5) + T (24)), 20);
            A := B + Rotate_Left ((A + G (B, C, D) + Words (10) + T (25)),  5);
            D := A + Rotate_Left ((D + G (A, B, C) + Words (15) + T (26)),  9);
            C := D + Rotate_Left ((C + G (D, A, B) + Words (4) + T (27)), 14);
            B := C + Rotate_Left ((B + G (C, D, A) + Words (9) + T (28)), 20);
            A := B + Rotate_Left ((A + G (B, C, D) + Words (14) + T (29)),  5);
            D := A + Rotate_Left ((D + G (A, B, C) + Words (3) + T (30)),  9);
            C := D + Rotate_Left ((C + G (D, A, B) + Words (8) + T (31)), 14);
            B := C + Rotate_Left ((B + G (C, D, A) + Words (13) + T (32)), 20);
            -- round 3
            A := B + Rotate_Left ((A + H (B, C, D) + Words (6) + T (33)),  4);
            D := A + Rotate_Left ((D + H (A, B, C) + Words (9) + T (34)), 11);
            C := D + Rotate_Left ((C + H (D, A, B) + Words (12) + T (35)), 16);
            B := C + Rotate_Left ((B + H (C, D, A) + Words (15) + T (36)), 23);
            A := B + Rotate_Left ((A + H (B, C, D) + Words (2) + T (37)),  4);
            D := A + Rotate_Left ((D + H (A, B, C) + Words (5) + T (38)), 11);
            C := D + Rotate_Left ((C + H (D, A, B) + Words (8) + T (39)), 16);
            B := C + Rotate_Left ((B + H (C, D, A) + Words (11) + T (40)), 23);
            A := B + Rotate_Left ((A + H (B, C, D) + Words (14) + T (41)),  4);
            D := A + Rotate_Left ((D + H (A, B, C) + Words (1) + T (42)), 11);
            C := D + Rotate_Left ((C + H (D, A, B) + Words (4) + T (43)), 16);
            B := C + Rotate_Left ((B + H (C, D, A) + Words (7) + T (44)), 23);
            A := B + Rotate_Left ((A + H (B, C, D) + Words (10) + T (45)),  4);
            D := A + Rotate_Left ((D + H (A, B, C) + Words (13) + T (46)), 11);
            C := D + Rotate_Left ((C + H (D, A, B) + Words (16) + T (47)), 16);
            B := C + Rotate_Left ((B + H (C, D, A) + Words (3) + T (48)), 23);
            -- round 4
            A := B + Rotate_Left ((A + I (B, C, D) + Words (1) + T (49)),  6);
            D := A + Rotate_Left ((D + I (A, B, C) + Words (8) + T (50)), 10);
            C := D + Rotate_Left ((C + I (D, A, B) + Words (15) + T (51)), 15);
            B := C + Rotate_Left ((B + I (C, D, A) + Words (6) + T (52)), 21);
            A := B + Rotate_Left ((A + I (B, C, D) + Words (13) + T (53)),  6);
            D := A + Rotate_Left ((D + I (A, B, C) + Words (4) + T (54)), 10);
            C := D + Rotate_Left ((C + I (D, A, B) + Words (11) + T (55)), 15);
            B := C + Rotate_Left ((B + I (C, D, A) + Words (2) + T (56)), 21);
            A := B + Rotate_Left ((A + I (B, C, D) + Words (9) + T (57)),  6);
            D := A + Rotate_Left ((D + I (A, B, C) + Words (16) + T (58)), 10);
            C := D + Rotate_Left ((C + I (D, A, B) + Words (7) + T (59)), 15);
            B := C + Rotate_Left ((B + I (C, D, A) + Words (14) + T (60)), 21);
            A := B + Rotate_Left ((A + I (B, C, D) + Words (5) + T (61)),  6);
            D := A + Rotate_Left ((D + I (A, B, C) + Words (12) + T (62)), 10);
            C := D + Rotate_Left ((C + I (D, A, B) + Words (3) + T (63)), 15);
            B := C + Rotate_Left ((B + I (C, D, A) + Words (10) + T (64)), 21);
            -- increment
            A := A + AA;
            B := B + BB;
            C := C + CC;
            D := D + DD;
         end;
      end loop;
      return
        (Turn_Around (A),
         Turn_Around (B),
         Turn_Around (C),
         Turn_Around (D));
   end MD5;

   function To_String (Item : MD5_Hash) return MD5_String is
      Hex_Chars : constant array (0 .. 15) of Character :=
        ('0', '1', '2', '3', '4', '5', '6', '7',
        '8', '9', 'a', 'b', 'c', 'd', 'e', 'f');
      Result    : MD5_String := (1      => '0',
                                 2      => 'x',
                                 others => '0');
      Temp      : Int32;
      Position  : Natural := Result'Last;
   begin
      for Part in reverse Item'Range loop
         Temp := Item (Part);
         while Position > Result'Last - (5 - Part) * 8 loop
            Result (Position) := Hex_Chars (Natural (Temp mod 16));
            Position          := Position - 1;
            Temp              := Temp / 16;
         end loop;
      end loop;
      return Result;
   end To_String;

end MD5;

with Ada.Strings.Unbounded;
with Ada.Text_IO;
with MD5;

procedure Tester is
   use Ada.Strings.Unbounded;
   type String_Array is array (Positive range <>) of Unbounded_String;
   Sources : constant String_Array :=
     (To_Unbounded_String (""),
      To_Unbounded_String ("a"),
      To_Unbounded_String ("abc"),
      To_Unbounded_String ("message digest"),
      To_Unbounded_String ("abcdefghijklmnopqrstuvwxyz"),
      To_Unbounded_String
         ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"),
      To_Unbounded_String
         ("12345678901234567890123456789012345678901234567890123456789012345678901234567890")
     );
   Digests : constant String_Array :=
     (To_Unbounded_String ("0xd41d8cd98f00b204e9800998ecf8427e"),
      To_Unbounded_String ("0x0cc175b9c0f1b6a831c399e269772661"),
      To_Unbounded_String ("0x900150983cd24fb0d6963f7d28e17f72"),
      To_Unbounded_String ("0xf96b697d7cb7938d525a2f31aaf161d0"),
      To_Unbounded_String ("0xc3fcd3d76192e4007dfb496cca67e13b"),
      To_Unbounded_String ("0xd174ab98d277d9f5a5611c2c9f419d9f"),
      To_Unbounded_String ("0x57edf4a22be3c955ac49da2e2107b67a"));
begin
   for I in Sources'Range loop
      Ada.Text_IO.Put_Line ("MD5 (""" & To_String (Sources (I)) & """):");
      Ada.Text_IO.Put_Line
        (MD5.To_String (MD5.MD5 (To_String (Sources (I)))));
      Ada.Text_IO.Put_Line (To_String (Digests (I)) & " (correct value)");
   end loop;
end Tester;

MD5 (""):
0xd41d8cd98f00b204e9800998ecf8427e
0xd41d8cd98f00b204e9800998ecf8427e (correct value)
MD5 ("a"):
0x0cc175b9c0f1b6a831c399e269772661
0x0cc175b9c0f1b6a831c399e269772661 (correct value)
MD5 ("abc"):
0x900150983cd24fb0d6963f7d28e17f72
0x900150983cd24fb0d6963f7d28e17f72 (correct value)
MD5 ("message digest"):
0xf96b697d7cb7938d525a2f31aaf161d0
0xf96b697d7cb7938d525a2f31aaf161d0 (correct value)
MD5 ("abcdefghijklmnopqrstuvwxyz"):
0xc3fcd3d76192e4007dfb496cca67e13b
0xc3fcd3d76192e4007dfb496cca67e13b (correct value)
MD5 ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"):
0xd174ab98d277d9f5a5611c2c9f419d9f
0xd174ab98d277d9f5a5611c2c9f419d9f (correct value)
MD5 ("12345678901234567890123456789012345678901234567890123456789012345678901234567890"):
0x57edf4a22be3c955ac49da2e2107b67a
0x57edf4a22be3c955ac49da2e2107b67a (correct value)

implement the MD5 Message Digest Algorithm without using any built-in or external hashing libraries. The implementation focuses on producing a correct message digest for an input string. It includes challenges faced, implementation choices made, and any limitations. The codes do not mimic all calling modes but provide practical illustrations of bit manipulation, unsigned integers, and working with little-endian data. It also includes verification strings and hashes from RFC 1321. The MD5 algorithm was developed by RSA Data Security, Inc. in 1991. However, MD5 is not recommended for applications requiring high security.


with Ada.Text_IO;

procedure Department_Numbers is
   use Ada.Text_IO;
begin
   Put_Line (" P S F");
   for Police in 2 .. 6 loop
      for Sanitation in 1 .. 7 loop
         for Fire in 1 .. 7 loop
            if
              Police mod 2 = 0                and
              Police + Sanitation + Fire = 12 and
              Sanitation /= Police            and
              Sanitation /= Fire              and
              Police     /= Fire
            then
               Put_Line (Police'Image & Sanitation'Image & Fire'Image);
            end if;
         end loop;
      end loop;
   end loop;
end Department_Numbers;

all possible combinations of unique numbers between 1 and 7 (inclusive) for three different departments (police, sanitation, fire) that add up to 12, with the police department number being an even number.


Fixed Length String Copying.[edit]
Src : String := "Hello";
Dest : String := Src;

Src : String := "Rosetta Stone";
Dest : String := Src(1..7); -- Assigns "Rosetta" to Dest
Dest2 : String := Src(9..13); -- Assigns "Stone" to Dest2

Bounded Length String Copying[edit]
-- Instantiate the generic package Ada.Strings.Bounded.Generic_Bounded_Length with a maximum length of 80 characters
package Flexible_String is new Ada.Strings.Bounded.Generic_Bounded_Length(80);
use Flexible_String;

Src : Bounded_String := To_Bounded_String("Hello");
Dest : Bounded_String := Src;

Unbounded Length String Copying[edit]
-- The package Ada.Strings.Unbounded contains the definition of the Unbounded_String type and all its methods
Src : Unbounded_String := To_Unbounded_String("Hello");
Dest : Unbounded_String := Src;

The code implements the task of copying a string in Ada programming language. It differentiates between copying the actual content of a string and creating an additional reference to an existing string. It utilizes three types of strings provided by Ada: fixed length String, Bounded_String with variable length up to a maximum size, and Unbounded_String with no maximum size. The code also manipulates slices of strings, particularly with the Bounded_String type.


with Ada.Text_Io; use Ada.Text_Io;
procedure Mutual_Recursion is
   function M(N : Integer) return Integer;
   function F(N : Integer) return Integer is
   begin
      if N = 0 then
         return 1;
      else
         return N - M(F(N - 1));
      end if;
   end F;
   function M(N : Integer) return Integer is
   begin
      if N = 0 then
         return 0;
      else
         return N - F(M(N-1));
      end if;
   end M;
begin
   for I in 0..19 loop
      Put_Line(Integer'Image(F(I)));
   end loop;
   New_Line;
   for I in 0..19 loop
      Put_Line(Integer'Image(M(I)));
   end loop;
end Mutual_recursion;

Works with: Ada 2012
with Ada.Text_Io; use Ada.Text_Io;
procedure Mutual_Recursion is
   function M(N: Natural) return Natural;
   function F(N: Natural) return Natural;

   function M(N: Natural) return Natural is
       (if N = 0 then 0 else N – F(M(N–1)));

   function F(N: Natural) return Natural is
       (if N =0 then 1 else N – M(F(N–1)));
begin
   for I in 0..19 loop
      Put_Line(Integer'Image(F(I)));
   end loop;
   New_Line;
   for I in 0..19 loop
      Put_Line(Integer'Image(M(I)));
   end loop;

end Mutual_recursion;

implement two mutually recursive functions to compute the Hofstadter Female and Male sequences. If the programming language does not support mutual recursion, it should be stated.


with Ada.Text_IO, Ada.Numerics.Float_Random;

procedure Pick_Random_Element is

   package Rnd renames Ada.Numerics.Float_Random;
   Gen: Rnd.Generator; -- used globally

   type Char_Arr is array (Natural range <>) of Character;

   function Pick_Random(A: Char_Arr) return Character is
      -- Chooses one of the characters of A (uniformly distributed)
   begin
      return A(A'First + Natural(Rnd.Random(Gen) * Float(A'Last)));
   end Pick_Random;

   Vowels    : Char_Arr := ('a', 'e', 'i', 'o', 'u');
   Consonants: Char_Arr := ('t', 'n', 's', 'h', 'r', 'd', 'l');
   Specials  : Char_Arr := (',', '.', '?', '!');

begin
   Rnd.Reset(Gen);
   for J in 1 .. 3 loop
      for I in 1 .. 10 loop
         Ada.Text_IO.Put(Pick_Random(Consonants));
         Ada.Text_IO.Put(Pick_Random(Vowels));
      end loop;
      Ada.Text_IO.Put(Pick_Random(Specials) & " ");
   end loop;
   Ada.Text_IO.New_Line;
end Pick_Random_Element;

"Code generates three 20-letter words by randomly picking each vowel and consonant from a respective list."


Library: AWS
with AWS.URL;
with Ada.Text_IO; use Ada.Text_IO;
procedure Decode is
   Encoded : constant String := "http%3A%2F%2Ffoo%20bar%2F";
begin
   Put_Line (AWS.URL.Decode (Encoded));
end Decode;

package URL is
   function Decode (URL : in String) return String;
end URL;

package body URL is
   function Decode (URL : in String) return String is
      Buffer   : String (1 .. URL'Length);
      Filled   : Natural := 0;
      Position : Positive := URL'First;
   begin
      while Position in URL'Range loop
         Filled := Filled + 1;

        case URL (Position) is
            when '+' =>
               Buffer (Filled) := ' ';
               Position := Position + 1;
            when '%' =>
               Buffer (Filled) :=
                 Character'Val
                   (Natural'Value
                      ("16#" & URL (Position + 1 .. Position + 2) & "#"));
               Position := Position + 3;
            when others =>
               Buffer (Filled) := URL (Position);
               Position := Position + 1;
         end case;
      end loop;

      return Buffer (1 .. Filled);
   end Decode;
end URL;

with Ada.Command_Line,
     Ada.Text_IO;

with URL;

procedure Test_URL_Decode is
   use Ada.Command_Line, Ada.Text_IO;
begin
   if Argument_Count = 0 then
      Put_Line (URL.Decode ("http%3A%2F%2Ffoo%20bar%2F"));
   else
      for I in 1 .. Argument_Count loop
         Put_Line (URL.Decode (Argument (I)));
      end loop;
   end if;
end Test_URL_Decode;

Implement a function to convert URL-encoded strings back into their original unencoded form. This includes handling special characters and not mistaking encoded representations for actual characters.


Recursive

with Ada.Text_IO;  use Ada.Text_IO;

procedure Test_Recursive_Binary_Search is
   Not_Found : exception;

   generic
      type Index is range <>;
      type Element is private;
      type Array_Of_Elements is array (Index range <>) of Element;
      with function "<" (L, R : Element) return Boolean is <>;
   function Search (Container : Array_Of_Elements; Value : Element) return Index;

   function Search (Container : Array_Of_Elements; Value : Element) return Index is
      Mid : Index;
   begin
      if Container'Length > 0 then
         Mid := (Container'First + Container'Last) / 2;
         if Value < Container (Mid) then
            if Container'First /= Mid then
               return Search (Container (Container'First..Mid - 1), Value);
            end if;
         elsif Container (Mid) < Value then
            if Container'Last /= Mid then
               return Search (Container (Mid + 1..Container'Last), Value);
            end if;
         else
            return Mid;
         end if;
      end if;
      raise Not_Found;
   end Search;

   type Integer_Array is array (Positive range <>) of Integer;
   function Find is new Search (Positive, Integer, Integer_Array);

   procedure Test (X : Integer_Array; E : Integer) is
   begin
      New_Line;
      for I in X'Range loop
         Put (Integer'Image (X (I)));
      end loop;
      Put (" contains" & Integer'Image (E) & " at" & Integer'Image (Find (X, E)));
   exception
      when Not_Found =>
         Put (" does not contain" & Integer'Image (E));
   end Test;
begin
   Test ((2, 4, 6, 8, 9), 2);
   Test ((2, 4, 6, 8, 9), 1);
   Test ((2, 4, 6, 8, 9), 8);
   Test ((2, 4, 6, 8, 9), 10);
   Test ((2, 4, 6, 8, 9), 9);
   Test ((2, 4, 6, 8, 9), 5);
end Test_Recursive_Binary_Search;

Iterative

with Ada.Text_IO;  use Ada.Text_IO;

procedure Test_Binary_Search is
   Not_Found : exception;

   generic
      type Index is range <>;
      type Element is private;
      type Array_Of_Elements is array (Index range <>) of Element;
      with function "<" (L, R : Element) return Boolean is <>;
   function Search (Container : Array_Of_Elements; Value : Element) return Index;

   function Search (Container : Array_Of_Elements; Value : Element) return Index is
      Low  : Index := Container'First;
      High : Index := Container'Last;
      Mid  : Index;
   begin
      if Container'Length > 0 then
         loop
            Mid := (Low + High) / 2;
            if Value < Container (Mid) then
               exit when Low = Mid;
               High := Mid - 1;
            elsif Container (Mid) < Value then
               exit when High = Mid;
               Low := Mid + 1;
            else
               return Mid;
            end if;
         end loop;
      end if;
      raise Not_Found;
   end Search;

   type Integer_Array is array (Positive range <>) of Integer;
   function Find is new Search (Positive, Integer, Integer_Array);

   procedure Test (X : Integer_Array; E : Integer) is
   begin
      New_Line;
      for I in X'Range loop
         Put (Integer'Image (X (I)));
      end loop;
      Put (" contains" & Integer'Image (E) & " at" & Integer'Image (Find (X, E)));
   exception
      when Not_Found =>
         Put (" does not contain" & Integer'Image (E));
   end Test;
begin
   Test ((2, 4, 6, 8, 9), 2);
   Test ((2, 4, 6, 8, 9), 1);
   Test ((2, 4, 6, 8, 9), 8);
   Test ((2, 4, 6, 8, 9), 10);
   Test ((2, 4, 6, 8, 9), 9);
   Test ((2, 4, 6, 8, 9), 5);
end Test_Binary_Search;

 2 4 6 8 9 contains 2 at 1
 2 4 6 8 9 does not contain 1
 2 4 6 8 9 contains 8 at 4
 2 4 6 8 9 does not contain 10
 2 4 6 8 9 contains 9 at 5
 2 4 6 8 9 does not contain 5

The code implements a binary search algorithm that divides a range of values into halves to find a specific "secret value". The algorithm can be recursive or iterative and works with a sorted integer array. It also handles cases where there are multiple values equal to the given value and returns the index of the found element. The code also includes variants that return the leftmost and rightmost insertion points for the given value. Additionally, the code handles potential overflow bugs.


with Ada.Command_line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;

procedure Print_Commands is
begin
   -- The number of command line arguments is retrieved from the function Argument_Count
   -- The actual arguments are retrieved from the function Argument
   -- The program name is retrieved from the function Command_Name
   Put(Command_Name & " ");
   for Arg in 1..Argument_Count loop
      Put(Argument(Arg) & " ");
   end loop;
   New_Line;
end Print_Commands;

Alternative version using Matreshka[edit]

with Ada.Wide_Wide_Text_IO;

with League.Application;
with League.Strings;

procedure Main is
begin
   for J in 1 .. League.Application.Arguments.Length loop
      Ada.Wide_Wide_Text_IO.Put_Line
       (League.Application.Arguments.Element (J).To_Wide_Wide_String);
   end loop;
end Main;

The code retrieves the list of command-line arguments provided to the program. It prints the arguments only when the program is run directly. The code uses the Ada.Command_Line package in Ada95 and later versions for this task, while in Ada83, the implementation is dependent. It uses Matreshka for parsing command-line arguments intelligently. For example, for the command line "myprogram -c "alpha beta" -h "gamma"", it retrieves and processes the arguments "-c", "alpha beta", "-h", "gamma".


generic
   type Float_Type is digits <>;
   Gravitation : Float_Type;
package Pendulums is
   type Pendulum is private;
   function New_Pendulum (Length : Float_Type;
                          Theta0 : Float_Type) return Pendulum;
   function Get_X (From : Pendulum) return Float_Type;
   function Get_Y (From : Pendulum) return Float_Type;
   procedure Update_Pendulum (Item : in out Pendulum; Time : in Duration);
private
   type Pendulum is record
      Length   : Float_Type;
      Theta    : Float_Type;
      X        : Float_Type;
      Y        : Float_Type;
      Velocity : Float_Type;
   end record;
end Pendulums;

with Ada.Numerics.Generic_Elementary_Functions;
package body Pendulums is
   package Math is new Ada.Numerics.Generic_Elementary_Functions (Float_Type);

   function New_Pendulum (Length : Float_Type;
                          Theta0 : Float_Type) return Pendulum is
      Result : Pendulum;
   begin
      Result.Length   := Length;
      Result.Theta    := Theta0 / 180.0 * Ada.Numerics.Pi;
      Result.X        := Math.Sin (Theta0) * Length;
      Result.Y        := Math.Cos (Theta0) * Length;
      Result.Velocity := 0.0;
      return Result;
   end New_Pendulum;

   function Get_X (From : Pendulum) return Float_Type is
   begin
      return From.X;
   end Get_X;

   function Get_Y (From : Pendulum) return Float_Type is
   begin
      return From.Y;
   end Get_Y;

   procedure Update_Pendulum (Item : in out Pendulum; Time : in Duration) is
      Acceleration : constant Float_Type := Gravitation / Item.Length *
                                            Math.Sin (Item.Theta);
   begin
         Item.X        := Math.Sin (Item.Theta) * Item.Length;
         Item.Y        := Math.Cos (Item.Theta) * Item.Length;
         Item.Velocity := Item.Velocity +
                          Acceleration  * Float_Type (Time);
         Item.Theta    := Item.Theta +
                          Item.Velocity * Float_Type (Time);
   end Update_Pendulum;
end Pendulums;

with Ada.Text_IO;
with Ada.Calendar;
with Pendulums;

procedure Main is
   package Float_Pendulum is new Pendulums (Float, -9.81);
   use Float_Pendulum;
   use type Ada.Calendar.Time;

   My_Pendulum : Pendulum := New_Pendulum (10.0, 30.0);
   Now, Before : Ada.Calendar.Time;
begin
   Before := Ada.Calendar.Clock;
   loop
      Delay 0.1;
      Now := Ada.Calendar.Clock;
      Update_Pendulum (My_Pendulum, Now - Before);
      Before := Now;
      -- output positions relative to origin
      -- replace with graphical output if wanted
      Ada.Text_IO.Put_Line (" X: " & Float'Image (Get_X (My_Pendulum)) &
                            " Y: " & Float'Image (Get_Y (My_Pendulum)));
   end loop;
end Main;

simulate a gravity pendulum system, animate its movement, and print out the relative positions of the pendulum to the anchor. The codes do not involve a GUI and the output method can be replaced with graphical update methods.


Alternative using GNATCOLL[edit]
with Ada.Text_IO;
with GNATCOLL.JSON;

procedure JSON_Test is
   use Ada.Text_IO;
   use GNATCOLL.JSON;

   JSON_String : constant String := "{""name"":""Pingu"",""born"":1986}";

   Penguin : JSON_Value := Create_Object;
   Parents : JSON_Array;
begin
   Penguin.Set_Field (Field_Name => "name",
                      Field      => "Linux");

   Penguin.Set_Field (Field_Name => "born",
                      Field      => 1992);

   Append (Parents, Create ("Linus Torvalds"));
   Append (Parents, Create ("Alan Cox"));
   Append (Parents, Create ("Greg Kroah-Hartman"));

   Penguin.Set_Field (Field_Name => "parents",
                      Field      => Parents);

   Put_Line (Penguin.Write);

   Penguin := Read (JSON_String, "json.errors");

   Penguin.Set_Field (Field_Name => "born",
                      Field      => 1986);

   Parents := Empty_Array;
   Append (Parents, Create ("Otmar Gutmann"));
   Append (Parents, Create ("Silvio Mazzola"));

   Penguin.Set_Field (Field_Name => "parents",
                      Field      => Parents);

   Put_Line (Penguin.Write);
end JSON_Test;

"Load a JSON string into a data structure, create a new data structure, serialize it into JSON, and validate the JSON."


with Ada.Text_IO;  use Ada.Text_IO;

procedure Test_Nth_Root is
   generic
      type Real is digits <>;
   function Nth_Root (Value : Real; N : Positive) return Real;

   function Nth_Root (Value : Real; N : Positive) return Real is
      type Index is mod 2;
      X : array (Index) of Real := (Value, Value);
      K : Index := 0;
   begin
      loop
         X (K + 1) := ( (Real (N) - 1.0) * X (K) + Value / X (K) ** (N-1) ) / Real (N);
         exit when X (K + 1) >= X (K);
         K := K + 1;
      end loop;
      return X (K + 1);
   end Nth_Root;

   function Long_Nth_Root is new Nth_Root (Long_Float);
begin
   Put_Line ("1024.0 10th  =" & Long_Float'Image (Long_Nth_Root (1024.0, 10)));
   Put_Line ("  27.0 3rd   =" & Long_Float'Image (Long_Nth_Root (27.0, 3)));
   Put_Line ("   2.0 2nd   =" & Long_Float'Image (Long_Nth_Root (2.0, 2)));
   Put_Line ("5642.0 125th =" & Long_Float'Image (Long_Nth_Root (5642.0, 125)));
end Test_Nth_Root;

1024.0 10th  = 2.00000000000000E+00
  27.0 3rd   = 3.00000000000000E+00
   2.0 2nd   = 1.41421356237310E+00
5642.0 125th = 1.07154759194477E+00

implement a generic algorithm to compute the principal nth root of a positive real number, as per the method explained on Wikipedia. The algorithm works with any floating-point type and converges when the iteration condition gets violated.


with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Sockets;

procedure Demo is
begin
   Put_Line (GNAT.Sockets.Host_Name);
end Demo;

The code retrieves the hostname of the system where the routine is being executed, compatible with GCC/GNAT.


with Ada.Text_IO; use Ada.Text_IO;

procedure Leonardo is

   function Leo
     (N      : Natural;
      Step   : Natural := 1;
      First  : Natural := 1;
      Second : Natural := 1) return Natural   is
      L : array (0..1) of Natural := (First, Second);
	begin
		for i in 1 .. N loop
			L := (L(1), L(0)+L(1)+Step);
		end loop;
		return L (0);
	end Leo;

begin
   Put_Line ("First 25 Leonardo numbers:");
   for I in 0 .. 24 loop
      Put (Integer'Image (Leo (I)));
   end loop;
   New_Line;
   Put_Line ("First 25 Leonardo numbers with L(0) = 0, L(1) = 1, " &
             "step = 0 (fibonacci numbers):");
   for I in 0 .. 24 loop
      Put (Integer'Image (Leo (I, 0, 0, 1)));
   end loop;
   New_Line;
end Leonardo;

generate the first 25 Leonardo numbers, starting from L(0), with the ability to specify the first two Leonardo numbers and the add number. The codes also have the functionality to generate the Fibonacci sequence by specifying 0 and 1 for L(0) and L(1), and 0 for the add number.


with Ada.Float_Text_IO;
with Ada.Text_IO;
with Ada.Numerics.Discrete_Random;
procedure Game_24 is
   subtype Digit is Character range '1' .. '9';
   package Random_Digit is new Ada.Numerics.Discrete_Random (Digit);
   Exp_Error : exception;
   Digit_Generator : Random_Digit.Generator;
   Given_Digits : array (1 .. 4) of Digit;
   Float_Value : constant array (Digit) of Float :=
      (1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 8.0, 9.0);
   function Apply_Op (L, R : Float; Op : Character) return Float is
   begin
      case Op is
         when '+' =>
            return L + R;
         when '-' =>
            return L - R;
         when '*' =>
            return L * R;
         when '/' =>
            return L / R;
         when others =>
            Ada.Text_IO.Put_Line ("Unexpected operator: " & Op);
            raise Exp_Error;
      end case;
   end Apply_Op;
   function Eval_Exp (E : String) return Float is
      Flt : Float;
      First : Positive := E'First;
      Last : Positive;
      function Match_Paren (Start : Positive) return Positive is
         Pos : Positive := Start + 1;
         Level : Natural := 1;
      begin
         loop
            if Pos > E'Last then
               Ada.Text_IO.Put_Line ("Unclosed parentheses.");
               raise Exp_Error;
            elsif E (Pos) = '(' then
               Level := Level + 1;
            elsif E (Pos) = ')' then
               Level := Level - 1;
               exit when Level = 0;
            end if;
            Pos := Pos + 1;
         end loop;
         return Pos;
      end Match_Paren;
   begin
      if E (First) = '(' then
         Last := Match_Paren (First);
         Flt := Eval_Exp (E (First + 1 .. Last - 1));
      elsif E (First) in Digit then
         Last := First;
         Flt := Float_Value (E (First));
      else
         Ada.Text_IO.Put_Line ("Unexpected character: " & E (First));
         raise Exp_Error;
      end if;
      loop
         if Last = E'Last then
            return Flt;
         elsif Last = E'Last - 1 then
            Ada.Text_IO.Put_Line ("Unexpected end of expression.");
            raise Exp_Error;
         end if;
         First := Last + 2;
         if E (First) = '(' then
            Last := Match_Paren (First);
            Flt := Apply_Op (Flt, Eval_Exp (E (First + 1 .. Last - 1)),
                             Op => E (First - 1));
         elsif E (First) in Digit then
            Last := First;
            Flt := Apply_Op (Flt, Float_Value (E (First)),
                             Op => E (First - 1));
         else
            Ada.Text_IO.Put_Line ("Unexpected character: " & E (First));
            raise Exp_Error;
         end if;
      end loop;
   end Eval_Exp;
begin
   Ada.Text_IO.Put_Line ("24 Game");
   Ada.Text_IO.Put_Line ("- Enter Q to Quit");
   Ada.Text_IO.Put_Line ("- Enter N for New digits");
   Ada.Text_IO.Put_Line ("Note: Operators are evaluated left-to-right");
   Ada.Text_IO.Put_Line ("      (use parentheses to override)");
   Random_Digit.Reset (Digit_Generator);
   <<GEN_DIGITS>>
   Ada.Text_IO.Put_Line ("Generating 4 digits...");
   for I in Given_Digits'Range loop
      Given_Digits (I) := Random_Digit.Random (Digit_Generator);
   end loop;
   <<GET_EXP>>
   Ada.Text_IO.Put ("Your Digits:");
   for I in Given_Digits'Range loop
      Ada.Text_IO.Put (" " & Given_Digits (I));
   end loop;
   Ada.Text_IO.New_Line;
   Ada.Text_IO.Put ("Enter your Expression: ");
   declare
      Value : Float;
      Response : constant String := Ada.Text_IO.Get_Line;
      Prev_Ch : Character := ' ';
      Unused_Digits : array (Given_Digits'Range) of Boolean :=
        (others => True);
   begin
      if Response = "n" or Response = "N" then
         goto GEN_DIGITS;
      end if;
      if Response = "q" or Response = "Q" then
         return;
      end if;
      -- check input
      for I in Response'Range loop
         declare
            Ch : constant Character := Response (I);
            Found : Boolean;
         begin
            if Ch in Digit then
               if Prev_Ch in Digit then
                  Ada.Text_IO.Put_Line ("Illegal multi-digit number used.");
                  goto GET_EXP;
               end if;
               Found := False;
               for J in Given_Digits'Range loop
                  if Unused_Digits (J) and then
                        Given_Digits (J) = Ch then
                     Unused_Digits (J) := False;
                     Found := True;
                     exit;
                  end if;
               end loop;
               if not Found then
                  Ada.Text_IO.Put_Line ("Illegal number used: " & Ch);
                  goto GET_EXP;
               end if;
            elsif Ch /= '(' and Ch /= ')' and Ch /= '+' and
                  Ch /= '-' and Ch /= '*' and Ch /= '/' then
               Ada.Text_IO.Put_Line ("Illegal character used: " & Ch);
               goto GET_EXP;
            end if;
            Prev_Ch := Ch;
         end;
      end loop;
      -- check all digits used
      for I in Given_Digits'Range loop
         if Unused_Digits (I) then
            Ada.Text_IO.Put_Line ("Digit not used: " & Given_Digits (I));
            goto GET_EXP;
         end if;
      end loop;
      -- check value
      begin
         Value := Eval_Exp (Response);
      exception
         when Exp_Error =>
            goto GET_EXP; -- Message displayed by Eval_Exp;
      end;
      if abs (Value - 24.0) > 0.001 then
         Ada.Text_IO.Put ("Value ");
         Ada.Float_Text_IO.Put (Value, Fore => 0, Aft => 3, Exp => 0);
         Ada.Text_IO.Put_Line (" is not 24!");
         goto GET_EXP;
      else
         Ada.Text_IO.Put_Line ("You won!");
         Ada.Text_IO.Put_Line ("Enter N for a new game, or try another solution.");
         goto GET_EXP;
      end if;
   end;
end Game_24;

The code is for a game called "24 Game" that tests a player's mental arithmetic skills. It randomly selects and displays four digits from 1 to 9, and prompts the player to form an arithmetic expression using these digits exactly once each. The goal is to create an expression that evaluates to 24 using only multiplication, division, addition, and subtraction. The code checks and evaluates the player's input expression. Division is performed using floating point or rational arithmetic to preserve remainders, and brackets are allowed. The code does not allow forming multiple digit numbers from the given digits. The order of the digits does not have to be preserved. The code does not generate the expression or test its possibility.


with Ada.Text_IO;        use Ada.Text_IO;
with Ada.Strings.Fixed;  use Ada.Strings.Fixed;
procedure Test_Run_Length_Encoding is
   function Encode (Data : String) return String is
   begin
      if Data'Length = 0 then
         return "";
      else
         declare
            Code  : constant Character := Data (Data'First);
            Index : Integer := Data'First + 1;
         begin
            while Index <= Data'Last and then Code = Data (Index) loop
               Index := Index + 1;
            end loop;
            declare
               Prefix : constant String := Integer'Image (Index - Data'First);
            begin
               return Prefix (2..Prefix'Last) & Code & Encode (Data (Index..Data'Last));
            end;
         end;
      end if;
   end Encode;
   function Decode (Data : String) return String is
   begin
      if Data'Length = 0 then
         return "";
      else
         declare
            Index : Integer := Data'First;
            Count : Natural := 0;
         begin
            while Index < Data'Last and then Data (Index) in '0'..'9' loop
               Count := Count * 10 + Character'Pos (Data (Index)) - Character'Pos ('0');
               Index := Index + 1;
            end loop;
            if Index > Data'First then
               return Count * Data (Index) & Decode (Data (Index + 1..Data'Last));
            else
               return Data;
            end if;
         end;
      end if;
   end Decode;
begin
   Put_Line (Encode ("WWWWWWWWWWWWBWWWWWWWWWWWWBBBWWWWWWWWWWWWWWWWWWWWWWWWBWWWWWWWWWWWWWW"));
   Put_Line (Decode ("12W1B12W3B24W1B14W"));
end Test_Run_Length_Encoding;

12W1B12W3B24W1B14W
WWWWWWWWWWWWBWWWWWWWWWWWWBBBWWWWWWWWWWWWWWWWWWWWWWWWBWWWWWWWWWWWWWW

implement a run-length encoding algorithm that compresses a string of uppercase characters by storing the length of repeated characters. It also provides a function to reverse the compression. The output can be used to recreate the original input string.


with Ada.Text_IO;  use Ada.Text_IO;

procedure String_Concatenation is
   S1 : constant String := "Hello";
   S2 : constant String := S1 & " literal";
begin
   Put_Line (S1);
   Put_Line (S2);
end String_Concatenation;

Sample output:
Hello
Hello literal

Initializes two string variables, one with a text value and the other as a concatenation of the first variable and a string literal, then displays their content.


Library: AWS
with AWS.URL;
with Ada.Text_IO; use Ada.Text_IO;
procedure Encode is
   Normal : constant String := "http://foo bar/";
begin
   Put_Line (AWS.URL.Encode (Normal));
end Encode;

provide a function to convert a given string into URL encoding. This function encodes all characters except 0-9, A-Z, and a-z into their corresponding hexadecimal code preceded by a percent symbol. ASCII control codes, symbols, and extended characters are all converted. The function also supports variations including lowercase escapes and different encoding standards such as RFC 3986 and HTML 5. An optional feature is the use of an exception string for symbols that don't need conversion. For example, "http://foo bar/" is encoded as "http%3A%2F%2Ffoo%20bar%2F".


with Ada.Text_Io;
with Ada.Containers.Vectors;

procedure Sorted is

   package Integer_Vectors is
     new Ada.Containers.Vectors (Index_Type   => Positive,
                                 Element_Type => Integer);
   use Integer_Vectors;

   package Vector_Sorting is
     new Integer_Vectors.Generic_Sorting;
   use Vector_Sorting;

   procedure Unique (Vec : in out Vector) is
      Res : Vector;
   begin
      for E of Vec loop
         if Res.Is_Empty or else Res.Last_Element /= E then
            Res.Append (E);
         end if;
      end loop;
      Vec := Res;
   end Unique;

   procedure Put (Vec : Vector) is
      use Ada.Text_Io;
   begin
      Put ("[");
      for E of Vec loop
         Put (E'Image);  Put (" ");
      end loop;
      Put ("]");
      New_Line;
   end Put;

   A : constant Vector := 5 & 1 & 3 & 8 & 9 & 4 & 8 & 7;
   B : constant Vector := 3 & 5 & 9 & 8 & 4;
   C : constant Vector := 1 & 3 & 7 & 9;
   R : Vector          := A & B & C;
begin
   Sort (R);
   Unique (R);
   Put (R);
end Sorted;

generates a common sorted list with unique elements from multiple integer arrays.


with Ada.Text_IO;
with Ada.Float_Text_IO;
with Ada.Strings.Unbounded;

procedure Knapsack_Continuous is
   package US renames Ada.Strings.Unbounded;

   type Item is record
      Name   : US.Unbounded_String;
      Weight : Float;
      Value  : Positive;
      Taken  : Float;
   end record;

   function "<" (Left, Right : Item) return Boolean is
   begin
      return Float (Left.Value) / Left.Weight <
             Float (Right.Value) / Right.Weight;
   end "<";

   type Item_Array is array (Positive range <>) of Item;

   function Total_Weight (Items : Item_Array) return Float is
      Sum : Float := 0.0;
   begin
      for I in Items'Range loop
         Sum := Sum + Items (I).Taken;
      end loop;
      return Sum;
   end Total_Weight;

   function Total_Value (Items : Item_Array) return Float is
      Sum : Float := 0.0;
   begin
      for I in Items'Range loop
         Sum := Sum + Float (Items (I).Value) / Items(I).Weight * Items (I).Taken;
      end loop;
      return Sum;
   end Total_Value;

   procedure Solve_Knapsack_Continuous
     (Items        : in out Item_Array;
      Weight_Limit : Float)
   is
   begin
      -- order items by value per weight unit
      Sorting : declare
         An_Item : Item;
         J       : Natural;
      begin
         for I in Items'First + 1 .. Items'Last loop
            An_Item := Items (I);
            J       := I - 1;
            while J in Items'Range and then Items (J) < An_Item loop
               Items (J + 1) := Items (J);
               J             := J - 1;
            end loop;
            Items (J + 1) := An_Item;
         end loop;
      end Sorting;
      declare
         Rest : Float := Weight_Limit;
      begin
         for I in Items'Range loop
            if Items (I).Weight <= Rest then
               Items (I).Taken := Items (I).Weight;
            else
               Items (I).Taken := Rest;
            end if;
            Rest := Rest - Items (I).Taken;
            exit when Rest <= 0.0;
         end loop;
      end;
   end Solve_Knapsack_Continuous;
    All_Items : Item_Array :=
     ((US.To_Unbounded_String ("beef"), 3.8, 36, 0.0),
      (US.To_Unbounded_String ("pork"), 5.4, 43, 0.0),
      (US.To_Unbounded_String ("ham"), 3.6, 90, 0.0),
      (US.To_Unbounded_String ("greaves"), 2.4, 45, 0.0),
      (US.To_Unbounded_String ("flitch"), 4.0, 30, 0.0),
      (US.To_Unbounded_String ("brawn"), 2.5, 56, 0.0),
      (US.To_Unbounded_String ("welt"), 3.7, 67, 0.0),
      (US.To_Unbounded_String ("salami"), 3.0, 95, 0.0),
      (US.To_Unbounded_String ("sausage"), 5.9, 98, 0.0));

begin
   Solve_Knapsack_Continuous (All_Items, 15.0);
   Ada.Text_IO.Put ("Total Weight: ");
   Ada.Float_Text_IO.Put (Total_Weight (All_Items), 0, 2, 0);
   Ada.Text_IO.New_Line;
   Ada.Text_IO.Put ("Total Value:  ");
   Ada.Float_Text_IO.Put (Total_Value (All_Items), 0, 2, 0);
   Ada.Text_IO.New_Line;
   Ada.Text_IO.Put_Line ("Items:");
   for I in All_Items'Range loop
      if All_Items (I).Taken > 0.0 then
         Ada.Text_IO.Put ("   ");
         Ada.Float_Text_IO.Put (All_Items (I).Taken, 0, 2, 0);
         Ada.Text_IO.Put_Line (" of " & US.To_String (All_Items (I).Name));
      end if;
   end loop;
end Knapsack_Continuous;

determine the optimal combination of items a thief can steal from a butcher's shop without exceeding a total weight of 15 kg in his knapsack, with the possibility of cutting items proportionally to their original price, in order to maximize the total value.


with Ada.Text_IO;  use Ada.Text_IO;

with Ada.Containers.Indefinite_Ordered_Maps;
with Ada.Containers.Indefinite_Ordered_Sets;

procedure Words_Of_Equal_Characters is
   package Set_Of_Words is new Ada.Containers.Indefinite_Ordered_Sets (String);
   use Ada.Containers, Set_Of_Words;
   package Anagrams is new Ada.Containers.Indefinite_Ordered_Maps (String, Set);
   use Anagrams;

   File   : File_Type;
   Result : Map;
   Max    : Count_Type := 1;

   procedure Put (Position : Anagrams.Cursor) is
      First : Boolean := True;
      List  : Set renames Element (Position);
      procedure Put (Position : Set_Of_Words.Cursor) is
      begin
         if First then
            First := False;
         else
            Put (',');
         end if;
         Put (Element (Position));
      end Put;
   begin
      if List.Length = Max then
         Iterate (List, Put'Access);
         New_Line;
      end if;
   end Put;

begin
   Open (File, In_File, "unixdict.txt");
   loop
      declare
         Word : constant String     := Get_Line (File);
         Key  : String (Word'Range) := (others => Character'Last);
         List : Set;
         Position : Anagrams.Cursor;
      begin
         for I in Word'Range loop
            for J in Word'Range loop
               if Key (J) > Word (I) then
                  Key (J + 1..I) := Key (J..I - 1);
                  Key (J) := Word (I);
                  exit;
               end if;
            end loop;
         end loop;
         Position := Find (Result, Key);
         if Has_Element (Position) then
            List := Element (Position);
            Insert (List, Word);
            Replace_Element (Result, Position, List);
         else
            Insert (List, Word);
            Include (Result, Key, List);
         end if;
         Max := Count_Type'Max (Max, Length (List));
      end;
   end loop;
exception
   when End_Error =>
      Iterate (Result, Put'Access);
      Close (File);
end Words_Of_Equal_Characters;

"Code identifies sets of anagrams with the most words from the provided word list."


with Ada.Text_Io; use Ada.Text_Io;

procedure Sierpinski_Carpet is
   subtype Index_Type is Integer range 1..81;
   type Pattern_Array is array(Index_Type range <>, Index_Type range <>) of Boolean;
   Pattern : Pattern_Array(1..81,1..81) := (Others =>(others => true));
   procedure Clear_Center(P : in out Pattern_Array; X1 : Index_Type; X2 : Index_Type;
         Y1 : Index_Type; Y2 : Index_Type) is
      Xfirst : Index_Type;
      Xlast  : Index_Type;
      Yfirst : Index_Type;
      Ylast  : Index_Type;
      Diff   : Integer;
   begin
      Xfirst :=(X2 - X1 + 1) / 3 + X1;
      Diff := Xfirst - X1;
      Xlast  := Xfirst + Diff;
      Yfirst := (Y2 - Y1) / 3 + Y1;
      YLast  := YFirst + Diff;

      for I in XFirst..XLast loop
         for J in YFirst..YLast loop
            P(I, J) := False;
         end loop;
      end loop;
   end Clear_Center;

   procedure Print(P : Pattern_Array) is
   begin
      for I in P'range(1) loop
         for J in P'range(2) loop
            if P(I,J) then
               Put('*');
            else
               Put(' ');
            end if;
         end loop;
         New_Line;
      end loop;
   end Print;

   procedure Divide_Square(P : in out Pattern_Array; Order : Positive) is
      Factor : Natural := 0;
      X1, X2 : Index_Type;
      Y1, Y2  : Index_Type;
      Division : Index_Type;
      Num_Sections : Index_Type;
   begin
      while Factor < Order loop
         Num_Sections := 3**Factor;
         Factor := Factor + 1;
         X1  := P'First;
         Division   := P'Last / Num_Sections;
         X2 := Division;
         Y1 := X1;
         Y2 := X2;
         loop
            loop
               Clear_Center(P, X1, X2, Y1, Y2);
               exit when X2 = P'Last;
               X1 := X2;
               X2 := X2 + Division;
            end loop;
            exit when Y2 = P'Last;
            Y1 := Y2;
            Y2 := Y2 + Division;
            X1 := P'First;
            X2 := Division;
         end loop;
      end loop;
   end Divide_Square;

begin
   Divide_Square(Pattern, 3);
   Print(Pattern);
end Sierpinski_Carpet;

generate a graphical or ASCII-art representation of a Sierpinski carpet of a given order N. The representation uses whitespace and non-whitespace characters, with the non-whitespace character not strictly required to be '#'. The placement of these characters follows the pattern of a Sierpinski carpet.


Works with: Ada 2005

with Ada.Containers.Indefinite_Ordered_Maps;
with Ada.Containers.Ordered_Maps;
with Ada.Finalization;
generic
   type Symbol_Type is private;
   with function "<" (Left, Right : Symbol_Type) return Boolean is <>;
   with procedure Put (Item : Symbol_Type);
   type Symbol_Sequence is array (Positive range <>) of Symbol_Type;
   type Frequency_Type is private;
   with function "+" (Left, Right : Frequency_Type) return Frequency_Type
     is <>;
   with function "<" (Left, Right : Frequency_Type) return Boolean is <>;
package Huffman is
   -- bits = booleans (true/false = 1/0)
   type Bit_Sequence is array (Positive range <>) of Boolean;
   Zero_Sequence : constant Bit_Sequence (1 .. 0) := (others => False);
   -- output the sequence
   procedure Put (Code : Bit_Sequence);

   -- type for freqency map
   package Frequency_Maps is new Ada.Containers.Ordered_Maps
     (Element_Type => Frequency_Type,
      Key_Type     => Symbol_Type);

   type Huffman_Tree is private;
   -- create a huffman tree from frequency map
   procedure Create_Tree
     (Tree        : out Huffman_Tree;
      Frequencies : Frequency_Maps.Map);
   -- encode a single symbol
   function Encode
     (Tree   : Huffman_Tree;
      Symbol : Symbol_Type)
      return   Bit_Sequence;
   -- encode a symbol sequence
   function Encode
     (Tree    : Huffman_Tree;
      Symbols : Symbol_Sequence)
      return    Bit_Sequence;
   -- decode a bit sequence
   function Decode
     (Tree : Huffman_Tree;
      Code : Bit_Sequence)
      return Symbol_Sequence;
   -- dump the encoding table
   procedure Dump_Encoding (Tree : Huffman_Tree);
private
   -- type for encoding map
   package Encoding_Maps is new Ada.Containers.Indefinite_Ordered_Maps
     (Element_Type => Bit_Sequence,
      Key_Type     => Symbol_Type);

   type Huffman_Node;
   type Node_Access is access Huffman_Node;
   -- a node is either internal (left_child/right_child used)
   -- or a leaf (left_child/right_child are null)
   type Huffman_Node is record
      Frequency   : Frequency_Type;
      Left_Child  : Node_Access := null;
      Right_Child : Node_Access := null;
      Symbol      : Symbol_Type;
   end record;
   -- create a leaf node
   function Create_Node
     (Symbol    : Symbol_Type;
      Frequency : Frequency_Type)
      return      Node_Access;
   -- create an internal node
   function Create_Node (Left, Right : Node_Access) return Node_Access;
   -- fill the encoding map
   procedure Fill
     (The_Node : Node_Access;
      Map      : in out Encoding_Maps.Map;
      Prefix   : Bit_Sequence);

   -- huffman tree has a tree and an encoding map
   type Huffman_Tree is new Ada.Finalization.Controlled with record
      Tree : Node_Access       := null;
      Map  : Encoding_Maps.Map := Encoding_Maps.Empty_Map;
   end record;
   -- free memory after finalization
   overriding procedure Finalize (Object : in out Huffman_Tree);
end Huffman;

with Ada.Text_IO;
with Ada.Unchecked_Deallocation;
with Ada.Containers.Vectors;
package body Huffman is
   package Node_Vectors is new Ada.Containers.Vectors
     (Element_Type => Node_Access,
      Index_Type   => Positive);

   function "<" (Left, Right : Node_Access) return Boolean is
   begin
      -- compare frequency
      if Left.Frequency < Right.Frequency then
         return True;
      elsif Right.Frequency < Left.Frequency then
         return False;
      end if;
      -- same frequency, choose leaf node
      if Left.Left_Child = null and then Right.Left_Child /= null then
         return True;
      elsif Left.Left_Child /= null and then Right.Left_Child = null then
         return False;
      end if;
      -- same frequency, same node type (internal/leaf)
      if Left.Left_Child /= null then
         -- for internal nodes, compare left children, then right children
         if Left.Left_Child < Right.Left_Child then
            return True;
         elsif Right.Left_Child < Left.Left_Child then
            return False;
         else
            return Left.Right_Child < Right.Right_Child;
         end if;
      else
         -- for leaf nodes, compare symbol
         return Left.Symbol < Right.Symbol;
      end if;
   end "<";
   package Node_Vector_Sort is new Node_Vectors.Generic_Sorting;

   procedure Create_Tree
     (Tree        : out Huffman_Tree;
      Frequencies : Frequency_Maps.Map) is
      Node_Queue : Node_Vectors.Vector := Node_Vectors.Empty_Vector;
   begin
      -- insert all leafs into the queue
      declare
         use Frequency_Maps;
         Position : Cursor      := Frequencies.First;
         The_Node : Node_Access := null;
      begin
         while Position /= No_Element loop
            The_Node :=
              Create_Node
                (Symbol    => Key (Position),
                 Frequency => Element (Position));
            Node_Queue.Append (The_Node);
            Next (Position);
         end loop;
      end;
      -- sort by frequency (see "<")
      Node_Vector_Sort.Sort (Node_Queue);
      -- iterate over all elements
      while not Node_Queue.Is_Empty loop
         declare
            First : constant Node_Access := Node_Queue.First_Element;
         begin
            Node_Queue.Delete_First;
            -- if we only have one node left, it is the root node of the tree
            if Node_Queue.Is_Empty then
               Tree.Tree := First;
            else
               -- create new internal node with two smallest frequencies
               declare
                  Second : constant Node_Access := Node_Queue.First_Element;
               begin
                  Node_Queue.Delete_First;
                  Node_Queue.Append (Create_Node (First, Second));
               end;
               Node_Vector_Sort.Sort (Node_Queue);
            end if;
         end;
      end loop;
      -- fill encoding map
      Fill (The_Node => Tree.Tree, Map => Tree.Map, Prefix => Zero_Sequence);
   end Create_Tree;

   -- create leaf node
   function Create_Node
     (Symbol    : Symbol_Type;
      Frequency : Frequency_Type)
      return      Node_Access
   is
      Result : Node_Access := new Huffman_Node;
   begin
      Result.Frequency := Frequency;
      Result.Symbol    := Symbol;
      return Result;
   end Create_Node;

   -- create internal node
   function Create_Node (Left, Right : Node_Access) return Node_Access is
      Result : Node_Access := new Huffman_Node;
   begin
      Result.Frequency   := Left.Frequency + Right.Frequency;
      Result.Left_Child  := Left;
      Result.Right_Child := Right;
      return Result;
   end Create_Node;

   -- fill encoding map
   procedure Fill
     (The_Node : Node_Access;
      Map      : in out Encoding_Maps.Map;
      Prefix   : Bit_Sequence) is
   begin
      if The_Node.Left_Child /= null then
         -- append false (0) for left child
         Fill (The_Node.Left_Child, Map, Prefix & False);
         -- append true (1) for right child
         Fill (The_Node.Right_Child, Map, Prefix & True);
      else
         -- leaf node reached, prefix = code for symbol
         Map.Insert (The_Node.Symbol, Prefix);
      end if;
   end Fill;

   -- free memory after finalization
   overriding procedure Finalize (Object : in out Huffman_Tree) is
      procedure Free is new Ada.Unchecked_Deallocation
        (Name   => Node_Access,
         Object => Huffman_Node);
      -- recursively free all nodes
      procedure Recursive_Free (The_Node : in out Node_Access) is
      begin
         -- free node if it is a leaf
         if The_Node.Left_Child = null then
            Free (The_Node);
         else
            -- free left and right child if node is internal
            Recursive_Free (The_Node.Left_Child);
            Recursive_Free (The_Node.Right_Child);
            -- free node afterwards
            Free (The_Node);
         end if;
      end Recursive_Free;
   begin
      -- recursively free root node
      Recursive_Free (Object.Tree);
   end Finalize;

   -- encode single symbol
   function Encode
     (Tree   : Huffman_Tree;
      Symbol : Symbol_Type)
      return   Bit_Sequence
   is
   begin
      -- simply lookup in map
      return Tree.Map.Element (Symbol);
   end Encode;

   -- encode symbol sequence
   function Encode
     (Tree    : Huffman_Tree;
      Symbols : Symbol_Sequence)
      return    Bit_Sequence
   is
   begin
      -- only one element
      if Symbols'Length = 1 then
         -- see above
         return Encode (Tree, Symbols (Symbols'First));
      else
         -- encode first element, append result of recursive call
         return Encode (Tree, Symbols (Symbols'First)) &
         Encode (Tree, Symbols (Symbols'First + 1 .. Symbols'Last));
      end if;
   end Encode;

   -- decode a bit sequence
   function Decode
     (Tree : Huffman_Tree;
      Code : Bit_Sequence)
      return Symbol_Sequence
   is
      -- maximum length = code length
      Result   : Symbol_Sequence (1 .. Code'Length);
      -- last used index of result
      Last     : Natural     := 0;
      The_Node : Node_Access := Tree.Tree;
   begin
      -- iterate over the code
      for I in Code'Range loop
         -- if current element is true, descent the right branch
         if Code (I) then
            The_Node := The_Node.Right_Child;
         else
            -- false: descend left branch
            The_Node := The_Node.Left_Child;
         end if;
         if The_Node.Left_Child = null then
            -- reached leaf node: append symbol to result
            Last          := Last + 1;
            Result (Last) := The_Node.Symbol;
            -- reset current node to root
            The_Node := Tree.Tree;
         end if;
      end loop;
      -- return subset of result array
      return Result (1 .. Last);
   end Decode;

   -- output a bit sequence
   procedure Put (Code : Bit_Sequence) is
      package Int_IO is new Ada.Text_IO.Integer_IO (Integer);
   begin
      for I in Code'Range loop
         if Code (I) then
            -- true = 1
            Int_IO.Put (1, 0);
         else
            -- false = 0
            Int_IO.Put (0, 0);
         end if;
      end loop;
      Ada.Text_IO.New_Line;
   end Put;

   -- dump encoding map
   procedure Dump_Encoding (Tree : Huffman_Tree) is
      use type Encoding_Maps.Cursor;
      Position : Encoding_Maps.Cursor := Tree.Map.First;
   begin
      -- iterate map
      while Position /= Encoding_Maps.No_Element loop
         -- key
         Put (Encoding_Maps.Key (Position));
         Ada.Text_IO.Put (" = ");
         -- code
         Put (Encoding_Maps.Element (Position));
         Encoding_Maps.Next (Position);
      end loop;
   end Dump_Encoding;
end Huffman;

with Ada.Text_IO;
with Huffman;
procedure Main is
   package Char_Natural_Huffman_Tree is new Huffman
     (Symbol_Type => Character,
      Put => Ada.Text_IO.Put,
      Symbol_Sequence => String,
      Frequency_Type => Natural);
   Tree         : Char_Natural_Huffman_Tree.Huffman_Tree;
   Frequencies  : Char_Natural_Huffman_Tree.Frequency_Maps.Map;
   Input_String : constant String :=
     "this is an example for huffman encoding";
begin
   -- build frequency map
   for I in Input_String'Range loop
      declare
         use Char_Natural_Huffman_Tree.Frequency_Maps;
         Position : constant Cursor := Frequencies.Find (Input_String (I));
      begin
         if Position = No_Element then
            Frequencies.Insert (Key => Input_String (I), New_Item => 1);
         else
            Frequencies.Replace_Element
              (Position => Position,
               New_Item => Element (Position) + 1);
         end if;
      end;
   end loop;

   -- create huffman tree
   Char_Natural_Huffman_Tree.Create_Tree
     (Tree        => Tree,
      Frequencies => Frequencies);

   -- dump encodings
   Char_Natural_Huffman_Tree.Dump_Encoding (Tree => Tree);

   -- encode example string
   declare
      Code : constant Char_Natural_Huffman_Tree.Bit_Sequence :=
        Char_Natural_Huffman_Tree.Encode
          (Tree    => Tree,
           Symbols => Input_String);
   begin
      Char_Natural_Huffman_Tree.Put (Code);
      Ada.Text_IO.Put_Line
        (Char_Natural_Huffman_Tree.Decode (Tree => Tree, Code => Code));
   end;
end Main;

The code implements Huffman encoding algorithm. It takes a string input, calculates the frequency of each character, and creates a priority queue with each character as a leaf node. It then constructs a binary tree by removing nodes with the highest priority (lowest probability) and creating new internal nodes with the sum of the probabilities of the two nodes. The code traverses the binary tree from root to leaves, assigning '0' for one branch and '1' for the other, accumulating these at each leaf to generate a Huffman encoding for each character. The output is a table of characters from the input string and their corresponding Huffman encodings.


Library: GTK version GtkAda
Library: GtkAda

with Gdk.Event;   use Gdk.Event;
with Gtk.Button;  use Gtk.Button;
with Gtk.Label;   use Gtk.Label;
with Gtk.Window;  use Gtk.Window;
with Gtk.Widget;  use Gtk.Widget;
with Gtk.Table;   use Gtk.Table;

with Gtk.Handlers;
with Gtk.Main;

procedure Simple_Windowed_Application is
   Window : Gtk_Window;
   Grid   : Gtk_Table;
   Button : Gtk_Button;
   Label  : Gtk_Label;
   Count  : Natural := 0;

   package Handlers is new Gtk.Handlers.Callback (Gtk_Widget_Record);
   package Return_Handlers is
      new Gtk.Handlers.Return_Callback (Gtk_Widget_Record, Boolean);

   function Delete_Event (Widget : access Gtk_Widget_Record'Class)
      return Boolean is
   begin
      return False;
   end Delete_Event;

   procedure Destroy (Widget : access Gtk_Widget_Record'Class) is
   begin
     Gtk.Main.Main_Quit;
   end Destroy;

   procedure Clicked (Widget : access Gtk_Widget_Record'Class) is
   begin
     Count := Count + 1;
     Set_Text (Label, "The button clicks:" & Natural'Image (Count));
   end Clicked;

begin
   Gtk.Main.Init;
   Gtk.Window.Gtk_New (Window);
   Gtk_New (Grid, 1, 2, False);
   Add (Window, Grid);
   Gtk_New (Label, "There have been no clicks yet");
   Attach (Grid, Label, 0, 1, 0, 1);
   Gtk_New (Button, "Click me");
   Attach (Grid, Button, 0, 1, 1, 2);
   Return_Handlers.Connect
   (  Window,
      "delete_event",
      Return_Handlers.To_Marshaller (Delete_Event'Access)
   );
   Handlers.Connect
   (  Window,
      "destroy",
      Handlers.To_Marshaller (Destroy'Access)
   );
   Handlers.Connect
   (  Button,
      "clicked",
      Handlers.To_Marshaller (Clicked'Access)
   );
   Show_All (Grid);
   Show (Window);

   Gtk.Main.Main;
end Simple_Windowed_Application;

create a GTK+ windowed application in Ada language. The application features a label initially displaying "There have been no clicks yet" and a button labeled "click me". Upon clicking the button, the label updates to show the total number of button clicks.


for I in reverse 0..10 loop
   Put_Line(Integer'Image(I));
end loop;

The code performs a countdown from 10 to 0 using a downward for loop.


WITH Ada.Text_IO, Ada.Characters.Handling;
USE Ada.Text_IO, Ada.Characters.Handling;

PROCEDURE Main IS
   SUBTYPE Alpha IS Character RANGE 'A' .. 'Z';
   TYPE Ring IS MOD (Alpha'Range_length);
   TYPE Seq IS ARRAY (Integer RANGE <>) OF Ring;

   FUNCTION "+" (S, Key : Seq) RETURN Seq IS
      R : Seq (S'Range);
   BEGIN
      FOR I IN R'Range LOOP
         R (I) := S (I) + Key (Key'First + (I - R'First) MOD Key'Length);
      END LOOP;
      RETURN R;
   END "+";

   FUNCTION "-" (S : Seq) RETURN Seq IS
      R : Seq (S'Range);
   BEGIN
      FOR I IN R'Range LOOP
         R (I) := - S (I);
      END LOOP;
      RETURN R;
   END "-";

   FUNCTION To_Seq (S : String) RETURN Seq IS
      R  : Seq (S'Range);
      I  : Integer := R'First;
   BEGIN
      FOR C OF To_Upper (S) LOOP
         IF C IN Alpha THEN
            R (I) := Ring'Mod (Alpha'Pos (C) - Alpha'Pos (Alpha'First));
            I := I + 1;
         END IF;
      END LOOP;
      RETURN R (R'First .. I - 1);
   END To_Seq;

   FUNCTION To_String (S : Seq ) RETURN String IS
      R : String (S'Range);
   BEGIN
      FOR I IN R'Range LOOP
         R (I) := Alpha'Val ( Integer (S (I)) + Alpha'Pos (Alpha'First));
      END LOOP;
      RETURN R;
   END To_String;

   Input : Seq := To_Seq (Get_Line);
   Key : Seq := To_Seq (Get_Line);
   Crypt : Seq := Input + Key;
BEGIN
   Put_Line ("Encrypted: " & To_String (Crypt));
   Put_Line ("Decrypted: " & To_String (Crypt + (-Key)));
END Main;

Implement both encryption and decryption of a Vigenère cipher. The codes handle keys and text of unequal length, capitalize all characters, and discard non-alphabetic characters. If non-alphabetic characters are handled differently, it is noted.


with Loopers;
use Loopers;

procedure For_Main is
begin
        Looper_1;
        Looper_2;
        Looper_3;
end For_Main;

package Loopers is
        procedure Looper_1;
        procedure Looper_2;
        procedure Looper_3;
end Loopers;

with Ada.Text_IO, Ada.Integer_Text_IO;
use Ada.Text_IO, Ada.Integer_Text_IO;

package body Loopers is
        procedure Looper_1 is
                Values : array(1..5) of Integer := (2,4,6,8,10);
        begin
                for I in Values'Range loop
                        Put(Values(I),0);
                        if I = Values'Last then
                                Put_Line(".");
                        else
                                Put(",");
                        end if;
                end loop;
        end Looper_1;

        procedure Looper_2 is
                E : Integer := 5;
        begin
                for I in 1..E loop
                        Put(I*2,0);
                        if I = E then
                                Put_Line(".");
                        else
                                Put(",");
                        end if;
                end loop;
        end Looper_2;

        procedure Looper_3 is
                Values : array(1..10) of Integer := (1,2,3,4,5,6,7,8,9,10);
                Indices : array(1..5) of Integer := (2,4,6,8,10);
        begin
                for I in Indices'Range loop
                        Put(Values(Indices(I)),0);
                        if I = Indices'Last then
                                Put_Line(".");
                        else
                                Put(",");
                        end if;
                end loop;
        end Looper_3;

end Loopers;

demonstrate three versions of a for-loop in Ada where the step-value is greater than one. The first version goes through a range of even values, the second version multiplies each value by two, and the third version uses a second range for the indices.


with Ada.Text_IO;  use Ada.Text_IO;

procedure Jensen_Device is
   function Sum
            (  I : not null access Float;
               Lo, Hi : Float;
               F : access function return Float
            )  return Float is
      Temp : Float := 0.0;
   begin
      I.all := Lo;
      while I.all <= Hi loop
         Temp := Temp + F.all;
         I.all := I.all + 1.0;
      end loop;
      return Temp;
   end Sum;

   I : aliased Float;
   function Inv_I return Float is
   begin
      return 1.0 / I;
   end Inv_I;
begin
   Put_Line (Float'Image (Sum (I'Access, 1.0, 100.0, Inv_I'Access)));
end Jensen_Device;

 5.18738E+00

implement Jensen's Device, a programming technique devised by Jørn Jensen. The technique is an exercise in call by name, where it computes the 100th harmonic number. The program uses a sum procedure that takes in four parameters, with the first and the last parameter being passed by name. This allows the expression passed as an actual parameter to be re-evaluated in the caller's context every time the corresponding formal parameter's value is required. The program also demonstrates the importance of passing the first parameter by name or by reference, as changes to it within the sum procedure need to be visible in the caller's context when computing each of the values to be added.


Library: GtkAda

with Cairo; use Cairo;
with Cairo.Png; use Cairo.Png;
with Cairo.Image_Surface; use Cairo.Image_Surface;
procedure XorPattern is
   type xorable is mod 256;
   Surface : Cairo_Surface;
   Data : RGB24_Array_Access;
   Status : Cairo_Status;
   Num : Byte;
begin
   Data := new RGB24_Array(0..256*256-1);
   for x in Natural range 0..255 loop
      for y in Natural range 0..255 loop
         Num := Byte(xorable(x) xor xorable(y));
         Data(x+256*y) := RGB24_Data'(Num,0,Num);
      end loop;
   end loop;
   Surface := Create_For_Data_RGB24(Data, 256, 256);
   Status := Write_To_Png (Surface, "AdaXorPattern.png");
   pragma Assert (Status = Cairo_Status_Success);
end XorPattern;

Creates a graphical pattern with pixel color determined by the 'x xor y' value from a color table, using the Cairo component of GtkAda, and saves the pattern as a PNG file.


Works with: Ada 2005
Works with: GNAT

generic
   Height : Positive;
   Width : Positive;
package Mazes is

   type Maze_Grid is private;

   procedure Initialize (Maze : in out Maze_Grid);

   procedure Put (Item : Maze_Grid);

private

   type Directions is (North, South, West, East);

   type Cell_Walls is array (Directions) of Boolean;
   type Cells is record
      Walls   : Cell_Walls := (others => True);
      Visited : Boolean    := False;
   end record;

   subtype Height_Type is Positive range 1 .. Height;
   subtype Width_Type is Positive range 1 .. Width;

   type Maze_Grid is array (Height_Type, Width_Type) of Cells;

end Mazes;

with Ada.Numerics.Discrete_Random;
with Ada.Text_IO;

package body Mazes is
   package RNG is new Ada.Numerics.Discrete_Random (Positive);
   package Random_Direction is new Ada.Numerics.Discrete_Random (Directions);

   Generator     : RNG.Generator;
   Dir_Generator : Random_Direction.Generator;

   function "-" (Dir : Directions) return Directions is
   begin
      case Dir is
         when North =>
            return South;
         when South =>
            return North;
         when East =>
            return West;
         when West =>
            return East;
      end case;
   end "-";

   procedure Move
     (Row        : in out Height_Type;
      Column     : in out Width_Type;
      Direction  : Directions;
      Valid_Move : out Boolean)
   is
   begin
      Valid_Move := False;
      case Direction is
         when North =>
            if Row > Height_Type'First then
               Valid_Move := True;
               Row        := Row - 1;
            end if;
         when East =>
            if Column < Width_Type'Last then
               Valid_Move := True;
               Column     := Column + 1;
            end if;
         when West =>
            if Column > Width_Type'First then
               Valid_Move := True;
               Column     := Column - 1;
            end if;
         when South =>
            if Row < Height_Type'Last then
               Valid_Move := True;
               Row        := Row + 1;
            end if;
      end case;
   end Move;

   procedure Depth_First_Algorithm
     (Maze   : in out Maze_Grid;
      Row    : Height_Type;
      Column : Width_Type)
   is
      Next_Row        : Height_Type;
      Next_Column     : Width_Type;
      Next_Direction  : Directions;
      Valid_Direction : Boolean;
      Tested_Wall     : array (Directions) of Boolean := (others => False);
      All_Tested      : Boolean;
   begin
      -- mark as visited
      Maze (Row, Column).Visited := True;
      loop
         -- use random direction
         loop
            Next_Direction := Random_Direction.Random (Dir_Generator);
            exit when not Tested_Wall (Next_Direction);
         end loop;
         Next_Row       := Row;
         Next_Column    := Column;
         Move (Next_Row, Next_Column, Next_Direction, Valid_Direction);
         if Valid_Direction then
            if not Maze (Next_Row, Next_Column).Visited then
               -- connect the two cells
               Maze (Row, Column).Walls (Next_Direction)              :=
                 False;
               Maze (Next_Row, Next_Column).Walls (-Next_Direction)   :=
                 False;
               Depth_First_Algorithm (Maze, Next_Row, Next_Column);
            end if;
         end if;
         Tested_Wall (Next_Direction) := True;
         -- continue as long as there are unvisited neighbours left
         All_Tested := True;
         for D in Directions loop
            All_Tested := All_Tested and Tested_Wall (D);
         end loop;
         -- all directions are either visited (from here,
         -- or previously visited), or invalid.
         exit when All_Tested;
      end loop;
   end Depth_First_Algorithm;

   procedure Initialize (Maze : in out Maze_Grid) is
      Row, Column : Positive;
   begin
      -- initialize random generators
      RNG.Reset (Generator);
      Random_Direction.Reset (Dir_Generator);
      -- choose starting cell
      Row    := RNG.Random (Generator) mod Height + 1;
      Column := RNG.Random (Generator) mod Width + 1;
      Ada.Text_IO.Put_Line
        ("Starting generation at " &
         Positive'Image (Row) &
         " x" &
         Positive'Image (Column));
      Depth_First_Algorithm (Maze, Row, Column);
   end Initialize;

   procedure Put (Item : Maze_Grid) is
   begin
      for Row in Item'Range (1) loop
         if Row = Item'First (1) then
            Ada.Text_IO.Put ('+');
            for Col in Item'Range (2) loop
               if Item (Row, Col).Walls (North) then
                  Ada.Text_IO.Put ("---+");
               else
                  Ada.Text_IO.Put ("   +");
               end if;
            end loop;
            Ada.Text_IO.New_Line;
         end if;
         for Col in Item'Range (2) loop
            if Col = Item'First (2) then
               if Item (Row, Col).Walls (West) then
                  Ada.Text_IO.Put ('|');
               else
                  Ada.Text_IO.Put (' ');
               end if;
            elsif Item (Row, Col).Walls (West)
              and then Item (Row, Col - 1).Walls (East)
            then
               Ada.Text_IO.Put ('|');
            elsif Item (Row, Col).Walls (West)
              or else Item (Row, Col - 1).Walls (East)
            then
               Ada.Text_IO.Put ('>');
            else
               Ada.Text_IO.Put (' ');
            end if;
            if Item (Row, Col).Visited then
               Ada.Text_IO.Put ("   ");
            else
               Ada.Text_IO.Put ("???");
            end if;
         end loop;
         if Item (Row, Item'Last (2)).Walls (East) then
            Ada.Text_IO.Put_Line ("|");
         else
            Ada.Text_IO.Put_Line (" ");
         end if;
         Ada.Text_IO.Put ('+');
         for Col in Item'Range (2) loop
            if Item (Row, Col).Walls (South) then
               Ada.Text_IO.Put ("---+");
            else
               Ada.Text_IO.Put ("   +");
            end if;
         end loop;
         Ada.Text_IO.New_Line;
      end loop;
   end Put;
end Mazes;

with Mazes;
procedure Main is
   package Small_Mazes is new Mazes (Height => 8, Width => 11);
   My_Maze : Small_Mazes.Maze_Grid;
begin
   Small_Mazes.Initialize (My_Maze);
   Small_Mazes.Put (My_Maze);
end Main;

generate and display a maze using the Depth-first search algorithm. It starts at a random cell, marks it as visited, and retrieves a list of its neighboring cells. For each neighbor, it removes the wall between the current cell and the unvisited neighbor, then recursively applies the same process with the neighbor as the current cell.


Works with: Ada 2005
Library: GMP

pi_digits.adb

with Ada.Command_Line;
with Ada.Text_IO;
with GNU_Multiple_Precision.Big_Integers;
with GNU_Multiple_Precision.Big_Rationals;
use GNU_Multiple_Precision;

procedure Pi_Digits is
   type Int is mod 2 ** 64;
   package Int_To_Big is new Big_Integers.Modular_Conversions (Int);

   -- constants
   Zero : constant Big_Integer := Int_To_Big.To_Big_Integer (0);
   One : constant Big_Integer := Int_To_Big.To_Big_Integer (1);
   Two : constant Big_Integer := Int_To_Big.To_Big_Integer (2);
   Three : constant Big_Integer := Int_To_Big.To_Big_Integer (3);
   Four : constant Big_Integer := Int_To_Big.To_Big_Integer (4);
   Ten : constant Big_Integer := Int_To_Big.To_Big_Integer (10);

   -- type LFT = (Integer, Integer, Integer, Integer
   type LFT is record
      Q, R, S, T : Big_Integer;
   end record;

   -- extr :: LFT -> Integer -> Rational
   function Extr (T : LFT; X : Big_Integer) return Big_Rational is
      use Big_Integers;
      Result : Big_Rational;
   begin
      -- extr (q,r,s,t) x = ((fromInteger q) * x + (fromInteger r)) /
      --                    ((fromInteger s) * x + (fromInteger t))
      Big_Rationals.Set_Numerator (Item         => Result,
                                   New_Value    => T.Q * X + T.R,
                                   Canonicalize => False);
      Big_Rationals.Set_Denominator (Item      => Result,
                                     New_Value => T.S * X + T.T);
      return Result;
   end Extr;

   -- unit :: LFT
   function Unit return LFT is
   begin
      -- unit = (1,0,0,1)
      return LFT'(Q => One, R => Zero, S => Zero, T => One);
   end Unit;

   -- comp :: LFT -> LFT -> LFT
   function Comp (T1, T2 : LFT) return LFT is
      use Big_Integers;
   begin
      -- comp (q,r,s,t) (u,v,w,x) = (q*u+r*w,q*v+r*x,s*u+t*w,s*v+t*x)
      return LFT'(Q => T1.Q * T2.Q + T1.R * T2.S,
                  R => T1.Q * T2.R + T1.R * T2.T,
                  S => T1.S * T2.Q + T1.T * T2.S,
                  T => T1.S * T2.R + T1.T * T2.T);
   end Comp;

   -- lfts = [(k, 4*k+2, 0, 2*k+1) | k<-[1..]
   K : Big_Integer := Zero;
   function LFTS return LFT is
      use Big_Integers;
   begin
      K := K + One;
      return LFT'(Q => K,
                  R => Four * K + Two,
                  S => Zero,
                  T => Two * K + One);
   end LFTS;

   -- next z = floor (extr z 3)
   function Next (T : LFT) return Big_Integer is
   begin
      return Big_Rationals.To_Big_Integer (Extr (T, Three));
   end Next;

   -- safe z n = (n == floor (extr z 4)
   function Safe (T : LFT; N : Big_Integer) return Boolean is
   begin
      return N = Big_Rationals.To_Big_Integer (Extr (T, Four));
   end Safe;

   -- prod z n = comp (10, -10*n, 0, 1)
   function Prod (T : LFT; N : Big_Integer) return LFT is
      use Big_Integers;
   begin
      return Comp (LFT'(Q => Ten, R => -Ten * N, S => Zero, T => One), T);
   end Prod;

   procedure Print_Pi (Digit_Count : Positive) is
      Z : LFT := Unit;
      Y : Big_Integer;
      Count : Natural := 0;
   begin
      loop
         Y := Next (Z);
         if Safe (Z, Y) then
            Count := Count + 1;
            Ada.Text_IO.Put (Big_Integers.Image (Y));
            exit when Count >= Digit_Count;
            Z := Prod (Z, Y);
         else
            Z := Comp (Z, LFTS);
         end if;
      end loop;
   end Print_Pi;

   N : Positive := 250;
begin
   if Ada.Command_Line.Argument_Count = 1 then
      N := Positive'Value (Ada.Command_Line.Argument (1));
   end if;
   Print_Pi (N);
end Pi_Digits;

 3 1 4 1 5 9 2 6 5 3 5 8 9 7 9 3 2 3 8 4 6 2 6 4 3 3 8 3 2 7 9 5 0 2 8 8 4 1 9 7 1 6 9 3 9 9 3 7 5 1 0 5 8 2 0 9 7 4 9 4 4 5 9 2 3 0 7 8 1 6 4 0 6 2 8 6 2 0 8 9 9 8 6 2 8 0 3 4 8 2 5 3 4 2 1 1 7 0 6 7

The code continually calculates and outputs the next decimal digit of Pi, starting from 3.14159265. The process continues indefinitely until the user aborts it. The calculation of Pi is based on the algorithm used in the Go solution from a specified source.


with Ada.Text_IO;  use Ada.Text_IO;
procedure Order is

   type IntArray is array (Positive range <>) of Integer;
   List1 : IntArray := (1, 2, 3, 4, 5);
   List2 : IntArray := (1, 2, 1, 5, 2, 2);
   List3 : IntArray := (1, 2, 1, 5, 2);
   List4 : IntArray := (1, 2, 1, 5, 2);

   type Animal is (Rat, Cat, Elephant);
   type AnimalArray is array (Positive range <>) of Animal;
   List5 : AnimalArray := (Cat, Elephant, Rat, Cat);
   List6 : AnimalArray := (Cat, Elephant, Rat);
   List7 : AnimalArray := (Cat, Cat, Elephant);

begin
   Put_Line (Boolean'Image (List1 > List2)); --  True
   Put_Line (Boolean'Image (List2 > List3)); --  True
   Put_Line (Boolean'Image (List3 > List4)); --  False, equal
   Put_Line (Boolean'Image (List5 > List6)); --  True
   Put_Line (Boolean'Image (List6 > List7)); --  True
end Order;

The function takes two numerical lists as input, compares them lexicographically, and returns true if the first list should be ordered before the second, otherwise returns false. If any list runs out of elements, it returns true for the first list and false for the second list or both. It handles arrays of user-defined types as well.


with Ada.Text_IO;  use Ada.Text_IO;

procedure Test_Ackermann is
   function Ackermann (M, N : Natural) return Natural is
   begin
      if M = 0 then
         return N + 1;
      elsif N = 0 then
         return Ackermann (M - 1, 1);
      else
         return Ackermann (M - 1, Ackermann (M, N - 1));
      end if;
   end Ackermann;
begin
   for M in 0..3 loop
      for N in 0..6 loop
         Put (Natural'Image (Ackermann (M, N)));
      end loop;
      New_Line;
   end loop;
end Test_Ackermann;

Implement the Ackermann function, a non-primitive recursive function that grows rapidly in value and call tree size. The function takes two non-negative arguments and always terminates. It is defined as follows: if m=0, return n+1; if m>0 and n=0, return A(m-1, 1); if m>0 and n>0, return A(m-1, A(m, n-1)). The function doesn't require arbitrary precision.


Implement and compare the Gamma function using various algorithms such as numerical integration, Lanczos approximation, and Stirling's approximation. The implementation also utilizes Taylor series coefficients taken from a mathematical functions reference. The functionality of the Gamma function is tested and compared with built-in or library functions if available.


with Ada.Text_IO;  use Ada.Text_IO;

procedure Queens is
   Board : array (1..8, 1..8) of Boolean := (others => (others => False));
   function Test (Row, Column : Integer) return Boolean is
   begin
      for J in 1..Column - 1 loop
         if (  Board (Row, J)
            or else
               (Row > J and then Board (Row - J, Column - J))
            or else
               (Row + J <= 8 and then Board (Row + J, Column - J))
            )  then
            return False;
         end if;
      end loop;
      return True;
   end Test;
   function Fill (Column : Integer) return Boolean is
   begin
      for Row in Board'Range (1) loop
         if Test (Row, Column) then
            Board (Row, Column) := True;
            if Column = 8 or else Fill (Column + 1) then
               return True;
            end if;
            Board (Row, Column) := False;
         end if;
      end loop;
      return False;
   end Fill;
begin
   if not Fill (1) then
      raise Program_Error;
   end if;
   for I in Board'Range (1) loop
      Put (Integer'Image (9 - I));
      for J in Board'Range (2) loop
         if Board (I, J) then
            Put ("|Q");
         elsif (I + J) mod 2 = 1 then
            Put ("|/");
         else
            Put ("| ");
         end if;
      end loop;
      Put_Line ("|");
   end loop;
   Put_Line ("   A B C D E F G H");
end Queens;

solve the N-queens problem, extending the eight queens puzzle to a board of size NxN. The codes count the number of solutions for small values of N (refer OEIS: A000170) and provide the flexibility to perform different operations for each solution.


type T is array (Positive range <>) of Integer;
X : T := (1, 2, 3);
Y : T := X & (4, 5, 6); -- Concatenate X and (4, 5, 6)

demonstrate how to concatenate two arrays in Ada using the & operation.