program memory;

const hoehe  = 2;
      breite = 10;
      groesse= hoehe * breite;
      mehr   = groesse + 1;
      base   = 10000;
      
type  tzeile = array[1..breite] of integer;
      handle = integer;

var   mem:     array[1..groesse] of integer;
      blocks:  array[1..mehr,1..3] of integer;
      {blocks[i, handle, adress, size]}
      c:       char;

procedure getmemm(var hd: integer; size: integer; var err: integer); forward;
procedure chblsize(var hd: integer;size: integer; var err: integer); forward;
procedure memdefrg(hd: integer); forward;
procedure insertbl(pos: integer); forward;
procedure deletebl(pos: integer); forward;
function  ffhandle: integer; forward;
function  getpt(var hd, err: integer): integer; forward;
          {gibt die Anfangsadresse des Handles hd zurueck}
function  freesize: integer; forward;

procedure init;
var i: integer;
begin
  for i:= 1 to 6 do
    writeln;
  writeln('                      Dynamische Speicherverwaltung');
  writeln;
  writeln('             Autoren: Ralf Kalb und Ernst Ludwig Wirl, WS 96/97, HUB');
  writeln('             Betreuung und Umsetzung forTRAN 77 -> SUN-PASCAL: Hubert Grassmann');
  writeln('Initialisierung');
  writeln('Speicherblock ...');
  for i:=1 to groesse do
    mem[i]:=0;
  writeln('Belegungstabelle...');
  for i:=1 to mehr do
  begin
    blocks[i,1]:=0;
    blocks[i,2]:=0;
    blocks[i,3]:=0;
  end;
  blocks[1,2]:= 1;
  blocks[1,3]:= groesse;
end;

procedure showstat;
var block, i, j, symbol: integer; tz: tzeile;
label m10;
begin
  for i:= 1 to breite do
    tz[i]:= 0;
  writeln('Eintraege der Belegungstabelle:');
  block:=1;
m10:
  if (blocks[block,1]=0) then
  begin
    write('  Freier Block bei ',blocks[block,2]:3);
    writeln(' Groesse: ',blocks[block,3]:3);
  end
  else
  begin
    write('  Block mit Handle ',blocks[block,1]:3,' bei ',blocks[block,2]:3);
    writeln(' Groesse: ',blocks[block,3]:3);
  end;
  block:=block+1;
  if (blocks[block,3]<>0) then
    goto m10;
  block:=1;
  for i:=0 to hoehe -1 do         {hg !! -1 eingefuegt}
  begin
    for j:=1 to breite do
    begin
      if (i*breite+j = blocks[block,2]) then
      begin
        if (blocks[block,1]=0) then
          symbol:= 0
        else
          symbol:= blocks[block,1];
        block:=block+1;
      end;
      tz[j]:= symbol;
    end;
    for j:= 1 to breite do
      write(tz[j]:4);
    writeln;
  end;
end;

procedure newmem;
var i, hd, size, err, pt: integer;
    inn: tzeile;
label m100;
begin
  write('Speicherblock belegen, Groesse ? ');
  readln(size);
  if  (size<1) or (size> groesse) then
    begin
      write('Fehler: Ungueltige Speicherblockgroesse!');
      writeln(' Gueltiger Bereich: 1...', groesse);
      goto m100;
    end;
  writeln('Speicherblock suchen...');
  getmemm(hd,size, err);
  if (err=0) then
    writeln(' Speicherblockhandle ',hd,' vergeben...')
  else
  begin
    writeln('Fehler: Kein solcher Speicherblock mehr verfuegbar.');
    goto m100;
  end;
  writeln('(rueckwaerts) ', size:3 ,' Stellen < base eingeben; jeweils <ret>');
  for i:= 1 to size do
    readln(inn[i]);
  pt:=getpt(hd,err);
  for i:=1 to size do
    mem[pt+i-1]:=inn[i] mod base;
  writeln(' Speicherblock momentan an Position ',pt);
m100:
end;

procedure getmemm(var hd: integer; size: integer; var err: integer);
var i, block: integer;
    bestfit: array[1..2] of integer;
