________________________________________________1
{ Iteracyjna realizacja algorytmu zamiany liczby dziesietnej na postac binarna }
program 10_2_i;
var
 dziesietna:longint;
 binarna:string;
begin
 Write('Podaj liczbe dziesietna: ');
 ReadLn(dziesietna);
 binarna:='';
 while dziesietna>0 do
 begin
  binarna:=Chr(dziesietna mod 2 + Ord('0')) + binarna;
  dziesietna:=dziesietna div 2;
 end;
 WriteLn(dziesietna,' = ',binarna,'B');
end.
________________________________________________2

{Rekurencyjna realizacja algorytmu zamiany liczby dziesietnej na postac binarna ***program poprawiony***}

program 10_2_r;

var

dziesietna:longint;

binarna:string;

procedure CyfraBinarna(dzies:longint);

begin

if dzies>0 then

begin

binarna:=Chr(dzies mod 2 + Ord('0')) + binarna;

CyfraBinarna(dzies div 2);

end

end;

begin

Write('Podaj liczbe dziesietna ');

ReadLn(dziesietna);

binarna:='';

CyfraBinarna(dziesietna);

WriteLn(dziesietna,' = ',binarna,'B');

end.

________________________________________________3
{ Zamiana liczb z systemu szesnastkowego i odwrotnie }
program 16_10_16;
var
 dziesietna:longint;
 szesnastkowa:string;

(* Funkcja podaje wartosc pojedynczej cyfry szesnastkowej *)
function H2D(hex:char):byte;
begin
 hex:=UpCase(hex);         (* Zamiana na wielka litere *)
 case hex of
  '0'..'9': H2D:=Ord(hex) - Ord('0');
  'A'..'F': H2D:=Ord(hex) - Ord('A') + 10;
 end;
end;

(* Funkcja zamienia liczbe dziesietna na cyfre szesnastkowa *)
function D2H(dec:byte):char;
begin
 case dec of
  0..9:  D2H:=Chr(dec + Ord('0'));
  10..15: D2H:=Chr(dec + Ord('A') - 10);
  else  D2H:=' ';
 end;
end;

function Hex2Dec(hex:string):longint;
var
 i:integer;
 wartosc:longint;
begin
 wartosc:=0;
 for i:=1 to Length(hex) do
  wartosc:=wartosc * 16 + H2D(hex[i]);
 Hex2Dec:=wartosc;
end;

function Dec2Hex(dec:longint):string;
var
 wartosc:string;
begin
 wartosc:='';
 while dec>0 do
 begin
  wartosc:=D2H(dec mod 16) + wartosc;
  dec:=dec div 16;
 end;
 Dec2Hex:=wartosc;
end;

begin
 Write('Podaj liczbe dziesietna: ');
 ReadLn(dziesietna);
 WriteLn(dziesietna,' = ',Dec2Hex(dziesietna),'H');
 Write('Podaj liczbe szesnastkowa: ');
 ReadLn(szesnastkowa);
 WriteLn(szesnastkowa,'H = ',Hex2Dec(szesnastkowa));
end.
________________________________________________4
{ Obliczanie wartosci dziesietnej liczby dwojkowej }

(*
** UWAGA:
**  program nie sprawdza poprawnosci wprowadzanych danych
*)
program 2_10;
var
 binarna:string;
 potega:longint;
 dziesietna:longint;
 i:integer;

begin
 Write('Podaj liczbe binarna: ');
 ReadLn(binarna);
 dziesietna:=0;
 potega:=1;
 for i:=Length(binarna) downto 1 do
 begin
  dziesietna:=dziesietna+(Ord(binarna[i])-Ord('0'))*potega;
  potega:=potega*2;
 end;
 WriteLn(binarna,'B = ',dziesietna);
end.
________________________________________________5
{ Sortowanie babelkowe }
program Babelki;
const
 MAX_DANYCH=100;
type
 TDane=array [1..MAX_DANYCH] of integer;
var
 MojeDane:TDane;

procedure WprowadzDane(var d:TDane);
var
 i:integer;
begin
 for i:=1 to MAX_DANYCH do
 begin
  Write('Podaj element nr ',i,': ');
  ReadLn(d[i]);
 end;
end;

procedure WyprowadzDane(var d:TDane);
var
 i:integer;
begin
 for i:=1 to MAX_DANYCH do
  Write(d[i]:8);
 WriteLn;
end;

procedure LosujDane(var d:TDane);
var
 i:integer;
begin
 for i:=1 to MAX_DANYCH do
  d[i]:=Random(MaxInt);
end;

procedure ZamienZmienne(var a,b:integer);
var
 t:integer;
begin
 t:=a;
 a:=b;
 b:=t;
end;

procedure SortujBabelkowo(var d:TDane);
var
 i,j:integer;
 zamiana:boolean;
begin
 i:=MAX_DANYCH-1;
 repeat
  zamiana:=FALSE;   (* Czy byla jakas zamiana? - w tym przebiegu nie *)
  for j:=1 to i do
   if d[j]<d[j+1] then
   begin
    ZamienZmienne(d[j],d[j+1]);
    zamiana:=TRUE;
   end;
  i:=i-1;
 until not zamiana; (* Az nie bedzie zadnej zamiany *)
end;

begin
 Randomize;
 LosujDane(MojeDane);
 WriteLn('Dane przed posortowaniem:');
 WyprowadzDane(MojeDane);
 WriteLn('Dane po posortowaniu:');
 SortujBabelkowo(MojeDane);
 WyprowadzDane(MojeDane);
end.
________________________________________________6
{ Algorytm przeszukiwania binarnego }
{ - zastosowanie metody "dziel i zwyciezaj" }
program Przeszukiwanie_binarne;
const
 LICZBA_DANYCH=100;
type
 TDane=array [1..LICZBA_DANYCH] of integer;
var
 MojeDane:TDane;
 x:integer;
 indeks:integer;

procedure WyprowadzDane(var d:TDane);
var
 i:integer;
begin
 for i:=1 to LICZBA_DANYCH do
  Write(d[i]:8);
 WriteLn;
end; (* WyprowadzDane *)

procedure LosujDane(var d:TDane);
var
 i:integer;
begin
 for i:=1 to LICZBA_DANYCH do
  d[i]:=Random(MaxInt);
end; (* LosujDane *)

procedure SortujPrzezWybor(var d:TDane);
var
 i,minIndeks:integer;

 function WyszukajMinIndeks(var d:TDane; start:integer):integer;
 var
  i:integer;
  minElement,minIndeks:integer;
 begin
  for i:=start to LICZBA_DANYCH do
   if i=start then
   begin
    minIndeks:=i;
    minElement:=d[minIndeks];
   end
   else
    if d[i]<minElement then
    begin
     minIndeks:=i;
     minElement:=d[minIndeks];
    end;
  WyszukajMinIndeks:=minIndeks;
 end; (* WyszukajMinIndeks *)

 procedure ZamienZmienne(var a,b:integer);
 var
  t:integer;
 begin
  t:=a; a:=b; b:=t;
 end; (* ZamienZmienne *)

begin
 for i:=1 to LICZBA_DANYCH-1 do
 begin
  minIndeks:=WyszukajMinIndeks(d,i);
  ZamienZmienne(d[i],d[minIndeks]);
 end;
end; (* SortujPrzezWyszukiwanie *)

function SzukajBinarnie(var d:TDane; x:integer):integer;
var
 lewy,prawy,srodek:integer;
 znalezione:boolean;
begin
 lewy:=1;
 prawy:=LICZBA_DANYCH;
 znalezione:=FALSE;
 while (lewy<=prawy) and not znalezione do
 begin
  srodek:=(lewy+prawy) div 2;
  if d[srodek]=x then
   znalezione:=TRUE
  else
   if d[srodek]<x then
    lewy:=srodek+1
   else
    prawy:=srodek-1;
 end;
 if znalezione then
  SzukajBinarnie:=srodek
 else
  SzukajBinarnie:=-1;
end; (* SzukajBinarnie *)

begin
 Randomize;
 LosujDane(MojeDane);
 Writeln('Dane przed posortowaniem:');
 WyprowadzDane(MojeDane);
 Writeln('Dane po posortowaniu:');
 SortujPrzezWybor(MojeDane);
 WyprowadzDane(MojeDane);
 Writeln('Podaj dana do wyszukania: ');
 Readln(x);
 indeks:=SzukajBinarnie(MojeDane,x);
 if indeks<0 then
  Writeln('Dana nieznaleziona')
 else
  Writeln('Dana znaleziona na pozycji ',indeks);
end.
________________________________________________7
{Algorytm wyszukiwania liczb pierwszych - sito Erastotenesa}

program Erastotenes;
uses
 CRT;
const
 MAX_N=64000;
var
 sito:array [1..MAX_N] of boolean;
 n,i,j,skok,sn:longint;
