Dze je subor www.TrSek.com/cover/lizal_okurek/sopky.pas

{ SOPKY.PAS              Copyright (c) Miroslav Lízal, Tomáš Okurek }
{ Evidencia sopiek vo svete.                                        }
{                                                                   }
{ Datum:25.04.2003                             http://www.trsek.com }

program hora_zaznamu;
uses crt;
type zaznam=record
             jm:string;
             vy:integer;
             st:string;
             ci:boolean;
           end;

type pole=array[1..10] of zaznam;
var p:pole;
    ps:integer;
    nabidka:integer;

procedure nacti(var cislo:integer);
var cinnost:char;
begin
cislo:=cislo+1;
clrscr;
writeln;
write('  Jmeno:          ');
readln(p[cislo].jm);
write('  Stat:           ');
readln(p[cislo].st);
write('  Vyska:          ');
readln(p[cislo].vy);
write('  Cinnost[a/n]:   ');
readln(cinnost);

if cinnost='a' then p[cislo].ci:=true
else p[cislo].ci:=false;
end;

procedure vypis(cislo:integer);
var i:integer;
    co:integer;
    cinnost:string;
begin
clrscr;
writeln;
writeln('  Seznam sopek:');
for i:=1 to cislo do writeln('  ',i,' ',p[i].jm);
writeln;
write('  Zadejte cislo sopky kterou chcete vypsat: ');
readln(co);
writeln;
writeln('  Jmeno:    ',p[co].jm);
writeln('  Stat:     ',p[co].st);
writeln('  Vyska:    ',p[co].vy);
if p[co].ci=true then cinnost:='je'
                  else cinnost:='neni';
writeln('  Cinnost:  sopka ',cinnost,' cinna');
readln;
end;

procedure vyvso(cislo:integer);
var cinnost:string;
    co:integer;
begin
clrscr;
for co:=1 to cislo do begin
  writeln;
  writeln('  Jmeno:    ',p[co].jm);
  writeln('  Stat:     ',p[co].st);
  writeln('  Vyska:    ',p[co].vy);
  if p[co].ci=true then cinnost:='je'
                   else cinnost:='neni';
  writeln('  Cinnost:  sopka ',cinnost,' cinna');

  delay(500);
end;
readln;
end;

procedure oprav(cislo:integer);
var cinnost:string;
    opravdu:char;
    i:integer;
    co:integer;
begin
clrscr;
writeln;
writeln('  Seznam sopek:');
for i:=1 to cislo do writeln('  ',i,' ',p[i].jm);
writeln;
write('  Zadejte cislo sopky kterou chcete upravit: ');
readln(co);
writeln;
writeln;
writeln('  Jmeno:    ',p[co].jm);
writeln('  Stat:     ',p[co].st);
writeln('  Vyska:    ',p[co].vy);
if p[co].ci=true then cinnost:='je'
                  else cinnost:='neni';
writeln('  Cinnost:  sopka ',cinnost,' cinna');

write('Opravdu chcete tento zaznam upravit[a/n]: ');
readln(opravdu);
if opravdu='a' then begin
    writeln;
    write('  Jmeno:          ');
    readln(p[co].jm);
    write('  Stat:           ');
    readln(p[co].st);
    write('  Vyska:          ');
    readln(p[co].vy);
    write('  Cinnost[a/n]:   ');
    readln(cinnost);
    if cinnost='a' then p[cislo].ci:=true
                   else p[cislo].ci:=false;
end;
end;

procedure vymaz(var cislo:integer);
var i:integer;
    co:integer;
    opravdu:char;
    cinnost:string;
begin

clrscr;
writeln;
writeln('  Seznam sopek:');
for i:=1 to cislo do writeln('  ',i,' ',p[i].jm);
writeln;
write('  Zadejte cislo sopky kterou chcete smazat: ');
readln(co);
writeln;
writeln;
writeln('  Jmeno:    ',p[co].jm);
writeln('  Stat:     ',p[co].st);
writeln('  Vyska:    ',p[co].vy);
if p[co].ci=true then cinnost:='je'
                  else cinnost:='neni';
writeln('  Cinnost:  sopka ',cinnost,' cinna');

write('Opravdu chcete tento zaznam upravit[a/n]: ');
readln(opravdu);
if opravdu='a' then begin

   for i:=co to cislo-1 do begin
                         p[i]:=p[i+1];
                         cislo:=cislo-1;
                        end;

end;

end;

begin
ps:=0;
textbackground(1);

repeat
  clrscr;
  textcolor(3);
  writeln;
  writeln;
  writeln('  Co chcete delat?');
  writeln;
  textcolor(15);
  writeln('  1 Nova sopka');
  writeln;
  writeln('  2 Upravit sopku');
  writeln;
  writeln('  3 Smazat sopku');
  writeln;
  writeln('  4 Vypsat sopku');
  writeln;
  writeln('  5 Vypsat vsechny sopky');
  writeln;
  textcolor(10);
  writeln('  9 Konec');
  textcolor(15);
  writeln;
  write('  Nabidka cislo: ');
  readln(nabidka);

  case nabidka of
   1: nacti(ps);
   2: oprav(ps);
   3: vymaz(ps);
   4: vypis(ps);
   5: vyvso(ps);
  end;

until nabidka=9;
end.

Copyrigth by Zdeno Sekerak 2007, http://www.trsek.com