label m1, m10, m20, m90, m100;
begin
m1:
  block:=1;
  bestfit[1]:=mehr;
  bestfit[2]:=0;
m10:
  if (blocks[block,3]=0) then
    if (bestfit[2]=0) then
    begin
      if (freesize >= size) then
      begin
        memdefrg(-1);
        goto m1;
      end;
      goto m100;
    end
    else
      goto m20;
  if ((blocks[block,1]=0) and (blocks[block,3] >= size)) then
  begin
    if (blocks[block,3]=size) then
      goto m90;
    if (blocks[block,3] < bestfit[1]) then
    begin
      bestfit[1]:=blocks[block,3];
      bestfit[2]:=block;
    end;
  end;
  block:=block+1;
  goto m10;
m20:
  block:=bestfit[2];
  insertbl(block);
  blocks[block+1,1]:=0;
  blocks[block+1,2]:=blocks[block,2]+size;
  blocks[block+1,3]:=blocks[block,3]-size;
  blocks[block,3]:=size;
m90:
  hd:=ffhandle;
  err:= 0;
  blocks[block,1]:=hd;
  for i:= blocks[block, 2] to blocks[block, 2] + blocks[block, 3] - 1 do
    mem[i]:= 0;                                 { hg }
  return;{exit;}
m100:
  err:= 1;
end;

function ffhandle: integer;
label m10, m20;
var i, ffhandl: integer;
begin
  ffhandl:=0;
m10:
  ffhandl:=ffhandl+1;
  i:=0;
m20:
  i:=i+1;
  if (blocks[i,3]=0) then
  begin
    ffhandle:= ffhandl;
    return;{exit;}
  end;
  if (blocks[i,1]=ffhandl) then
    goto m10
  else
    goto m20;
end;

function getpt(var hd,err: integer): integer;
var block: integer;
label m10;
begin
  block:=1;
m10:
  if (blocks[block,1]=hd) then
  begin
    getpt:=blocks[block,2];
    err:=0;
    return;{exit;}
  end;
  block:=block+1;
  if (blocks[block,3]<>0) then
    goto m10;
  err:=1;
end;

function getbl(var hd,err: integer): integer;
{ gibt den Block an, wo hd steht}
var block: integer;
label m10;
begin
  block:=1;
m10:
  if (blocks[block,1]=hd) then
  begin
    getbl:=block;
    err:=0;
    return;{exit;}
  end;
  block:=block+1;
  if (blocks[block,3]<>0) then
    goto m10;
  err:=1;
end;

procedure changemem;
var hd,size,err: integer;
label m100;
begin
  writeln;
  writeln('Speicherblockgroesse aendern');
  write(' Blockhandle : ');
  read (hd);
  if (hd<1) or (hd>groesse) then
  begin
    writeln('Fehler: Ungueltiger Bereich fuer Handles!');
    writeln('Gueltiger Bereich: 1...', groesse);
    goto m100;
  end;
  write('  Neue Groesse : ');
  readln (size);
  if ((size<0) or (size>groesse)) then
  begin
    writeln('Fehler: Ungueltige Speicherblockgroesse!');
    writeln('Gueltiger Bereich: 0...', groesse);
    goto m100;
  end;
  chblsize(hd,size,err);
  writeln;
  if (err=0) then
    if (size=0) then
      writeln('Speicherblock freigemeldet. Handle freigegeben.')
    else
      writeln('Speicherblockgroesse angepasst.')
  else
    if (err=1) then
      writeln('Fehler: Speicherblockgroesse konnte nicht veraendert werden!')
    else
      writeln('Ungueltiges Handle.');
m100:
end;

procedure chblsize(var hd: integer; size: integer; var err: integer);
var block: integer;
label m1, m10, m50, m80, m100, m101;
begin
m1:
  block:=1;
m10:
  if (blocks[block,1]=hd) then
    goto m50
  else
  begin
    block:=block+1;
    if (blocks[block,3]=0) then
    begin
      err:=2;
      return;{exit;}
    end;
  end;
  goto m10;
