generic
   type Element_Type is private;
package Generic_Stack is
   type Stack is private;
   procedure Push (Item : Element_Type; Onto : in out Stack);
   procedure Pop (Item : out Element_Type; From : in out Stack);
   function Create return Stack;
   Stack_Empty_Error : exception;
private
   type Node;
   type Stack is access Node;
   type Node is record
      Element : Element_Type;
      Next    : Stack        := null;
   end record;
end Generic_Stack;

with Ada.Unchecked_Deallocation;

package body Generic_Stack is

   ------------
   -- Create --
   ------------

   function Create return Stack is
   begin
      return (null);
   end Create;

   ----------
   -- Push --
   ----------

   procedure Push(Item : Element_Type; Onto : in out Stack) is
      Temp : Stack := new Node;
   begin
      Temp.Element := Item;
      Temp.Next := Onto;
      Onto := Temp;
   end Push;

   ---------
   -- Pop --
   ---------

   procedure Pop(Item : out Element_Type; From : in out Stack) is
      procedure Free is new Ada.Unchecked_Deallocation(Node, Stack);
      Temp : Stack := From;
   begin
      if Temp = null then
         raise Stack_Empty_Error;
      end if;
      Item := Temp.Element;
      From := Temp.Next;
      Free(Temp);
   end Pop;

end Generic_Stack;

implement a generic stack with basic operations including push (adding a new element to the top of the stack), pop (removing and returning the last pushed element from the stack), and empty (checking if the stack contains no elements). The stack follows a last in, first out (LIFO) access policy.


with Ada.Text_IO, Ada.Command_Line;

procedure Fib is

   X: Positive := Positive'Value(Ada.Command_Line.Argument(1));

   function Fib(P: Positive) return Positive is
   begin
      if P <= 2 then
         return 1;
      else
         return Fib(P-1) + Fib(P-2);
      end if;
   end Fib;

