Zadania z tablic

program ileliter; {wypisuje ile jest jakich liter}
type tablica=array['A'..'Z'] of integer;
var napis:string;ch:char;i:byte;T:tablica;
begin
for ch:='A' to 'Z' do T[ch]:=0;
writeln('Napisz ilka lini tekstu');
repeat
readln(napis);
for i:=1 to length(napis) do
begin
ch:=upcase(napis[i]);
if ch in['A'..'Z'] then T[ch]:=T[ch]+1;
end
until length(napis)=0;
for ch:='A' to 'Z' do
if T[ch]<>0 then write(ch,':',T[ch]:3,' ');
readln;
end.

program cyfry; { Maksymalna ilosc cyfr wystepujacych pod rzad w tekscie }
uses Crt;
const cyfry : set of '0'..'9' = ['0'..'9']; }
var txt : String;
i, ile : Integer;
max : Integer;
begin
ClrScr;
writeln('Napisz jaki tekst i nacinij ENTER');
readln(txt);
max:=0;
i:=0;
while i<=length(txt) do
begin
while not (txt[i] in cyfry) do inc(i);
ile:=0;
while (txt[i] in cyfry) do
begin
inc(ile); inc(i);
end;
if max < ile then max:=ile;
end;
writeln('Maksymalny ciag znakow skladajacy sie z samych cyfr');
writeln('ma dlugosc: ',max);
readln
end.

Program liczba; { Minimalna i maksymalna liczba w tablicy }
const n=10;
var i, min, max : Integer;
a : Array[1..n] of Integer;
begin
writeln ('Podaj ',n,' liczb. Po kazdej nacisnij ENTER');
for i:=1 to n do readln(a[i]);
min:=32767; max:=-32767;
for i:=1 to n do
begin
if a[i] > max then max:=a[i];
if a[i] < min then min:=a[i];
end;
writeln('min= ',min,' max= ',max);
readln;
end.

Program palindrom;
uses Crt;
var txt : String;
i, dltxt: Integer;
jest : Boolean;
begin
ClrScr;
writeln('Napisz jaki tekst i nacinij ENTER');
readln(txt);
for i:=1 to length(txt) do
if txt[i]=' ' then delete(txt,i,1);
dltxt:=length(txt);
jest:=true;
i:=dltxt div 2;
while jest and (i>=1) do
begin
if UpCase(txt[i])<>UpCase(txt[dltxt-i+1]) then jest:=false;
inc(i,-1)
end;
if jest then writeln('Tekst jest palindromem')
else writeln('Tekst nie jest palindromem');
readln
end.

Program wspak; { Uzyskac rekurencyjnie zadane slowo wspak }
var txt : String;
procedure wspak (i:Integer; txt:String);
begin
if i=length(txt) then write(txt[i])
else begin
wspak(i+1,txt);
write(txt[i])
end
end; { procedury wspak }
begin
writeln('Podaj tekst');
readln(txt);
writeln('wspak: ');
wspak(1,txt);
readln
end.

