PROGRAM KEYWORD;
(* Program reads a file and removes all words.  Puts words in list   *)

CONST
     DATE     = '4/18/86';
     VERSION  = 'VERSION 1.0';
     WORDLEN  = 40;
TYPE
     SWORD    = STRING[WORDLEN];
     S20      = STRING[20];
     S4       = STRING[4];
     S128     = STRING[128];

     KWPTR    = ^KWORD;
     KWORD    = RECORD
                    KW    : SWORD;
                    KWCAP : SWORD;
                    LEFT  : KWPTR;
                    RIGHT : KWPTR;
                 END;

     CHARSET  = SET OF CHAR;
VAR
     HEAD     : KWPTR;
     NAME     : S20;
     D1       : TEXT;
     WORDSET  : CHARSET;
     STARTSET : CHARSET;
     WSIZE    : INTEGER;
     SIZE     : INTEGER;

(* **************************************************************** *)
(*                     PROCEDURES/FUNCTIONS                         *)
(* **************************************************************** *)

PROCEDURE GET_FILE_NAME(VAR NAME : S20);
VAR
     CMDLINE  : S20 ABSOLUTE $80;
     F1       : TEXT;
BEGIN
     NAME := CMDLINE;
     ASSIGN(F1,NAME);
     {$I-} RESET(F1); {$I+}
     IF IORESULT <> 0 THEN
     BEGIN
        WRITELN('INVALID NAME. PLEASE REDO.');
        HALT;
     END;
     CLOSE(F1);
END;

PROCEDURE GET_SIZE(VAR SIZE : INTEGER;
                       NAME : S20     );
VAR
   FZ  : FILE;
BEGIN
     ASSIGN(FZ,NAME);
     RESET(FZ);
     SIZE := FILESIZE(FZ);
     CLOSE(FZ);
END;

PROCEDURE UPSHIFT(VAR X : SWORD);
VAR
     I,J  : INTEGER;
BEGIN
     FOR I := 1 TO LENGTH(X) DO
        IF X[I] IN ['a'..'z'] THEN
           X[I] := UPCASE(X[I]);
END;

PROCEDURE GET_OUT_DEVICE(VAR D1 : TEXT );
VAR
     ONAME : SWORD;
     GOOD  : BOOLEAN;
BEGIN
     REPEAT
        GOOD := TRUE;
        WRITE('ENTER OUTPUT DEVICE (CON:,LST:,FILENAME) -> ');
        READLN(ONAME);
        UPSHIFT(ONAME);
        
        IF ONAME = 'CON:' THEN
        BEGIN
           ASSIGN(D1,'CON:');
           RESET(D1);
        END
        ELSE
        IF ONAME = 'LST:' THEN
        BEGIN
           ASSIGN(D1,'LST:');
           RESET(D1);
        END
        ELSE
        BEGIN                   (* OPEN FILE                        *)
           ASSIGN(D1,ONAME);
           {$I-} RESET(D1); {$I+}
           IF IORESULT = 0 THEN 
           BEGIN
              WRITELN('FILE - ',ONAME,' - ALREADY EXISTS');
              CLOSE(D1);
              GOOD := FALSE;
           END
           ELSE
           BEGIN                (* OPEN FILE FOR WRITE              *)
              {$I-} REWRITE(D1); {$I+}
              IF IORESULT <> 0 THEN
              BEGIN
                 WRITELN('INVALID NAME - ',ONAME);
                 GOOD := FALSE;
              END;
           END;                 (* END OF OPEN FILE FOR WRITE       *)
        END;                 (* END OF OPEN FILE                    *)
     UNTIL GOOD;          (* OUTPUT DEVICE OPENED                   *)
END;                   (* END OF PROCEDURE GET_OUTPUT_DEVICE        *)

FUNCTION GET_SETS(X  : S4) : BOOLEAN;
VAR
     A  : CHAR;