begin
 ClrScr;
 Write('Podaj n(<=',MAX_N,'): ');
 ReadLn(n);
 { Inicjalizacja tablicy }
 for i:=1 to n do
  sito[i]:=TRUE;
 { Przesiewanie }
 sn:=Round(Sqrt(n));
 for i:=2 to sn do
  if sito[i] then
  begin
   j:=i+i;
   while j<=n do
   begin
    sito[j]:=FALSE;
    j:=j+i;
   end;
  end;
 { Wypisywanie wynik˘w }
 for i:=2 to n do
  if sito[i] then
   Write(i:8);
 Writeln;
end.
________________________________________________8
{ Iteracyjna realizacja algorytmu Euklidesa - wersja z dzieleniem }
program Euklides_i;
var
 a,b:word;

function Euklides(a,b: word):word;
var
 t:word;
begin
 while b<>0 do
 begin
  t:=a;
  a:=b;
  b:=t mod b;
 end;
 Euklides:=a;
end;

begin
 Write('Podaj a, b: ');
 ReadLn(a,b);
 WriteLn('NWD(',a,',',b,')=',Euklides(a,b));
end.
________________________________________________9
{ Rekurencyjna realizacja algorytmu Euklidesa - wersja z dzieleniem }
program Euklides_r;
var
 a,b:word;

function Euklides(a,b: word):word;
begin
 if b=0 then
  Euklides:=a
 else
  Euklides:=Euklides(b, a mod b);
end;

begin
 Write('Podaj a, b: ');
 ReadLn(a,b);
 WriteLn('NWD(',a,',',b,')=',Euklides(a,b));
end.
________________________________________________10
{ Iteracyjna realizacja algorytmu Euklidesa - wersja z odejmowaniem }
program Euklides_i;
var
 a,b:integer;
begin
 Write('Podaj a, b: ');
 ReadLn(a, b);
 while a<>b do
  if a>b then a:=a-b
         else b:=b-a;
 WriteLn('NWD=',a);
end.
________________________________________________11
program Euk_od_r;
var
 a,b:word;

function Euklides(a,b: word):word;
begin
 if a=b then
  Euklides:=a
 else
  if a<b then
   Euklides:=Euklides(a,b-a)
  else
   Euklides:=Euklides(a-b,b);
end;

begin
 Write('Podaj a, b: ');
 ReadLn(a,b);
 WriteLn('NWD(',a,',',b,')=',Euklides(a,b));
end.
________________________________________________12
{ Iteracyjna realizacja algorytmu obliczania liczb Fibonacciego }
program Fibonacci_i;
var
 i:integer;

function Fib(n:integer):longint;
var
 i,poprzedni1, poprzedni2:longint;
 wynik:longint;
begin
 if n<3 then
  Fib:=1
 else
 begin
  poprzedni1:=1;
  poprzedni2:=1;
  for i:=3 to n do
  begin
   wynik:=poprzedni1+poprzedni2;
   poprzedni2:=poprzedni1;
   poprzedni1:=wynik;
  end;
  Fib:=wynik;
 end;
end;

begin
 for i:=1 to 40 do
  WriteLn('F(',i,')=',Fib(i));
end.
________________________________________________13
{ Rekurencyjna realizacja algorytmu obliczania liczb Fibonacciego }
program Fibonacci_r;
var
 i:word;

function Fib(n:word):longint;
begin
 if n<3 then
  Fib:=1
 else
  Fib:=Fib(n-2)+Fib(n-1);
end;

begin
 for i:=1 to 40 do
  WriteLn('F(',i,')=',Fib(i));
end.
________________________________________________14
{Iteracyjna realizacja Wiez Hanoi - wersja z tablicami}
program Hanoi_it;
const
 MAX_KRAZKI=100;
type
 TPalik= object
     private
      krazki:array [1..MAX_KRAZKI] of integer;
      liczbaKrazkow:integer;
     public
      Nazwa:string;
      procedure Inicjalizuj(lKrazkow:integer);
      function NajwyzszyKrazek:integer;
      function ZdejmijKrazek:integer;
      procedure PolozKrazek(k:integer);
      function JestPusty:boolean;
      function MoznaPolozyc(k:integer):boolean;
     end;
 TNazwaPalika=(PALIK_A,PALIK_B,PALIK_C);
var
 Paliki:array [TNazwaPalika] of TPalik;
 lKrazkow:integer;
 krazek:integer;
 lPrzelozen:integer;
 koniec:boolean;

procedure TPalik.Inicjalizuj(lKrazkow:integer);
var
 i:integer;
begin
 for i:=1 to lKrazkow do
  krazki[i]:=lKrazkow-i+1;
 liczbaKrazkow:=lKrazkow;
end; (* TPalik.Inicjalizuj *)

function TPalik.NajwyzszyKrazek:integer;
begin
 NajwyzszyKrazek:=krazki[liczbaKrazkow];
end; (* TPalik.NajwyzszyKrazek *)

function TPalik.ZdejmijKrazek:integer;
begin
 ZdejmijKrazek:=krazki[liczbaKrazkow];
 Dec(liczbaKrazkow);
end; (* TPalik.ZdejmijKrazek *)

procedure TPalik.PolozKrazek(k:integer);
begin
 Inc(liczbaKrazkow);
 krazki[liczbaKrazkow]:=k;
end; (* TPalik.PolozKrazek *)

function TPalik.JestPusty:boolean;
begin
 JestPusty:=liczbaKrazkow=0;
end; (* TPalik.JestPusty *)

function TPalik.MoznaPolozyc(k:integer):boolean;
begin
 if liczbaKrazkow=0 then
  MoznaPolozyc:= TRUE
 else
  MoznaPolozyc:= k<krazki[liczbaKrazkow];
end; (* TPalik.MoznaPolozyc *)

procedure PrzelozNajmniejszy;
var
 P1,P2:TNazwaPalika;
begin
 if Paliki[PALIK_A].JestPusty and Paliki[PALIK_B].JestPusty then
  P1:=PALIK_C
 else if Paliki[PALIK_A].JestPusty and Paliki[PALIK_C].JestPusty then
  P1:=PALIK_B
 else if Paliki[PALIK_B].JestPusty and Paliki[PALIK_C].JestPusty then
  P1:=PALIK_A
 else if Paliki[PALIK_A].JestPusty then
  if Paliki[PALIK_B].NajwyzszyKrazek<
    Paliki[PALIK_C].NajwyzszyKrazek then  P1:=PALIK_B
  else                    P1:=PALIK_C
 else if Paliki[PALIK_B].JestPusty then
  if Paliki[PALIK_A].NajwyzszyKrazek<
    Paliki[PALIK_C].NajwyzszyKrazek then  P1:=PALIK_A
  else                    P1:=PALIK_C
 else if Paliki[PALIK_C].JestPusty then
  if Paliki[PALIK_A].NajwyzszyKrazek<
    Paliki[PALIK_B].NajwyzszyKrazek then  P1:=PALIK_A
  else                    P1:=PALIK_B
 else
  if Paliki[PALIK_A].NajwyzszyKrazek<
    Paliki[PALIK_B].NajwyzszyKrazek then
   if Paliki[PALIK_A].NajwyzszyKrazek<
     Paliki[PALIK_C].NajwyzszyKrazek then P1:=PALIK_A
   else                   P1:=PALIK_C
  else
   if Paliki[PALIK_B].NajwyzszyKrazek<
     Paliki[PALIK_C].NajwyzszyKrazek then P1:=PALIK_B
   else                   P1:=PALIK_C;

 if P1=PALIK_A then   P2:=PALIK_B
 else if P1=PALIK_B then P2:=PALIK_C
 else          P2:=PALIK_A;

Writeln('Przekladam ',Paliki[P1].Nazwa,' -> ',Paliki[P2].Nazwa);
 Paliki[P2].PolozKrazek(Paliki[P1].ZdejmijKrazek);
 Inc(lPrzelozen);
end;

procedure PrzelozNienajmniejszy;
var
 P1,P2:TNazwaPalika;