Program slowami;
uses crt;
var w: word;
s, l: string;
procedure koncz;
begin
writeln(l);
halt;
end;
begin
writeln;
write('Podaj liczbe: ');
readln(w);
str(w, s);
if s[0] = #0 then koncz;
for w := length(s) downto 1 do s[5+length(s)-w] := s[w];
for w := 5 to 5+length(s) do s[w-4] := s[w];
if (s[0] = #1) AND (s[1] = '0') then begin
l := 'zero';
koncz;
end;
if (s[0] > #1) AND (s[2] = '1') then begin
case s[1] of
'0': l := 'dziesiec';
'1': l := 'jedenascie';
'2': l := 'dwanascie';
'3': l := 'trzynascie';
'4': l := 'czternascie';
'5': l := 'pietnascie';
'6': l := 'szesnascie';
'7': l := 'siedemnascie';
'8': l := 'osiemnascie';
'9': l := 'dziewietnascie';
end;
end
else case s[1] of
'1': l := 'jeden';
'2': l := 'dwa';
'3': l := 'trzy';
'4': l := 'cztery';
'5': l := 'piec';
'6': l := 'szesc';
'7': l := 'siedem';
'8': l := 'osiem';
'9': l := 'dziewiec';
end;
case s[2] of
'2': l := 'dwadziescia ' + l;
'3': l := 'trzydziesci ' + l;
'4': l := 'czterdziesci ' + l;
'5': l := 'piecdziesiat ' + l;
'6': l := 'szescdziesiat ' + l;
'7': l := 'siedemdziesiat ' + l;
'8': l := 'osiemdziesiat ' + l;
'9': l := 'dziewiecdziesiat ' + l;
end;
if s[0] < #3 then koncz;
case s[3] of
'1': l := 'sto ' + l;
'2': l := 'dwiescie ' + l;
'3': l := 'trzysta ' + l;
'4': l := 'czterysta ' + l;
'5': l := 'piecset ' + l;
'6': l := 'szescset ' + l;
'7': l := 'siedemset ' + l;
'8': l := 'osiemset ' + l;
'9': l := 'dziewiecset ' + l;
end;
if s[0] < #4 then koncz;
case s[4] of
'1': l := 'tysiac ' + l;
'2': l := 'dwa tysiace ' + l;
'3': l := 'trzy tysiace ' + l;
'4': l := 'cztery tysiace ' + l;
'5': l := 'piec tysiecy ' + l;
'6': l := 'szesc tysiecy ' + l;
'7': l := 'siedem tysiecy ' + l;
'8': l := 'osiem tysiecy ' + l;
'9': l := 'dziewiec tysiecy ' + l;
end;
koncz;
end.

Program suma; { Suma cyfr liczby naturalnej }
uses Crt;
var x0, x, suma, cyfra : Integer;
begin
ClrScr;
repeat
writeln('Podaj liczb‘ naturaln† mniejsz† od 32768');
readln(x);
until (x >= 0);
x0:=x;
suma:=0;
while x>0 do
begin
cyfra:=x mod 10;
x:=x div 10; { dzielenie ca’kowite przez 10 }
suma:=suma+cyfra
end;
writeln('Suma cyfr liczby ',x0,' = ',suma);
readln;
end.

Program na sylaby; { Podzia’ s’owa na sylaby }
uses Crt;
const samogloski: set of char =
['a','o','e','i','u','y','ł','ź','ż',
'A','O','E','I','U','Y','Ł','Ź','Ż'];
var txt : String;
i : Integer;
function ostatnia(i:integer) : Boolean;
var n :Integer;
x :Boolean;
begin
x:=true;
for n:=i+1 to length(txt) do
if txt[n] in samogloski then x:=false;
ostatnia:=x
end;
begin
ClrScr;
writeln('Napisz jakie s’owo i nacinij ENTER');
readln(txt);
writeln('Po podzieleniu na sylaby:');
for i := 1 to length(txt) do
if (not (txt[i] in samogloski)) or { jeli badana litera nie jest samog’osk† }
((UpCase(txt[i]) = 'I') and (txt[i+1] in samogloski)) or { lub jest
liter† 'i' stoj†c† przed samog’osk† }
((UpCase(txt[i]) = 'A') and (UpCase(txt[i+1]) = 'U')) or { lub jest
liter† 'a' stoj†c† przed liter† 'u' }
((txt[i] in samogloski) and ostatnia(i)) { lub jest samog’oska ale
ostatni† liter† w s’owie }
then write(txt[i]) { napisz j† bez zmian }
else write(txt[i],'-'); { napisz j† i oddziel od
nast‘pnej sylaby kresk† }
readln;
end.

Program komputer; { Czy w tekcie jest s’owo 'komputer'}
uses Crt;
var txt : String; { badany tekst }
slowo : String; { wyodr‘bnione s’owo z tekstu }
i, j : Integer;
jest : Boolean; { = TRUE jeli w tekcie jest poszukiwane s’owo }
begin
ClrScr;
writeln('Napisz jaki tekst i nacinij ENTER');
readln(txt);
jest := false; { zakladamy, ze nie ma slowa 'komputer' w 'txt' }
i := 1;
repeat
while (txt[i] = ' ') do inc(i);
j := 1;
while (txt[i] <> ' ') and (txt[i] <> '.') and (txt[i] <> ',') and
(txt[i]<>';') and (txt[i]<>'?') and (txt[i]<>'!') and
(txt[i]<>':') and
{ lub tekstu }
(i <= length(txt)) do
begin
slowo[j] := UpCase(txt[i]);
inc(i); inc(j);
end;
slowo[0] := Chr(j-1);
if slowo = 'KOMPUTER' then jest := true;
until jest or (i >= length(txt));
if jest then writeln('W tekcie jest s’owo ''komputer''')
else writeln('W tekcie brak s’owa ''komputer''');
readln
end.

Program usuniecie cyfr; { Usuni‘cie z tekstu wszystkich znakw nie b‘d†cych literami }
uses Crt;
var txt : String;
i : Integer;
function litera(z:Char): Boolean;
const polskie: set of Char =
['†','‘','','’','¦','','','','',
'Ź','','Ł','ś',' ','','•','Ą',''];
begin
if ((64 ((96 (z in polskie)
then litera:=true
else litera:=false
end;
begin
ClrScr;
writeln('Napisz jakie s’owo i nacinij ENTER');
readln(txt);
i:=1;
while i<=length(txt) do
if not litera(txt[i]) then delete(txt,i,1)
else inc(i);
writeln;
writeln('Tekst po usuni‘ciu innych znakw ni litery:');
writeln(txt);
readln
end.

PROGRAM Zlicz_Litery;
CONST
STOP='*';
VAR
liczby:ARRAY ['A'..'Z'] OF INTEGER;
litery:SET OF CHAR;
zn :CHAR;
BEGIN
litery:=['A'..'Z'];
FOR zn:='A' TO 'Z' DO
liczby[zn]:=0;
zn:=' ';
WRITELN('Podaj tekst zakonczony znakiem *');
WHILE zn<>stop DO
BEGIN
READ(zn);
IF zn IN litery
THEN liczby[zn]:=liczby[zn]+1
END;
FOR zn:='A' TO 'Z' DO
WRITELN(zn,liczby[zn]:4)
END. {Zlicz_Litery}

PROGRAM Tablicowanie;
VAR
a,b,h,x,y:REAL;
FUNCTION Fun(x:REAL):REAL;
BEGIN
Fun:=COS(x)
END; {Fun}
BEGIN {Program glowny}
WRITE('Podaj przedzial tablicowania funkcji i krok (a,b,h) :');
READLN(a,b,h);
WRITELN('Tablicowanie wartosci funkcji w przedziale (' ,a,',',b,')');
x:=a;
WHILE x<=b DO
BEGIN
y:=Fun(x);
WRITELN(x:6:1,y:8:4);
x:=x+h
END;
IF (x<>b) AND ((x-b)<0.001)
THEN
BEGIN
y:=Fun(b);
WRITELN(x:6:1,y:8:4)
END
END. {Tablicowanie}

1. Wprowadzic program obliczajacy
max = maksimum{x1,x2,...,xn},
w ktorym liczby sa przechowywane w tablicy.

PROGRAM Maksimum;
VAR
x :ARRAY [1..10] OF REAL;
i :INTEGER;
max,c:REAL;
BEGIN
WRITELN('Podaj 10 liczb : ');
FOR i:=1 TO 10 DO
READ(x[i]);
max:=x[1];
FOR i:=2 TO 10 DO
BEGIN
c:=x[i];
IF c>max THEN max:=c
END;
WRITELN('Maksymalna liczba=',max)
END. {Maksimum}