BEGIN
     REPEAT
        WRITE('   INCLUDE "',X,'" (Y/N) -> ');
        READLN(A);
        A := UPCASE(A);
     UNTIL A IN ['Y','N'];
     IF A = 'Y' THEN
        GET_SETS := TRUE
     ELSE
        GET_SETS := FALSE;
END;

PROCEDURE GET_CHAR_SET(VAR WSET  : CHARSET;
                       VAR A     : CHAR;
                           WX    : S20    );
VAR
     GOOD  : BOOLEAN;
     ASET  : S20;
     I     : INTEGER;
BEGIN
     WSET := [];
     WRITELN;
     WRITELN('DEFINE CHARACTERS IN ',WX);

     IF GET_SETS('A..Z') THEN
        WSET := WSET + ['A'..'Z'];
     IF GET_SETS('a..z') THEN
        WSET := WSET + ['a'..'z'];
     IF GET_SETS('0..9') THEN
        WSET := WSET + ['0'..'9'];
     WRITE('   ENTER ANY OTHER CHARACTERS IN ',WX,' -> ');
     READLN(ASET);
     FOR I := 1 TO LENGTH(ASET) DO
        WSET := WSET + [ASET[I]];

     WRITELN;
     WRITE(WX,' => ');
     IF 'A' IN WSET THEN
        WRITE('A..Z ');
     IF 'a' IN WSET THEN
        WRITE('a..z ');
     IF '0' IN WSET THEN
        WRITE('0..9 ' );
     WRITELN(ASET);
     REPEAT
        WRITE('IS THIS CORRECT (Y/N) -> ');
        READLN(A);
        A := UPCASE(A);
     UNTIL A IN ['Y','N'];
END;                             (* END PROCEDURE GET_CHAR_SET     *)

PROCEDURE GET_OPTIONS(VAR WSIZE    : INTEGER;
                      VAR WORDSET  : CHARSET;
                      VAR STARTSET : CHARSET );
VAR
     A     : CHAR;
     WX    : S20;
BEGIN
     REPEAT
        WRITE('ENTER SIZE OF SMALLEST KEY WORD (1,2,etc) -> ');
        READLN(WSIZE);
        IF NOT (WSIZE IN [1..(WORDLEN DIV 2)]) THEN
        BEGIN
           WRITELN('INVALID WORD SIZE');
           WSIZE := 0;
        END;
     UNTIL WSIZE > 0;

     REPEAT
        WX := 'KEY WORD SET';
        GET_CHAR_SET(WORDSET,A,WX);
     UNTIL A = 'Y';

     REPEAT
        WX := 'START WORD SET';
        GET_CHAR_SET(STARTSET,A,WX);
     UNTIL A = 'Y';

END;                                   (* END PROCEDURE GET_OPTIONS *)

PROCEDURE INITIALIZE(VAR HEAD   : KWPTR );
BEGIN
     HEAD := NIL;
END;

PROCEDURE PUT_WORD_IN_TREE(VAR HEAD    : KWPTR;
                               W       : SWORD );
VAR
     CUR   : KWPTR;
     PREV  : KWPTR;
     TW    : SWORD;
BEGIN
     TW := W;
     UPSHIFT(TW);
     IF HEAD = NIL THEN
     BEGIN
        NEW(HEAD);
        HEAD^.KW := W;
        HEAD^.KWCAP := TW;
        HEAD^.LEFT  := NIL;
        HEAD^.RIGHT := NIL;
     END
     ELSE
     BEGIN
        CUR := HEAD;
        PREV:=CUR;

        WHILE (CUR <> NIL) AND (CUR^.KWCAP <> TW) DO
        BEGIN
           PREV := CUR;
           IF TW < CUR^.KWCAP THEN
              CUR := CUR^.LEFT
           ELSE
              CUR := CUR^.RIGHT;
        END;

        IF CUR = NIL THEN
        BEGIN
           NEW(CUR);
           CUR^.KW    := W;
           CUR^.KWCAP := TW;
           CUR^.LEFT  := NIL;
           CUR^.RIGHT := NIL;
           IF TW < PREV^.KWCAP THEN
              PREV^.LEFT := CUR
           ELSE
              PREV^.RIGHT := CUR;
        END;
     END;                     (* END NOT FIRST WORD                 *)