begin
 if Paliki[PALIK_A].JestPusty then
  if Paliki[PALIK_B].NajwyzszyKrazek>
    Paliki[PALIK_C].NajwyzszyKrazek then  P1:=PALIK_B
  else                    P1:=PALIK_C
 else if Paliki[PALIK_B].JestPusty then
  if Paliki[PALIK_A].NajwyzszyKrazek>
    Paliki[PALIK_C].NajwyzszyKrazek then  P1:=PALIK_A
  else                    P1:=PALIK_C
 else if Paliki[PALIK_C].JestPusty then
  if Paliki[PALIK_A].NajwyzszyKrazek>
    Paliki[PALIK_B].NajwyzszyKrazek then  P1:=PALIK_A
  else                    P1:=PALIK_B
 else
  if (Paliki[PALIK_A].NajwyzszyKrazek<Paliki[PALIK_B].NajwyzszyKrazek) and
    (Paliki[PALIK_A].NajwyzszyKrazek<Paliki[PALIK_C].NajwyzszyKrazek) then
   if Paliki[PALIK_B].NajwyzszyKrazek<
     Paliki[PALIK_C].NajwyzszyKrazek then P1:=PALIK_B
   else                   P1:=PALIK_C
  else if (Paliki[PALIK_B].NajwyzszyKrazek<Paliki[PALIK_A].NajwyzszyKrazek) and
      (Paliki[PALIK_B].NajwyzszyKrazek<Paliki[PALIK_C].NajwyzszyKrazek) then
   if Paliki[PALIK_A].NajwyzszyKrazek<
     Paliki[PALIK_C].NajwyzszyKrazek then P1:=PALIK_A
   else                   P1:=PALIK_C
  else
   if Paliki[PALIK_A].NajwyzszyKrazek<
     Paliki[PALIK_B].NajwyzszyKrazek then P1:=PALIK_A
   else                   P1:=PALIK_B;

 if P1=PALIK_A then
  if Paliki[PALIK_B].MoznaPolozyc(Paliki[PALIK_A].NajwyzszyKrazek) then
   P2:=PALIK_B
  else
   P2:=PALIK_C
 else if P1=PALIK_B then
  if Paliki[PALIK_A].MoznaPolozyc(Paliki[PALIK_B].NajwyzszyKrazek) then
   P2:=PALIK_A
  else
   P2:=PALIK_C
 else
  if Paliki[PALIK_A].MoznaPolozyc(Paliki[PALIK_C].NajwyzszyKrazek) then
   P2:=PALIK_A
  else
   P2:=PALIK_B;

 Writeln('Przekladam ',Paliki[P1].Nazwa,' -> ',Paliki[P2].Nazwa);
 Paliki[P2].PolozKrazek(Paliki[P1].ZdejmijKrazek);
 Inc(lPrzelozen);
end;

begin
 repeat
  Write('Podaj liczbe krazkow [1..',MAX_KRAZKI,']: ');
  Readln(lKrazkow);
 until (lKrazkow>=1) and (lKrazkow<=MAX_KRAZKI);
 Paliki[PALIK_A].Inicjalizuj(lKrazkow);
 Paliki[PALIK_A].Nazwa:='A';
 Paliki[PALIK_B].Inicjalizuj(0);
 Paliki[PALIK_B].Nazwa:='B';
 Paliki[PALIK_C].Inicjalizuj(0);
 Paliki[PALIK_C].Nazwa:='C';
 lPrzelozen:=0;
 repeat
  PrzelozNajmniejszy;
  koniec:=Paliki[PALIK_A].JestPusty and
      (Paliki[PALIK_B].JestPusty or Paliki[PALIK_C].JestPusty);
  if not koniec then
   PrzelozNienajmniejszy;
 until koniec;
 Writeln('Calkowita liczba przelozen: ',lPrzelozen);
end.
________________________________________________15
{ Iteracyjna realizacja Wiez Hanoi - wersja ze wskaźnikami}
program Hanoi_iw;
const
 MAX_KRAZKI=100;
type
 TPalik= object
     private
      krazki:array [1..MAX_KRAZKI] of integer;
      liczbaKrazkow:integer;
     public
      Nazwa:string;
      procedure Inicjalizuj(lKrazkow:integer);
      function NajwyzszyKrazek:integer;
      function ZdejmijKrazek:integer;
      procedure PolozKrazek(k:integer);
      function JestPusty:boolean;
      function MoznaPolozyc(k:integer):boolean;
     end;
var
 A,B,C:TPalik;
 P1,P2:^TPalik;
 lKrazkow:integer;
 krazek:integer;
 lPrzelozen:integer;
 koniec:boolean;

procedure TPalik.Inicjalizuj(lKrazkow:integer);
var
 i:integer;
begin
 for i:=1 to lKrazkow do
  krazki[i]:=lKrazkow-i+1;
 liczbaKrazkow:=lKrazkow;
end; (* TPalik.Inicjalizuj *)

function TPalik.NajwyzszyKrazek:integer;
begin
 NajwyzszyKrazek:=krazki[liczbaKrazkow];
end; (* TPalik.NajwyzszyKrazek *)

function TPalik.ZdejmijKrazek:integer;
begin
 ZdejmijKrazek:=krazki[liczbaKrazkow];
 Dec(liczbaKrazkow);
end; (* TPalik.ZdejmijKrazek *)

procedure TPalik.PolozKrazek(k:integer);
begin
 Inc(liczbaKrazkow);
 krazki[liczbaKrazkow]:=k;
end; (* TPalik.PolozKrazek *)

function TPalik.JestPusty:boolean;
begin
 JestPusty:=liczbaKrazkow=0;
end; (* TPalik.JestPusty *)

function TPalik.MoznaPolozyc(k:integer):boolean;
begin
 if liczbaKrazkow=0 then
  MoznaPolozyc:=TRUE
 else
  MoznaPolozyc:= k<krazki[liczbaKrazkow];
end; (* TPalik.MoznaPolozyc *)

procedure PrzelozNajmniejszy;
begin
 if A.JestPusty and B.JestPusty then
  P1:=@C
 else if A.JestPusty and C.JestPusty then
  P1:=@B
 else if B.JestPusty and C.JestPusty then
  P1:=@A
 else if A.JestPusty then
  if B.NajwyzszyKrazek<C.NajwyzszyKrazek then  P1:=@B
  else                     P1:=@C
 else if B.JestPusty then
  if A.NajwyzszyKrazek<C.NajwyzszyKrazek then  P1:=@A
  else                     P1:=@C
 else if C.JestPusty then
  if A.NajwyzszyKrazek<B.NajwyzszyKrazek then  P1:=@A
  else                     P1:=@B
 else
  if A.NajwyzszyKrazek<B.NajwyzszyKrazek then
   if A.NajwyzszyKrazek<C.NajwyzszyKrazek then P1:=@A
   else                    P1:=@C
  else
   if B.NajwyzszyKrazek<C.NajwyzszyKrazek then P1:=@B
   else                    P1:=@C;

if P1=@A then    P2:=@B
 else if P1=@B then P2:=@C
 else        P2:=@A;

 Writeln('Przekladam ',P1^.Nazwa,' -> ',P2^.Nazwa);
 P2^.PolozKrazek(P1^.ZdejmijKrazek);
 Inc(lPrzelozen);
end;

procedure PrzelozNienajmniejszy;
begin
 if A.JestPusty then
  if B.NajwyzszyKrazek>C.NajwyzszyKrazek then  P1:=@B
  else                     P1:=@C
 else if B.JestPusty then
  if A.NajwyzszyKrazek>C.NajwyzszyKrazek then  P1:=@A
  else                     P1:=@C
 else if C.JestPusty then
  if A.NajwyzszyKrazek>B.NajwyzszyKrazek then  P1:=@A
  else                     P1:=@B
 else
  if (A.NajwyzszyKrazek<B.NajwyzszyKrazek) and
    (A.NajwyzszyKrazek<C.NajwyzszyKrazek) then
   if B.NajwyzszyKrazek<C.NajwyzszyKrazek then P1:=@B
   else                    P1:=@C
  else if (B.NajwyzszyKrazek<A.NajwyzszyKrazek) and
      (B.NajwyzszyKrazek<C.NajwyzszyKrazek) then
   if A.NajwyzszyKrazek<C.NajwyzszyKrazek then P1:=@A
   else                    P1:=@C
  else
   if A.NajwyzszyKrazek<B.NajwyzszyKrazek then P1:=@A
   else                    P1:=@B;

 if P1=@A then
  if B.MoznaPolozyc(A.NajwyzszyKrazek) then   P2:=@B
  else                     P2:=@C
 else if P1=@B then
  if A.MoznaPolozyc(B.NajwyzszyKrazek) then   P2:=@A
  else                     P2:=@C
 else
  if A.MoznaPolozyc(C.NajwyzszyKrazek) then   P2:=@A
  else                     P2:=@B;

 Writeln('Przekladam ',P1^.Nazwa,' -> ',P2^.Nazwa);
 P2^.PolozKrazek(P1^.ZdejmijKrazek);
 Inc(lPrzelozen);
end;

begin
 repeat
  Write('Podaj liczbe krazkow [1..',MAX_KRAZKI,']: ');
  Readln(lKrazkow);
 until (lKrazkow>=1) and (lKrazkow<=MAX_KRAZKI);
 A.Inicjalizuj(lKrazkow); A.Nazwa:='A';
 B.Inicjalizuj(0);     B.Nazwa:='B';
 C.Inicjalizuj(0);     C.Nazwa:='C';
 lPrzelozen:=0;
 repeat
  PrzelozNajmniejszy;
  koniec:=A.JestPusty and (B.JestPusty or C.JestPusty);
  if not koniec then
   PrzelozNienajmniejszy;
 until koniec;
 Writeln('Calkowita liczba przelozen: ',lPrzelozen);
end.
________________________________________________16
{ Rekurencyjna realizacja Wiez Hanoi - wersja z tablicami}
program Hanoi_rt;
const
 MAX_KRAZKI=100;
