Simulate chain memory in pascal

Category: KMP (Club of young programmers)

Author: Ján Benkovič
web: www.tbteacher.host.sk

Program: Pamat.pas
File exe: Pamat.exe

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