home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / sigm / vol291 / concord.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1986-12-22  |  2.5 KB  |  132 lines
  1. {$A-}
  2. Program Concordance;
  3.  
  4. Const
  5.   MaxWordLen = 20;
  6.   InName = 'OUT.';
  7.   OutName = 'Con:';
  8.  
  9. Type
  10.   CharIndex = 1..MaxWordLen;
  11.   CountType = 1..MaxInt;
  12.   WordType = Array [CharIndex] Of Char;
  13.   Pointer = ^EntryType;
  14.   EntryType =
  15.     Record
  16.       Left,Right : Pointer;
  17.       Word : WordType;
  18.       Count : CountType;
  19.     End;
  20.  
  21. Var
  22.   WordTree : Pointer;
  23.   NextWord : WordType;
  24.   Letters  : Set Of Char;
  25.   Input,OutPut : Text;
  26.  
  27. Procedure ReadWord ( Var PackedWord : WordType );
  28.  
  29. Const
  30.   Blank = ' ';
  31.  
  32. Var
  33.   Buffer    : Array [CharIndex] Of Char;
  34.   CharCount : 0..MaxWordLen;
  35.   Ch        : Char;
  36.  
  37. Begin
  38.   If Not Eof(Input)
  39.     Then
  40.       Repeat
  41.         Read(Input,Ch)
  42.       Until Eof(Input) Or (Ch In Letters);
  43.   If Not Eof(Input)
  44.     Then
  45.       Begin
  46.         CharCount := 0;
  47.         While Ch In Letters Do
  48.           Begin
  49.             If CharCount < MaxWordLen
  50.               Then
  51.                 Begin
  52.                   CharCount := CharCount + 1;
  53.                   Buffer[CharCount] := Ch
  54.                 End;
  55.             If Eof(Input)
  56.               Then Ch := Blank
  57.               Else Read(Input,Ch)
  58.           End;
  59.         For CharCount := Charcount + 1 To MaxWordLen Do
  60.           Buffer[CharCount] := Blank;
  61.         PackedWord := Buffer
  62.       End;
  63. End; { ReadWord }
  64.  
  65. Procedure PrintWord (PackedWord : WordType);
  66.  
  67. Var
  68.   CharPos : 1..MaxWordLen;
  69.  
  70. Begin
  71.   For CharPos := 1 To MaxWordLen Do
  72.     Write(OutPut,PackedWord[CharPos])
  73. End; { PrintWord }
  74.  
  75. Procedure MakEntry ( Var Tree  : Pointer;
  76.                          Entry : WordType);
  77.  
  78. Begin
  79.   If Tree = Nil
  80.     Then
  81.       Begin
  82.         New(Tree);
  83.         With Tree^ Do
  84.           Begin
  85.             Word := Entry;
  86.             Count := 1;
  87.             Left := Nil;
  88.             Right := Nil;
  89.           End;
  90.       End
  91.     Else
  92.       With Tree^ Do
  93.         If Entry < Word
  94.           Then MakEntry(Left,Entry)
  95.         Else If Entry > Word
  96.           Then MakEntry(Right,Entry)
  97.         Else Count := Count + 1
  98. End; { MakEntry }
  99.  
  100. Procedure PrintTree ( Tree : Pointer );
  101.  
  102. Begin
  103.   If Tree <> Nil
  104.     Then
  105.       With Tree^ Do
  106.         Begin
  107.           PrintTree(Left);
  108.           PrintWord(Word);
  109.           Writeln(OutPut,Count);
  110.           PrintTree(Right)
  111.         End
  112. End; { PrintTree }
  113.  
  114. Begin { Concordance }
  115.   Assign(Input,InName);
  116.   Assign(OutPut,OutName);
  117.   Reset(Input);
  118.   ReWrite(OutPut);
  119.   Letters := ['A'..'Z','a'..'z'];
  120.   WordTree := Nil;
  121.   While Not Eof(Input) Do
  122.     Begin
  123.       ReadWord(NextWord);
  124.       If Not Eof(Input)
  125.         Then MakEntry(WordTree,NextWord)
  126.     End;
  127.   PrintTree(WordTree);
  128.   Close(Input);
  129.   Close(OutPut);
  130. End.
  131.  
  132.