type
 TPalik= object
     private
      krazki:array [1..MAX_KRAZKI] of integer;
      liczbaKrazkow:integer;
     public
      Nazwa:string;
      procedure Inicjalizuj(lKrazkow:integer);
      function NajwyzszyKrazek:integer;
      function ZdejmijKrazek:integer;
      procedure PolozKrazek(k:integer);
      function JestPusty:boolean;
      function MoznaPolozyc(k:integer):boolean;
     end;
 TNazwaPalika=(PALIK_A,PALIK_B,PALIK_C);
var
 Paliki:array [TNazwaPalika] of TPalik;
 lKrazkow:integer;
 krazek:integer;
 lPrzelozen:integer;
 koniec:boolean;

procedure TPalik.Inicjalizuj(lKrazkow:integer);
var
 i:integer;
begin
 for i:=1 to lKrazkow do
  krazki[i]:=lKrazkow-i+1;
 liczbaKrazkow:=lKrazkow;
end; (* TPalik.Inicjalizuj *)

function TPalik.NajwyzszyKrazek:integer;
begin
 NajwyzszyKrazek:=krazki[liczbaKrazkow];
end; (* TPalik.NajwyzszyKrazek *)

function TPalik.ZdejmijKrazek:integer;
begin
 ZdejmijKrazek:=krazki[liczbaKrazkow];
 Dec(liczbaKrazkow);
end; (* TPalik.ZdejmijKrazek *)

procedure TPalik.PolozKrazek(k:integer);
begin
 Inc(liczbaKrazkow);
 krazki[liczbaKrazkow]:=k;
end; (* TPalik.PolozKrazek *)

function TPalik.JestPusty:boolean;
begin
 JestPusty:=liczbaKrazkow=0;
end; (* TPalik.JestPusty *)

function TPalik.MoznaPolozyc(k:integer):boolean;
begin
 if liczbaKrazkow=0 then
  MoznaPolozyc:= TRUE
 else
  MoznaPolozyc:= k<krazki[liczbaKrazkow];
end; (* TPalik.MoznaPolozyc *)

procedure PrzeniesN(n:integer; p1,p2:TNazwaPalika);
var
 p3:TNazwaPalika;
begin
 if n>0 then
 begin
  if (p1=PALIK_A) and (p2=PALIK_B) then    p3:=PALIK_C
  else if (p1=PALIK_A) and (p2=PALIK_C) then p3:=PALIK_B
  else                                        p3:=PALIK_A;

  PrzeniesN(n-1,p1,p3);
  Writeln('Przekladam ',Paliki[p1].Nazwa,' -> ',Paliki[p2].Nazwa);
  Paliki[p2].PolozKrazek(Paliki[p1].ZdejmijKrazek);
  Inc(lPrzelozen);
  PrzeniesN(n-1,p3,p2);
 end;
end; (* PrzeniesN *)

begin
 repeat
  Write('Podaj liczbe krazkow [1..',MAX_KRAZKI,']: ');
  Readln(lKrazkow);
 until (lKrazkow>=1) and (lKrazkow<=MAX_KRAZKI);
 Paliki[PALIK_A].Inicjalizuj(lKrazkow);
 Paliki[PALIK_A].Nazwa:='A';
 Paliki[PALIK_B].Inicjalizuj(0);
 Paliki[PALIK_B].Nazwa:='B';
 Paliki[PALIK_C].Inicjalizuj(0);
 Paliki[PALIK_C].Nazwa:='C';
 lPrzelozen:=0;
 PrzeniesN(lKrazkow,PALIK_A,PALIK_B);
 Writeln('Calkowita liczba przelozen: ',lPrzelozen);
end.
________________________________________________17
{ Rekurencyjna realizacja Wiez Hanoi - wersja ze wskaznikami }
program Hanoi_rw;
const
 MAX_KRAZKI=100;
type
 TPalik= object
     private
      krazki:array [1..MAX_KRAZKI] of integer;
      liczbaKrazkow:integer;
     public
      Nazwa:string;
      procedure Inicjalizuj(lKrazkow:integer);
      function NajwyzszyKrazek:integer;
      function ZdejmijKrazek:integer;
      procedure PolozKrazek(k:integer);
      function JestPusty:boolean;
      function MoznaPolozyc(k:integer):boolean;
     end;
var
 A,B,C:TPalik;
 lKrazkow:integer;
 krazek:integer;
 lPrzelozen:integer;
 koniec:boolean;

procedure TPalik.Inicjalizuj(lKrazkow:integer);
var
 i:integer;
begin
 for i:=1 to lKrazkow do
  krazki[i]:=lKrazkow-i+1;
 liczbaKrazkow:=lKrazkow;
end; (* TPalik.Inicjalizuj *)

function TPalik.NajwyzszyKrazek:integer;
begin
 NajwyzszyKrazek:=krazki[liczbaKrazkow];
end; (* TPalik.NajwyzszyKrazek *)

function TPalik.ZdejmijKrazek:integer;
begin
 ZdejmijKrazek:=krazki[liczbaKrazkow];
 Dec(liczbaKrazkow);
end; (* TPalik.ZdejmijKrazek *)

procedure TPalik.PolozKrazek(k:integer);
begin
 Inc(liczbaKrazkow);
 krazki[liczbaKrazkow]:=k;
end; (* TPalik.PolozKrazek *)

function TPalik.JestPusty:boolean;
begin
 JestPusty:=liczbaKrazkow=0;
end; (* TPalik.JestPusty *)

function TPalik.MoznaPolozyc(k:integer):boolean;
begin
 if liczbaKrazkow=0 then
  MoznaPolozyc:=TRUE
 else
  MoznaPolozyc:= k<krazki[liczbaKrazkow];
end; (* TPalik.MoznaPolozyc *)

procedure PrzeniesN(n:integer; var p1,p2:TPalik);
var
 p3:^TPalik;
begin
 if n>0 then
 begin
  if (p1.Nazwa='A') and (p2.Nazwa='B') then    p3:=@C
  else if (p1.Nazwa='A') and (p2.Nazwa='C') then p3:=@B
  else                                           p3:=@A;

  PrzeniesN(n-1,p1,p3^);
  Writeln('Przekladam ',p1.Nazwa,' -> ',p2.Nazwa);
  p2.PolozKrazek(p1.ZdejmijKrazek);
  Inc(lPrzelozen);
  PrzeniesN(n-1,p3^,p2);
 end;
end; (* PrzeniesN *)

begin
 repeat
  Write('Podaj liczbe krazkow [1..',MAX_KRAZKI,']: ');
  Readln(lKrazkow);
 until (lKrazkow>=1) and (lKrazkow<=MAX_KRAZKI);
 A.Inicjalizuj(lKrazkow); A.Nazwa:='A';
 B.Inicjalizuj(0);     B.Nazwa:='B';
 C.Inicjalizuj(0);     C.Nazwa:='C';
 lPrzelozen:=0;
 PrzeniesN(lKrazkow,A,B);
 Writeln('Calkowita liczba przelozen: ',lPrzelozen);
end.
________________________________________________18
{ Iteracyjna realizacja schematu Hornera }
program Horner_i;
const
 MAX_WSP=4;
type
 TWsp=array [0..MAX_WSP] of real;
var
 MojeWsp:TWsp;
 x:real;

procedure WprowadzWsp(var w:TWsp);
var
 i:integer;
begin
 for i:=MAX_WSP downto 0 do
 begin
  Write('Podaj wspolczynnik nr ',i,': ');
  ReadLn(w[i]);
 end;
end;

procedure WypiszWielomian(var w:TWsp);
var
 i:integer;
begin
 for i:=MAX_WSP downto 1 do
  Write(w[i]:6:2,'*x^',i,' + ');
 WriteLn(w[0]:6:2);
end;

function Horner(var w:TWsp; x:real):real;
var
 i:integer;
 wynik:real;
begin
 wynik:=w[MAX_WSP];
 for i:=MAX_WSP-1 downto 0 do
  wynik:=w[i]+x*wynik;
 Horner:=wynik;
end;

begin
 WriteLn('*** Wprowadzanie wspolczynnikow wielomianu ***');
 WprowadzWsp(MojeWsp);
 WypiszWielomian(MojeWsp);
 WriteLn('Podaj wartosc x: ');
 ReadLn(x);
 WriteLn('Wartosc wielomianu=',Horner(MojeWsp,x):8:2);
end.
________________________________________________19
{ Rekurencyjna realizacja schematu Hornera }
program Horner_r;
const
 MAX_WSP=5;
type
 TWsp=array [0..MAX_WSP] of extended;
var
 MojeWsp:TWsp;
 x:real;

procedure WprowadzWsp(var w:TWsp);
var
 i:integer;
begin
 for i:=MAX_WSP downto 0 do
 begin
  Write('Podaj wspolczynnik nr ',i,': ');
  ReadLn(w[i]);
 end;
end;

procedure WypiszWielomian(var w:TWsp);
var
 i:integer;
begin
 for i:=MAX_WSP downto 1 do
  if w[i]<>0 then
   Write(w[i]:6:2,'*x^',i,' + ');
 WriteLn(w[0]:6:2);
end;

procedure LosujWsp(var w:TWsp);
var
 i:integer;