m50:
  if (size=0) then
  begin
    blocks[block,1]:=0;
    goto m80;
  end;
  if (size<blocks[block,3]) then
  begin
  if ((blocks[block+1,3]<>0) and (blocks[block+1,1]=0)) then
    begin
      blocks[block+1,2]:=blocks[block+1,2]-blocks[block,3]+size;
      blocks[block+1,3]:=blocks[block+1,3]+blocks[block,3]-size;
    end
    else
    begin
      if (blocks[block+1,3]<>0) then
        insertbl(block+1);
      blocks[block+1,1]:=0;
      blocks[block+1,2]:=blocks[block,2]+size;
      blocks[block+1,3]:=blocks[block,3]-size;
    end;
    blocks[block,3]:=size;
    goto m100;
  end;
  if (size>blocks[block,3]) then
  begin
    if ((blocks[block+1,1]=0) and (blocks[block+1,3]>=size-blocks[block,3])) then
    begin
      blocks[block+1,3]:=blocks[block+1,3]-size+blocks[block,3];
      blocks[block+1,2]:=blocks[block+1,2]+size-blocks[block,3];
      blocks[block,3]:=size;
      if (blocks[block+1,3]=0) then
        deletebl(block+1);
      goto m100;
    end;
    if (freesize+blocks[block,3]<size)
     then goto m101;
    memdefrg(hd);
    goto m1;
  end;
m80:
  if (blocks[block+1,3]<>0) and (blocks[block,1]=0) and (blocks[block+1,1]=0) then
  begin
    blocks[block,3]:=blocks[block,3]+blocks[block+1,3];
    deletebl(block+1);
  end;
  if ((block<>1) and (blocks[block-1,1]=0) and (blocks[block,1]=0)) then
  begin
    blocks[block-1,3]:=blocks[block-1,3]+blocks[block,3];
    deletebl(block);
  end;
m100:
  err:=0;
  return;{exit;}
m101:
  err:=1;
end;

procedure memdefrg(hd: integer);
var block,i,bls,org,dst: integer;
label m10, m20, m30, m50;
begin
  block:=1;
m10:
  if (blocks[block,1]=hd) then
    goto m20;
  if ((blocks[block,1]=0) and (blocks[block+1,3]<>0)) then
  begin
    bls:=blocks[block+1,3]-1;
    org:=blocks[block+1,2];
    dst:=blocks[block,2];
    for i:=0 to bls do
      mem[dst+i]:=mem[org+i];
    blocks[block,1]:=blocks[block+1,1];
    blocks[block+1,1]:=0;
    blocks[block+1,2]:=blocks[block,2]+blocks[block+1,3];
    blocks[block+1,3]:=blocks[block,3];
    blocks[block,3]:=blocks[block+1,2]-blocks[block,2];
    if ((blocks[block+2,3]<>0) and (blocks[block+2,1]=0)) then
    begin
      blocks[block+1,3]:=blocks[block+1,3]+blocks[block+2,3];
      deletebl(block+2);
    end;
{ Falls der gesuchte Block hier druntergetauscht wurde:}
    block:=block-1;
  end;
  block:=block+1;
  if (blocks[block,3]=0) then
    goto m50;
  goto m10;
m20:
  block:=block+1;
  if (blocks[block,3]<>0) then
    goto m20;
  block:=block-1;
m30:
  if ((blocks[block,1]=0) and (blocks[block-1,1]<>hd)) then
  begin
    bls:=blocks[block-1,3]-1;
    org:=blocks[block-1,2];
    blocks[block,1]:=blocks[block-1,1];
    blocks[block-1,1]:=0;
    blocks[block,2]:=blocks[block-1,2]+blocks[block,3];
    blocks[block,3]:=blocks[block-1,3];
    blocks[block-1,3]:=blocks[block,2]-blocks[block-1,2];
    dst:=blocks[block,2];
    for i:=bls downto 0 do
      mem[dst+i]:=mem[org+i];
    if (blocks[block-2,1]=0) then
    begin
      blocks[block-2,3]:=blocks[block-1,3]+blocks[block-2,3];
      deletebl(block-1);
    end;
  end;
  block:=block-1;
  if (blocks[block,1]<>hd) then
    goto m30;
