{*******************************************************************************
*                                                                              *
*  Simulationsprogramm fuer einen extrem redundanzarmen Textcodierer (Teil 3)  *
*                                                                              *
********************************************************************************
*                                                                              *
*  Verfasser : Dipl.-Ing. Jochen Meyer   Adresse : TH Darmstadt                *
*  Telefon   : 0 61 51 / 16 - 36 66                Institut fuer Datentechnik  *
*  Programm  : Code                                Merckstr. 25                *
*  Datum     : 08.07.1988                          D-6100 Darmstadt            *
*                                                                              *
*******************************************************************************}

program code(input, output, textfile, metafile) ;

  const
    textfilename = 'USRDSK2:[D93F]4_CODE_??.' ;
    netzfilename = 'USRDSK2:[D93F]5_NETZ_??.' ;

    zelle_hashteiler = 78643 ; { > 1,2 * Anzahl der Wortzellen }
    zelle_max_index  = zelle_hashteiler - 1 ;
    puffer_max_index =    10 ; { maximale Wortanzahl einer Gruppenzelle }
    zellenmax        =  1279 ; { 40 Bloecke mit zellentyp }
    elementmax       =  1279 ; { 20 Bloecke mit elementtyp }

  type
    filenamentyp = packed array[1..24] of char ;

    elementzeiger = ^elementtyp ;
    zellenzeiger  = ^zellentyp ;

    elementtyp = record
                   zahl   : integer ;
                   zeiger : elementzeiger ;
                 end ;

    zellentyp = record
                  nummer     : integer ;
                  inhalt,
                  verbindung : elementzeiger ;
                  zeiger     : zellenzeiger ;
                end ;

    datentyp = record
                 verbindungen_max,
                 zeichen,
                 woerter,
                 textwoerter,
                 metawoerter,
                 fehlende_verbindungen,
                 fehlende_zellen,
                 zu_lange_codeworte     : integer ;
               end ;

  var
    textfile, metafile : file of integer ;
    zelle              : array[-1..zelle_max_index] of zellenzeiger ;
    daten              : datentyp ;
    start, ziel, ebene : integer ;

  function filename(name : filenamentyp ; ebene : integer) : filenamentyp ;

    begin
      name[22] := chr(ebene div 10 + 48) ;
      name[23] := chr(ebene mod 10 + 48) ;
      filename := name ;
    end ;

  function hashfunktion(index : integer) : integer ;

    begin
      hashfunktion := index mod zelle_hashteiler ;
    end ;

  procedure lies_netz(ebene : integer) ;

    const
      trennsymbol = maxint ;

    var
      freies_element : elementzeiger ;
      freie_zelle,
      zeig           : zellenzeiger ;
      zellenanzahl,
      index, hash,
      code           : integer ;

    procedure loesche_netz ;

      var
        i : integer ;

      begin
        for i := 0 to zelle_max_index do
          zelle[i] := nil ;
        with daten do
          begin
            fehlende_verbindungen := 0 ;
            fehlende_zellen       := 0 ;
            zu_lange_codeworte    := 0 ;
          end ;
        freies_element := nil ;
        freie_zelle    := nil ;
      end ;

    procedure neue_zelle(var neu : zellenzeiger) ;

      type
        zellenarray  = [volatile] array[1..zellenmax] of zellentyp ;

      var
        zelle : ^zellenarray ;
        i     : integer ;

      begin
        if (freie_zelle = nil)
          then
            begin
              new(zelle) ;
              freie_zelle := address(zelle^[1]) ;
              for i := 1 to (zellenmax - 1) do
                zelle^[i].zeiger := address(zelle^[i + 1]) ;
              zelle^[zellenmax].zeiger := nil ;
            end ;
        neu         := freie_zelle ;
        freie_zelle := neu^.zeiger ;
      end ;

    procedure lies_zelle(zell : zellenzeiger ; zellenanzahl, code : integer) ;

      var
        zeig : elementzeiger ;

      procedure neues_element(var neu : elementzeiger) ;

        type
          elementarray = [volatile] array[1..elementmax] of elementtyp ;

        var
          element : ^elementarray ;
          i       : integer ;

        begin
          if (freies_element = nil)
            then
              begin
                new(element) ;
                freies_element := address(element^[1]) ;
                for i := 1 to (elementmax - 1) do
                  element^[i].zeiger := address(element^[i + 1]) ;
                element^[elementmax].zeiger := nil ;
              end ;
          neu            := freies_element ;
          freies_element := neu^.zeiger ;
        end ;

      begin
        with zell^ do
          begin
            nummer     := zellenanzahl ;
            inhalt     := nil ;
            verbindung := nil ;
            zeiger     := nil ;
            while (code <> trennsymbol) do
              begin
                case (inhalt = nil) of
                  true  : begin
                            neues_element(inhalt) ;
                            zeig := inhalt ;
                          end ;
                  false : begin
                            neues_element(zeig^.zeiger) ;
                            zeig := zeig^.zeiger ;
                          end ;
                end ;
                zeig^.zahl := code ;
                read(textfile, code) ;
              end ;
            if (inhalt <> nil)
              then
                zeig^.zeiger := nil ;
            read(textfile, code) ;
            while (code <> trennsymbol) do
              begin
                case (verbindung = nil) of
                  true  : begin
                            neues_element(verbindung) ;
                            zeig := verbindung ;
                          end ;
                  false : begin
                            neues_element(zeig^.zeiger) ;
                            zeig := zeig^.zeiger ;
                          end ;
                end ;
                zeig^.zahl := code ;
                read(textfile, code) ;
              end ;
            case (verbindung = nil) of
              true  : verbindung   := zelle[-1]^.verbindung ;
              false : zeig^.zeiger := zelle[-1]^.verbindung ;
            end ;
          end ;
      end ;

    begin
      writeln('|') ;
      writeln('+------------------------------------------------------------') ;
      writeln('|') ;
      write('|  Ich lese das Netz der ', ebene: 1) ;
      writeln('-ten Ebene von Platte !') ;
      loesche_netz ;
      open(textfile, filename(netzfilename, ebene), history := old) ;
      reset(textfile) ;
      read(textfile, daten.verbindungen_max) ;
      zellenanzahl := 0 ;
      index        := 0 ;
      hash         := -1 ;
      repeat
        read(textfile, code) ;
        if (code <> trennsymbol)
          then
            hash := hashfunktion(code) ;
        case (hash = index) of
          false : begin
                    index := hash ;
                    neue_zelle(zelle[index]) ;
                    zeig := zelle[index] ;
                  end ;
          true  : begin
                    neue_zelle(zeig^.zeiger) ;
                    zeig := zeig^.zeiger ;
                  end ;
        end ;
        lies_zelle(zeig, zellenanzahl, code) ;
        zellenanzahl := zellenanzahl + 1 ;
      until eof(textfile) ;
      close(textfile) ;
      writeln('|  Groesse des Netzes : ', zellenanzahl: 1, ' Zellen') ;
    end ;

  procedure codiere_text(ebene : integer) ;

    const
      leer      = maxint - 3 ;
      ganz_leer = -leer ;

    var
      puffer      : array[1..puffer_max_index] of integer ;
      vorgaenger,
      nachfolger  : zellenzeiger ;
      codefaktor,
      codepuffer,
      wortanzahl,
      code, i     : integer ;

    procedure fuelle_puffer(wortanzahl : integer) ;

      var
        i, j : integer ;

      begin
        for i := 1 to (puffer_max_index - wortanzahl) do
          puffer[i] := puffer[i + wortanzahl] ;
        for j := (puffer_max_index - wortanzahl + 1) to puffer_max_index do
          case eof(textfile) of
            false : read(textfile, puffer[j]) ;
            true  : puffer[j] := ganz_leer ;
          end ;
      end ;

    procedure suche_zelle(var zell : zellenzeiger ; var wortanzahl : integer) ;

      var
        zeig   : zellenzeiger ;
        anzahl : integer ;

      procedure teste_inhalt(inhalt : elementzeiger ;
        var wortanzahl : integer) ;

        begin
          wortanzahl := 1 ;
          repeat
            case (inhalt^.zahl = puffer[wortanzahl]) of
              true  : begin
                        inhalt     := inhalt^.zeiger ;
                        wortanzahl := wortanzahl + 1 ;
                      end ;
              false : wortanzahl := 1 ;
            end ;
          until (inhalt = nil) or (wortanzahl = 1) ;
          wortanzahl := wortanzahl - 1 ;
        end ;

      begin
        wortanzahl := 0 ;
        zeig       := zelle[hashfunktion(puffer[1])] ;
        while (zeig <> nil) do
          begin
            teste_inhalt(zeig^.inhalt, anzahl) ;
            if (anzahl > wortanzahl)
              then
                begin
                  zell       := zeig ;
                  wortanzahl := anzahl ;
                end ;
            zeig := zeig^.zeiger ;
          end ;
        if (wortanzahl = 0)
          then
            zell := zelle[-1] ;
      end ;

    procedure schreibe_code(code, anzahl : integer) ;

      var
        code1, code2, faktor : integer ;

      begin
        case (anzahl = 1) of
          true  : begin
                    if (code >= codefaktor)
                      then
                        begin
                          code := code mod codefaktor ;
                          with daten do
                            zu_lange_codeworte := zu_lange_codeworte + 1 ;
                        end ;
                    case (codepuffer = leer) of
                      true  : codepuffer := code ;
                      false : begin
                                write(metafile,
                                  (codepuffer + codefaktor * code)) ;
                                codepuffer := leer ;
                                with daten do
                                  metawoerter := metawoerter + 1 ;
                              end ;
                    end ;
                  end ;
          false : begin
                    code1  := 0 ;
                    code2  := 0 ;
                    faktor := 1 ;
                    while (code > 0) do
                      begin
                        code1  := code1 + faktor * (code mod 2) ;
                        code   := code div 2 ;
                        code2  := code2 + faktor * (code mod 2) ;
                        code   := code div 2 ;
                        faktor := 2 * faktor ;
                      end ;
                    schreibe_code(code1, 1) ;
                    schreibe_code(code2, 1) ;
                  end ;
        end ;
      end ;

    procedure codiere_nachfolger(vorgaenger, nachfolger : zellenzeiger ;
      var wortanzahl : integer) ;

      var
        zeig : elementzeiger ;
        code : integer ;

      begin
        zeig := vorgaenger^.verbindung ;
        code := 2 ;
        while (zeig^.zahl <> nachfolger^.nummer) and
          (code <= daten.verbindungen_max) do
          begin
            zeig := zeig^.zeiger ;
            code := code + 1 ;
          end ;
        case (zeig^.zahl = nachfolger^.nummer) of
          true  : schreibe_code(code, 1) ;
          false : case (nachfolger = zelle[-1]) of
                    false : begin
                              schreibe_code(0, 1) ;
                              schreibe_code(nachfolger^.nummer, 2) ;
                              with daten do
                                fehlende_verbindungen :=
                                  fehlende_verbindungen + 1 ;
                            end ;
                    true  : begin
                              wortanzahl := 1 ;
                              schreibe_code(1, 1) ;
                              schreibe_code(puffer[1], 2) ;
                              with daten do
                                fehlende_zellen := fehlende_zellen + 1 ;
                            end ;
                  end ;
        end ;
      end ;

    procedure zeige_statistik ;

      var
        bits : integer ;

      begin
        with daten do
          begin
            bits := 2 * trunc(ln(codefaktor) / ln(2)) * metawoerter ;
            writeln('|') ;
            writeln('|  Textlaenge (Klartext) :', zeichen: 8, '   Zeichen') ;
            writeln('|  Textlaenge (Klartext) :', woerter: 8, '   Woerter') ;
            writeln('|  Codelaenge            :', bits: 8, '   bit') ;
            write('|  Mittlere Codelaenge   :') ;
            case (bits > zeichen) of
              true  : writeln((bits / zeichen): 10: 1, ' bit pro Zeichen') ;
              false : begin
                        write((1E3 * bits / zeichen): 10: 1) ;
                        writeln(' Millibit pro Zeichen') ;
                        write('|  Mittlere Codelaenge   :') ;
                        writeln((zeichen / bits): 10: 1, ' Zeichen pro bit') ;
                      end ;
            end ;
            write('|  Mittlere Codelaenge   :') ;
            case (bits > woerter) of
              true  : writeln((bits / woerter): 10: 1, ' bit pro Wort') ;
              false : begin
                        write((1E3 * bits / woerter): 10: 1) ;
                        writeln(' Millibit pro Wort') ;
                        write('|  Mittlere Codelaenge   :') ;
                        writeln((woerter / bits): 10: 1, ' Woerter pro bit') ;
                      end ;
            end ;
            writeln('|') ;
            write('|  ', ebene: 2, '-te Ebene :') ;
            writeln(textwoerter: 8, ' Codeworte') ;
            write('|  ', (ebene + 1): 2, '-te Ebene :') ;
            writeln(metawoerter: 8, ' Codeworte') ;
            if (fehlende_verbindungen > 0) or (fehlende_zellen > 0) or
               (zu_lange_codeworte > 0)
              then
                writeln('|') ;
            if (fehlende_verbindungen > 0)
              then
                begin
                  write('|  Fehlende Verbindungen :') ;
                  writeln(fehlende_verbindungen: 8) ;
                end ;
            if (fehlende_zellen > 0)
              then
                writeln('|  Fehlende Zellen       :', fehlende_zellen: 8) ;
            if (zu_lange_codeworte > 0)
              then
                writeln('|  Zu lange Codeworte    :', zu_lange_codeworte: 8) ;
            if (metawoerter >= textwoerter)
              then
                begin
                  writeln('|') ;
                  writeln('|  Schlechte Codierung !') ;
                end ;
          end ;
      end ;

    begin
      writeln('|') ;
      writeln('|  Ich codiere den Text der ', ebene: 1, '-ten Ebene !') ;
      with daten do
        begin
          codefaktor := 2 ** trunc(ln(verbindungen_max + 1.5) / ln(2) + 1) ;
          codepuffer := leer ;
          open(textfile, filename(textfilename,  ebene),      history := old) ;
          open(metafile, filename(textfilename, (ebene + 1)), history := new) ;
          reset(textfile) ;
          rewrite(metafile) ;
          read(textfile,  zeichen, woerter) ;
          write(metafile, zeichen, woerter) ;
          for i := 2 to ebene do
            begin
              read(textfile,  code) ;
              write(metafile, code) ;
            end ;
          textwoerter := ebene - 1 ;
          metawoerter := ebene - 1 ;
          fuelle_puffer(puffer_max_index) ;
          suche_zelle(vorgaenger, wortanzahl) ;
          schreibe_code(vorgaenger^.nummer, 2) ;
          textwoerter := textwoerter + wortanzahl ;
          fuelle_puffer(wortanzahl) ;
          if (puffer[1] <> ganz_leer)
            then
              begin
                repeat
                  suche_zelle(nachfolger, wortanzahl) ;
                  codiere_nachfolger(vorgaenger, nachfolger, wortanzahl) ;
                  textwoerter := textwoerter + wortanzahl ;
                  fuelle_puffer(wortanzahl) ;
                  vorgaenger := nachfolger ;
                until (puffer[1] = ganz_leer) ;
                if (codepuffer <> leer)
                  then
                    schreibe_code(0, 1) ;
              end ;
          close(metafile) ;
          close(textfile) ;
          zeige_statistik ;
        end ;
    end ;

  begin
    writeln ;
    writeln('+------------------------------------------------------------') ;
    writeln('|') ;
    writeln('|  Extrem redundanzarmer Textcodierer (Teil 3: CODE)') ;
    writeln('|') ;
    repeat
      write('|  Welche Ebene soll ich zuerst bearbeiten ?   [1..23] ') ;
      readln(start) ;
      writeln ;
    until (start in [1..23]) ;
    repeat
      write('|  Welche Ebene soll ich zuletzt bearbeiten ? [') ;
      write(start: 2, '..23] ') ;
      readln(ziel) ;
      writeln ;
    until (ziel in [start..23]) ;
    for ebene := start to ziel do
      begin
        lies_netz(ebene) ;
        codiere_text(ebene) ;
      end ;
    writeln('|') ;
    writeln('+------------------------------------------------------------') ;
    writeln ;
  end .