begin
 for i:=MAX_WSP downto 0 do
  w[i]:=Random*40-20;
end; (* LosujWsp *)

function Horner(var w:TWsp; n:integer; x:real):real;
var
 wynik:real;
begin
 if n=MAX_WSP then
  Horner:=w[MAX_WSP]
 else
  Horner:=w[n]+x*Horner(w,n+1,x);
end;

function ObliczWielomian(var w:TWsp; x:real):real;
begin
 ObliczWielomian:=Horner(w,0,x);
end;

begin
 WriteLn('*** Wprowadzanie wspolczynnikow wielomianu ***');
 WprowadzWsp(MojeWsp);
 WypiszWielomian(MojeWsp);
 WriteLn('Podaj wartosc x: ');
 ReadLn(x);
 WriteLn('Wartosc wielomianu=',ObliczWielomian(MojeWsp,x):8:2);
end.
________________________________________________20
{ Znajdowanie maksimum z n liczb }
program Maksimum;
var
 n,m:integer;

function Max(n:integer):integer;
var
 i,liczba,wynik:integer;
begin
 for i:=1 to n do
 begin
  Write('Podaj liczbe: ');
  ReadLn(liczba);
  if i=1 then
   wynik:=liczba
  else
   if liczba>wynik then
    wynik:=liczba;
 end;
 max:=wynik;
end;

begin
 Write('Podaj liczbe element˘w: ');
 ReadLn(n);
 m:=Max(n);
 WriteLn('Maksimum = ',m);
end.
________________________________________________21
{ Algorytm jednoczesnego szukania najmniejszego i najwiekszego elementu zbioru }
{ - zastosowanie metody "dziel i zwyciezaj" }
program MinMax;
const
 N=100;
type
 TDane=array [1..N] of integer;
var
 MojeDane:TDane;
 min,max:integer;

procedure LosujDane(var d:TDane);
var
 i:integer;
begin
 for i:=1 to N do
  d[i]:=Random(MaxInt);
end; (* LosujDane *)

procedure WypiszDane(var d:TDane);
var
 i:integer;
begin
 Writeln('Wylosowane dane: ');
 for i:=1 to N do
  Write(d[i]:8);
 Writeln;
end; (* WypiszDane *)

procedure WyszukajMinMax(var d:TDane; var min,max:integer);
var
 i:integer;
 min1,max1:integer;
begin
 for i:=1 to N div 2 do
 begin
  if d[i*2-1]<d[i*2] then
  begin
   min1:=d[i*2-1]; max1:=d[i*2];
  end
  else
  begin
   min1:=d[i*2];  max1:=d[i*2-1];
  end;
  if i=1 then
  begin
   min:=min1; max:=max1;
  end
  else
  begin
   if min1<min then
    min:=min1;
   if max1>max then
    max:=max1;
  end;
 end;

 if N div 2=1 then
 begin
  if d[N]<min then
   min:=d[N];
  if d[N]>max then
   max:=d[N];
 end;
end; (* WyszukajMinMax *)

begin
 Randomize;
 LosujDane(MojeDane);
 WypiszDane(MojeDane);
 WyszukajMinMax(MojeDane,Min,Max);
 Writeln('Min=',Min,' Max=',Max);
end.
________________________________________________22
{Algorytm wyszukiwania liczb pierwszych - podejscie naiwne }

program Pierwsze_naiwny;
uses
 CRT;
var
 i,j,n:longint;
 Pierwsza:boolean;
begin
 ClrScr;
 Write('Podaj n: ');
 ReadLn(n);
 for i:=2 to n do
 begin
  Pierwsza:=TRUE;
  j:=2;
  while Pierwsza and (j<i) do
  begin
   if i mod j=0 then
    Pierwsza:=FALSE;
   j:=j+1;
  end;
  if Pierwsza then
   Write(i:8);
 end;
 Writeln;
end.
________________________________________________23
{ Wypisanie wszystkich palindromow z danego tekstu }

(*
** Zakladamy, ze wyrazy sa rozdzielone spacjami
** Dopuszczamy mozliwosc wystapienia kilku spacji pod rzad
** i traktujemy je jako jedna spacje
*)
program Palindrom;
var
 s, slowo:string;
 i:integer;
 bylaSpacja:boolean;

function JestPalindromem(s:string):boolean;
var
 i, dlugosc:integer;
begin
 JestPalindromem:=TRUE;
 dlugosc:=Length(s);
 for i:=1 to dlugosc div 2 do
  if UpCase(s[i])<>UpCase(s[dlugosc-i+1]) then
  begin
   JestPalindromem:=FALSE;
   exit;
  end;
end;

begin
 Write('Podaj napis: ');
 ReadLn(s);
 s:=s+' ';         (* Wartownik *)
 bylaSpacja:=TRUE;
 for i:=1 to Length(s) do
  if s[i]=' ' then
  begin
   if slowo<>'' then
   begin
    Write('Slowo "',slowo,'" ');
    if not JestPalindromem(slowo) then
     Write('nie ');
    WriteLn('jest palindromem');
   end;
   bylaSpacja:=TRUE;
   slowo:='';
  end
  else
  begin
   slowo:=slowo+s[i];
   bylaSpacja:=FALSE;
  end;
end.
________________________________________________24
{ Sprawdzanie, czy liczba jest pierwsza }
program Pierwsza;
var
 liczba:word;

function JestPierwsza(n:word):boolean;
var
 i:word;
begin
 JestPierwsza:=TRUE;
 for i:=2 to Trunc(Sqrt(n)) do
  if n mod i=0 then      (* Podzielna *)
  begin
   JestPierwsza:=FALSE;
   exit;
  end;
end;

begin
 Write('Podaj liczbe: ');
 ReadLn(liczba);
 if JestPierwsza(liczba) then
  WriteLn('Liczba ',liczba,' jest pierwsza')
 else
  WriteLn('Liczba ',liczba,' nie jest pierwsza');
end.
________________________________________________25
{ Iteracyjna realizacja algorytmu oblicznia wartosci poteg liczb o wykladnikach naturalnych }
program Potega_i;
var
 p:real;
 w:word;

function Potega(a:real; n:word):real;
var
 x,wynik:real;
 k:word;
begin
 (* Krok 1 *)
 wynik:=1;
 x:=a;
 k:=n;
 (* Krok 2 *)
 while k<>0 do
  (* Krok 3 *)
  if k mod 2=1 then
  begin
   wynik:=wynik*x;
   Dec(k);
  end
  else
  begin
   k:=k div 2;
   x:=x*x;
  end;
 (* Krok 4*)
 Potega:=wynik;
end;

begin
 Write('Podaj podstawe: ');
 Readln(p);
 Write('Podaj wykladnik: ');
 Readln(w);
 Writeln(p:6:2,'^',w,'=',Potega(p,w):8:2);
end.
________________________________________________26
{ Rekurencyjna realizacja algorytmu oblicznia wartosci poteg liczb o wykladnikach naturalnych }
program Potega_r;
var
 p:real;
 w:word;

function Potega(a:real; n:word):real;
begin
 if n=0 then
  Potega:=1
 else
  Potega:=a*Potega(a,n-1);
end;

begin
 Write('Podaj podstawe: ');
 Readln(p);
 Write('Podaj wykladnik: ');
 Readln(w);
 Writeln(p:6:2,'^',w,'=',Potega(p,w):8:2);
end.
________________________________________________27
{ Obliczanie obszaru ograniczonego - metoda prostokatow }
program metoda_prostokatow;
uses
 CRT;
var
 a,b:real;
 n:integer;

function Fun(x: real): real;
begin
 Fun:=sin(x);
end;

function PoleProstokaty(a,b: real; n:integer):real;
var
 pole:real;
 w,xi:real;
 i:integer;
begin
 pole:=0;
 w:=(b-a)/n;
 xi:=a+w/2;
 while xi<b do
 begin
  pole:=pole+Fun(xi);
  xi:=xi+w;
 end;
 PoleProstokaty:=w*pole;
end;

begin
 ClrScr;
 Write('Podaj dolna granice przedzialu: ');
 Readln(a);
 Write('Podaj gorna granice przedzialu: ');
 Readln(b);
 Write('Podaj liczbe iteracji: ');
 Readln(n);
 Writeln('Pole=',PoleProstokaty(a,b,n):8:4);
end.
________________________________________________28
{ Rozwiazywanie rownania kwadratowego }
program Rownanie_kwadratowe;
var
 a,b,c,d,pd:real;
begin
 Write('Podaj a: '); ReadLn(a);
 Write('Podaj b: '); ReadLn(b);
 Write('Podaj c: '); ReadLn(c);
 d:=b*b-4*a*c;
 if d<0 then
  WriteLn('Brak rozwiazan')
 else if d=0 then
 begin
  WriteLn('x1=x2=',-b/(2*a):6:2);
 end
 else
 begin
  pd:=sqrt(d);
  WriteLn('x1=',(-b-pd)/(2*a):6:2);
  WriteLn('x2=',(-b+pd)/(2*a):6:2);
 end;