m50:
  writeln('MEMDEFRG - Speicherdefragmentierung durchgefuehrt.');
end;

function freesize: integer;
var freesiz, i: integer;
label m10;
begin
  freesiz:=0;
  i:=1;
m10:
  if (blocks[i,1]=0) then
    freesiz:=freesiz+blocks[i,3];
  i:=i+1;
  if (blocks[i,3]<>0) then
    goto m10;
  freesize:= freesiz;
end;

procedure insertbl(pos: integer);
var i: integer;
label m10, m20;
begin
  i:=pos;
m10:
  i:=i+1;
  if (blocks[i,3]<>0) then
    goto m10;
m20:
  blocks[i,1]:=blocks[i-1,1];
  blocks[i,2]:=blocks[i-1,2];
  blocks[i,3]:=blocks[i-1,3];
  i:=i-1;
  if (i<>pos) then
    goto m20;
end;

procedure deletebl(pos: integer);
var i: integer;
label m10;
begin
  i:=pos;
m10:
  blocks[i,1]:=blocks[i+1,1];
  blocks[i,2]:=blocks[i+1,2];
  blocks[i,3]:=blocks[i+1,3];
  i:=i+1;
  if (blocks[i,3]<>0) then
  goto m10;
end;

procedure showmem;
var block,i,j: integer;
begin
  block:=1;
  for i:=0 to hoehe - 1 do
  begin
    for j:=1 to breite do
    begin
      if (blocks[block,1]=0) then
        write(0:6)
      else
        write(mem[i*breite+j]:6);
      if (i*breite+j=blocks[block,2]+blocks[block,3]-1) then
        block:=block+1;
    end;
    writeln;
  end;
end;

{
writeln('Projekt Wissenschaftliches Rechnen Wintersemester 1996/97');
writeln('Aufgabe ist es, einen Speicherbereich dynamisch zu verwalten.');
writeln('Das Programm demonstriert die zur Realisierung notwendigen Routinen:');
writeln('Es koennen Speicherbloecke angeforderter Groesse zur Verfuegung gestellt werden,');
writeln('falls der Speicherplatz dazu ausreicht (getmemm).');
writeln('Es besteht die Moeglichkeit, die Speicherblockgroesse zu veraendern (CHBLSIZE).');
writeln('Der Benutzer erhaelt keine feste Adresse fuer seinen Speicherblock zurueck,');
writeln('sondern ein Handle, unter dem er nach Anforderungen oder Vergroesserungen');
writeln('anderer Speicherbloecke vor erneutem Zugriff auf seinen Speicherblock dessen');
writeln('eventuell veraenderte Adresse nachfragen muss (GETPT).');
writeln('Das ermoeglicht, bei Bedarf den Speicherbereich zu defragmentieren (MEMDEFRG).');
writeln;
writeln('Loesung von Ralf Kalb und Ernst Ludwig Wirl');
writeln;
}
{
function min(i,j: integer): integer;
begin
  if i < j then
    min:= i
  else
    min:= j;
end;

function max(i, j: integer): integer;
begin
  if i > j then
    max:= i
  else
    max:= j;
end;
}
procedure add(i, j: handle; var k: handle);
var pi, pj, pk, err, x, y, z, bi, bj, bk: integer;
begin
  bi:= getbl(i, err);
  if err <> 0 then
  begin
    writeln('Handle ', i:3, ' nicht vorhanden');
    k:= -1;
    return;{exit;}
  end;
  bj:= getbl(j, err);
  if err <> 0 then
  begin
    writeln('Handle ', j:3, ' nicht vorhanden');
    k:= -1;
    return;{exit;}
  end;
  pi:= blocks[bi, 2];
  pj:= blocks[bj, 2];
  getmemm(k, max(blocks[bi,3], blocks[bj,3]) + 1, err);
  if err <> 0 then
  begin
    k:= -2;
    return;{exit;}
  end;
  bk:= getbl(k, err);
  pk:= blocks[bk, 2];
  if blocks[bi,3] <= blocks[bj,3] then
    y:= blocks[bi,3]
  else
    y:= blocks[bj,3]; {jeweils das Minimum}
  for x:= 0 to y-1 do
  begin
    z:= mem[pk + x] + mem[pi + x] + mem[pj + x];
    mem[pk + x]:=     z mod base;
    mem[pk + x + 1]:= z div base;
  end;
  if y = blocks[bj, 3] then
    for x:= y to blocks[bi, 3] - 1 do
    begin
      z:= mem[pk + x] + mem[pi + x];
      mem[pk + x]:=     z mod base;
      mem[pk + x + 1]:= z div base;
    end
  else
    for x:= y to blocks[bj, 3] - 1 do
    begin
      z:= mem[pk + x] + mem[pj + x];
      mem[pk + x]:=     z mod base;
      mem[pk + x + 1]:= z div base;
    end;
  if mem[pk + blocks[bk, 3] - 1] = 0 then
    chblsize(k, blocks[bk, 3] - 1, err);
