3.1.2. Jazyk pascal

Příklady v jazyce Pascal

Viz. [ CUNI1 ]

Příklad 3.5. Test na prvočísla

program test_prvocislo;

var
        N : integer;      { Testovane cislo }
        D : integer;      { Prochazi vsechny delitele }
        Pocet : integer;  { Pocet delitelu }

begin
        write('Zadej cislo: ');
        readln(N);

        if N <= 0 then writeln('Pracuji jen s kladnymi cisly')
        else if N = 1 then writeln('Jedna neni prvocislo ani cislo slozene')
        else begin
                Pocet := 0;

                { Cyklus For - projdi vsechna cisla od 2 do N-1. }

                { for D := 2 to N-1 do
                    if N mod D = 0 then Pocet := Pocet + 1;
                }

                { Cyklus While - Skonci, kdyz
                        1) najdes prvniho delitele ; nebo
                        2) prosel jsi uz vsechny delitele, tj. do odmocniny z N
                }

                D := 2;
                while (Pocet = 0) and (D < sqrt(N)) do begin
                        if N mod D = 0 then Pocet := Pocet + 1;
                        D := D + 1;
                end;

                { Plati veta: Jestlize je cislo N prvocislo vetsi nez 3, pak N=6k-1 nebo N=6k+1 pro nejake k prirozene.
                Ukol: Napiste program, ktery bude testovat delitelnost pouze cisly, ktera mohou byt prvocisla podle predchozi vety.
                Tj. testujte delitelnost cisly 5, 7,  11, 13,  17, 19,  23, 25, ... Nezapomente na to, ze 2 a 3 jsou take prvocisla. }

                if Pocet = 0 then writeln('Prvocislo')
                else writeln('Slozene');

        end;
        readln;
end.

Příklad 3.6. Kořeny kvadratické rovnice

var	a,b,c:integer; {Koeficienty kvadratické rovnice (pro nás celočíselné).}
	diskriminant,x,y :real; {Čísla x,y jsou možné kořeny kv.rovnice, už nutně reálné.}

begin
writeln(' Program pocita koreny kvadraticke rovnice Ax*x + Bx + C ');
write(' Vlozte A: '); read(a);
write(' Vlozte B: '); read(b);
write(' Vlozte C: '); read(c); {Načítání koeficientů ukončeno}
diskriminant:=b*b-4*a*c;
if diskriminant<0 then 
	writeln(' Rovnice nema realne koreny. ')
else if diskriminant >= 0 then
begin
	x:=(-b+sqrt(diskriminant))/(2*a);
	y:=(-b-sqrt(diskriminant))/(2*a); {Je-li diskriminant nezáporný spočítáme kořeny.}
	{Následující podmínka tvrdí, pokud je x=y (tedy diskriminant je roven 0) má rovnice právě jeden reálný kořen.
	Pokud jsou x a y různá čísla (diskriminant je větší nuly) má dva různé reálné kořeny}
	if x=y then
	begin
		writeln (' Rovnice (',a,')x*x +(',b,')x +(',c,') ma prave jeden realny koren.');
		writeln (' x = ',x);
	end
	else
	begin
		writeln (' Rovnice (',a,')x*x +(',b,')x +(',c,') ma prave dva realne koreny.');
		writeln (' x1 =',x:4,' x2 =',y:4);
	end;
end;
         
readln; readln;


end.

Příklad 3.7. Fronta a zásobník

Uses Crt;

const MAX = 1000;

var
	Fronta : Array [1..MAX] of String;
	FrontaPocet : Word;

procedure frontaInicializace;
begin
	FrontaPocet := 0;
end;

function frontaVloz(jm : String) : Boolean;
begin
	if FrontaPocet = MAX then frontaVloz := false
	else begin
		frontaVloz := true;
		FrontaPocet := FrontaPocet + 1;
		Fronta[FrontaPocet] := jm;
	end;
end;

function frontaVyjmi(var jm : String) : Boolean;
var i : Word;
begin
	if FrontaPocet = 0 then frontaVyjmi := false
	else begin
		frontaVyjmi := true;
		FrontaPocet := FrontaPocet - 1;
		
		{Fronta}
		jm := Fronta[1];
		for i := 1 to FrontaPocet do Fronta[i] := Fronta[i+1];
		
		{ Zasobnik}
		{jm := Fronta[FrontaPocet+1];}
	end;
end;

var jm : String;
	
begin
	frontaInicializace;
	
	WriteLn('Zadavej jmena, ktera se budou ukladat do fronty. Zadavani ukoncis zadanim "-".');
	ReadLn(jm);
	while jm <> '-' do begin
		if not frontaVloz(jm) then begin
			WriteLn('Nepodarilo se ulozit - uz neni misto. Ukoncuji zadavani.');
			break;
		end;
		ReadLn(jm);
	end;
	
	WriteLn('Vypis jmen:');
	while frontaVyjmi(jm) do WriteLn(jm);
end.

Příklad 3.8. Aritmetický součet posloupnosti

program pod;

var cislo,mnozstvi,soucet:integer;
    prumer:real;