END;                      (* END PROCEDURE PUT_WORD_IN_TREE         *)

PROCEDURE READ_FILE(VAR WSIZE   : INTEGER;
                        WORDSET : CHARSET;
                        STARTSET: CHARSET;
                    VAR HEAD    : KWPTR;
                        NAME    : S20;
                        SIZE    : INTEGER   );
VAR
     F1    : FILE;
     A     : CHAR;
     W     : SWORD;
     DONE  : BOOLEAN;
     CNT   : REAL;
     FSIZE : REAL;
     BUF   : S128;
     PT    : INTEGER;

     PROCEDURE READ_CHAR(VAR A    : CHAR;
                         VAR BUF  : S128;
                         VAR PT   : INTEGER );
     VAR
        RECREAD   : INTEGER;
     BEGIN
          IF PT = 128 THEN
          BEGIN
             BLOCKREAD(F1,BUF,1,RECREAD);
             IF RECREAD = 0 THEN
             BEGIN
                  WRITELN('READ ERROR');
                  HALT;
             END;
             PT := 0;
          END;

          PT := PT + 1;
          A := BUF[PT];
     END;                  (* END OF PROCEDURE READ_CHAR            *)

BEGIN
     ASSIGN(F1,NAME);
     RESET(F1);
     CNT := 0;
     PT  := 128;
     BUF := '';
     FSIZE := SIZE * 128.0;

     WHILE CNT < FSIZE DO
     BEGIN
        DONE := FALSE;
        READ_CHAR(A,BUF,PT);
        CNT := CNT + 1.0;
        WHILE (NOT DONE) AND (NOT (A IN STARTSET)) DO
        BEGIN
           IF CNT = FSIZE THEN
              DONE := TRUE
           ELSE
           BEGIN
              READ_CHAR(A,BUF,PT);
              CNT := CNT + 1.0;
           END;
        END;

        W := '';
        WHILE (NOT DONE) AND (A IN WORDSET) DO
        BEGIN
           IF LENGTH(W) = WORDLEN THEN
           BEGIN
              PUT_WORD_IN_TREE(HEAD,W);
              W := '';
           END;
           W := W + A;
           IF CNT < FSIZE THEN
           BEGIN
              READ_CHAR(A,BUF,PT);
              CNT := CNT + 1.0;
           END
           ELSE
              DONE := TRUE;
        END;

        IF LENGTH(W) >= WSIZE THEN
           PUT_WORD_IN_TREE(HEAD,W);
     END;                              (* END OF WHILE NOT EOF      *)
     CLOSE(F1);
END;                   (* END OF PROCEDURE READ_FILE                *)

{$A-}
PROCEDURE PRINT_WORDS(CUR   : KWPTR );
BEGIN
     IF CUR <> NIL THEN
     BEGIN
        PRINT_WORDS(CUR^.LEFT);
        WRITELN(D1,CUR^.KW);
        PRINT_WORDS(CUR^.RIGHT)        
     END;
END;
{$A+}

(* **************************************************************** *)
(*                     MAIN PROGRAM                                 *)
(* **************************************************************** *)

BEGIN
     GET_FILE_NAME(NAME);
     GET_SIZE(SIZE,NAME);
     GET_OUT_DEVICE(D1);
     GET_OPTIONS(WSIZE,WORDSET,STARTSET);
     INITIALIZE(HEAD);

     READ_FILE(WSIZE,WORDSET,STARTSET,HEAD,NAME,SIZE);

     PRINT_WORDS(HEAD);
     CLOSE(D1);
END.