home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
CP/M
/
CPM_CDROM.iso
/
cpm
/
turbopas
/
keyword.lbr
/
KEYWORD.PQS
/
KEYWORD.PAS
Wrap
Pascal/Delphi Source File
|
1986-05-18
|
9KB
|
364 lines
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.