end;

procedure sub(i, j: handle; var k: handle);
var pi, pj, pk, bi, bj, bk, err, x, y, z: integer;
begin
  bi:= getbl(i, err);
  if err <> 0 then
  begin
    writeln('Handle ', i:3, ' nicht vorhanden');
    k:= -1;
    return;{exit;}
  end;
  bj:= getbl(j, err);
  if err <> 0 then
  begin
    writeln('Handle ', j:3, ' nicht vorhanden');
    k:= -1;
    return;{exit;}
  end;
  pi:= blocks[bi, 2];
  pj:= blocks[bj, 2];
  getmemm(k, blocks[bi,3], err); { das Maximum }
  if err <> 0 then
  begin
    k:= -2;
    return;{exit;}
  end;  
  bk:= getbl(k, err);
  pk:= blocks[bk, 2];
  y:= blocks[bj,3]; {das Minimum}
  z:= 0;
  for x:= 0 to y-1 do
  begin
    z:= z + mem[pk + x] + mem[pi + x] - mem[pj + x];
    if z < 0 then
    begin
      mem[pk + x]:= z + base;
      z:= -1;
    end
    else
    begin
      mem[pk + x]:= z;
      z:= 0;
    end;
  end;
  x:= blocks[bj, 3] - 1 {};
  while (z < 0) and (x < blocks[bi, 3]) do
  begin
    x:= x + 1;
    z:= z + mem[pi + x];
    if z < 0 then
      mem[pk + x]:= base - 1
    else
      mem[pk + x]:= z;
  end;
  while x < blocks[bi, 3] do
  begin
    x:= x + 1;
    mem[pk + x]:= mem[pi + x];
  end;
  x:= 1;
  while mem[pk + blocks[bk, 3] - x] = 0 do
    x:= x + 1;
  chblsize(k, blocks[bk, 3] - x + 1 , err);
end;

procedure zeigen(pb: handle);
var i, x: integer;
begin
 { pb:= getbl(h, err); }
  if blocks[pb, 1] <> 0 then
  begin
 {   ph:= blocks[pb, 2];}
    write('  Handle ', blocks[pb, 1]:3, ' in Block ', pb:3,' ab ', blocks[pb, 2]:3,' : ');
    if blocks[pb, 3] = 0 then
    begin
      writeln('null');
      return;{exit;}
    end;
    for i:= blocks[pb, 2] + blocks[pb, 3] - 1 downto blocks[pb, 2] do
    begin
      x:= mem[i];
      case x of
           0..9: write('000');
         10..99: write('00');
       100..999: write('0');
      otherwise
      end;
      write(x:1,'.');
    end;
    writeln;
  end;  
end;
(* a(+inc):= a(+inc) + b*x *)
procedure addmult(a, b: handle; x: integer; incc: integer);
var i, l, bb, ap, bp, err: integer;
    w: integer;