begin
   Ada.Text_IO.Put("Fibonacci(" & Integer'Image(X) & " ) = ");
   Ada.Text_IO.Put_Line(Integer'Image(Fib(X)));
end Fib;

with Ada.Text_IO;  use Ada.Text_IO;

procedure Test_Fibonacci is
   function Fibonacci (N : Natural) return Natural is
      This : Natural := 0;
      That : Natural := 1;
      Sum  : Natural;
   begin
      for I in 1..N loop
         Sum  := This + That;
         That := This;
         This := Sum;
      end loop;
      return This;
   end Fibonacci;
begin
   for N in 0..10 loop
      Put_Line (Positive'Image (Fibonacci (N)));
   end loop;
end Test_Fibonacci;

The code implements a function to generate the nth Fibonacci number, using either an iterative or recursive approach. It optionally supports negative n values by inversely applying the Fibonacci sequence formula. The function utilizes a big integer implementation from a cryptographic library.


with Ada.Integer_Text_Io; use Ada.Integer_Text_Io;
with Ada.Text_Io; use Ada.Text_Io;

procedure Array_Selection is
   type Array_Type is array (Positive range <>) of Integer;
   Null_Array : Array_Type(1..0);

   function Evens (Item : Array_Type) return Array_Type is
   begin
      if Item'Length > 0 then
         if Item(Item'First) mod 2 = 0 then
            return Item(Item'First) & Evens(Item((Item'First + 1)..Item'Last));
         else
            return Evens(Item((Item'First + 1)..Item'Last));
         end if;
      else
         return Null_Array;
      end if;
   end Evens;

   procedure Print(Item : Array_Type) is
   begin
      for I in Item'range loop
         Put(Item(I));
         New_Line;
      end loop;
   end Print;

   Foo : Array_Type := (1,2,3,4,5,6,7,8,9,10);
begin
   Print(Evens(Foo));
end Array_Selection;

with Ada.Text_IO;  use Ada.Text_IO;

procedure Array_Selection is
   type Array_Type is array (Positive range <>) of Integer;

   function Evens (Item : Array_Type) return Array_Type is
      Result : Array_Type (1..Item'Length);
      Index  : Positive := 1;
   begin
      for I in Item'Range loop
         if Item (I) mod 2 = 0 then
            Result (Index) := Item (I);
            Index := Index + 1;
         end if;
      end loop;
      return Result (1..Index - 1);
   end Evens;

   procedure Put (Item : Array_Type) is
   begin
      for I in Item'range loop
         Put (Integer'Image (Item (I)));
      end loop;
   end Put;
begin
   Put (Evens ((1,2,3,4,5,6,7,8,9,10)));
   New_Line;
end Array_Selection;

select certain elements from an array into a new array, specifically all even numbers. It also provides an optional destructive filtering solution that modifies the original array instead of creating a new one.


type String is array (Positive range <>) of Character;

A (<first-index>..<last-index>)

with Ada.Text_IO;        use Ada.Text_IO;
with Ada.Strings.Fixed;  use Ada.Strings.Fixed;

procedure Test_Slices is
   Str : constant String := "abcdefgh";
   N : constant := 2;
   M : constant := 3;
begin
   Put_Line (Str (Str'First + N - 1..Str'First + N + M - 2));
   Put_Line (Str (Str'First + N - 1..Str'Last));
   Put_Line (Str (Str'First..Str'Last - 1));
   Put_Line (Head (Tail (Str, Str'Last - Index (Str, "d", 1)), M));
   Put_Line (Head (Tail (Str, Str'Last - Index (Str, "de", 1) - 1), M));
end Test_Slices;

- Display a substring starting from a specific character position and of a certain length.
- Display a substring starting from a specific character position up to the end of the string.
- Display the entire string minus the last character.
- Display a substring starting from a known character within the string and of a certain length.
- Display a substring starting from a known substring within the string and of a certain length.
- The codes are compatible with any valid Unicode code point in UTF-8 or UTF-16.
- The codes reference logical characters, not 8-bit code units for UTF-8 or 16-bit code units for UTF-16.
- The codes are not required to handle all Unicode characters for other encodings.
- In Ada language, the codes use the term slice for substring and can handle slices in mutable or immutable mode.
- The codes use the first character of the string as the starting point for slicing.


with Ada.Text_IO; use Ada.Text_IO;

procedure Reverse_String is
   function Reverse_It (Item : String) return String is
      Result : String (Item'Range);
   begin
      for I in Item'range loop
         Result (Result'Last - I + Item'First) := Item (I);
      end loop;
      return Result;
   end Reverse_It;
begin
   Put_Line (Reverse_It (Get_Line));
end Reverse_String;

Reverses a given string while preserving Unicode combining characters. For instance, it transforms "asdf" to "fdsa" and "as⃝df̅" to "f̅ds⃝a".


Works with: GNAT

private with Ada.Containers.Ordered_Maps;
generic
   type t_Vertex is (<>);
package Dijkstra is

   type t_Graph is limited private;

   -- Defining a graph (since limited private, only way to do this is to use the Build function)
   type t_Edge is record
      From, To : t_Vertex;
      Weight   : Positive;
   end record;
   type t_Edges is array (Integer range <>) of t_Edge;
   function Build (Edges : in t_Edges; Oriented : in Boolean := True) return t_Graph;

   -- Computing path and distance
   type t_Path is array (Integer range <>) of t_Vertex;
   function Shortest_Path (Graph    : in out t_Graph;
                           From, To : in t_Vertex) return t_Path;
   function Distance      (Graph    : in out t_Graph;
                           From, To : in t_Vertex) return Natural;

private
   package Neighbor_Lists is new Ada.Containers.Ordered_Maps (Key_Type => t_Vertex, Element_Type => Positive);
   type t_Vertex_Data is record
      Neighbors : Neighbor_Lists.Map; -- won't be affected after build
      -- Updated each time a function is called with a new source
      Previous  : t_Vertex;
      Distance  : Natural;
   end record;
   type t_Graph is array (t_Vertex) of t_Vertex_Data;
end Dijkstra;

with Ada.Containers.Ordered_Sets;
package body Dijkstra is

   Infinite : constant Natural := Natural'Last;

   -- ----- Graph constructor
   function Build (Edges : in t_Edges; Oriented : in Boolean := True) return t_Graph is
   begin
      return Answer : t_Graph := (others => (Neighbors => Neighbor_Lists.Empty_Map,
                                             Previous  => t_Vertex'First,
                                             Distance  => Natural'Last)) do
         for Edge of Edges loop
            Answer(Edge.From).Neighbors.Insert (Key => Edge.To, New_Item => Edge.Weight);
            if not Oriented then
               Answer(Edge.To).Neighbors.Insert (Key => Edge.From, New_Item => Edge.Weight);
            end if;
         end loop;
      end return;
   end Build;

   -- ----- Paths / distances data updating in case of computation request for a new source
   procedure Update_For_Source (Graph : in out t_Graph;
                                From  : in t_Vertex) is
      function Nearer (Left, Right : in t_Vertex) return Boolean is
        (Graph(Left).Distance < Graph(Right).Distance or else
         (Graph(Left).Distance = Graph(Right).Distance and then Left < Right));
      package Ordered is new Ada.Containers.Ordered_Sets (Element_Type => t_Vertex, "<" => Nearer);
      use Ordered;
      Remaining : Set := Empty_Set;
   begin
      -- First, let's check if vertices data are already computed for this source
      if Graph(From).Distance /= 0 then
         -- Reset distances and remaining vertices for a new source
         for Vertex in Graph'range loop
            Graph(Vertex).Distance := (if Vertex = From then 0 else Infinite);
            Remaining.Insert (Vertex);
         end loop;
         -- ----- The Dijkstra algorithm itself
         while not Remaining.Is_Empty
               -- If some targets are not connected to source, at one point, the remaining
               -- distances will all be infinite, hence the folllowing stop condition
               and then Graph(Remaining.First_Element).Distance /= Infinite loop
            declare
               Nearest : constant t_Vertex := Remaining.First_Element;
               procedure Update_Neighbor (Position : in Neighbor_Lists.Cursor) is
                  use Neighbor_Lists;
                  Neighbor     : constant t_Vertex := Key (Position);
                  In_Remaining : Ordered.Cursor    := Remaining.Find (Neighbor);
                  Try_Distance : constant Natural  :=
                    (if In_Remaining = Ordered.No_Element
                     then Infinite -- vertex already reached, this distance will fail the update test below
                     else Graph(Nearest).Distance + Element (Position));
               begin
                  if Try_Distance < Graph(Neighbor).Distance then
                     -- Update distance/path data and reorder the remaining set
                     Remaining.Delete (In_Remaining);
                     Graph(Neighbor).Distance := Try_Distance;
                     Graph(Neighbor).Previous := Nearest;
                     Remaining.Insert (Neighbor);
                  end if;
               end Update_Neighbor;
            begin
               Remaining.Delete_First;
               Graph(Nearest).Neighbors.Iterate (Update_Neighbor'Access);
            end;
         end loop;
      end if;
   end Update_For_Source;

   -- ----- Bodies for the interfaced functions
   function Shortest_Path (Graph    : in out t_Graph;
                           From, To : in t_Vertex) return t_Path is
      function Recursive_Build (From, To : in t_Vertex) return t_Path is
        (if From = To then (1 => From)
         else Recursive_Build(From, Graph(To).Previous) & (1 => To));
   begin
      Update_For_Source (Graph, From);
      if Graph(To).Distance = Infinite then
         raise Constraint_Error with "No path from " & From'Img & " to " & To'Img;
      end if;
      return Recursive_Build (From, To);
   end Shortest_Path;

   function Distance (Graph    : in out t_Graph;
                      From, To : in t_Vertex) return Natural is
   begin
      Update_For_Source (Graph, From);
      return Graph(To).Distance;
   end Distance;

end Dijkstra;

with Ada.Text_IO; use Ada.Text_IO;
with Dijkstra;
procedure Test_Dijkstra is
   subtype t_Tested_Vertices is Character range 'a'..'f';
   package Tested is new Dijkstra (t_Vertex => t_Tested_Vertices);
   use Tested;
   Graph : t_Graph := Build (Edges => (('a', 'b', 7),
                                       ('a', 'c', 9),
                                       ('a', 'f', 14),
                                       ('b', 'c', 10),
                                       ('b', 'd', 15),
                                       ('c', 'd', 11),
                                       ('c', 'f', 2),
                                       ('d', 'e', 6),
                                       ('e', 'f', 9)));
   procedure Display_Path (From, To : in t_Tested_Vertices) is
      function Path_Image (Path : in t_Path; Start : Boolean := True) return String is
        ((if Start then "["
          elsif Path'Length /= 0 then ","
          else "") &
         (if Path'Length = 0 then "]"
          else Path(Path'First) & Path_Image(Path(Path'First+1..Path'Last), Start => False)));
   begin
      Put      ("Path from '" & From & "' to '" & To & "' = ");
      Put_Line (Path_Image (Shortest_Path (Graph, From, To))
                & " distance =" & Distance (Graph, From, To)'Img);
   exception
      when others => Put_Line("no path");
   end Display_Path;
begin
   Display_Path ('a', 'e');
   Display_Path ('a', 'f');
   New_Line;
   for From in t_Tested_Vertices loop
      for To in t_Tested_Vertices loop
         Display_Path (From, To);
      end loop;
   end loop;
end Test_Dijkstra;

The code implements Dijkstra's algorithm to find the shortest path from a single source to all other vertices in a directed, weighted graph. The graph is represented by an adjacency matrix or list, and a start node. The algorithm takes into account non-negative edge path costs. The output is a set of edges representing the shortest path to each reachable node from the origin. The code also includes functionality to interpret the output and display the shortest path from a specific node to other selected nodes. The vertices and edges of the graph can be identified either by numbers or names.


with Ada.Text_IO, Ada.Finalization, Ada.Unchecked_Deallocation;

procedure Main is

   generic
      type Key_Type is private;
      with function "<"(a, b : Key_Type) return Boolean is <>;
      with function "="(a, b : Key_Type) return Boolean is <>;
      with function "<="(a, b : Key_Type) return Boolean is <>;
   package AVL_Tree is
      type Tree is tagged limited private;
      function insert(self : in out Tree; key : Key_Type) return Boolean;
      procedure delete(self : in out Tree; key : Key_Type);
      procedure print_balance(self : in out Tree);

   private
      type Height_Amt is range -1 .. Integer'Last;

      -- Since only one key is inserted before each rebalance, the balance of
      -- all trees/subtrees will stay in range -2 .. 2
      type Balance_Amt is range -2 .. 2;

      type Node;
      type Node_Ptr is access Node;
      type Node is new Ada.Finalization.Limited_Controlled with record
         left, right, parent : Node_Ptr := null;
         key : Key_Type;
         balance : Balance_Amt := 0;
      end record;
      overriding procedure Finalize(self : in out Node);
      subtype Node_Parent is Ada.Finalization.Limited_Controlled;

      type Tree is new Ada.Finalization.Limited_Controlled with record
         root : Node_Ptr := null;
      end record;
      overriding procedure Finalize(self : in out Tree);

   end AVL_Tree;

   package body AVL_Tree is

      procedure Free_Node is new Ada.Unchecked_Deallocation(Node, Node_Ptr);

      overriding procedure Finalize(self : in out Node) is
      begin
         Free_Node(self.left);
         Free_Node(self.right);
      end Finalize;

      overriding procedure Finalize(self : in out Tree) is
      begin
         Free_Node(self.root);
      end Finalize;

      function height(n : Node_Ptr) return Height_Amt is
      begin
         if n = null then
            return -1;
         else
            return 1 + Height_Amt'Max(height(n.left), height(n.right));
         end if;
      end height;

      procedure set_balance(n : not null Node_Ptr) is
      begin
         n.balance := Balance_Amt(height(n.right) - height(n.left));
      end set_balance;

      procedure update_parent(parent : Node_Ptr; new_child : Node_Ptr; old_child : Node_Ptr) is
      begin
         if parent /= null then
            if parent.right = old_child then
               parent.right := new_child;
            else
               parent.left := new_child;
            end if;
         end if;
      end update_parent;

      function rotate_left(a : not null Node_Ptr) return Node_Ptr is
         b : Node_Ptr := a.right;
      begin
         b.parent := a.parent;
         a.right := b.left;
         if a.right /= null then
            a.right.parent := a;
         end if;
         b.left := a;
         a.parent := b;
         update_parent(parent => b.parent, new_child => b, old_child => a);

         set_balance(a);
         set_balance(b);
         return b;
      end rotate_left;

      function rotate_right(a : not null Node_Ptr) return Node_Ptr is
         b : Node_Ptr := a.left;
      begin
         b.parent := a.parent;
         a.left := b.right;
         if a.left /= null then
            a.left.parent := a;
         end if;
         b.right := a;
         a.parent := b;
         update_parent(parent => b.parent, new_child => b, old_child => a);

         set_balance(a);
         set_balance(b);
         return b;
      end rotate_right;

      function rotate_left_right(n : not null Node_Ptr) return Node_Ptr is
      begin
         n.left := rotate_left(n.left);
         return rotate_right(n);
      end rotate_left_right;

      function rotate_right_left(n : not null Node_Ptr) return Node_Ptr is
      begin
         n.right := rotate_right(n.right);
         return rotate_left(n);
      end rotate_right_left;

      procedure rebalance(self : in out Tree; n : not null Node_Ptr) is
         new_n : Node_Ptr := n;
      begin
         set_balance(new_n);
         if new_n.balance = -2 then
            if height(new_n.left.left) >= height(new_n.left.right) then
               new_n := rotate_right(new_n);
            else
               new_n := rotate_left_right(new_n);
            end if;
         elsif new_n.balance = 2 then
            if height(new_n.right.right) >= height(new_n.right.left) then
               new_n := rotate_left(new_n);
            else
               new_n := rotate_right_left(new_n);
            end if;
         end if;

         if new_n.parent /= null then
            rebalance(self, new_n.parent);
         else
            self.root := new_n;
         end if;
      end rebalance;

      function new_node(key : Key_Type) return Node_Ptr is
        (new Node'(Node_Parent with key => key, others => <>));

      function insert(self : in out Tree; key : Key_Type) return Boolean is
         curr, parent : Node_Ptr;
         go_left : Boolean;
      begin
         if self.root = null then
            self.root := new_node(key);
            return True;
         end if;

         curr := self.root;
         while curr.key /= key loop
            parent := curr;
            go_left := key < curr.key;
            curr := (if go_left then curr.left else curr.right);
            if curr = null then
               if go_left then
                  parent.left := new_node(key);
                  parent.left.parent := parent;
               else
                  parent.right := new_node(key);
                  parent.right.parent := parent;
               end if;
               rebalance(self, parent);
               return True;
            end if;
         end loop;
         return False;
      end insert;

      procedure delete(self : in out Tree; key : Key_Type) is
         successor, parent, child : Node_Ptr := self.root;
         to_delete : Node_Ptr := null;
      begin
         if self.root = null then
            return;
         end if;

         while child /= null loop
            parent := successor;
            successor := child;
            child := (if successor.key <= key then successor.right else successor.left);
            if successor.key = key then
               to_delete := successor;
            end if;
         end loop;

         if to_delete = null then
            return;
         end if;
         to_delete.key := successor.key;
         child := (if successor.left = null then successor.right else successor.left);
         if self.root.key = key then
            self.root := child;
         else
            update_parent(parent => parent, new_child => child, old_child => successor);
            rebalance(self, parent);
         end if;
         Free_Node(successor);
      end delete;

      procedure print_balance(n : Node_Ptr) is
      begin
         if n /= null then
            print_balance(n.left);
            Ada.Text_IO.Put(n.balance'Image);
            print_balance(n.right);
         end if;
      end print_balance;

      procedure print_balance(self : in out Tree) is
      begin
         print_balance(self.root);
      end print_balance;
   end AVL_Tree;

   package Int_AVL_Tree is new AVL_Tree(Integer);

   tree : Int_AVL_Tree.Tree;
   success : Boolean;
begin
   for i in 1 .. 10 loop
      success := tree.insert(i);
   end loop;
   Ada.Text_IO.Put("Printing balance: ");
   tree.print_balance;
   Ada.Text_IO.New_Line;
end Main;

implement an AVL tree, a self-balancing binary search tree where the heights of the two child subtrees of any node differ by at most one. The code ensures this by rebalancing the tree after each insertion or deletion. The operations of lookup, insertion, and deletion all take O(log n) time. The code does not allow duplicate node keys. The AVL tree implemented can be compared with red-black trees for its efficiency in lookup-intensive applications.


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

procedure Test_Loop_Break is
   type Value_Type is range 0..19;
   package Random_Values is new Ada.Numerics.Discrete_Random (Value_Type);
   use Random_Values;
   Dice : Generator;
   A, B : Value_Type;
begin
   loop
      A := Random (Dice);
      Put_Line (Value_Type'Image (A));
      exit when A = 10;
      B := Random (Dice);
      Put_Line (Value_Type'Image (B));
   end loop;
end Test_Loop_Break;

generate and print random numbers from 0 to 19. If the generated number is 10, the loop stops. If the number is not 10, a second random number is generated and printed before the loop restarts. If 10 is never generated, the loop runs indefinitely.


with Ada.Text_IO;
--  reuse Is_Prime from [[Primality by Trial Division]]
with Is_Prime;

procedure Mersenne is
   function Is_Set (Number : Natural; Bit : Positive) return Boolean is
   begin
      return Number / 2 ** (Bit - 1) mod 2 = 1;
   end Is_Set;

   function Get_Max_Bit (Number : Natural) return Natural is
      Test : Natural := 0;
   begin
      while 2 ** Test <= Number loop
         Test := Test + 1;
      end loop;
      return Test;
   end Get_Max_Bit;

   function Modular_Power (Base, Exponent, Modulus : Positive) return Natural is
      Maximum_Bit : constant Natural := Get_Max_Bit (Exponent);
      Square      : Natural := 1;
   begin
      for Bit in reverse 1 .. Maximum_Bit loop
         Square := Square ** 2;
         if Is_Set (Exponent, Bit) then
            Square := Square * Base;
         end if;
         Square := Square mod Modulus;
      end loop;
      return Square;
   end Modular_Power;

   Not_A_Prime_Exponent : exception;

   function Get_Factor (Exponent : Positive) return Natural is
      Factor : Positive;
   begin
      if not Is_Prime (Exponent) then
         raise Not_A_Prime_Exponent;
      end if;
      for K in 1 .. 16384 / Exponent loop
         Factor := 2 * K * Exponent + 1;
         if Factor mod 8 = 1 or else Factor mod 8 = 7 then
            if Is_Prime (Factor) and then Modular_Power (2, Exponent, Factor) = 1 then
               return Factor;
            end if;
         end if;
      end loop;
      return 0;
   end Get_Factor;

   To_Test : constant Positive := 929;
   Factor  : Natural;
begin
   Ada.Text_IO.Put ("2 **" & Integer'Image (To_Test) & " - 1 ");
   begin
      Factor := Get_Factor (To_Test);
      if Factor = 0 then
         Ada.Text_IO.Put_Line ("is prime.");
      else
         Ada.Text_IO.Put_Line ("has factor" & Integer'Image (Factor));
      end if;
   exception
      when Not_A_Prime_Exponent =>
         Ada.Text_IO.Put_Line ("is not a Mersenne number");
   end;
end Mersenne;

The code implements a method to find a factor of a Mersenne number, specifically 2^929-1 (M929). It uses efficient algorithms to determine if a number divides 2^P-1 and implements the modPow operation. The code also includes a primality test that works only on Mersenne numbers where P is prime. The process is refined by considering properties of Mersenne numbers, such as any factor q of 2^P-1 must be of the form 2kP+1, k being a positive integer or zero, and q must be 1 or 7 mod 8. The algorithm stops when 2kP+1 > sqrt(N).


with ada.containers.ordered_sets, ada.text_io;
use ada.text_io;

procedure set_demo is
	package cs is new ada.containers.ordered_sets (character); use cs;

	function "+" (s : string) return set is
	(if s = "" then empty_set else Union(+ s(s'first..s'last - 1), To_Set (s(s'last))));

	function "-" (s : Set) return string is
	(if s = empty_set then "" else - (s - To_Set (s.last_element)) & s.last_element);
	s1, s2 : set;
begin
	loop
		put ("s1= ");
		s1 := + get_line;
		exit when s1 = +"Quit!";
		put ("s2= ");
		s2 := + get_line;
		Put_Line("Sets [" & (-s1) & "], [" & (-s2) & "] of size"
                & S1.Length'img & " and" & s2.Length'img & ".");
  		Put_Line("Intersection:   [" & (-(Intersection(S1, S2))) & "],");
  		Put_Line("Union:          [" & (-(Union(s1, s2)))        & "],");
  		Put_Line("Difference:     [" & (-(Difference(s1, s2)))   & "],");
  		Put_Line("Symmetric Diff: [" & (-(s1 xor s2)) & "],");
  		Put_Line("Subset: "  & Boolean'Image(s1.Is_Subset(s2))
              & ", Equal: " & Boolean'Image(s1 = s2) & ".");
	end loop;
end set_demo;

demonstrate various set operations including set creation, testing if an element is in a set, union, intersection, difference, subset, and equality of sets. It also optionally shows other set operations and methods to modify a mutable set. The set can be implemented using an associative array, binary search tree, hash table, or an ordered array of binary bits. The code uses the Ordered_Sets package from the Ada.Containers standard library, but an alternative solution could use the Hashed_Maps package from Ada.Containers.


with Ada.Calendar.Formatting;  use Ada.Calendar.Formatting;
with Ada.Text_IO;              use Ada.Text_IO;

procedure Yuletide is
begin
   for Year in 2008..2121 loop
      if Day_Of_Week (Time_Of (Year, 12, 25)) = Sunday then
         Put_Line (Image (Time_Of (Year, 12, 25)));
      end if;
   end loop;
end Yuletide;

The code determines the years between 2008 and 2121 where Christmas (25th December) falls on a Sunday, using standard date handling libraries. It also compares the results with other languages to identify any anomalies in date/time representation, such as overflow issues similar to y2k problems.


with Ada.Text_IO; use Ada.Text_IO;
with Ada.Numerics.Real_Arrays; use Ada.Numerics.Real_Arrays;
with Ada.Numerics.Generic_Elementary_Functions;
procedure QR is

   procedure Show (mat : Real_Matrix) is
      package FIO is new Ada.Text_IO.Float_IO (Float);
   begin
      for row in mat'Range (1) loop
         for col in mat'Range (2) loop
            FIO.Put (mat (row, col), Exp => 0, Aft => 4, Fore => 5);
         end loop;
         New_Line;
      end loop;
   end Show;

   function GetCol (mat : Real_Matrix; n : Integer) return Real_Matrix is
      column : Real_Matrix (mat'Range (1), 1 .. 1);
   begin
      for row in mat'Range (1) loop
         column (row, 1) := mat (row, n);
      end loop;
      return column;
   end GetCol;

   function Mag (mat : Real_Matrix) return Float is
      sum : Real_Matrix := Transpose (mat) * mat;
      package Math is new Ada.Numerics.Generic_Elementary_Functions
         (Float);
   begin
      return Math.Sqrt (sum (1, 1));
   end Mag;

   function eVect (col : Real_Matrix; n : Integer) return Real_Matrix is
      vect : Real_Matrix (col'Range (1), 1 .. 1);
   begin
      for row in col'Range (1) loop
         if row /= n then vect (row, 1) := 0.0;
         else vect (row, 1) := 1.0; end if;
      end loop;
      return vect;
   end eVect;

   function Identity (n : Integer) return Real_Matrix is
      mat : Real_Matrix (1 .. n, 1 .. n) := (1 .. n => (others => 0.0));
   begin
      for i in Integer range 1 .. n loop mat (i, i) := 1.0; end loop;
      return mat;
   end Identity;

   function Chop (mat : Real_Matrix; n : Integer) return Real_Matrix is
      small : Real_Matrix (n .. mat'Length (1), n .. mat'Length (2));
   begin
      for row in small'Range (1) loop
         for col in small'Range (2) loop
            small (row, col) := mat (row, col);
         end loop;
      end loop;
      return small;
   end Chop;

   function H_n (inmat : Real_Matrix; n : Integer)
      return Real_Matrix is
      mat : Real_Matrix := Chop (inmat, n);
      col : Real_Matrix := GetCol (mat, n);
      colT : Real_Matrix (1 .. 1, mat'Range (1));
      H : Real_Matrix := Identity (mat'Length (1));
      Hall : Real_Matrix := Identity (inmat'Length (1));
   begin
      col := col - Mag (col) * eVect (col, n);
      col := col / Mag (col);
      colT := Transpose (col);
      H := H - 2.0 * (col * colT);
      for row in H'Range (1) loop
         for col in H'Range (2) loop
            Hall (n - 1 + row, n - 1 + col) := H (row, col);
         end loop;
      end loop;
      return Hall;
   end H_n;

   A : constant Real_Matrix (1 .. 3, 1 .. 3) := (
      (12.0, -51.0, 4.0),
      (6.0, 167.0, -68.0),
      (-4.0, 24.0, -41.0));
   Q1, Q2, Q3, Q, R: Real_Matrix (1 .. 3, 1 .. 3);
begin
   Q1 := H_n (A, 1);
   Q2 := H_n (Q1 * A, 2);
   Q3 := H_n (Q2 * Q1* A, 3);
   Q := Transpose (Q1) * Transpose (Q2) * TransPose(Q3);
   R := Q3 * Q2 * Q1 * A;
   Put_Line ("Q:"); Show (Q);
   Put_Line ("R:"); Show (R);
end QR;

"Implement QR decomposition using Householder reflections. The code takes a rectangular matrix and decomposes it into a product of an orthogonal matrix and an upper triangular matrix. It also demonstrates the QR decomposition on a given example matrix and uses it to solve linear least squares problems. The code handles cases where the matrix is not square by cutting off zero padded bottom rows. The solution is then obtained by back substitution."


Works with: GNAT version GPL 2018
with Ada.Containers.Ordered_Sets, Ada.Text_IO;
use Ada.Text_IO;

procedure Duplicate is
	package Int_Sets is new Ada.Containers.Ordered_Sets (Integer);
	Nums : constant array (Natural range <>) of Integer := (1,2,3,4,5,5,6,7,1);
	Unique : Int_Sets.Set;
begin
	for n of Nums loop
		Unique.Include (n);
	end loop;
	for e of Unique loop
		Put (e'img);
	end loop;
end Duplicate;

implement three methods to remove duplicate elements from an array: 1) Using a hash table, 2) Sorting the array and removing consecutive duplicates, and 3) Iterating through the list and discarding any repeated elements.


-----------------------------------------------------------------------
-- Generic Quick_Sort procedure
-----------------------------------------------------------------------
generic
   type Element is private;
   type Index is (<>);
   type Element_Array is array(Index range <>) of Element;
   with function "<" (Left, Right : Element) return Boolean is <>;
procedure Quick_Sort(A : in out Element_Array);

-----------------------------------------------------------------------
-- Generic Quick_Sort procedure
-----------------------------------------------------------------------

procedure Quick_Sort (A : in out Element_Array) is

   procedure Swap(Left, Right : Index) is
      Temp : Element := A (Left);
   begin
      A (Left) := A (Right);
      A (Right) := Temp;
   end Swap;

begin
   if A'Length > 1 then
   declare
      Pivot_Value : Element := A (A'First);
      Right       : Index := A'Last;
      Left        : Index := A'First;
   begin
       loop
          while Left < Right and not (Pivot_Value < A (Left)) loop
             Left := Index'Succ (Left);
          end loop;
          while Pivot_Value < A (Right) loop
             Right := Index'Pred (Right);
          end loop;
          exit when Right <= Left;
          Swap (Left, Right);
          Left := Index'Succ (Left);
          Right := Index'Pred (Right);
       end loop;
       if Right = A'Last then
          Right := Index'Pred (Right);
          Swap (A'First, A'Last);
       end if;
       if Left = A'First then
          Left := Index'Succ (Left);
       end if;
       Quick_Sort (A (A'First .. Right));
       Quick_Sort (A (Left .. A'Last));
   end;
   end if;
end Quick_Sort;

with Ada.Text_Io;
with Ada.Float_Text_IO; use Ada.Float_Text_IO;
with Quick_Sort;

procedure Sort_Test is
   type Days is (Mon, Tue, Wed, Thu, Fri, Sat, Sun);
   type Sales is array (Days range <>) of Float;
   procedure Sort_Days is new Quick_Sort(Float, Days, Sales);

   procedure Print (Item : Sales) is
   begin
      for I in Item'range loop
         Put(Item => Item(I), Fore => 5, Aft => 2, Exp => 0);
      end loop;
   end Print;

   Weekly_Sales : Sales := (Mon => 300.0,
      Tue => 700.0,
      Wed => 800.0,
      Thu => 500.0,
      Fri => 200.0,
      Sat => 100.0,
      Sun => 900.0);

begin

   Print(Weekly_Sales);
   Ada.Text_Io.New_Line(2);
   Sort_Days(Weekly_Sales);
   Print(Weekly_Sales);

end Sort_Test;

implement the quicksort algorithm to sort an array or list elements. The algorithm selects a pivot from the array, divides the rest of the elements into two partitions (one with elements less than the pivot and one with elements greater than the pivot), and then recursively sorts these partitions. The codes also include an optimized version of quicksort that works in place by swapping elements within the array to avoid additional memory allocation. The pivot selection method is not specified and can vary. The codes can handle any discrete index type.


with Ada.Calendar;             use Ada.Calendar;
with Ada.Calendar.Formatting;  use Ada.Calendar.Formatting;
with Ada.Text_IO;              use Ada.Text_IO;

procedure Date_Format is
   function Image (Month : Month_Number) return String is
   begin
      case Month is
         when 1  => return "January";
         when 2  => return "February";
         when 3  => return "March";
         when 4  => return "April";
         when 5  => return "May";
         when 6  => return "June";
         when 7  => return "July";
         when 8  => return "August";
         when 9  => return "September";
         when 10 => return "October";
         when 11 => return "November";
         when 12 => return "December";
      end case;
   end Image;
   function Image (Day : Day_Name) return String is
   begin
      case Day is
         when Monday    => return "Monday";
         when Tuesday   => return "Tuesday";
         when Wednesday => return "Wednesday";
         when Thursday  => return "Thursday";
         when Friday    => return "Friday";
         when Saturday  => return "Saturday";
         when Sunday    => return "Sunday";
      end case;
   end Image;
   Today : Time := Clock;
begin
   Put_Line (Image (Today) (1..10));
   Put_Line
   (  Image (Day_Of_Week (Today)) & ", "
   &  Image (Ada.Calendar.Month (Today))
   &  Day_Number'Image (Ada.Calendar.Day (Today)) & ","
   &  Year_Number'Image (Ada.Calendar.Year (Today))
   );
end Date_Format;

display the current date in two formats: "2007-11-23" and "Friday, November 23, 2007".


with Ada.Text_IO, Ada.Command_Line;
use Ada.Text_IO, Ada.Command_Line;

procedure powerset is
begin
	for set in 0..2**Argument_Count-1 loop
		Put ("{");
		declare
			k : natural := set;
			first : boolean := true;
		begin
			for i in 1..Argument_Count loop
				if k mod 2 = 1 then
					Put ((if first then "" else ",") & Argument (i));
					first := false;
			  	end if;
				k := k / 2; -- we go to the next bit of "set"
			end loop;
		end;
		Put_Line("}");
	end loop;
end powerset;

The code takes a set S as input and generates its power set. The power set includes all subsets of S, including the empty set and the set itself. For a set with n elements, the power set will have 2^n elements. The code also demonstrates the handling of power sets for an empty set and a set that contains only the empty set. The implementation uses either a library or built-in set type, or a custom set type with necessary operations. The code also has a feature to print the power set of n arguments passed via the command line, using the i'th bit of a natural number between 0 and 2^n -1 to determine whether to include the i'th element of the command line in the set.


with Ada.Text_IO;  use Ada.Text_IO;

procedure Roman_Numeral_Test is
   function To_Roman (Number : Positive) return String is
      subtype Digit is Integer range 0..9;
      function Roman (Figure : Digit; I, V, X : Character) return String is
      begin
         case Figure is
            when 0 => return "";
            when 1 => return "" & I;
            when 2 => return I & I;
            when 3 => return I & I & I;
            when 4 => return I & V;
            when 5 => return "" & V;
            when 6 => return V & I;
            when 7 => return V & I & I;
            when 8 => return V & I & I & I;
            when 9 => return I & X;
         end case;
      end Roman;
   begin
      pragma Assert (Number >= 1 and Number < 4000);
      return
         Roman (Number / 1000,       'M', ' ', ' ') &
         Roman (Number / 100 mod 10, 'C', 'D', 'M') &
         Roman (Number / 10 mod 10,  'X', 'L', 'C') &
         Roman (Number mod 10,       'I', 'V', 'X');
   end To_Roman;
begin
   Put_Line (To_Roman (1999));
   Put_Line (To_Roman (25));
   Put_Line (To_Roman (944));
end Roman_Numeral_Test;

create a function that converts a positive integer into its equivalent Roman numeral representation.


procedure Array_Test is

   A, B : array (1..20) of Integer;

   -- Ada array indices may begin at any value, not just 0 or 1
   C : array (-37..20) of integer

   -- Ada arrays may be indexed by enumerated types, which are
   -- discrete non-numeric types
   type Days is (Mon, Tue, Wed, Thu, Fri, Sat, Sun);
   type Activities is (Work, Fish);
   type Daily_Activities is array(Days) of Activities;
   This_Week : Daily_Activities := (Mon..Fri => Work, Others => Fish);

   -- Or any numeric type
   type Fingers is range 1..4; -- exclude thumb
   type Fingers_Extended_Type is array(fingers) of Boolean;
   Fingers_Extended : Fingers_Extended_Type;

   -- Array types may be unconstrained. The variables of the type
   -- must be constrained
   type Arr is array (Integer range <>) of Integer;
   Uninitialized : Arr (1 .. 10);
   Initialized_1 : Arr (1 .. 20) := (others => 1);
   Initialized_2 : Arr := (1 .. 30 => 2);
   Const         : constant Arr := (1 .. 10 => 1, 11 .. 20 => 2, 21 | 22 => 3);
   Centered      : Arr (-50..50) := (0 => 1, Others => 0);

   Result        : Integer
begin

   A := (others => 0);     -- Assign whole array
   B := (1 => 1, 2 => 1, 3 => 2, others => 0);
                           -- Assign whole array, different values
   A (1) := -1;            -- Assign individual element
   A (2..4) := B (1..3);   -- Assign a slice
   A (3..5) := (2, 4, -1); -- Assign a constant slice
   A (3..5) := A (4..6);   -- It is OK to overlap slices when assigned

   Fingers_Extended'First := False; -- Set first element of array
   Fingers_Extended'Last := False;  -- Set last element of array

end Array_Test;

demonstrate the basic syntax of arrays in a specific programming language. They include creating an array, assigning a value to it, and retrieving an element from it. Both fixed-length and dynamic arrays are covered. The codes also show that arrays are first-class objects in Ada, which can be allocated statically or dynamically. The number of elements in an array is always constrained, and variable size arrays are provided by the standard container library.


with Ada.Text_IO; use Ada.Text_IO;

procedure Read_And_Write_File_Line_By_Line is
   Input, Output : File_Type;
begin
   Open (File => Input,
         Mode => In_File,
         Name => "input.txt");
   Create (File => Output,
           Mode => Out_File,
           Name => "output.txt");
   loop
      declare
         Line : String := Get_Line (Input);
      begin
         -- You can process the contents of Line here.
         Put_Line (Output, Line);
      end;
   end loop;
   Close (Input);
   Close (Output);
exception
   when End_Error =>
      if Is_Open(Input) then
         Close (Input);
      end if;
      if Is_Open(Output) then
         Close (Output);
      end if;
end Read_And_Write_File_Line_By_Line;

with Ada.Command_Line, Ada.Text_IO; use Ada.Command_Line, Ada.Text_IO;

procedure Read_And_Write_File_Line_By_Line is
   Read_From : constant String := "input.txt";
   Write_To  : constant String := "output.txt";

   Input, Output : File_Type;
begin
   begin
      Open (File => Input,
            Mode => In_File,
            Name => Read_From);
   exception
      when others =>
         Put_Line (Standard_Error,
                   "Can not open the file '" & Read_From & "'. Does it exist?");
         Set_Exit_Status (Failure);
         return;
   end;

   begin
      Create (File => Output,
              Mode => Out_File,
              Name => Write_To);
   exception
      when others =>
         Put_Line (Standard_Error,
                   "Can not create a file named '" & Write_To & "'.");
         Set_Exit_Status (Failure);
         return;
   end;

   loop
      declare
         Line : String := Get_Line (Input);
      begin
         -- You can process the contents of Line here.
         Put_Line (Output, Line);
      end;
   end loop;
   Close (Input);
   Close (Output);
exception
   when End_Error =>
      if Is_Open(Input) then
         Close (Input);
      end if;
      if Is_Open(Output) then
         Close (Output);
      end if;
end Read_And_Write_File_Line_By_Line;

with Ada.Sequential_IO;

procedure Read_And_Write_File_Character_By_Character is
   package Char_IO is new Ada.Sequential_IO (Character);
   use Char_IO;

   Input, Output : File_Type;
   Buffer        : Character;
begin
   Open   (File => Input,  Mode => In_File,  Name => "input.txt");
   Create (File => Output, Mode => Out_File, Name => "output.txt");
   loop
      Read  (File => Input,  Item => Buffer);
      Write (File => Output, Item => Buffer);
   end loop;
   Close (Input);
   Close (Output);
exception
   when End_Error =>
      if Is_Open(Input) then
         Close (Input);
      end if;
      if Is_Open(Output) then
         Close (Output);
      end if;
end Read_And_Write_File_Character_By_Character;

with Ada.Text_IO;               use Ada.Text_IO;
with Ada.Text_IO.Text_Streams;  use Ada.Text_IO.Text_Streams;

procedure Using_Text_Streams is
   Input, Output : File_Type;
   Buffer        : Character;
begin
   Open   (File => Input,  Mode => In_File,  Name => "input.txt");
   Create (File => Output, Mode => Out_File, Name => "output.txt");
   loop
      Buffer := Character'Input (Stream (Input));
      Character'Write (Stream (Output), Buffer);
   end loop;
   Close (Input);
   Close (Output);
exception
   when End_Error =>
      if Is_Open(Input) then
         Close (Input);
      end if;
      if Is_Open(Output) then
         Close (Output);
      end if;
end Using_Text_Streams;

The code reads the contents of "input.txt" file into an intermediate variable, then writes the contents of this variable into a new file called "output.txt". It demonstrates file reading and writing operations with proper error handling. It also includes an example of using stream I/O for more efficient reading and writing, skipping formatting.


with Ada.Characters.Handling, Ada.Text_IO;
use  Ada.Characters.Handling, Ada.Text_IO;

procedure Upper_Case_String is
   S : constant String := "alphaBETA";
begin
   Put_Line (To_Upper (S));
   Put_Line (To_Lower (S));
end Upper_Case_String;

demonstrate the conversion of the string "alphaBETA" to upper-case and lower-case using the default string literal or ASCII encoding. The code also showcases additional case conversion functions such as swapping case or capitalizing the first letter if available in the language's library. Note that in some languages, the toLower and toUpper functions may not be reversible.


with Ada.Numerics.Generic_Elementary_Functions;
with Ada.Text_IO;

procedure Closest is
   package Math is new Ada.Numerics.Generic_Elementary_Functions (Float);

   Dimension : constant := 2;
   type Vector is array (1 .. Dimension) of Float;
   type Matrix is array (Positive range <>) of Vector;

   -- calculate the distance of two points
   function Distance (Left, Right : Vector) return Float is
      Result : Float := 0.0;
      Offset : Natural := 0;
   begin
      loop
         Result := Result + (Left(Left'First + Offset) - Right(Right'First + Offset))**2;
         Offset := Offset + 1;
         exit when Offset >= Left'Length;
      end loop;
      return Math.Sqrt (Result);
   end Distance;

   -- determine the two closest points inside a cloud of vectors
   function Get_Closest_Points (Cloud : Matrix) return Matrix is
      Result : Matrix (1..2);
      Min_Distance : Float;
   begin
      if Cloud'Length(1) < 2 then
         raise Constraint_Error;
      end if;
      Result := (Cloud (Cloud'First), Cloud (Cloud'First + 1));
      Min_Distance := Distance (Cloud (Cloud'First), Cloud (Cloud'First + 1));
      for I in Cloud'First (1) .. Cloud'Last(1) - 1 loop
         for J in I + 1 .. Cloud'Last(1) loop
            if Distance (Cloud (I), Cloud (J)) < Min_Distance then
               Min_Distance := Distance (Cloud (I), Cloud (J));
               Result := (Cloud (I), Cloud (J));
            end if;
         end loop;
      end loop;
      return Result;
   end Get_Closest_Points;

   Test_Cloud : constant Matrix (1 .. 10) := ( (5.0, 9.0),  (9.0, 3.0),
                                               (2.0, 0.0),  (8.0, 4.0),
                                               (7.0, 4.0),  (9.0, 10.0),
                                               (1.0, 9.0),  (8.0, 2.0),
                                               (0.0, 10.0), (9.0, 6.0));
   Closest_Points : Matrix := Get_Closest_Points (Test_Cloud);

   Second_Test : constant Matrix (1 .. 10) := ( (0.654682, 0.925557), (0.409382, 0.619391),
                                                (0.891663, 0.888594), (0.716629,   0.9962),
                                                (0.477721, 0.946355), (0.925092,  0.81822),
                                                (0.624291, 0.142924), (0.211332, 0.221507),
                                                (0.293786, 0.691701), (0.839186,  0.72826));
   Second_Points : Matrix := Get_Closest_Points (Second_Test);
begin
   Ada.Text_IO.Put_Line ("Closest Points:");
   Ada.Text_IO.Put_Line ("P1: " & Float'Image (Closest_Points (1) (1)) & " " & Float'Image (Closest_Points (1) (2)));
   Ada.Text_IO.Put_Line ("P2: " & Float'Image (Closest_Points (2) (1)) & " " & Float'Image (Closest_Points (2) (2)));
   Ada.Text_IO.Put_Line ("Distance: " & Float'Image (Distance (Closest_Points (1), Closest_Points (2))));
   Ada.Text_IO.Put_Line ("Closest Points 2:");
   Ada.Text_IO.Put_Line ("P1: " & Float'Image (Second_Points (1) (1)) & " " & Float'Image (Second_Points (1) (2)));
   Ada.Text_IO.Put_Line ("P2: " & Float'Image (Second_Points (2) (1)) & " " & Float'Image (Second_Points (2) (2)));
   Ada.Text_IO.Put_Line ("Distance: " & Float'Image (Distance (Second_Points (1), Second_Points (2))));
end Closest;

The code provides a solution to the Closest Pair of Points problem in a two-dimensional plane. It includes two functions: one implementing a brute-force algorithm with a time complexity of O(n^2), and another using a recursive divide-and-conquer approach with a time complexity of O(n log n). Both functions return the minimum distance and the pair of points with the minimum distance from a given set of points. The divide-and-conquer function sorts the points by x and y coordinates and uses the brute-force function for small subsets. The code also includes a procedure for formatting the output.


procedure Array_Collection is

   A : array (-3 .. -1) of Integer := (1, 2, 3);

begin

   A (-3) := 3;
   A (-2) := 2;
   A (-1) := 1;

end Array_Collection;

procedure Array_Collection is

   type Array_Type is array (1 .. 3) of Integer;
   A : Array_Type := (1, 2, 3);

begin

   A (1) := 3;
   A (2) := 2;
   A (3) := 1;

end Array_Collection;

procedure Array_Collection is

   type Array_Type is array (positive range <>) of Integer; -- may be indexed with any positive
                                                            -- Integer value
   A : Array_Type(1 .. 3);  -- creates an array of three integers, indexed from 1 to 3

begin

   A (1) := 3;
   A (2) := 2;
   A (3) := 1;

end Array_Collection;

Works with: Ada 2005
Library: Ada.Containers.Doubly_Linked_Lists
with Ada.Containers.Doubly_Linked_Lists;
use  Ada.Containers;

procedure Doubly_Linked_List is

   package DL_List_Pkg is new Doubly_Linked_Lists (Integer);
   use     DL_List_Pkg;

   DL_List : List;

begin

   DL_List.Append (1);
   DL_List.Append (2);
   DL_List.Append (3);

end Doubly_Linked_List;

Works with: Ada 2005
Library: Ada.Containers.Vectors
with Ada.Containers.Vectors;
use  Ada.Containers;

procedure Vector_Example is

   package Vector_Pkg is new Vectors (Natural, Integer);
   use     Vector_Pkg;

   V : Vector;

begin

   V.Append (1);
   V.Append (2);
   V.Append (3);

end Vector_Example;

create a collection and add a few values to it. The codes also demonstrate the use of arrays in Ada 95 and Ada 2005, including the creation of anonymous and dynamic arrays. The limitations of anonymous arrays are also discussed. Examples of Doubly Linked Lists and Vectors are provided, along with the usage of hashed and ordered Maps and Sets. The codes also illustrate how arrays can be indexed on any range of discrete values.


with Ada.Text_IO;

procedure Knapsack_Unbounded is

   type Bounty is record
      Value  : Natural;
      Weight : Float;
      Volume : Float;
   end record;

   function Min (A, B : Float) return Float is
   begin
      if A < B then
         return A;
      else
         return B;
      end if;
   end Min;

   Panacea : Bounty := (3000,  0.3, 0.025);
   Ichor   : Bounty := (1800,  0.2, 0.015);
   Gold    : Bounty := (2500,  2.0, 0.002);
   Limits  : Bounty := (   0, 25.0, 0.250);
   Best    : Bounty := (   0,  0.0, 0.000);
   Current : Bounty := (   0,  0.0, 0.000);

   Best_Amounts : array (1 .. 3) of Natural := (0, 0, 0);

   Max_Panacea : Natural := Natural (Float'Floor (Min
                              (Limits.Weight / Panacea.Weight,
                               Limits.Volume / Panacea.Volume)));
   Max_Ichor   : Natural := Natural (Float'Floor (Min
                              (Limits.Weight / Ichor.Weight,
                               Limits.Volume / Ichor.Volume)));
   Max_Gold    : Natural := Natural (Float'Floor (Min
                              (Limits.Weight / Gold.Weight,
                               Limits.Volume / Gold.Volume)));

begin
   for Panacea_Count in 0 .. Max_Panacea loop
      for Ichor_Count in 0 .. Max_Ichor loop
         for Gold_Count in 0 .. Max_Gold loop
            Current.Value  := Panacea_Count * Panacea.Value +
                              Ichor_Count * Ichor.Value +
                              Gold_Count * Gold.Value;
            Current.Weight := Float (Panacea_Count) * Panacea.Weight +
                              Float (Ichor_Count) * Ichor.Weight +
                              Float (Gold_Count) * Gold.Weight;
            Current.Volume := Float (Panacea_Count) * Panacea.Volume +
                              Float (Ichor_Count) * Ichor.Volume +
                              Float (Gold_Count) * Gold.Volume;
            if Current.Value  >  Best.Value and
               Current.Weight <= Limits.Weight and
               Current.Volume <= Limits.Volume then
               Best := Current;
               Best_Amounts := (Panacea_Count, Ichor_Count, Gold_Count);
            end if;
         end loop;
      end loop;
   end loop;
   Ada.Text_IO.Put_Line ("Maximum value:" & Natural'Image (Best.Value));
   Ada.Text_IO.Put_Line ("Panacea:" & Natural'Image (Best_Amounts (1)));
   Ada.Text_IO.Put_Line ("Ichor:  " & Natural'Image (Best_Amounts (2)));
   Ada.Text_IO.Put_Line ("Gold:   " & Natural'Image (Best_Amounts (3)));
end Knapsack_Unbounded;

determine the maximum value of items that a traveler can carry in his knapsack, given the weight and volume constraints. The items include vials of panacea, ampules of ichor, and bars of gold. The code calculates the optimal quantity of each item to maximize the total value, considering that only whole units of any item can be taken.


with Ada.Text_IO;

procedure LoopsAndHalf is
begin
  for i in 1 .. 10 loop
    Ada.Text_IO.put (i'Img);
    exit when i = 10;
    Ada.Text_IO.put (",");
  end loop;
  Ada.Text_IO.new_line;
end LoopsAndHalf;

The code writes a comma-separated list from 1 to 10, using separate output statements for the number and the comma within a loop. The loop executes a partial body in its last iteration.


with Ada.Containers.Vectors; use Ada.Containers;

package Digraphs is

   type Node_Idx_With_Null is new Natural;
   subtype Node_Index is Node_Idx_With_Null range 1 .. Node_Idx_With_Null'Last;
   -- a Node_Index is a number from 1, 2, 3, ... and the representative of a node

   type Graph_Type is tagged private;

   -- make sure Node is in Graph (possibly without connections)
   procedure Add_Node
     (Graph: in out Graph_Type'Class; Node: Node_Index);

   -- insert an edge From->To into Graph; do nothing if already there
   procedure Add_Connection
     (Graph: in out Graph_Type'Class; From, To: Node_Index);

   -- get the largest Node_Index used in any Add_Node or Add_Connection op.
   -- iterate over all nodes of Graph: "for I in 1 .. Graph.Node_Count loop ..."
   function Node_Count(Graph: Graph_Type) return Node_Idx_With_Null;

   -- remove an edge From->To from Fraph; do nothing if not there
   -- Graph.Node_Count is not changed
   procedure Del_Connection
     (Graph: in out Graph_Type'Class; From, To: Node_Index);

   -- check if an edge From->to exists in Graph
   function Connected
     (Graph: Graph_Type; From, To: Node_Index) return Boolean;

   -- data structure to store a list of nodes
   package Node_Vec is new Vectors(Positive, Node_Index);

   -- get a list of all nodes From->Somewhere in Graph
   function All_Connections
     (Graph: Graph_Type; From: Node_Index) return Node_Vec.Vector;

   Graph_Is_Cyclic: exception;

   -- a depth-first search to find a topological sorting of the nodes
   -- raises Graph_Is_Cyclic if no topological sorting is possible
   function Top_Sort
     (Graph: Graph_Type) return Node_Vec.Vector;

private

   package Conn_Vec is new Vectors(Node_Index, Node_Vec.Vector, Node_Vec."=");

   type Graph_Type is new Conn_Vec.Vector with null record;

end Digraphs;

package body Digraphs is

   function Node_Count(Graph: Graph_Type) return Node_Idx_With_Null is
   begin
      return Node_Idx_With_Null(Graph.Length);
   end Node_Count;

   procedure Add_Node(Graph: in out Graph_Type'Class; Node: Node_Index) is
   begin
      for I in Node_Index range Graph.Node_Count+1 .. Node loop
         Graph.Append(Node_Vec.Empty_Vector);
      end loop;
   end Add_Node;

   procedure Add_Connection
     (Graph: in out Graph_Type'Class; From, To: Node_Index) is
   begin
      Graph.Add_Node(Node_Index'Max(From, To));
      declare
         Connection_List: Node_Vec.Vector := Graph.Element(From);
      begin
         for I in Connection_List.First_Index .. Connection_List.Last_Index loop
            if Connection_List.Element(I) >= To then
               if Connection_List.Element(I) = To then
                  return; -- if To is already there, don't add it a second time
               else -- I is the first index with Element(I)>To, insert To here
                  Connection_List.Insert(Before => I, New_Item => To);
                  Graph.Replace_Element(From, Connection_List);
                  return;
               end if;
            end if;
         end loop;
         -- there was  no I with no Element(I) > To, so insert To at the end
         Connection_List.Append(To);
         Graph.Replace_Element(From, Connection_List);
         return;
      end;
   end Add_Connection;

   procedure Del_Connection
     (Graph: in out Graph_Type'Class; From, To: Node_Index) is
      Connection_List: Node_Vec.Vector := Graph.Element(From);
   begin
      for I in Connection_List.First_Index .. Connection_List.Last_Index loop
         if Connection_List.Element(I) = To then
            Connection_List.Delete(I);
            Graph.Replace_Element(From, Connection_List);
            return; -- we are done
         end if;
      end loop;
   end Del_Connection;

   function Connected
     (Graph: Graph_Type; From, To: Node_Index) return Boolean is
      Connection_List: Node_Vec.Vector renames Graph.Element(From);
   begin
      for I in Connection_List.First_Index .. Connection_List.Last_Index loop
         if Connection_List.Element(I) = To then
            return True;
         end if;
      end loop;
      return False;
   end Connected;

   function All_Connections
     (Graph: Graph_Type; From: Node_Index) return Node_Vec.Vector is
   begin
      return Graph.Element(From);
   end All_Connections;

   function Top_Sort
     (Graph: Graph_Type) return Node_Vec.Vector is

      Result: Node_Vec.Vector;
      Visited: array(1 .. Graph.Node_Count) of Boolean := (others => False);
      Active:  array(1 .. Graph.Node_Count) of Boolean := (others => False);

      procedure Visit(Node: Node_Index) is
      begin
         if not Visited(Node) then
            Visited(Node) := True;
            Active(Node)  := True;
            declare
               Cons: Node_Vec.Vector := All_Connections(Graph, Node);
            begin
               for Idx in Cons.First_Index .. Cons.Last_Index loop
                  Visit(Cons.Element(Idx));
               end loop;
            end;
            Active(Node) := False;
            Result.Append(Node);
         else
            if Active(Node) then
               raise Constraint_Error with "Graph is Cyclic";
            end if;
         end if;
      end Visit;

   begin
      for Some_Node in Visited'Range loop
         Visit(Some_Node);
      end loop;
      return Result;
   end Top_Sort;

end Digraphs;

private with Ada.Containers.Indefinite_Vectors;

generic
   type Index_Type_With_Null is new Natural;
package Set_Of_Names is
   subtype Index_Type is Index_Type_With_Null
       range 1 .. Index_Type_With_Null'Last;
   -- manage a set of strings;
   -- each string in the set is assigned a unique index of type Index_Type

   type Set is tagged private;

   -- inserts Name into Names; do nothing if already there;
   procedure Add(Names: in out Set; Name: String);

   -- Same operation, additionally emiting Index=Names.Idx(Name)
   procedure Add(Names: in out Set; Name: String; Index: out Index_Type);

   -- remove Name from Names; do nothing if not found
   -- the removal may change the index of other strings in Names
   procedure Sub(Names: in out Set; Name: String);

   -- returns the unique index of Name in Set; or 0 if Name is not there
   function Idx(Names: Set; Name: String) return Index_Type_With_Null;

   -- returns the unique name of Index;
   function Name(Names: Set; Index: Index_Type) return String;

   -- first index, last index and total number of names in set
   -- to iterate over Names, use "for I in Names.Start .. Names.Stop loop ...
   function Start(Names: Set) return Index_Type;
   function Stop(Names: Set) return Index_Type_With_Null;
   function Size(Names: Set) return Index_Type_With_Null;

private

   package Vecs is new Ada.Containers.Indefinite_Vectors
     (Index_Type => Index_Type, Element_Type => String);

   type Set is new Vecs.Vector with null record;

end Set_Of_Names;

package body Set_Of_Names is

   use type Ada.Containers.Count_Type, Vecs.Cursor;

   function Start(Names: Set) return Index_Type is
   begin
      if Names.Length = 0 then
         return 1;
      else
         return Names.First_Index;
      end if;
   end Start;

   function Stop(Names: Set) return Index_Type_With_Null is
   begin
      if Names.Length=0 then
         return 0;
      else
         return Names.Last_Index;
      end if;
   end Stop;

   function Size(Names: Set) return Index_Type_With_Null is
   begin
      return Index_Type_With_Null(Names.Length);
   end Size;

   procedure Add(Names: in out Set; Name: String; Index: out Index_Type) is
      I: Index_Type_With_Null := Names.Idx(Name);
   begin
      if I = 0 then -- Name is not yet in Set
         Names.Append(Name);
         Index := Names.Stop;
      else
        Index := I;
      end if;
   end Add;

   procedure Add(Names: in out Set; Name: String) is
      I: Index_Type;
   begin
      Names.Add(Name, I);
   end Add;

   procedure Sub(Names: in out Set; Name: String) is
      I: Index_Type_With_Null := Names.Idx(Name);
   begin
      if I /= 0 then -- Name is in set
         Names.Delete(I);
      end if;
   end Sub;

   function Idx(Names: Set; Name: String) return Index_Type_With_Null is
   begin
      for I in Names.First_Index .. Names.Last_Index loop
         if Names.Element(I) = Name then
            return I;
         end if;
      end loop;
      return 0;
   end Idx;

   function Name(Names: Set; Index: Index_Type) return String is
   begin
      return Names.Element(Index);
   end Name;

end Set_Of_Names;

with Ada.Text_IO, Digraphs, Set_Of_Names, Ada.Command_Line;

procedure Toposort is

   -- shortcuts for package names, intantiation of generic package
   package TIO renames Ada.Text_IO;
   package DG renames Digraphs;
   package SN is new Set_Of_Names(DG.Node_Idx_With_Null);

   -- reat the graph from the file with the given Filename
   procedure Read(Filename: String; G: out DG.Graph_Type; N: out SN.Set) is

      -- finds the first word in S(Start .. S'Last), delimited by spaces
      procedure Find_Token(S: String; Start: Positive;
                           First: out Positive; Last: out Natural) is

      begin
         First := Start;
         while First <= S'Last and then S(First)= ' ' loop
            First := First + 1;
         end loop;
         Last := First-1;
         while Last < S'Last and then S(Last+1) /= ' ' loop
            Last := Last + 1;
         end loop;
      end Find_Token;

      File: TIO.File_Type;
   begin
      TIO.Open(File, TIO.In_File, Filename);
      TIO.Skip_Line(File, 2);
      -- the first two lines contain header and "===...==="
      while not TIO.End_Of_File(File) loop
         declare
            Line: String := TIO.Get_Line(File);
            First: Positive;
            Last: Natural;
            To, From: DG.Node_Index;
         begin
            Find_Token(Line, Line'First, First, Last);
            if Last >= First then
               N.Add(Line(First .. Last), From);
               G.Add_Node(From);
               loop
                  Find_Token(Line, Last+1, First, Last);
                  exit when Last < First;
                     N.Add(Line(First .. Last), To);
                     G.Add_Connection(From, To);
                  end loop;
            end if;
         end;
      end loop;
      TIO.Close(File);
   end Read;

   Graph: DG.Graph_Type;
   Names: SN.Set;

begin
   Read(Ada.Command_Line.Argument(1), Graph, Names);

   -- eliminat self-cycles
   for Start in 1 .. Graph.Node_Count loop
      Graph.Del_Connection(Start, Start);
   end loop;

   -- perform the topological sort and output the result
   declare
      Result:  DG.Node_Vec.Vector;
   begin
      Result := Graph.Top_Sort;
      for Index in Result.First_Index .. Result.Last_Index loop
         TIO.Put(Names.Name(Result.Element(Index)));
         if Index < Result.Last_Index then
            TIO.Put(" -> ");
         end if;
      end loop;
      TIO.New_Line;
   exception
      when DG.Graph_Is_Cyclic =>
         TIO.Put_Line("There is no topological sorting -- the Graph is cyclic!");
   end;
end Toposort;

The code is a function that performs a topological sort on a given set of VHDL libraries and their dependencies. It takes a file with library dependencies as input and returns a valid compile order of the libraries. The function also handles special cases such as self-dependencies, which are ignored, and un-orderable dependencies, which are flagged. The function uses Kahn's 1962 topological sort and depth-first search algorithms for sorting. If the dependencies are circular, the function indicates this in the output. The code also includes a package for directed graphs, representing nodes as positive numbers, and a feature for translating strings into numbers and vice versa.


with Ada.Strings.Fixed;  use Ada.Strings.Fixed;
with Ada.Text_IO;        use Ada.Text_IO;

procedure Match_Strings is
   S1 : constant String := "abcd";
   S2 : constant String := "abab";
   S3 : constant String := "ab";
begin
   if S1'Length >= S3'Length and then S1 (S1'First..S1'First + S3'Length - 1) = S3 then
      Put_Line (''' & S1 & "' starts with '" & S3 & ''');
   end if;
   if S2'Length >= S3'Length and then S2 (S2'Last - S3'Length + 1..S2'Last) = S3 then
      Put_Line (''' & S2 & "' ends with '" & S3 & ''');
   end if;
   Put_Line (''' & S3 & "' first appears in '" & S1 & "' at" & Integer'Image (Index (S1, S3)));
   Put_Line
   (  ''' & S3 & "' appears in '" & S2 & ''' &
      Integer'Image (Ada.Strings.Fixed.Count (S2, S3)) & " times"
   );
end Match_Strings;

The code checks if a given string starts with, contains, or ends with a second string. It also prints the location of the match and handles multiple occurrences of the second string within the first string.


with Ada.Text_IO;

procedure Puzzle_Square_4 is

   procedure Four_Rings (Low, High : in Natural; Unique, Show : in Boolean) is
      subtype Test_Range is Natural range Low .. High;

      type Value_List is array (Positive range <>) of Natural;
      function Is_Unique (Values : Value_List) return Boolean is
         Count : array (Test_Range) of Natural := (others => 0);
      begin
         for Value of Values loop
            Count (Value) := Count (Value) + 1;
            if Count (Value) > 1 then
               return False;
            end if;
         end loop;
         return True;
      end Is_Unique;

      function Is_Valid (A,B,C,D,E,F,G : in Natural) return Boolean is
         Ring_1 : constant Integer := A + B;
         Ring_2 : constant Integer := B + C + D;
         Ring_3 : constant Integer := D + E + F;
         Ring_4 : constant Integer := F + G;
      begin
         return
           Ring_1 = Ring_2 and
           Ring_1 = Ring_3 and
           Ring_1 = Ring_4;
      end Is_Valid;

      use Ada.Text_IO;
      Count : Natural := 0;
   begin
      for A in Test_Range loop
         for B in Test_Range loop
            for C in Test_Range loop
               for D in Test_Range loop
                  for E in Test_Range loop
                     for F in Test_Range loop
                        for G in Test_Range loop
                           if Is_Valid (A,B,C,D,E,F,G) then
                              if not Unique or (Unique and Is_Unique ((A,B,C,D,E,F,G))) then
                                 Count := Count + 1;
                                 if Show then
                                    Put_Line (A'Image & B'Image & C'Image & D'Image & E'Image & F'Image & G'Image);
                                 end if;
                              end if;
                           end if;
                        end loop;
                     end loop;
                  end loop;
               end loop;
            end loop;
         end loop;
      end loop;
      Put_Line ("There are " & Count'Image &
                  (if Unique then " unique " else " non-unique ") &
                    "solutions in " & Low'Image & " .." & High'Image);
      New_Line;
   end Four_Rings;

begin
   Four_Rings (Low => 1, High => 7, Unique => True,  Show => True);
   Four_Rings (Low => 3, High => 9, Unique => True,  Show => True);
   Four_Rings (Low => 0, High => 9, Unique => False, Show => False);
end Puzzle_Square_4;

The code finds all possible solutions for a 4-squares puzzle where each square sums up to the same total. It operates under two conditions: each letter representing a unique value between 1-7 and 3-9, and each letter representing a non-unique value between 0-9. The code also counts the number of non-unique solutions.


Library: SDLAda
with Ada.Numerics.Elementary_Functions;
with Ada.Calendar.Formatting;
with Ada.Calendar.Time_Zones;

with SDL.Video.Windows.Makers;
with SDL.Video.Renderers.Makers;
with SDL.Events.Events;

procedure Draw_A_Clock is
   use Ada.Calendar;
   use Ada.Calendar.Formatting;
   Window   : SDL.Video.Windows.Window;
   Renderer : SDL.Video.Renderers.Renderer;
   Event    : SDL.Events.Events.Events;
   Offset   : Time_Zones.Time_Offset;

   procedure Draw_Clock (Stamp : Time)
   is
      use SDL.C;
      use Ada.Numerics.Elementary_Functions;
      Radi : constant array (0 .. 59) of int := (0 | 15 | 30 | 45 => 2,
                                                 5 | 10 | 20 | 25 | 35 | 40 | 50 | 55 => 1,
                                                 others => 0);
      Diam : constant array (0 .. 59) of int := (0 | 15 | 30 | 45 => 5,
                                                 5 | 10 | 20 | 25 | 35 | 40 | 50 | 55 => 3,
                                                 others => 1);
      Width  : constant int   := Window.Get_Surface.Size.Width;
      Height : constant int   := Window.Get_Surface.Size.Height;
      Radius : constant Float := Float (int'Min (Width, Height));
      R_1    : constant Float := 0.48 * Radius;
      R_2    : constant Float := 0.35 * Radius;
      R_3    : constant Float := 0.45 * Radius;
      R_4    : constant Float := 0.47 * Radius;
      Hour   : constant Hour_Number   := Formatting.Hour   (Stamp, Offset);
      Minute : constant Minute_Number := Formatting.Minute (Stamp, Offset);
      Second : constant Second_Number := Formatting.Second (Stamp);

      function To_X (A : Float; R : Float) return int is
         (Width / 2 + int (R * Sin (A, 60.0)));

      function To_Y (A : Float; R : Float) return int is
         (Height / 2 - int (R * Cos (A, 60.0)));

   begin
      SDL.Video.Renderers.Makers.Create (Renderer, Window.Get_Surface);
      Renderer.Set_Draw_Colour ((0, 0, 150, 255));
      Renderer.Fill (Rectangle => (0, 0, Width, Height));
      Renderer.Set_Draw_Colour ((200, 200, 200, 255));
      for A in 0 .. 59 loop
         Renderer.Fill (Rectangle => (To_X (Float (A), R_1) - Radi (A),
                                      To_Y (Float (A), R_1) - Radi (A), Diam (A), Diam (A)));
      end loop;
      Renderer.Set_Draw_Colour ((200, 200, 0, 255));
      Renderer.Draw (Line => ((Width / 2, Height / 2),
                              (To_X (5.0 * (Float (Hour) + Float (Minute) / 60.0), R_2),
                               To_Y (5.0 * (Float (Hour) + Float (Minute) / 60.0), R_2))));
      Renderer.Draw (Line => ((Width / 2, Height / 2),
                              (To_X (Float (Minute) + Float (Second) / 60.0, R_3),
                               To_Y (Float (Minute) + Float (Second) / 60.0, R_3))));
      Renderer.Set_Draw_Colour ((220, 0, 0, 255));
      Renderer.Draw (Line => ((Width / 2, Height / 2),
                              (To_X (Float (Second), R_4),
                               To_Y (Float (Second), R_4))));
      Renderer.Fill (Rectangle => (Width / 2 - 3, Height / 2 - 3, 7, 7));
   end Draw_Clock;

   function Poll_Quit return Boolean is
      use type SDL.Events.Event_Types;
   begin
      while SDL.Events.Events.Poll (Event) loop
         if Event.Common.Event_Type = SDL.Events.Quit then
            return True;
         end if;
      end loop;
      return False;
   end Poll_Quit;

begin
   Offset := Time_Zones.UTC_Time_Offset;

   if not SDL.Initialise (Flags => SDL.Enable_Screen) then
      return;
   end if;

   SDL.Video.Windows.Makers.Create (Win      => Window,
                                    Title    => "Draw a clock",
                                    Position => SDL.Natural_Coordinates'(X => 10, Y => 10),
                                    Size     => SDL.Positive_Sizes'(300, 300),
                                    Flags    => SDL.Video.Windows.Resizable);
   loop
      Draw_Clock (Clock);
      Window.Update_Surface;
      delay 0.200;
      exit when Poll_Quit;
   end loop;

   Window.Finalize;
   SDL.Finalise;
end Draw_A_Clock;

draw a time-keeping device that updates every second, cycles periodically, and aligns with the system clock without overusing CPU resources. The code is simple, clear, and efficient.


WITH PRINTABLE_CALENDAR;

PROCEDURE REAL_CAL IS

   C: PRINTABLE_CALENDAR.CALENDAR := PRINTABLE_CALENDAR.INIT_132
     ((WEEKDAY_REP =>
          "MO TU WE TH FR SA SO",
       MONTH_REP   =>
         ("      JANUARY       ", "      FEBRUARY      ",
          "       MARCH        ", "       APRIL        ",
          "        MAY         ", "        JUNE        ",
          "        JULY        ", "       AUGUST       ",
          "      SEPTEMBER     ", "       OCTOBER      ",
          "      NOVEMBER      ", "      DECEMBER      ")
      ));

BEGIN
   C.PRINT_LINE_CENTERED("[SNOOPY]");
   C.NEW_LINE;
   C.PRINT(1969, "NINETEEN-SIXTY-NINE");
END REAL_CAL;

The code provides an algorithm that generates a printable calendar, formatted to fit a page that is 132 characters wide. The entire code is written in uppercase, inspired by the programming practices of the 1960s. The code does not include Snoopy generation, instead, it outputs a placeholder. The code is written in Ada and reuses the "PRINTABLE_CALENDAR" package from a previous calendar task. The output can be adjusted for 80-character devices by replacing "INIT_132" with "INIT_80".


with Ada.Text_IO;

procedure Pythagorean_Triples is

   type Large_Natural is range 0 .. 2**63-1;
     -- this is the maximum for gnat

   procedure New_Triangle(A, B, C: Large_Natural;
                          Max_Perimeter: Large_Natural;
                          Total_Cnt, Primitive_Cnt: in out Large_Natural) is
      Perimeter: constant Large_Natural := A + B + C;
   begin
      if Perimeter <= Max_Perimeter then
         Primitive_Cnt := Primitive_Cnt + 1;
         Total_Cnt     := Total_Cnt + Max_Perimeter / Perimeter;
         New_Triangle(A-2*B+2*C,     2*A-B+2*C,    2*A-2*B+3*C,   Max_Perimeter, Total_Cnt, Primitive_Cnt);
         New_Triangle(A+2*B+2*C,     2*A+B+2*C,    2*A+2*B+3*C,   Max_Perimeter, Total_Cnt, Primitive_Cnt);
         New_Triangle(2*B+2*C-A,     B+2*C-2*A,    2*B+3*C-2*A,   Max_Perimeter, Total_Cnt, Primitive_Cnt);
      end if;
   end New_Triangle;

   T_Cnt, P_Cnt: Large_Natural;

begin
   for I in 1 .. 9 loop
      T_Cnt := 0;
      P_Cnt := 0;
      New_Triangle(3,4,5, 10**I, Total_Cnt => T_Cnt, Primitive_Cnt => P_Cnt);
      Ada.Text_IO.Put_Line("Up to 10 **" & Integer'Image(I) & " :" &
                             Large_Natural'Image(T_Cnt) & " Triples," &
                             Large_Natural'Image(P_Cnt) & " Primitives");
   end loop;
end Pythagorean_Triples;

Up to 10 ** 1 : 0 Triples, 0 Primitives
Up to 10 ** 2 : 17 Triples, 7 Primitives
Up to 10 ** 3 : 325 Triples, 70 Primitives
Up to 10 ** 4 : 4858 Triples, 703 Primitives
Up to 10 ** 5 : 64741 Triples, 7026 Primitives
Up to 10 ** 6 : 808950 Triples, 70229 Primitives
Up to 10 ** 7 : 9706567 Triples, 702309 Primitives
Up to 10 ** 8 : 113236940 Triples, 7023027 Primitives
Up to 10 ** 9 : 1294080089 Triples, 70230484 Primitives

The code calculates the number of Pythagorean triples with a perimeter not exceeding 100, as well as the number of these triples that are primitive. It also has the capability to handle larger perimeter values up to 100,000,000. The Pythagorean triples are sets of three positive integers that satisfy the condition a^2 + b^2 = c^2 and a < b < c. A triple is considered primitive if the greatest common divisor of any two numbers is 1. The code uses an efficient algorithm to deliver results in a timely manner.


Library: GTK
Library: GtkAda
Uses: GtkAda (Components:{{#foreach: component$n$|{{{component$n$}}}Property "Uses library" (as page type) with input value "library/GtkAda/{{{component$n$}}}" contains invalid characters or is incomplete and therefore can cause unexpected results during a query or annotation process., }})
with Gtk.Window;  use Gtk.Window;
with Gtk.Widget;  use Gtk.Widget;

with Gtk.Handlers;
with Gtk.Main;

procedure Windowed_Application is
   Window : Gtk_Window;

   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;

begin
   Gtk.Main.Init;
   Gtk.Window.Gtk_New (Window);
   Return_Handlers.Connect
   (  Window,
      "delete_event",
      Return_Handlers.To_Marshaller (Delete_Event'Access)
   );
   Handlers.Connect
   (  Window,
      "destroy",
      Handlers.To_Marshaller (Destroy'Access)
   );
   Show (Window);

   Gtk.Main.Main;
end Windowed_Application;

"Creates an empty GUI window that can respond to close requests."


with Ada.Text_IO;

procedure Letter_Frequency is
   Counters: array (Character) of Natural := (others => 0); -- initialize all Counters to 0
   C:        Character;
   File:     Ada.Text_IO.File_Type;

begin
   Ada.Text_IO.Open(File, Mode => Ada.Text_IO.In_File, Name => "letter_frequency.adb");
   while not Ada.Text_IO.End_Of_File(File) loop
      Ada.Text_IO.Get(File, C);
      Counters(C) := Counters(C) + 1;
   end loop;

   for I in Counters'Range loop
      if Counters(I) > 0 then
            Ada.Text_IO.Put_Line("'" & I & "':" & Integer'Image(Counters(I)));
      end if;
   end loop;
end Letter_Frequency;

Open a text file, count the frequency of each letter, and differentiate between counting all characters or only letters A to Z.


type Link;
type Link_Access is access Link;
type Link is record
   Next : Link_Access := null;
   Data : Integer;
end record;

define a data structure for a singly-linked list element. This element contains a data member for storing a numeric value and a mutable link to the next element in the list.


Library: SDLAda
with Ada.Numerics.Elementary_Functions;

with SDL.Video.Windows.Makers;
with SDL.Video.Renderers.Makers;
with SDL.Video.Rectangles;
with SDL.Events.Events;

procedure Fractal_Tree is

   Width   : constant := 600;
   Height  : constant := 600;
   Level   : constant := 13;
   Length  : constant := 130.0;
   X_Start : constant := 475.0;
   Y_Start : constant := 580.0;
   A_Start : constant := -1.54;
   Angle_1 : constant := 0.10;
   Angle_2 : constant := 0.35;
   C_1     : constant := 0.71;
   C_2     : constant := 0.87;

   Window   : SDL.Video.Windows.Window;
   Renderer : SDL.Video.Renderers.Renderer;
   Event    : SDL.Events.Events.Events;

   procedure Draw_Tree (Level  : in Natural;
                        Length : in Float;
                        Angle  : in Float;
                        X, Y   : in Float)
   is
      use SDL;
      use Ada.Numerics.Elementary_Functions;
      Pi   : constant       := Ada.Numerics.Pi;
      X_2  : constant Float := X + Length * Cos (Angle, 2.0 * Pi);
      Y_2  : constant Float := Y + Length * Sin (Angle, 2.0 * Pi);
      Line : constant SDL.Video.Rectangles.Line_Segment
        := ((C.int (X), C.int (Y)), (C.int (X_2), C.int (Y_2)));
   begin
      if Level > 0 then
         Renderer.Set_Draw_Colour (Colour => (0, 220, 0, 255));
         Renderer.Draw (Line => Line);

         Draw_Tree (Level - 1, C_1 * Length, Angle + Angle_1, X_2, Y_2);
         Draw_Tree (Level - 1, C_2 * Length, Angle - Angle_2, X_2, Y_2);
      end if;
   end Draw_Tree;

   procedure Wait is
      use type SDL.Events.Event_Types;
   begin
      loop
         while SDL.Events.Events.Poll (Event) loop
            if Event.Common.Event_Type = SDL.Events.Quit then
               return;
            end if;
         end loop;
         delay 0.100;
      end loop;
   end Wait;

begin
   if not SDL.Initialise (Flags => SDL.Enable_Screen) then
      return;
   end if;

   SDL.Video.Windows.Makers.Create (Win      => Window,
                                    Title    => "Fractal tree",
                                    Position => SDL.Natural_Coordinates'(X => 10, Y => 10),
                                    Size     => SDL.Positive_Sizes'(Width, Height),
                                    Flags    => 0);
   SDL.Video.Renderers.Makers.Create (Renderer, Window.Get_Surface);
   Renderer.Set_Draw_Colour ((0, 0, 0, 255));
   Renderer.Fill (Rectangle => (0, 0, Width, Height));

   Draw_Tree (Level, Length, A_Start, X_Start, Y_Start);
   Window.Update_Surface;

   Wait;
   Window.Finalize;
   SDL.Finalise;
end Fractal_Tree;

generate and draw a fractal tree by first drawing the trunk, then splitting the trunk at the end by a certain angle to form two branches, and repeating this process until a desired level of branching is reached.


with Ada.Text_IO;
with Ada.Command_Line;
procedure Factors is
   Number  : Positive;
   Test_Nr : Positive := 1;
begin
   if Ada.Command_Line.Argument_Count /= 1 then
      Ada.Text_IO.Put (Ada.Text_IO.Standard_Error, "Missing argument!");
      Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
      return;
   end if;
   Number := Positive'Value (Ada.Command_Line.Argument (1));
   Ada.Text_IO.Put ("Factors of" & Positive'Image (Number) & ": ");
   loop
      if Number mod Test_Nr = 0 then
         Ada.Text_IO.Put (Positive'Image (Test_Nr) & ",");
      end if;
      exit when Test_Nr ** 2 >= Number;
      Test_Nr := Test_Nr + 1;
   end loop;
   Ada.Text_IO.Put_Line (Positive'Image (Number) & ".");
end Factors;

compute the factors of a given positive integer, excluding zero and negative numbers. The factors are the positive integers that can divide the input number to yield a positive integer. For prime numbers, the factors are 1 and the number itself.


Library: Simple components for Ada
with Ada.Characters.Latin_1;  use Ada.Characters.Latin_1;
with Ada.Text_IO;             use Ada.Text_IO;
with Strings_Edit;            use Strings_Edit;

procedure Column_Aligner is
   Text : constant String :=
      "Given$a$text$file$of$many$lines,$where$fields$within$a$line$" & NUL &
      "are$delineated$by$a$single$'dollar'$character,$write$a$program" & NUL &
      "that$aligns$each$column$of$fields$by$ensuring$that$words$in$each$" & NUL &
      "column$are$separated$by$at$least$one$space." & NUL &
      "Further,$allow$for$each$word$in$a$column$to$be$either$left$" & NUL &
      "justified,$right$justified,$or$center$justified$within$its$column." & NUL;
   File    : File_Type;
   Width   : array (1..1_000) of Natural := (others => 0);
   Line    : String (1..200);
   Column  : Positive := 1;
   Start   : Positive := 1;
   Pointer : Positive;
begin
   Create (File, Out_File, "columned.txt");
      -- Determining the widths of columns
   for I in Text'Range loop
      case Text (I) is
         when '$' | NUL =>
            Width (Column) := Natural'Max (Width (Column), I - Start + 1);
            Start  := I + 1;
            if Text (I) = NUL then
               Column := 1;
            else
               Column := Column + 1;
            end if;
         when others =>
            null;
      end case;
   end loop;
      -- Formatting
   for Align in Alignment loop
      Column  := 1;
      Start   := 1;
      Pointer := 1;
      for I in Text'Range loop
         case Text (I) is
            when '$' | NUL =>
               Put -- Formatted output of a word
               (  Destination => Line,
                  Pointer     => Pointer,
                  Value       => Text (Start..I - 1),
                  Field       => Width (Column),
                  Justify     => Align
               );
               Start  := I + 1;
               if Text (I) = NUL then
                  Put_Line (File, Line (1..Pointer - 1));
                  Pointer := 1;
                  Column := 1;
               else
                  Column := Column + 1;
               end if;
            when others =>
               null;
         end case;
      end loop;
   end loop;
   Close (File);
end Column_Aligner;

Given      a          text       file   of     many      lines,     where    fields  within  a      line
are        delineated by         a      single 'dollar'  character, write    a       program
that       aligns     each       column of     fields    by         ensuring that    words   in     each
column     are        separated  by     at     least     one        space.
Further,   allow      for        each   word   in        a          column   to      be      either left
justified, right      justified, or     center justified within     its      column.
      Given          a       text   file     of      many     lines,    where  fields  within      a line
        are delineated         by      a single  'dollar' character,    write       a program
       that     aligns       each column     of    fields         by ensuring    that   words     in each
     column        are  separated     by     at     least        one   space.
   Further,      allow        for   each   word        in          a   column      to      be either left
 justified,      right justified,     or center justified     within      its column.
   Given        a        text     file    of      many     lines,     where   fields  within    a   line
    are    delineated     by        a   single  'dollar' character,   write     a    program
   that      aligns      each    column   of     fields      by     ensuring   that   words    in   each
  column       are     separated   by     at     least       one     space.
 Further,     allow       for     each   word      in         a      column     to      be   either left
justified,    right   justified,   or   center justified   within      its   column.

The code reads a text file where fields within a line are separated by a dollar character. It aligns each column of fields by ensuring at least one space between words in each column. It also allows for words in a column to be left justified, right justified, or center justified. The code disregards trailing dollar characters, consecutive spaces at the end of lines, and does not require separating characters between or around columns. The minimum space between columns is computed from the text.


with Ada.Text_IO;

procedure Main is
   type Char_Matrix is
     array (Positive range <>, Positive range <>) of Character;

   function Create_Cuboid
     (Width, Height, Depth : Positive)
      return                 Char_Matrix
   is
      Result : Char_Matrix (1 .. Height + Depth + 3,
         1 .. 2 * Width + Depth + 3) := (others => (others => ' '));
   begin
      -- points
      Result (1, 1)                                      := '+';
      Result (Height + 2, 1)                             := '+';
      Result (1, 2 * Width + 2)                          := '+';
      Result (Height + 2, 2 * Width + 2)                 := '+';
      Result (Height + Depth + 3, Depth + 2)             := '+';
      Result (Depth + 2, 2 * Width + Depth + 3)          := '+';
      Result (Height + Depth + 3, 2 * Width + Depth + 3) := '+';
      -- width lines
      for I in 1 .. 2 * Width loop
         Result (1, I + 1)                          := '-';
         Result (Height + 2, I + 1)                 := '-';
         Result (Height + Depth + 3, Depth + I + 2) := '-';
      end loop;
      -- height lines
      for I in 1 .. Height loop
         Result (I + 1, 1)                             := '|';
         Result (I + 1, 2 * Width + 2)                 := '|';
         Result (Depth + I + 2, 2 * Width + Depth + 3) := '|';
      end loop;
      -- depth lines
      for I in 1 .. Depth loop
         Result (Height + 2 + I, 1 + I)             := '/';
         Result (1 + I, 2 * Width + 2 + I)          := '/';
         Result (Height + 2 + I, 2 * Width + 2 + I) := '/';
      end loop;
      return Result;
   end Create_Cuboid;

   procedure Print_Cuboid (Width, Height, Depth : Positive) is
      Cuboid : Char_Matrix := Create_Cuboid (Width, Height, Depth);
   begin
      for Row in reverse Cuboid'Range (1) loop
         for Col in Cuboid'Range (2) loop
            Ada.Text_IO.Put (Cuboid (Row, Col));
         end loop;
         Ada.Text_IO.New_Line;
      end loop;
   end Print_Cuboid;
begin
   Print_Cuboid (2, 3, 4);
end Main;

generate a graphical or ASCII art representation of a cuboid with dimensions 2x3x4, ensuring three faces are visible, using either static or rotational projection. A single width unit in ASCII art is represented by two characters long ('--').


with Ada.Text_IO.Text_Streams; use Ada.Text_IO.Text_Streams;
with Ada.Strings.Maps; use Ada.Strings.Maps;
with Ada.Command_Line; use Ada.Command_Line;

procedure Rot_13 is

   From_Sequence : Character_Sequence := "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ";
   Result_Sequence : Character_Sequence := "nopqrstuvwxyzabcdefghijklmNOPQRSTUVWXYZABCDEFGHIJKLM";
   Rot_13_Mapping : Character_Mapping := To_Mapping(From_Sequence, Result_Sequence);

   In_Char : Character;
   Stdio : Stream_Access := Stream(Ada.Text_IO.Standard_Input);
   Stdout : Stream_Access := Stream(Ada.Text_Io.Standard_Output);
   Input : Ada.Text_Io.File_Type;

begin
   if Argument_Count > 0 then
      for I in 1..Argument_Count loop
         begin
            Ada.Text_Io.Open(File => Input, Mode => Ada.Text_Io.In_File, Name => Argument(I));
            Stdio := Stream(Input);
             while not Ada.Text_Io.End_Of_File(Input) loop
               In_Char :=Character'Input(Stdio);
               Character'Output(Stdout, Value(Rot_13_Mapping, In_Char));
            end loop;
            Ada.Text_IO.Close(Input);
         exception
            when Ada.Text_IO.Name_Error =>
               Ada.Text_Io.Put_Line(File => Ada.Text_Io.Standard_Error, Item => "File " & Argument(I) & " is not a file.");
            when Ada.Text_Io.Status_Error =>
               Ada.Text_Io.Put_Line(File => Ada.Text_Io.Standard_Error, Item => "File " & Argument(I) & " is already opened.");
         end;
      end loop;
   else
      while not Ada.Text_Io.End_Of_File loop
         In_Char :=Character'Input(Stdio);
         Character'Output(Stdout, Value(Rot_13_Mapping, In_Char));
      end loop;
   end if;
end Rot_13;

implement a rot-13 function that replaces every letter of the ASCII alphabet with the letter which is "rotated" 13 characters around the 26 letter alphabet. The function should work on both upper and lower case letters, preserve case, and pass all non-alphabetic characters without alteration. Optionally, the function can be wrapped in a utility program that performs rot-13 encoding line-by-line for every line of input in each file listed on its command line or acts as a filter on its standard input.


with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Text_IO;           use Ada.Text_IO;

with Ada.Containers.Generic_Array_Sort;

procedure Demo_Array_Sort is

   function "+" (S : String) return Unbounded_String renames To_Unbounded_String;

   type A_Composite is
      record
         Name  : Unbounded_String;
         Value : Unbounded_String;
      end record;

   function "<" (L, R : A_Composite) return Boolean is
   begin
      return L.Name < R.Name;
   end "<";

   procedure Put_Line (C : A_Composite) is
   begin
      Put_Line (To_String (C.Name) & " " & To_String (C.Value));
   end Put_Line;

   type An_Array is array (Natural range <>) of A_Composite;

   procedure Sort is new Ada.Containers.Generic_Array_Sort (Natural, A_Composite, An_Array);

   Data : An_Array := (1 => (Name => +"Joe",    Value => +"5531"),
                       2 => (Name => +"Adam",   Value => +"2341"),
                       3 => (Name => +"Bernie", Value => +"122"),
                       4 => (Name => +"Walter", Value => +"1234"),
                       5 => (Name => +"David",  Value => +"19"));

begin
   Sort (Data);
   for I in Data'Range loop
      Put_Line (Data (I));
   end loop;
end Demo_Array_Sort;

  C:\Ada\sort_composites\lib\demo_array_sort
  Adam 2341
  Bernie 122
  David 19
  Joe 5531
  Walter 1234

with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Text_IO;           use Ada.Text_IO;

with Ada.Containers.Ordered_Sets;

procedure Sort_Composites is

   function "+" (S : String) return Unbounded_String renames To_Unbounded_String;

   type A_Composite is
      record
         Name  : Unbounded_String;
         Value : Unbounded_String;
      end record;

   function "<" (L, R : A_Composite) return Boolean is
   begin
      return L.Name < R.Name;
   end "<";

   procedure Put_Line (C : A_Composite) is
   begin
      Put_Line (To_String (C.Name) & " " & To_String (C.Value));
   end Put_Line;

   package Composite_Sets is new Ada.Containers.Ordered_Sets (A_Composite);

   procedure Put_Line (C : Composite_Sets.Cursor) is
   begin
      Put_Line (Composite_Sets.Element (C));
   end Put_Line;

   Data : Composite_Sets.Set;

begin
   Data.Insert (New_Item => (Name => +"Joe",    Value => +"5531"));
   Data.Insert (New_Item => (Name => +"Adam",   Value => +"2341"));
   Data.Insert (New_Item => (Name => +"Bernie", Value => +"122"));
   Data.Insert (New_Item => (Name => +"Walter", Value => +"1234"));
   Data.Insert (New_Item => (Name => +"David",  Value => +"19"));
   Data.Iterate (Put_Line'Access);
end Sort_Composites;

  C:\Ada\sort_composites\lib\sort_composites
  Adam 2341
  Bernie 122
  David 19
  Joe 5531
  Walter 1234

with Ada.Text_Io;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;

procedure Sort_Composite is
   type Composite_Record is record
      Name : Unbounded_String;
      Value : Unbounded_String;
   end record;

   type Pairs_Array is array(Positive range <>) of Composite_Record;

   procedure Swap(Left, Right : in out Composite_Record) is
      Temp : Composite_Record := Left;
   begin
      Left := Right;
      Right := Temp;
   end Swap;

   -- Sort_Names uses a bubble sort

   procedure Sort_Name(Pairs : in out Pairs_Array) is
      Swap_Performed : Boolean := True;
   begin
      while Swap_Performed loop
         Swap_Performed := False;
         for I in Pairs'First..(Pairs'Last - 1) loop
            if Pairs(I).Name > Pairs(I + 1).Name then
               Swap (Pairs(I), Pairs(I + 1));
               Swap_Performed := True;
            end if;
         end loop;
      end loop;
   end Sort_Name;

   procedure Print(Item : Pairs_Array) is
   begin
      for I in Item'range loop
         Ada.Text_Io.Put_Line(To_String(Item(I).Name) & ", " &
            to_String(Item(I).Value));
      end loop;
   end Print;
   type Names is (Fred, Barney, Wilma, Betty, Pebbles);
   type Values is (Home, Work, Cook, Eat, Bowl);
   My_Pairs : Pairs_Array(1..5);
begin
   for I in My_Pairs'range loop
      My_Pairs(I).Name := To_Unbounded_String(Names'Image(Names'Val(Integer(I - 1))));
      My_Pairs(I).Value := To_Unbounded_String(Values'Image(Values'Val(Integer(I - 1))));
   end loop;
   Print(My_Pairs);
   Ada.Text_Io.Put_Line("=========================");
   Sort_Name(My_Pairs);
   Print(My_Pairs);
end Sort_Composite;

define a composite structure named pair with two string properties: name and value. It also creates an array of such pairs. Then, it sorts this array by the key 'name' using a custom comparator. In Ada 2005, it uses standard subprograms for sorting both constrained and unconstrained arrays. It also provides ordered containers, eliminating the need for explicit sorting calls. For Ada 95, a simple bubble sort function is implemented as there is no standard sort function.


for I in 1..5 loop
   for J in 1..I loop
      Put("*");
   end loop;
   New_Line;
end loop;

demonstrate how to use nested for loops to print a specific pattern. The number of iterations in the inner loop is controlled by the outer loop, resulting in a pattern of increasing asterisks.


Works with: GNAT version GPL 2007
with Ada.Containers.Ordered_Maps;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Text_IO;

procedure Associative_Array is

   -- Instantiate the generic package Ada.Containers.Ordered_Maps

   package Associative_Int is new Ada.Containers.Ordered_Maps(Unbounded_String, Integer);
   use Associative_Int;

   Color_Map : Map;
   Color_Cursor : Cursor;
   Success : Boolean;
   Value : Integer;
begin

   -- Add values to the ordered map

   Color_Map.Insert(To_Unbounded_String("Red"), 10, Color_Cursor, Success);
   Color_Map.Insert(To_Unbounded_String("Blue"), 20, Color_Cursor, Success);
   Color_Map.Insert(To_Unbounded_String("Yellow"), 5, Color_Cursor, Success);

   -- retrieve values from the ordered map and print the value and key
   -- to the screen

   Value := Color_Map.Element(To_Unbounded_String("Red"));
   Ada.Text_Io.Put_Line("Red:" & Integer'Image(Value));
   Value := Color_Map.Element(To_Unbounded_String("Blue"));
   Ada.Text_IO.Put_Line("Blue:" & Integer'Image(Value));
   Value := Color_Map.Element(To_Unbounded_String("Yellow"));
   Ada.Text_IO.Put_Line("Yellow:" & Integer'Image(Value));
end Associative_Array;

"Create an associative array, also known as a dictionary, map, or hash."