Pascal repeat until használata alprogramokban?
Sziasztok!
A minap az oldalon sokan segítettetek nekem egy feladat megoldásában, ami elég jól sikerült!
Ugyan ezt a programot kellene kicsit továbbfejleszteni, úgy hogy procedúrákat használjon.
program absz;
uses crt;
var
maganhangzo, massalhangzo, kulonlegeskarakter, szoveg, z : string;
maganhangzos:array[1..14] of byte;
massalhangzos:array[1..21] of byte;
specialiskarakter:array[1..19] of byte;
i,j,k,l : byte;
betu,x : char;
betus : byte;
procedure karakterek;
begin
betus := 0;
for j := 1 to 14 do
maganhangzos[j]:=0;
for k := 1 to 21 do
massalhangzos[k]:=0;
for l := 1 to 19 do
specialiskarakter[l]:=0;
maganhangzo:='áéöőüűúóíaeiou';
massalhangzo:='bcdfghjklmnpqrstvwxyz';
kulonlegeskarakter:=',;?.:-_@#/\+"!%=()*';
end;
procedure beolvasas;
begin
textcolor(12);
write('Irjon be egy szoveget! ');
readln(szoveg);
delay(1400);
Write('Kerem a megszamolando betut : ');
readln(betu);
textcolor(6);
for i := 1 to length(szoveg) do
begin
for l:=1 to 19 do
if (lowercase(szoveg[i])=kulonlegeskarakter[l]) then inc(specialiskarakter[l]);
for j:=1 to 14 do
if (lowercase(szoveg[i])=maganhangzo[j]) then inc(maganhangzos[j]);
for k:=1 to 21 do
if (lowercase(szoveg[i])=massalhangzo[k]) then inc(massalhangzos[k]);
if (lowercase(szoveg[i])=lowercase(betu)) then inc(betus);
end;
WriteLn;
end;
procedure kiir1;
begin
WriteLn('A szovegben a(z) ',betu,' betu ',betus,' alkalommal fordult elo.');
writeln;
end;
procedure kiir2;
begin
textcolor(5);
writeln('Megmutassam a maganhangzokat es massalhangzokat?');
textcolor(6);
repeat
writeln('I/N');
x:=(upcase(readkey));
until(x <> 'I') or (x <> 'N');
if x='I' then begin
writeln('Maganhangzok: ');
for j:=1 to 14 do
if maganhangzos[j]>0 then writeln(maganhangzo[j],' betu: ',maganhangzos[j],' alkalommal fordult elo.');
writeln('Massalhangzok:');
for k:=1 to 21 do
if massalhangzos[k]>0 then writeln(massalhangzo[k],' betu: ',massalhangzos[k],' alkalommal fordult elo.');
end;
end;
procedure kiir3;
begin
textcolor(5);
writeln('Megmutassam a kulonleges karaktereket?');
textcolor(6);
repeat
writeln('I/N');
x:=(upcase(readkey));
until(x <> 'I') or (x <> 'N');
if x='I' then begin
writeln('Kulonleges karakterek: ');
for l:=1 to 19 do
if specialiskarakter[l]>0 then writeln(kulonlegeskarakter[l],' karakter: ',specialiskarakter[l],' alkalommal fordult elo.');
end;
end;
procedure kiir4;
begin
textcolor(5);
writeln('Erdekli hogy hany karaktert gepelt be?');
textcolor(6);
repeat
writeln('I/N');
x:=(upcase(readkey));
until(x <> 'I') or (x <> 'N');
if x='I' then begin
writeln('Ennyi karakter talaltam osszesen: ',length(szoveg));
end;
end;
procedure restart;
begin
repeat
textcolor(5);
writeln('Futtassam meg egyszer a programot?');
textcolor(6);
writeln('Igen/Nem');
readln(z)
until z='nem';
end;
begin
clrscr;
karakterek;
beolvasas;
kiir1;
kiir2;
kiir3;
kiir4;
restart;
readln;
end.
Így néz ki a program most. Jelenleg a 'restart' procedure csak saját magát indítja újra, tudom. Ezt kellene úgy megoldani hogy az egész programot újraindítsa.
Meg hát, én is úgy csináltam...
@SimkoL:
El is kezdtem ám, mert sejtettem, hogy számon kéred, de aztán az éjjeli torpor-állapotban belezavarodtam, hogy hogyan kéne a karakterenkénti nyilvántartást intézni, inkább nem hagytam el a kitaposott ösvényt.
Az elv:
program Project1;
type TCharSet = set of Char;
var
magan : TCharSet = ['a','e','i','o','u'];
massal : TCharSet = ['b','c','d','f','g','h','j','k','l','m','n','p','q','r','s','t','v','w','x','y','z'];
spec : TCharSet = ['<','>','[',']',',',';','?','.',':','-','_','@','#','/','\','+','"','!','%','=','(',')','*'];
darab : array[0..255] of byte;
s: string;
i : integer;
begin
s := 'a zsiroskenyeret nagyon szeretem nyaron, friss gyenge hagymaval, hagymaszarral';
for i := 1 to Length(s) do Inc(darab[Ord(s[i])]);
WriteLn('maganhangzok: ');
for i := 0 to Length(darab) - 1 do if (Chr(i) in magan) and (darab[i] > 0) then WriteLn(Chr(i), darab[i]:3);
WriteLn('massalhangzok: ');
for i := 0 to Length(darab) - 1 do if (Chr(i) in massal) and (darab[i] > 0) then WriteLn(Chr(i), darab[i]:3);
WriteLn('specialis: ');
for i := 0 to Length(darab) - 1 do if (Chr(i) in spec) and (darab[i] > 0) then WriteLn(Chr(i), darab[i]:3);
ReadLn;
end.
A többit rád bízom.
Újabb kísérlet, halmazokkal:
A type-ot elhagytam, nem mintha sok értelme lenne, csak így a „set of char”-t mindegyiknél kiírva egyelőre talán jobban érthető.
Még annyit: Megmaradtam a linuxban működő, 127-nél kisebb karakterek tartományában, és csak a szóköztől indul a tömb, mert a kisebb különleges karaktereket úgysem tudtam billentyűzetről bevinni -- lehet, hogy ez is a linux miatt van, mindenesetre a határok könnyen megváltoztathatók.
Utólag látom, hogy a ClrScr-t nem kellett volna a programtörzsben hagynom, jó lett volna az a beolvasás elején is, de mindegy.
Másik verzió, helyenként karikaturisztikus elemekkel:
Function-válaszbeolvasással és egyéb cifrákkal:
További kérdések:
Minden jog fenntartva © 2024, www.gyakorikerdesek.hu
GYIK | Szabályzat | Jogi nyilatkozat | Adatvédelem | Cookie beállítások | WebMinute Kft. | Facebook | Kapcsolat: info(kukac)gyakorikerdesek.hu
Ha kifogással szeretne élni valamely tartalommal kapcsolatban, kérjük jelezze e-mailes elérhetőségünkön!