end.
________________________________________________29
{ Rozwiazywanie rownania liniowego }
program Rownanie_liniowe;
var
 a,b,x:real;
 i,n:integer;
begin
 Write('Podaj liczbe danych: ');
 ReadLn(n);
 for i:=1 to n do
 begin
  Write('Podaj a, b: ');
  ReadLn(a, b);
  if a=0 then
   if b=0 then
    WriteLn('Nieskonczenie wiele rozwiazan')
   else
    WriteLn('Rownanie sprzeczne')
  else
  begin
   x:=-b/a;
   Writeln('x=',x:6:2);
  end;
 end;
end.
________________________________________________30
{Sortowanie przez scalanie - realizacja iteracyjna }
program Scalanie_i;
uses
 CRT;
const
 MAX_MN=100;
type
 TTablica=array[1..MAX_MN] of integer;
 TDane=record
     dane:TTablica;
     lDanych:integer;
    end;
var
 Wynik,Dane1,Dane2:TDane;

procedure WprowadzDane(var d:TDane);
var
 i:integer;
begin
 Write('Podaj liczbe danych: ');
 repeat
  Readln(d.lDanych);
  if (d.lDanych<1) or (d.LDanych>MAX_MN) then
   Writeln('Niepoprawna liczba danych');
 until (d.lDanych>=1) and (d.LDanych<=MAX_MN);
 Writeln('Wprowadz dane:');
 for i:=1 to d.lDanych do
 begin
  Write('Podaj element nr ',i,': ');
  Readln(d.dane[i]);
 end;
end;

procedure WyprowadzDane(var d:TDane);
var
 i:integer;
begin
 Writeln('Dane:');
 for i:=1 to d.lDanych do
  Write(d.dane[i]:8);
 Writeln;
end;

procedure SortujPrzezScalanie(var w:TDane; var d1,d2:TDane);
var
 a,b,ab:TTablica;
 ia,ib,iab:integer;         (* Pozycja w ciagu *)
 la,lb,lab:integer;         (* Liczba elementow ciagu *)
begin
 a:=d1.dane;
 b:=d2.dane;
 ia:=1;
 ib:=1;
 iab:=1;
 la:=d1.lDanych;
 lb:=d2.lDanych;
 while (ia<=la) and (ib<=lb) do   (* Sprawdz, czy w ciagu sa dane *)
  if a[ia]<b[ib] then
  begin
   ab[iab]:=a[ia]; Inc(iab); Inc(ia);
  end
  else if a[ia]>b[ib] then
  begin
   ab[iab]:=b[ib]; Inc(iab); Inc(ib);
  end
  else
  begin
   ab[iab]:=a[ia]; Inc(iab); Inc(ia);
   ab[iab]:=b[ib]; Inc(iab); Inc(ib);
  end;
 while ia<=la do
 begin
  ab[iab]:=a[ia]; Inc(iab); Inc(ia);
 end;
 while ib<=lb do
 begin
  ab[iab]:=b[ib]; Inc(iab); Inc(ib);
 end;
 lab:=iab-1;
 w.dane:=ab;
 w.lDanych:=lab;
end;

begin
 Writeln('*** Ciag A');
 WprowadzDane(Dane1);
 Writeln('*** Ciag B');
 WprowadzDane(Dane2);
 SortujPrzezScalanie(Wynik,Dane1,Dane2);
 Writeln('*** Ciag scalony');
 WyprowadzDane(Wynik);
end.
________________________________________________31
{ Iteracyjna realizacja algorytmu obliczania silni }
program Silnia_i;
var
 n:integer;

function SilniaIt(n:integer):longint;
var
 i:integer;
 wynik:longint;
begin
 if n<2 then
  SilniaIt:=1
 else
 begin
  wynik:=2;
  for i:=3 to n do
   wynik:=wynik*i;
  SilniaIt:=wynik;
 end;
end;

begin
 Write('Podaj n: ');
 Readln(n);
 WriteLn(n,'!=',SilniaIt(n));
end.
________________________________________________32
{ Rekurencyjna realizacja algorytmu obliczania silni }
program Silnia_r;
var
 n:integer;

function SilniaRek(n:integer):longint;
begin
 if n=0 then
  SilniaRek:=1
 else
  SilniaRek:=n*SilniaRek(n-1);
end;

begin
 Write('Podaj n: ');
 Readln(n);
 WriteLn(n,'!=',SilniaRek(n));
end.
________________________________________________33
{Zamiana liczb miedzy dowolnymi systemami pozycyjnymi }
program Systemy;
uses
 CRT;
var
 number:string;
 p1,p2:integer;
 ok:boolean;

function C2V(c:char):byte;
begin
 c:=UpCase(c);
 if (c>='0') and (c<='9') then
  C2V:=Ord(c)-Ord('0')
 else if (c>='A') and (c<='Z') then
  C2V:=Ord(c)-Ord('A')+10
 else
  C2V:=0;
end;

function V2C(v:byte):char;
begin
 if v<10 then
  V2C:=Chr(v+Ord('0'))
 else if v<36 then
  V2C:=Chr(v-10+Ord('A'))
 else
  V2C:=' ';
end;

function X2D(x:string; p:integer):integer;
var
 i,w:integer;
begin
 w:=0;
 for i:=1 to Length(x) do
  w:=w*p+C2V(x[i]);
 X2D:=w;
end;

function D2X(v:integer; p:integer):string;
var
 w:string;
begin
 if v=0 then
  w:='0'
 else
 begin
  w:='';
  while v>0 do
  begin
   w:=V2C(v mod p)+w;
   v:=v div p;
  end;
 end;
 D2X:=w;
end;

function X2X(s:string; p1,p2:integer):string;
begin
 X2X:=D2X(X2D(s,p1),p2);
end;

function DigitCorrect(c:char; p:integer):boolean;
var
 up:char;
begin
 c:=UpCase(c);
 if (p<2) or (p>36) then
  DigitCorrect:=FALSE
 else
 begin
  up:=V2C(p);
  if p<=10 then
   DigitCorrect:=c in ['0'..up]
  else
   DigitCorrect:=c in ['0'..'9','A'..up];
 end;
end;

function NumberCorrect(s:string; p:integer):boolean;
var
 i:integer;
begin
 NumberCorrect:=TRUE;
 for i:=1 to Length(s) do
  if not DigitCorrect(s[i],p) then
  begin
   NumberCorrect:=FALSE;
   exit;
  end;
end;

procedure Convert(s:string; p1,p2:integer);
begin
 Writeln(s,'(',p1,')=',X2X(s,p1,p2),'(',p2,')');
end;

begin
 ClrScr;
 repeat
  Write('Podaj liczbe do zamiany: ');
  Readln(number);
  repeat
   Write('Podaj podstawe systemu liczby: ');
   Readln(p1);
   if (p1<2) or (p1>36) then
    Writeln('Podstawa poza zakresem');
  until (p1>=2) and (p1<=36);
  ok:=NumberCorrect(number,p1);
  if not ok then
   Writeln('Podana liczba w podanym systemie jest nieprawidlowa');
 until ok;
 repeat
  Write('Podaj podstawe systemu docelowego: ');
  Readln(p2);
  if (p2<2) or (p2>36) then
   Writeln('Podstawa poza zakresem');
 until (p2>=2) and (p2<=36);
 Convert(number,p1,p2);
end.
________________________________________________34
{ Algorytm przeszukiwania liniowego - wyszukiwanie liczby w tablicy liczb }
program T11_p5;
const
 N=100;
type
 TDane=array [1..N] of integer;
var
 MojeDane:TDane;
 x,i:integer;

procedure LosujDane(var d:TDane);
var
 i:integer;
begin
 for i:=1 to N do
  d[i]:=Random(MaxInt);
end; (* LosujDane *)

procedure WypiszDane(var d:TDane);
var
 i:integer;
begin
 Writeln('Wylosowane dane: ');
 for i:=1 to N do
  Write(d[i]:8);
 Writeln;
end; (* WypiszDane *)

function WyszukajDana(var d:TDane; x:integer):integer;
var
 i:integer;
begin
 i:=0;
 repeat
  Inc(i);
 until (i>N) or (d[i]=x);
 if i>N then  WyszukajDana:=-1
 else         WyszukajDana:=i;
end; (* WyszukajDana *)

begin
 Randomize;
 LosujDane(MojeDane);
 WypiszDane(MojeDane);
 Write('Podaj dana do wyszukania: ');
 Readln(x);
 i:=WyszukajDana(MojeDane,x);
 if i>0 then
  Writeln('Dana znaleziona pod indeksem ',i)
 else
  Writeln('Dana nieznaleziona');
end.
________________________________________________35
{ Sortowanie szybkie - realizacja rekurencyjna }
program Szybki_r;
uses
 CRT;
const
 N=8;
type
 TDane=array[1..N] of integer;
var
 Dane:TDane;

procedure WprowadzDane(var d:TDane);
var
 i:integer;
