Umiestnenie súboru www.TrSek.com/cover/benkovic/pamat.pas

{ PAMAT.PAS                              Copyright (c) Jan Benkovic }
{ Simulacia zretazenej pamate.                                      }
{                                                                   }
{ Datum:13.09.2001                             http://www.trsek.com }

Program Simlacie_zretazenej_pamate;

uses crt;

const
Free = 0;
_End  = -1;
Pocet_miest = 16;

var
pole1 : array[1..pocet_miest] of string[1];
pole2 : array[1..pocet_miest] of integer;
c     : char;

procedure vynuluj_polia;                (*Vynuluje polia*)
var pom : word;
begin
  for pom:= 1 to Pocet_miest do
   begin
    pole1[pom]:=' ';
    pole2[pom]:=Free;
   end;
end;

procedure napis_menu;                   (*Napise menu*)
begin
  clrscr;
  gotoxy(1,1);
  textcolor(white);
  Writeln('1| Vypis To!');
  Writeln('2| Uloz');
  Writeln('3| Uvolni');
  Writeln('4| Vyhod ma');
end;

procedure vypis;                        (*Vypise polia*)
var pom: byte;
begin
  clrscr;
  gotoxy(1,1);
  Writeln('Vypis polia : ');
  gotoxy(1,2);
  for pom:= 1 to Pocet_miest do Write(pole1[pom],' ');
  Writeln;
  for pom:= 1 to Pocet_miest do Write(pole2[pom],' ');
  readkey;
  clrscr;
  napis_menu;
end;

procedure zmaz;                         (*Zmaze zadane pismeno z pola*)
var
  pismeno   : string[1];
  pom       : integer;
  new_poz   : byte;
  pocet_pis : byte;

begin
  gotoxy(1,1);
  clrscr;
  Writeln('Napis ake pismeno chces zmazat :');
  Readln(pismeno);
  pom:=0;

  repeat                                (*Najde prve pismeno alebo to skonci ak nenajde*)
   inc(pom);
  until (pole1[pom]=pismeno) or (pom=Pocet_miest);

  if pole1[pom]=pismeno then
   begin
    repeat                              (*Repeat uskutocny zmazanie podla pola2*)
     new_poz:=pom;
     pole1[new_poz]:=' ';
     pom:=pole2[new_poz];
     pole2[new_poz]:=Free;
    until pom=_End;
    Writeln('Mas to prec!');            (*Vypise ukoncenie*)
   end
  else Writeln('Boh vie co sa stalo!');
  Readkey;
  napis_menu;
end;

procedure uloz;                         (*Ulozi pismenko do pola + jeho pozicie*)
var
  pom1,pom        : byte;
  dalej           : boolean;
  volne_miesta    : byte;
  zaplnene_miesta : byte;
  zaberat         : byte;
  old_poz         : byte;
  pismeno         : string[1];

begin
  clrscr;
  gotoxy(1,1);
  zaplnene_miesta:=0;
  volne_miesta:=0;
  pismeno:=' ';
  pom:=0;
  dalej:=true;
  zaplnene_miesta:=0;
  zaberat:=0;
  old_poz:=0;

  for pom:= 1 to pocet_miest do
    if pole2[pom]<>Free then
       inc(zaplnene_miesta);

  if zaplnene_miesta=pocet_miest then
     dalej:=false;

  if dalej=false then
   begin
     Writeln('Pole je plne musis ho zmazat');
     readkey;
     clrscr;
     Napis_menu;
     exit;
   end;

  gotoxy(1,1);                          (*Testovanie ci to tam vodje*)
  repeat                                (*Zapise pismeno + osetrenia*)
   Write('Ake pismenko chces zapisat? : ');
   Readln(pismeno);
   for pom:= 1 to pocet_miest do if pole1[pom]=pismeno then dalej:=false;
  until (dalej=true)or(dalej=false);

  if dalej=false then
   begin
    Writeln('Pismenko uz tam mas !');
    readkey;
    clrscr;
    napis_menu;
    exit;
   end;

  for pom:=1 to pocet_miest do
    if pole2[pom]=Free then
       inc(volne_miesta);

  repeat                                (*Zapise miesto + osrtrenie*)
   Write('Napis kolko ma zaberat miesta : ');
   Readln(zaberat);
   if zaberat>volne_miesta then Writeln('Mozes zabrat max. : ',volne_miesta,' miest.');
  until zaberat<=volne_miesta;

  pom:=0;
  pom1:=0;
  repeat                                 (*Zapise pozicie pismen do druheho pola*)
   inc(pom);
   if pole1[pom]=' ' then
    begin
     inc(pom1);
     pole1[pom]:=pismeno;
     if (pom>1)and(old_poz>=1) then pole2[old_poz]:=pom;
     old_poz:=pom;
    end;
  until pom1=zaberat;

  pole2[old_poz]:=_End;
  Writeln('Ukoncene.');
  readkey;
  clrscr;
  napis_menu;
end;

begin                                   (*Hlavny Begin*)
clrscr;
vynuluj_polia;
napis_menu;
repeat
  c:=readkey;
  case c of
   '1' : vypis;
   '2' : uloz;
   '3' : zmaz;
   '4' : halt;
  end;
until (c=#27);
end.

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