begin
  bb:= getbl(b, err);
  ap:= getpt(a, err);;
  bp:= blocks[bb, 2];
  l:= blocks[bb, 3];
  w:=0;
  begin
    for i:= 1 to l do
    begin
      w:= w + mem[ap + i + incc -1] + mem[bp + i -1] * x;
{      INC(w, a^.m[i+incc] + integer(b^.m[i]*x)); }
      mem[ap + i + incc - 1]:= w mod base;  
{      a^.m[i+incc]:= w mod base;}
      w:= w div base;
    end;
    i:=l+incc;
    while w>0 do
    begin
      i:= i + 1;
      w:= w + mem[ap + i - 1];
      mem[ap + i - 1]:= w mod base;
      w:= w div base;
    end;
  end;
end;

procedure inimult(a, b: handle; x: integer);
var i, l, bb, bp, ap, w, err: integer;
begin
  bb:= getbl(b, err);
  l:= blocks[bb, 3];
  bp:= blocks[bb, 2];
  ap:= getpt(a, err);
  w:=0;
  for i:= 1 to l do
  begin
    w:= w + mem[bp + i -1] * x;
{    INC(w, integer(b^.m[i])*x); }
    mem[ap + i - 1]:= w mod base;
{    a^.m[i]:= w mod base; }
    w:= w div base;
  end;
  if w<>0 then
    mem[ap + l]:= w;
{    a^.m[succ(l)]:= w;}
end;

(* mult long, c:= a * b 
procedure nlMl(a, b:handle; var c: handle);
var la, lb, i, hl: integer;
    h: integer;
begin
  IF (a=NIL) OR (b=NIL) then
  begin
    c:= NIL;
    exit;
  end;
  la:= a^.l;
  lb:= b^.l;
  IF (la=1) AND (lb=1) then
  begin
    h:= integer(a^.m[1]) * integer(b^.m[1]);
    IF h<base then
    begin
      newl(c,1);
      c^.m[1]:= h;
    end
    else
    begin
      newl(c,2);
      c^.m[1]:= h mod base;
      c^.m[2]:= h div base;
    end;
    c^.n:= (a^.n<>b^.n);
    exit;
  end;
  hl:= la+lb;
  newl(c, hl);
  fillchar(c^.m, c^.l, byte(0));
{
  for i:= 1 to c^.l do
    c^.m[i]:= 0;
}
  IF la < lb then
  begin
    inimult(c, b, integer(a^.m[1]));
    for i:= 2 to la do
      addmult(c, b, integer(a^.m[i]), pred(i));
  end
  else
  begin
    inimult(c, a, integer(b^.m[1]));
    for i:= 2 to lb do
      addmult(c, a, integer(b^.m[i]), pred(i));
  end;
  shrink(c);
  c^.n:= a^.n <> b^.n;
end {nlMl};
*)

var i, j, k, l, err: handle;

{ noch keine Behandlung der Null; diese sollte durch das Handle 0
  dargestellt werden }

begin
  init;
  showstat;
  repeat
{    for i:= 1 to ffhandle do     
 }
    i:= 1;
    while blocks[i,3] <> 0 do
    begin
      zeigen(i);
      i:= i + 1;
    end;  
    write('(B)elegen (G)roesse (A)nzeigen (L)oeschen (S)tatus (Z)eigen ');
    writeln('(+) (-) (E)nde');
    readln(c);
    case c of
      'b': newmem;
      'g': changemem;
      'a': showmem;
      'l': 
           begin
             writeln('Handle:');
             readln(j);
             chblsize(j, 0, err);
           end;
      's': showstat;
      '+':
           begin
             writeln('1. Summand');
             readln(i);
             writeln('2. Summand');
             readln(j);
             add(i, j, k);
             writeln('Summe hat Handle ', k:3);
           end;
      '-':
           begin
             writeln('Subtrahend');
             readln(i);
             writeln('Minuend');
             readln(j);
             sub(i, j, k);
             writeln('Differenz hat Handle ', k:3);
           end;
      'z':
           begin
             writeln('Handle: ');
             readln(l);
             zeigen(l);
           end;
      'e': begin
             writeln('Beendet');
             return;
           end;
    end;
  until false;
end.