begin
 Writeln('*** Wprowadzanie danych');
 for i:=1 to N do
 begin
  Write('Podaj element nr ',i,': ');
  Readln(d[i]);
 end;
 Writeln('*** Dane wprowadzone');
end;

procedure WyprowadzDane(var d:TDane);
var
 i:integer;
begin
 Writeln('*** Wyprowadzanie danych');
 for i:=1 to N do
  Write(d[i]:8);
 Writeln;
 Writeln('*** Dane wyprowadzone');
end;

procedure SortujRekurencyjnie(var w:TDane; var a:TDane; la:integer);
var
 x,y:TDane;
 xw,yw:TDane;
 k:integer;
 ix,iy,iw:integer;
 i:integer;
begin
 if la>1 then
 begin
  k:=a[1];
  ix:=1;
  iy:=1;
  for i:=2 to la do
   if a[i]<=k then
   begin
    x[ix]:=a[i]; Inc(ix);
   end
   else
   begin
    y[iy]:=a[i]; Inc(iy);
   end;
  SortujRekurencyjnie(xw,x,ix-1);
  SortujRekurencyjnie(yw,y,iy-1);
  iw:=1;
  for i:=1 to ix-1 do
  begin
   w[iw]:=xw[i]; Inc(iw);
  end;
  w[iw]:=k; Inc(iw);
  for i:=1 to iy-1 do
  begin
   w[iw]:=yw[i]; Inc(iw);
  end;
 end
 else if la=1 then
  w[1]:=a[1];
end;

procedure SortujDane(var d:TDane);
var
 w:TDane;
begin
 SortujRekurencyjnie(w,d,N);
 d:=w;
end;

begin
 WprowadzDane(Dane);
 SortujDane(Dane);
 WyprowadzDane(Dane);
end.
________________________________________________36
{Szyfrowanie i deszyfrowanie szyfrem kolumnowym }
program Szyfrowanie;
uses
 CRT;
var
 Tekst:string;
 Wybor:char;
 Szerokosc:integer;

function Szyfruj(s:string; n:integer):string;
var
 i,poz,l:integer;
 wynik:string;
begin
 l:=Length(s);
 wynik:='';
 poz:=1;
 for i:=1 to l do
 begin
  wynik:=wynik + s[poz];
  poz:=poz+n;
  if poz>l then
   poz:=poz mod n +1;
 end;
 Szyfruj:=wynik;
end;

function Deszyfruj(s:string; n:integer):string;
begin
 n:=Length(s) div n;
 if n=0 then n:=1;
 Deszyfruj:=Szyfruj(s,n);
end;

begin
 repeat
  ClrScr;
  WriteLn('1 - Szyfrowanie');
  WriteLn('2 - Deszyfrowanie');
  WriteLn('0 - Koniec');
  Wybor:=ReadKey;
  case Wybor of

   '1': begin
       Write('Podaj tekst do zaszyfrowania: ');
       ReadLn(Tekst);
       Write('Podaj szerokosc kolumny: ');
       ReadLn(Szerokosc);
       WriteLn(Tekst,' -> ',Szyfruj(Tekst,Szerokosc));
       WriteLn;
       WriteLn('Nacisnij dowolny klawisz');
       ReadKey;
      end;
   '2': begin
       Write('Podaj tekst do deszyfrowania: ');
       ReadLn(Tekst);
       Write('Podaj szerokosc kolumny: ');
       ReadLn(Szerokosc);
       WriteLn(Tekst,' -> ',Deszyfruj(Tekst,Szerokosc));
       WriteLn;
       WriteLn('Nacisnij dowolny klawisz');
       ReadKey;
      end;
   '0': begin end;
   else begin
       WriteLn('Bledny wybor');
       Delay(500);
      end;
  end;
 until Wybor='0';
end.
________________________________________________37
{ Obliczanie obszaru ograniczonego - metoda trapezow }
program Metoda_trapezow;
uses
 CRT;
var
 a,b:real;
 n:integer;

function Fun(x: real): real;
begin
 Fun:=sin(x);
end;

function PoleTrapezy(a,b: real; n:integer):real;
var
 pole:real;
 w,xi:real;
 i:integer;
begin
 pole:=0;
 w:=(b-a)/n;
 xi:=a+w;
 while xi<b do
 begin
  pole:=pole+Fun(xi);
  xi:=xi+w;
 end;
 PoleTrapezy:=(Fun(a)+Fun(b)+2*pole)*w/2;
end;

begin
 ClrScr;
 Write('Podaj dolna granice przedzialu: ');
 Readln(a);
 Write('Podaj gorna granice przedzialu: ');
 Readln(b);
 Write('Podaj liczbe iteracji: ');
 Readln(n);
 Writeln('Pole=',PoleTrapezy(a,b,n):8:4);
end.
________________________________________________38
{Rozwiazywanie ukladu dwoch rownan liniowych }
{- metoda wyznacznikow }
program UkladRownan;
var
 a,b,c,d,e,f:real;
 w,wx,wy:real;

begin
 Writeln('Rozwiazywanie ukladu rownan postaci:');
 Writeln('  ax + by = c');
 Writeln('  dx + ey = f');
 Write('Podaj a: '); Readln(a);
 Write('Podaj b: '); Readln(b);
 Write('Podaj c: '); Readln(c);
 Write('Podaj d: '); Readln(d);
 Write('Podaj e: '); Readln(e);
 Write('Podaj f: '); Readln(f);
 Writeln('Uklad rownan:');
 Writeln(a:6:2,'*x + ',b:6:2,'*y = ',c:6:2);
 Writeln(d:6:2,'*x + ',e:6:2,'*y = ',f:6:2);
 w:=a*e-b*d;
 wx:=c*e-b*f;
 wy:=a*f-c*d;
 if w=0 then
  if (wx=0) and (wy=0) then
   Writeln('Uklad rownan ma nieskonczenie wiele rozwiazan')
  else
   Writeln('Uklad rownan nie ma rozwiazan')
 else
  Writeln('x=',wx/w:6:2,' y=',wy/w:6:2);
end.
________________________________________________39
{Zamiana ulamka dziesietnego na liczbe binarna }
program Ulamek_2;
const
 DOKLADNOSC=20;        (* Maksymalna liczba cyfr *)
var
 liczba, potega, x:real;
 i:integer;
 wynik:string;
begin
 potega:=0.5;
 wynik:='0.';
 i:=DOKLADNOSC;
 Write('Podaj liczbe (<1): ');
 Readln(liczba);
 x:=liczba;
 while (x<>0) and (i>0) do
 begin
  if x<potega then
   wynik:=wynik+'0'
  else
  begin
   wynik:=wynik+'1';
   x:=x-potega;
  end;
  potega:=potega/2;
  Dec(i);
 end;
 Writeln(liczba:8:6,'=',wynik,'(2)');
end.
________________________________________________40
{ Sortowanie przez wstawianie - realizacja iteracyjna }
program Wstawianie_i;
uses
 CRT;
const
 N=8;
type
 TDane=array[1..N] of integer;
var
 Dane:TDane;

procedure WprowadzDane(var d:TDane);
var
 i:integer;
begin
 Writeln('*** Wprowadzanie danych');
 for i:=1 to N do
 begin
  Write('Podaj element nr ',i,': ');
  Readln(d[i]);
 end;
 Writeln('*** Dane wprowadzone');
end;

procedure WyprowadzDane(var d:TDane);
var
 i:integer;
begin
 Writeln('*** Wyprowadzanie danych');
 for i:=1 to N do
  Write(d[i]:8);
 Writeln;
 Writeln('*** Dane wyprowadzone');
end;

procedure SortujDane(var d:TDane);
var
 a,b:TDane;
 i,j,l:integer;
 k:integer;
 liczbaElB:integer;
begin
 a:=d;
 b[1]:=a[1];
 liczbaElB:=1;
 for i:=2 to N do
 begin
  k:=a[i];
  j:=1;
  while (j<=liczbaElB) and (k>b[j]) do
   Inc(j);
  if j>liczbaElB then        (* Dopisz element *)
   b[j]:=k
  else
  begin               (* Wstaw element *)
   for l:=liczbaElB downto j do  (* Przesun elementy o 1 *)
    b[l+1]:=b[l];
   b[j]:=k;            (* Wstaw element *)
  end;
  Inc(liczbaElB);
 end;
 d:=b;
end;

begin
 WprowadzDane(Dane);
 SortujDane(Dane);
 WyprowadzDane(Dane);
end.
________________________________________________41
{ Sortowanie przez wstawianie - realizacja rekurencyjna }
program Wstawianie_r;
uses
 CRT;
const
 N=7;
type
 TDane=array[1..N] of integer;
var
 Dane:TDane;

procedure WprowadzDane(var d:TDane);
var
 i:integer;
begin
 Writeln('*** Wprowadzanie danych');
 for i:=1 to N do
 begin
  Write('Podaj element nr ',i,': ');
  Readln(d[i]);
 end;
 Writeln('*** Dane wprowadzone');
end;

procedure WyprowadzDane(var d:TDane);
var
 i:integer;
