Evidencia sopiek vo svete

Kategorija: KMP (Programy mladňakoch

Zrobil: Miroslav Lízal, Tomáš Okurek
web: pascalweb.wz.cz/index86.html

Program: Sopky.pas
Subor exe: Sopky.exe

{ 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.