(******************************************************)
(*----------------------------------------------------*)
(*    textanalysator      paul - h. koop              *)
(*                                                    *)
(*----------------------------------------------------*)
(******************************************************)

      program textanalysator ( rtext , dat );
      uses crt;
(*---- constanten typen variablen --------------------*)

      const
           blank                   = '@' ;
           punkt                   = #91 ;
           komma                   = #92 ;
           semikolon               = #93 ;
           fragezeichen            = #94 ;
           ausrufezeichen          = #95 ;
           ae                      = #96;
           ue                      = #97;
           oe                      = #98;
           eszett                  = #99;
           null                    =  0  ;

      type
          vorgaenger = string(.3.) ;
          buchstaben = blank..eszett    ;

      var
         vor         : vorgaenger ;
         ch,
         a,
         b,
         c,
         d           : buchstaben ;
         name        : string(.80.);
         rtext       : text;
         dat         : file of longint;
         nullen      : longint;
         letter      : set of buchstaben ;
         zeichen     : char ;

(*----- funktionen prozeduren --------------------------*)

      function ort ( b : buchstaben ) : longint ;
               begin
                    ort := ord ( b ) - ord ('@')
               end;


      function k (blank , eszett : buchstaben ) : longint ;
               begin
                    k := ( ord(eszett) - ord(blank) + 1 )
               end;


      procedure zaehlen ( a,b,c,d : buchstaben );
                var
                   zahl     : longint;
                   n        : longint ;

                begin
                     n := k ( blank , eszett ) ;
                     seek( dat , ort(a)*n*n*n+ort(b)*n*n+ort(c)*n+ort(d) );
                     read( dat,zahl );
                     zahl := zahl + 1 ;
                     seek( dat , ort(a)*n*n*n+ort(b)*n*n+ort(c)*n+ort(d) );
                     write( dat , zahl )
                end;

       procedure aktualisieren ( var vor : vorgaenger ;
                                     ch  : buchstaben );
                 begin
                      vor(.1.) := vor(.2.);
                      vor(.2.) := vor(.3.);
                      vor(.3.) := ch
                 end;

       function anpassung ( ch : char ) : char ;
                begin
                        case ch of
                         ' ' : ch := blank;
                         '.' : ch := punkt;
                         ',' : ch := komma;
                         ';' : ch := semikolon;
                         '?' : ch := fragezeichen;
                         '!' : ch := ausrufezeichen;
                         '�','�' : ch := ae;
                         '�','�' : ch := ue;
                         '�','�' : ch := oe;
                         '�'     : ch := eszett
                         else  ch := upcase(ch)
                        end;
                     anpassung  := ch;
                end;
       procedure kummuliere ( a,b,c : buchstaben );
                var
                   d        : buchstaben;
                   n,
                   zvor,
                   zahl        : longint ;

                begin
                     n := k ( blank , eszett ) ;
                     for d := succ(blank) to eszett
                     do
                     begin
                     seek(dat , ort(a)*n*n*n+ort(b)*n*n+ort(c)*n+ort(pred(d)));
                     read( dat,zvor);
                     seek( dat , ort(a)*n*n*n+ort(b)*n*n+ort(c)*n+ort(d) );
                     read( dat , zahl );
                     seek( dat , ort(a)*n*n*n+ort(b)*n*n+ort(c)*n+ort(d) );
                     zahl := zahl + zvor;
                     write( dat , zahl )
                     end
                end;

       begin
(*============== hauptprogramm =======================*)

            nullen := null;
            writeln('typo analyser 5.1 (c) Paul Koop 1988, 1989, 1992');
            write('rohdatei  ');
            readln(name);
            assign(rtext,name);

            reset(rtext);

            write('zieldatei ');
            readln(name);
            assign( dat, name );

            rewrite(dat);
            writeln('anlegen');

            for a := blank to eszett do
                for b := blank to eszett do
                    for c := blank to eszett do
                        for d := blank to eszett do
                             write( dat , nullen ) ;
            close(dat);
            reset ( dat );
            writeln('analyse');

            for a := blank to eszett do letter := letter + (.a.);

            for nullen := 1 to 3
                do
                repeat
                        read ( rtext,vor(.nullen.));
                        vor(.nullen.) := anpassung (vor(.nullen.))
                until vor(.nullen.) in letter;


                while not eof ( rtext )
                      do
                        begin
                             while not eoln ( rtext )
                                   do
                                     begin
                                          read(rtext,zeichen);
                                          if not(( anpassung ( zeichen ))
                                             in letter)
                                             then zeichen := blank;
                                          ch := anpassung ( zeichen );
                                          zaehlen ( vor(.1.),
                                                    vor(.2.),
                                                    vor(.3.),
                                                    ch       );
                                          aktualisieren ( vor , ch )
                                     end;
                        readln ( rtext )
                        end ;

            reset ( dat ) ;
            writeln('kummuliere');
            for a := blank to eszett do
                for b := blank to eszett do
                    for c := blank to eszett do
                        kummuliere ( a,b,c );
            close(dat);
            close(rtext);
            sound(440);
            repeat until keypressed;
            nosound
            end.