begin
 Writeln('*** Wyprowadzanie danych');
 for i:=1 to N do
  Write(d[i]:8);
 Writeln;
 Writeln('*** Dane wyprowadzone');
end;

procedure SortujRekurencyjnie(var w:TDane; var lw:integer; var a:TDane;
               pierwszy,ostatni:integer);
var
 x,y:TDane;
 lx,ly:integer;
 srodek:integer;
 iw,ix,iy:integer;
begin
 if pierwszy<ostatni then
 begin
  srodek:=(pierwszy+ostatni) div 2;
  SortujRekurencyjnie(x,lx,a,pierwszy,srodek);
  SortujRekurencyjnie(y,ly,a,srodek+1,ostatni);
  (* Scal uporzadkowane ciagi iteracyjnie *)
  iw:=1;
  ix:=1;
  iy:=1;
  while (ix<=lx) and (iy<=ly) do
   if x[ix]<y[iy] then
   begin
    w[iw]:=x[ix]; Inc(iw); Inc(ix);
   end
   else if x[ix]>y[iy] then
   begin
    w[iw]:=y[iy]; Inc(iw); Inc(iy);
   end
   else
   begin
    w[iw]:=x[ix]; Inc(iw); Inc(ix);
    w[iw]:=y[iy]; Inc(iw); Inc(iy);
   end;
  while ix<=lx do
  begin
   w[iw]:=x[ix]; Inc(iw); Inc(ix);
  end;
  while iy<=ly do
  begin
   w[iw]:=y[iy]; Inc(iw); Inc(iy);
  end;
  lw:=iw-1;
 end
 else if pierwszy=ostatni then
 begin
  w[1]:=a[pierwszy];
  lw:=1;
 end
end;

procedure SortujDane(var d:TDane);
var
 w:TDane;
 lw:integer;
begin
 SortujRekurencyjnie(w,lw,d,1,N);
 d:=w;
end;

begin
 WprowadzDane(Dane);
 SortujDane(Dane);
 WyprowadzDane(Dane);
end.
________________________________________________42
{ Sortowanie przez wybor }
program Sort_wybor;
const
 LICZBA_DANYCH=100;
type
 TDane=array [1..LICZBA_DANYCH] of integer;
var
 MojeDane:TDane;

procedure WyprowadzDane(var d:TDane);
var
 i:integer;
begin
 for i:=1 to LICZBA_DANYCH do
  Write(d[i]:8);
 WriteLn;
end; (* WyprowadzDane *)

procedure LosujDane(var d:TDane);
var
 i:integer;
begin
 for i:=1 to LICZBA_DANYCH do
  d[i]:=Random(MaxInt);
end; (* LosujDane *)

procedure ZamienZmienne(var a,b:integer);
var
 t:integer;
begin
 t:=a;
 a:=b;
 b:=t;
end; (* ZamienZmienne *)

procedure SortujPrzezWybor(var d:TDane);
var
 i,minIndeks:integer;

function WyszukajMinIndeks(var d:TDane; start:integer):integer;
 var
  i:integer;
  minElement,minIndeks:integer;
 begin
  for i:=start to LICZBA_DANYCH do
   if i=start then
   begin
    minIndeks:=i;
    minElement:=d[minIndeks];
   end
   else
    if d[i]<minElement then
    begin
     minIndeks:=i;
     minElement:=d[minIndeks];
    end;
  WyszukajMinIndeks:=minIndeks;
 end; (* WyszukajMinIndeks *)

begin
 for i:=1 to LICZBA_DANYCH-1 do
 begin
  minIndeks:=WyszukajMinIndeks(d,i);
  ZamienZmienne(d[i],d[minIndeks]);
 end;
end; (* SortujPrzezWybor *)

begin
 Randomize;
 LosujDane(MojeDane);
 WriteLn('Dane przed posortowaniem:');
 WyprowadzDane(MojeDane);
 WriteLn('Dane po posortowaniu:');
 SortujPrzezWybor(MojeDane);
 WyprowadzDane(MojeDane);
end.
________________________________________________43
{ Wyznaczanie miejsca zerowego funkcji }
program Miejsce_zerowe;
uses
 CRT;
var
 a,b:real;
 d1,d2:real;
 n:integer;
 x:real;

function Fun(x: real): real;
begin
 Fun:=3*x*x + x - 2;
{ Fun:=sin(x) + sqrt(3)*cos(x) - 1;}
{ Fun:=x*x*x + x*x - 2*x;}
{ Fun:=3*x*x*x - 2*x*x - 3*x +2;}
end;

function CheckConditions(a,b:real):boolean;
begin
 if a<b then         (* Warunek a < b *)
  CheckConditions:= Fun(a)*Fun(b)<0
 else
  CheckConditions:= FALSE;
end;

function ZeroN(a, b: real; n: integer; var x: real): boolean;

 function Recurse(a,b:real; n:integer):real;
 var
  c,fx:real;
 begin
  c:=(a+b)/2;
  fx:=Fun(c);
  if fx=0 then         (* Miejsce zerowe znalezione *)
   Recurse:=c
  else             (* Miejsce zerowe nieznalezione *)
   if n=0 then         (* Koniec rekurencji *)
    Recurse:=c
   else
    if fx*Fun(a)<0 then    (* Lewy przedziaˆ *)
     Recurse:=Recurse(a,c,n-1)
    else           (* Prawy przedziaˆ *)
     Recurse:=Recurse(c,b,n-1);
 end;

begin
 if CheckConditions(a,b) then  (* Warunki poczĄtkowe speˆnione *)
 begin
  x:=Recurse(a,b,n);
  ZeroN:=TRUE;
 end
 else              (* Warunki poczĄtkowe niespeˆnione *)
  ZeroN:=FALSE;
end;

function ZeroDelta1(a, b: real; delta: real; var x: real): boolean;

 function Recurse(a,b:real; delta:real):real;
 var
  c,fx:real;
 begin
  c:=(a+b)/2;
  fx:=Fun(c);
  if fx=0 then         (* Miejsce zerowe znalezione *)
   Recurse:=c
  else             (* Miejsce zerowe nieznalezione *)
   if Abs(fx)<delta then    (* OsiĄgni©to zaˆoľone przybliľenie *)
    Recurse:=c
   else
    if fx*Fun(a)<0 then    (* Lewy przedziaˆ *)
     Recurse:=Recurse(a,c,delta)
    else           (* Prawy przedziaˆ *)
     Recurse:=Recurse(c,b,delta);
 end;

begin
 if CheckConditions(a,b) then  (* Warunki poczĄtkowe speˆnione *)
 begin
  x:=Recurse(a,b,delta);
  ZeroDelta1:=TRUE;
 end
 else              (* Warunki poczĄtkowe niespeˆnione *)
  ZeroDelta1:=FALSE;
end;

function ZeroDelta2(a, b: real; delta: real; var x: real):boolean;

 function Recurse(a,b:real; delta:real):real;
 var
  c,fx:real;
 begin
  c:=(a+b)/2;
  fx:=Fun(c);
  if fx=0 then         (* Miejsce zerowe znalezione *)
   Recurse:=c
  else             (* Miejsce zerowe nieznalezione *)
   if Abs(b-a)<delta then   (* OsiĄgni©to zaˆoľone przybliľenie *)
    Recurse:=c
   else
    if fx*Fun(a)<0 then    (* Lewy przedziaˆ *)
     Recurse:=Recurse(a,c,delta)
    else           (* Prawy przedziaˆ *)
     Recurse:=Recurse(c,b,delta);
 end;

begin
 if CheckConditions(a,b) then  (* Warunki poczĄtkowe speˆnione *)
 begin
  x:=Recurse(a,b,delta);
  ZeroDelta2:=TRUE;
 end
 else              (* Warunki poczĄtkowe niespeˆnione *)
  ZeroDelta2:=FALSE;
end;

begin
 ClrScr;
 Write('Podaj dolna granice przedzialu: ');
 Readln(a);
 Write('Podaj gorna granice przedzialu: ');
 Readln(b);
 Write('Podaj liczbe iteracji: ');
 Readln(n);
 Write('Podaj delte dla funkcji ZeroDelta1: ');
 Readln(d1);
 Write('Podaj delte dla funkcji ZeroDelta2: ');
 Readln(d2);
 if ZeroN(a,b,n,x) then
  Writeln('Miejsce zerowe znalezione funkcja ZeroN: ',x:8:4)
 else
  Writeln('Znalezienie miejsca zerowego funkcja ZeroN nie bylo mozliwe');
 if ZeroDelta1(a,b,d1,x) then
  Writeln('Miejsce zerowe znalezione funkcja ZeroDelta1: ',x:8:4)
 else
  Writeln('Znalezienie miejsca zerowego funkcja ZeroDelta1 nie bylo mozliwe');
 if ZeroDelta2(a,b,d2,x) then
  Writeln('Miejsce zerowe znalezione funkcja ZeroDelta2: ',x:8:4)
 else
  Writeln('Znalezienie miejsca zerowego funkcja ZeroDelta2 nie bylo mozliwe');
end.