http://www.adaconcept.com/programs/gyerekcsomagos/szamrendszerek-vegyes_alapu_szamrendszer.adb
-- with Ada.Text_IO; -- teszteleshez
with Szamrendszerek.Szamabrazolas;
package body Szamrendszerek.Vegyes_Alapu_Szamrendszer is
function Letrehoz(Alapok : Alap_Tomb_Tipus) return Vegyes_Alapu_Szam_Tipus is
Vissza : Vegyes_Alapu_Szam_Tipus;
begin
-- Ada.Text_IO.Put_Line("Letrehoz indul"); -- szandekosan a kodban hagyott kommnet
Vissza.Abrazolas.Szamrendszerek := new Implementacios_Reszletek.Szamrendszerek_Tomb_Tipus'(Implementacios_Reszletek.Szamrendszerek_Tomb_Tipus(Alapok)); --| a ket letrehozott tomb index tartomanya azonos kell legyen!
Vissza.Abrazolas.Szamjegyek := new Implementacios_Reszletek.Szamjegyek_Tomb_Tipus'(Alapok'Range => 0); --|
-- Ada.Text_IO.Put_Line("Letrehoz vege"); -- szandekosan a kodban hagyott komment
return Vissza;
-- limited Vegyes_Alapu_Szam_Tipus eseten Ada 2005 -tol : kiterjesztett return utasitas
-- return Vissza : Vegyes_Alapu_Szam_Tipus do
-- Vissza.Abrazolas.Szamrendszerek := new Implementacios_Reszletek.Szamrendszerek_Tomb_Tipus'(Implementacios_Reszletek.Szamrendszerek_Tomb_Tipus(Alapok));
-- Vissza.Abrazolas.Szamjegyek := new Implementacios_Reszletek.Szamjegyek_Tomb_Tipus'(Alapok'Range => 0);
-- end return;
end Letrehoz;
procedure Letrehoz(Szam : in out Vegyes_Alapu_Szam_Tipus; Alapok : Alap_Tomb_Tipus) is
begin
Szam := Letrehoz(Alapok);
end Letrehoz;
procedure Beallit(Szam : in out Vegyes_Alapu_Szam_Tipus; Ertek : Szamjegyek_Tomb_Tipus) is -- FONTOS! Warning -ot kaphatunk a Szam -ra (a kesobbiekben visszaterunk erre)
use type Implementacios_Reszletek.Szamjegyek_Tomb_Mutato_Tipus;
function Ertekul_Adhato(Szam : in Vegyes_Alapu_Szam_Tipus; Ertek : Szamjegyek_Tomb_Tipus) return Boolean is
Vissza : Boolean := True;
begin
for i in Szam.Abrazolas.Szamjegyek'Range loop
if Ertek(i) not in 0 .. Szam.Abrazolas.Szamrendszerek(i) - 1 then
Vissza := False;
end if;
end loop;
return Vissza;
end Ertekul_Adhato;
begin
if Szam.Abrazolas.Szamjegyek /= null and then (Szam.Abrazolas.Szamjegyek.all'First = Ertek'First and Szam.Abrazolas.Szamjegyek.all'Last = Ertek'Last) then
if Ertekul_Adhato(Szam, Ertek) then
Szam.Abrazolas.Szamjegyek.all := Implementacios_Reszletek.Szamjegyek_Tomb_Tipus(Ertek);
else
raise Ertekadas_Hiba;
end if;
else
raise Ertekadas_Hiba;
end if;
end Beallit;
procedure Egyet_Hozzaad(Szam : in out Vegyes_Alapu_Szam_Tipus; Hanyadik_Indexu_Helyierteken : in out Natural) is
h : Natural; -- az aktualis helyierteket mutatja
Jegyek : Implementacios_Reszletek.Szamjegyek_Tomb_Tipus renames Szam.Abrazolas.Szamjegyek.all; -- az aktualis szamjegy
Alapok : Implementacios_Reszletek.Szamrendszerek_Tomb_Tipus renames Szam.Abrazolas.Szamrendszerek.all;
Van_Atvitel : Boolean;
begin
-- Csak abban az esetben tortenjen meg a noveles, ha a Szam valtozo nem csordult tul
if not Szam.Abrazolas.Tulcsordult then
-- egy hasznos technika egy adott indexre allashoz...
h := Jegyek'First;
for i in 1 .. Hanyadik_Indexu_Helyierteken loop
if Natural'Succ(h) in Jegyek'Range then
h := Natural'Succ(h); -- altalanos megoldas...
end if;
end loop;
Van_Atvitel := False;
loop
if Jegyek(h) < Alapok(h) - 1 then
Van_Atvitel := False;
Jegyek(h) := Jegyek(h) + 1;
else
Van_Atvitel := True;
Jegyek(h) := 0;
h := h + 1;
end if;
exit when not Van_Atvitel or h > Jegyek'Last;
end loop;
if h > Jegyek'Last then
Szam.Abrazolas.Tulcsordult := True;
-- Ada.Text_IO.Put_Line("TULCSORDULAS"); -- tesztelest segito komment
end if;
else
raise Tulcsordult_Szam_Novelese_Hiba;
end if;
Hanyadik_Indexu_Helyierteken := h;
end Egyet_Hozzaad;
procedure Hozzaad(Szam : in out Vegyes_Alapu_Szam_Tipus; Mennyit : Natural := 1; Hanyadik_Indexu_Helyierteken : Natural := 0) is
h : Natural;
begin
for i in 1..Mennyit loop
h := Hanyadik_Indexu_Helyierteken;
Egyet_Hozzaad(Szam, h);
end loop;
end Hozzaad;
procedure Novel(Szam : in out Vegyes_Alapu_Szam_Tipus; Hanyadik_Indexu_Helyierteken : in out Natural; Mennyivel : Natural := 1) is
begin
for i in 1..Mennyivel loop
Egyet_Hozzaad(Szam, Hanyadik_Indexu_Helyierteken);
end loop;
end Novel;
function Legmagasabb_Helyiertek_Indexe(Szam : Vegyes_Alapu_Szam_Tipus) return Natural is
begin
return Szam.Abrazolas.Szamjegyek'Last;
end Legmagasabb_Helyiertek_Indexe;
function Tulcsordulas(Szam : Vegyes_Alapu_Szam_Tipus) return Boolean is
begin
return Szam.Abrazolas.Tulcsordult;
end Tulcsordulas;
function Image(Szam : Vegyes_Alapu_Szam_Tipus) return String is -- nem hasznalunk Unbounded_String -et
Jegyek : Szamjegyek_Tomb_Tipus := Szamjegyek(Szam);
-- Rekurziv
function Rekurzivan_Stringge_Alakitva_Hozzafuz(Mihez : String; Mit : Szamjegyek_Tomb_Tipus) return string is
begin
if Mit'Length > 0 then
return Rekurzivan_Stringge_Alakitva_Hozzafuz(Mihez => Mihez & "(" & Natural 'Image(Mit(Mit'Last))(2..Natural 'Image(Mit(Mit'Last))'Last) & ")",
Mit => Mit(Mit'First .. Natural'Pred(Mit'Last)));
else
-- rekurzio vege
return Mihez;
end if;
end Rekurzivan_Stringge_Alakitva_Hozzafuz;
begin
-- trukk
declare
Vissza : String := Rekurzivan_Stringge_Alakitva_Hozzafuz(Mihez => "",
Mit => Vegyes_Alapu_Szamrendszer.Szamjegyek_Tomb_Tipus (Szam.Abrazolas.Szamjegyek.all ) ); -- a stringunk 1 -tol lesz indexelve
begin
return Vissza;
end;
end Image;
function Szamjegyek(Szam : Vegyes_Alapu_Szam_Tipus) return Szamjegyek_Tomb_Tipus is
begin
return Vegyes_Alapu_Szamrendszer.Szamjegyek_Tomb_Tipus( Szam.Abrazolas.Szamjegyek.all );
end Szamjegyek;
end Szamrendszerek.Vegyes_Alapu_Szamrendszer;