begin
mnozstvi:=0;
soucet:=0;
writeln('Zadavejte cisla, vstup ukoncete stisknutim nuly a entrem.');
repeat
	read(cislo);
	if cislo<>0 then
	begin
		mnozstvi:=mnozstvi+1;
		soucet:=soucet+cislo;
		prumer:=soucet/mnozstvi;
		write('Prumer je ',prumer);
	end;
until cislo=0;

readln;readln;
end.

Příklad 3.9. Základní třídící algoritmy

Program BubbleSort;

const
	MAX = 100;
	debug = false; { Pro testovaci ucely }

var
	pole : array [1..MAX] of Integer;
	pole_max : Word;

{ Vypsani cisel z pole. }
procedure vypis();
var i : Word;
begin
	for i := 1 to pole_max do begin
		if i > 1 then Write(', ');
		Write(pole[i]);
	end;
	WriteLn;
end;

{ Vymeni cisla na indexech i a j. }
procedure vymen(i, j: Word);
var swap : Integer;
begin
	swap := pole[i];
	pole[i] := pole[j];
	pole[j] := swap;
end;

{ BubbleSort
  ==========
Porovnavame dve cisla a kdyz jsou ve spatnem poradi, tak je prehodime. }
procedure bubble_sort();
var i, j : Word;
begin
	for i := 1 to pole_max-1 do { Faze. V kazde fazi nejvetsi cislo (ze zbyvajicich) probubla az na konec (doprava). }
		for j := i+1 to pole_max do { Plati: i < j }
			if pole[i] > pole[j] then vymen(i,j);
	
end;

{ InsertSort
  ==========
Pracujeme ve fazich. V i-te fazi najdeme i-te nejmensi cislo a to umistime. }
procedure insert_sort();
var i, j, k : Word;
begin
	for i := 1 to pole_max-1 do { Pocet fazi }
	begin
		k := pole[i]; { Tady je chyba, ale objevte ji sami }
		for j := i+1 to pole_max do 
			if pole[k] > pole[j] then k := j;
		if debug then WriteLn('Vymenuji ', i, ' <-> ', k);
		if debug then vypis;
		vymen(i, k);
		if debug then vypis;
	end;
	
end;

{ QuickSort
  =========
}
function partition(start, finish, level : Word) : Word;
const randomized = false; { Randomizovany QuickSort : pivota vyberu nahodne. }
var i, j, q, pivot : Word;
begin
	if randomized then begin
		{ Nahodne vybereme pivota a umistime ho na konec. }
		i := start + random(finish - start + 1);
		if debug then begin for q := 0 to level do Write('   '); WriteLn('Randomizuji [', i, '] = ', pole[i]); end;
		vymen(i, finish);
	end;
	
	pivot := pole[finish];
	i := start;
	j := finish;
	if debug then begin for q := 0 to level do Write('   '); WriteLn('Pivot = ', pivot); end;
	while i < j do begin
		while (pole[i] <= pivot) and (i < j) do i := i + 1;
		if pivot < pole[i] then begin
			vymen(i, j);
			if debug then begin for q := 0 to level do Write('   '); WriteLn('Vymenuji [', i, '] = ', pole[i], ' <=> [', j, '] = ', pole[j]); end;
		end;
		while (pivot < pole[j]) and (i < j) do j := j - 1;
		if pole[j] < pivot then begin
			vymen(i, j);
			if debug then begin for q := 0 to level do Write('   '); WriteLn('Vymenuji [', i, '] = ', pole[i], ' <=> [', j, '] = ', pole[j]); end;
		end;
	end;
	pole[j] := pivot;
	partition := j;
end;

procedure quick_sort_special(start, finish, level : Word);
var split, q : Word;
begin
	if finish <= start then exit;
		if debug then begin for q := 0 to level do Write('   '); Write('Tridim  '); for q := start to finish do Write(pole[q], ' '); WriteLn('   start = ', start, ', finish = ', finish); end;
	split :=  partition(start, finish, level);
		if debug then begin
			for q := 0 to level do Write('   ');
			Write('Po rozdeleni  ');
			for q := start to split-1 do Write(pole[q], ' ');
			Write('|', pole[split], '| ');
			for q := split+1 to finish do Write(pole[q], ' ');
			WriteLn;
		end;
	quick_sort_special(start, split-1, level+1);
	quick_sort_special(split+1, finish, level+1);
		if debug then begin for q := 0 to level do Write('   '); Write('Setrideno  '); for q := start to finish do Write(pole[q], ' '); WriteLn; end;
end;

procedure quick_sort();
begin
	quick_sort_special(1, pole_max, 0);
end;

var i : Word;
begin
	{ Inicializace }
	if debug then randomize;
	
	{ Nacteni cisel }
	repeat
		Write('Zadej pocet cisel: ');
		ReadLn(pole_max);
	until (1 <= pole_max) and (pole_max <= MAX);
	
	for i := 1 to pole_max do
		if not debug then begin
			Write('Zadej ', i, '. cislo: ');
			ReadLn(pole[i]);
		end else pole[i] := random(100);
	
	WriteLn('Zadana cisla:');
	vypis;
	
	{ Trideni }
	bubble_sort;
	{ insert_sort; }
	{ quick_sort; }
	
	WriteLn('Setridena cisla:');
	vypis;
end.