home *** CD-ROM | disk | FTP | other *** search
/ Between Heaven & Hell 2 / BetweenHeavenHell.cdr / 300 / 245 / brekdown.pas < prev    next >
Pascal/Delphi Source File  |  1985-12-18  |  32KB  |  798 lines
  1. {$C-,R-,V-}
  2. {          BREAK DOWN  -- a text analysis and generation program
  3.                   copyright 1985 by Neil J. Rubenking
  4.       based on the program TRAVESTY, from the Nov. 1984 BYTE magazine
  5.  
  6.   NOTE that the "KEY" that indexes the DATA files is not included in the
  7.   DATA files.  This saves about 20% on the DATA file size, and that 20%
  8.   can be important.  It also means that you cannot restore a "corrupted"
  9.   INDEX file, but that's not likely to be a problem.  Also note that the
  10.   KEY values in the INDEX file always take MaxKeyLen+1 bytes, even if the
  11.   "order" is smaller.  If you want to try orders greater than 8, change
  12.   the value of MaxKeyLen and recompile.
  13. }
  14.  
  15. program BreakDown;
  16. const
  17.   outCharNum     = 34;   { If you change the number of characters tracked,
  18.                            you will have to change this constant.         }
  19.   MaxKeyLen      = 7;    { MaxKeyLen is one less that the maximum order. }
  20.   lineWidth      = 55;   { lines less than this length will be considered
  21.                            to have ended "early", with a hard <CR> }
  22.  
  23. {TURBO-Access constants}
  24. const
  25.  
  26.   MaxDataRecSize = OutCharNum;
  27.   PageSize       = 48;     { You can experiment with these  }
  28.   Order          = 24;     { constants, which are described }
  29.   PageStackSize  = 16;     { in not-quite-enough detail in  }
  30.   MaxHeight      = 8;      { the TURBO TOOLBOX manual       }
  31.  
  32. {$I access.box}
  33. {$I getkey.box}
  34. {$I AddKey.box}
  35. {$I DelKey.box}
  36.  
  37.  
  38. type
  39.   char_set      = set of char;
  40.   choices       = array[1..outCharNum] of byte;
  41.   line          = string[90];
  42.   chunkString   = string[MaxKeyLen];
  43.   filename_type = string[14];
  44.  
  45. var
  46.   Breakout, worked                                        : boolean;
  47.   ordr, N, co                                             : byte;
  48.   chars_to_output, KeyNum, Totl_to_out,  counter, AllRecs : integer;
  49.   ShowRecs                                                : real;
  50.   Ch, OutDrive, InxDrive, DatDrive                        : char;
  51.   outChars                                                : string[40];
  52.   source, outFile, BSource                                : text;
  53.   sourceName, DatName, OutName, InxName, OldName,
  54.   BSourceName, BDatName, BInxName                         : filename_type;
  55.   OkayChars, PuncChars, NumbChars                         : char_set;
  56.   sourceLine                                              : line;
  57.   NoChance, AR, BR                                        : choices;
  58.   lookChunk                                               : chunkString;
  59.   DatF, BDatF                              : datafile;     {TOOLBOX types}
  60.   IndexF, BIndexF                          : IndexFile;    {TOOLBOX types}
  61.  
  62. {@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
  63. procedure BreakMessage; external 'BREK2.TXT';
  64. {@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
  65. procedure PlayMessage(offset : integer);
  66. var N : integer;
  67. begin
  68.   N := 0;
  69.   repeat
  70.     write(chr(MEM[CSeg:Offset + N]));
  71.     N := N + 1;
  72.   until MEM[CSeg:N+Offset] = $1A;
  73. end;
  74. {@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
  75. function rep(CH : char ; BY : byte):line;
  76. var
  77.   temp : line;            { "rep" produces a string of BY repetitions of }
  78.   N    : byte;            { the character CH.                            }
  79. begin
  80.   temp := '';
  81.   for N := 1 to BY do
  82.     temp := temp + CH;
  83.   rep := temp;
  84. end;
  85. {@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
  86. procedure RevVideo;
  87. begin
  88.   textColor(black);
  89.   textBackGround(white);
  90. end;
  91. {@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
  92. function LowCase(CC : char):char;
  93. begin
  94.   if CC in ['A'..'Z'] then LowCase := chr(ord(CC)+32)
  95.     else LowCase := CC;
  96. end;
  97. {@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
  98. procedure DoHeader(act1, AFile, act2, BFile : filename_type);
  99. begin
  100.   ClrScr;                                { This produces a header that tells}
  101.   RevVideo;                              { what BREAK DOWN is doing, with a }
  102.   Write(#218,rep(#196,78),#191,#179);    { reverse-video box around it.     }
  103.   HighVideo;
  104.   write('  BREAK DOWN is now ',act1,' ',AFile,act2,BFile);
  105.   write(rep(' ',49-length(AFile)-length(act1)-length(act2)-length(BFile)));
  106.   write('ORDER ',ordr:2);
  107.   RevVideo;
  108.   write(#179,#212,rep(#205,78),#190);
  109.   HighVideo;
  110. end;
  111. {@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
  112. function exists(ThisFile : filename_type):boolean;
  113. var
  114.   tempFile : text;  {We can get away with assigning a text file to ANY
  115.                      filename because we aren't going to do any input/output}
  116. begin
  117.   assign(tempFile,ThisFile);
  118.   {$I-}                                   { Here we set I/O error checking   }
  119.   reset(tempFile);                        { OFF and do a RESET.  If the file }
  120.   {$I+}                                   { exists, there's no error, and    }
  121.   if IOResult = 0 then exists := true     { IOResult = 0.  If not, IOResult  }
  122.     else exists := false;                 { holds the error number.          }
  123.   close(tempFile);
  124. end;
  125. {@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
  126. procedure Process(VAR FromName, ToName : filename_type;
  127.                                  drive : char;
  128.                                    ext : chunkString);
  129. begin
  130.   if ordr < 10 then               { If the order is 9 or less, put that  }
  131.     ext[3] := chr(48+ordr)        { digit in the middle of the extension.}
  132.   else ext[3] := chr(55+ordr);    { For 10 and up, use A, B, C, &c.      }
  133.   ToName := FromName;
  134.   if pos('.',ToName) <> 0 then             { IF an extension is included,  }
  135.     delete(ToName,pos('.',ToName),4);      { delete it.  Then add the new  }
  136.   ToName := ToName + ext;                  { extension.                    }
  137.  
  138.   if UpCase(drive) in ['A'..'Z'] then  {IF the drive character is valid, then}
  139.     if pos(':',ToName) <> 0 then           { if a drive has been specified,}
  140.       ToName[1] := drive                   { just change the first char -- }
  141.     else ToName := drive + ':' + ToName;   { else add drive and ':'        }
  142. end;
  143. {@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
  144. procedure initialize(mode : char);
  145.                     { modes are M for Make a new file,
  146.                                 O for Open an existing file,
  147.                                 G for (Open a file and) Generate,
  148.                                 B for Open another existing file  }
  149.  
  150.   { The procedures SetUp and SetUpB exist solely for the purpose of
  151.     breaking up the action into graspable chunks.                  }
  152.   {==========================================================================}
  153.   procedure SetUp;
  154.   begin
  155.     if (exists(sourceName)) or (mode = 'O') then
  156.       begin
  157.         process(sourceName, DatName, DatDrive, '.DAT');
  158.         case mode of
  159.           'M': MakeFile( DatF, DatName, OutCharNum);
  160.           'O': OpenFile( DatF, DatName, OutCharNum);
  161.         end;
  162.         if OK then
  163.           begin
  164.             process(sourceName, InxName, InxDrive, '.INX');
  165.             case mode of
  166.               'M': MakeIndex(IndexF,InxName,MaxKeyLen,0);
  167.               'O': OpenIndex(IndexF,InxName,MaxKeyLen,0);
  168.             end;
  169.             if not OK then
  170.             case mode of
  171.               'M': writeLn('Cannot create index file');
  172.               'O': WriteLn('Index file does not exist');
  173.             end;
  174.           end
  175.             else
  176.               case mode of
  177.                 'M': writeLn('Cannot create data file');
  178.                 'O': WriteLn('Data file does not exist');
  179.               end;
  180.             worked := OK;
  181.       end { if exists }
  182.     else
  183.       begin
  184.         WriteLn('Source file does not exist.');
  185.         worked := false;
  186.       end;
  187.   end;
  188.   {==========================================================================}
  189.   procedure SetUpB;
  190.   begin
  191.     process(BsourceName, BDatName, DatDrive, '.DAT');
  192.     OpenFile( BDatF, BDatName, OutCharNum);
  193.     if OK then
  194.       begin
  195.         process(BsourceName, BInxName, InxDrive, '.INX');
  196.         OpenIndex(BIndexF,BInxName,MaxKeyLen,0);
  197.         if not OK then
  198.           WriteLn('Secondary Index file does not exist');
  199.       end
  200.     else
  201.       WriteLn('Secondary Data file does not exist');
  202.     worked := OK;
  203.   end;
  204.   {==========================================================================}
  205.  
  206. begin
  207.   mode := upCase(mode);
  208.   if mode = 'B' then WriteLn('Name of second source file: ')
  209.     else WriteLn('  Name of main source file: ');
  210.   WriteLn('       Drive for DATA file: ');
  211.   WriteLn('      Drive for INDEX file: ');
  212.   if mode = 'G' then
  213.     WriteLn('          Drive for output: ')
  214.   else WriteLn;
  215.   DatDrive := ' '; InxDrive := ' '; outDrive := ' ';
  216.   GotoXY(29,WhereY-4);
  217.   if mode = 'B' then read(BsourceName)
  218.     else
  219.       begin
  220.         Read(sourceName);
  221.         if sourceName = '' then          { If you just hit <return> when }
  222.           begin                          { prompted for a SourceName,    }
  223.             if OldName <> '' then        { the default is whatever the   }
  224.               begin                      { most recent previous name was.}
  225.                 sourceName := OldName;
  226.                 GotoXY(29,WhereY);
  227.                 write(sourceName);
  228.               end;
  229.           end
  230.         else
  231.           OldName := SourceName;
  232.       end;
  233.                                      { The data file for fff.xxx will be  }
  234.   GotoXY(29,WhereY+1);               { called fff.DnT, where n is the     }
  235.   read(DatDrive);                    { order of the BreakDown.  The index }
  236.   GotoXY(29,WhereY+1);               { will be fff.InX, and any output    }
  237.   read(InxDrive);                    { file will be fff.OnT               }
  238.   if mode = 'G' then                 {    If the order is 10 or more, "n" }
  239.     begin                            { will be a letter, starting with    }
  240.       GotoXY(29,WhereY+1);           { A for 10.                          }
  241.       read(outDrive);
  242.     end;
  243.   WriteLn;                                        { The source file only has}
  244.   if mode = 'G' then mode := 'O';                 { to be present if we're  }
  245.                                                   { [M]aking a new BreakDown}
  246.   if mode = 'B' then SetUpB
  247.     else SetUp;
  248. end;
  249. {@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
  250. procedure Merge;
  251. var
  252.   RC, matches       : real;
  253.   BRecNum, ARecNum  : integer;
  254.   {==========================================================================}
  255.   procedure Combine(VAR AA,BB : choices);
  256.   begin
  257.     if CH = 'C' then
  258.       begin
  259.         for co := 1 to outCharNum do
  260.           begin
  261.             if AA[co] + BB[co] > 0 then
  262.               if AA[co] + BB[co]*RC < 255.0 then
  263.                 AA[co] := AA[co] + (trunc(BB[co]*RC) and $FF)
  264.               else AA[co] := $FF;
  265.           end;
  266.       end
  267.     else
  268.       begin
  269.         for co := 1 to OutCharNum do
  270.           begin
  271.             if AA[co] + BB[co] > 0 then
  272.               if AA[co] + BB[co] < $FF then
  273.                 AA[co] := AA[co] + BB[co]
  274.               else AA[co] := $FF;
  275.           end;
  276.       end;
  277.   end;
  278.   {==========================================================================}
  279.   procedure GetConstant;
  280.   begin
  281.     repeat
  282.       GotoXY(1,WhereY); ClrEOl;
  283.       Write('Multiply by what constant? (0.01 to 100)');
  284.       read(RC);
  285.     until (RC > 0.01) and (RC <= 100 );
  286.   end;
  287.   {==========================================================================}
  288.   procedure DoMerge;
  289.   var
  290.     BOK : boolean;
  291.   begin
  292.     AllRecs := UsedRecs(BDatF);
  293.     ShowRecs := AllRecs;
  294.     if ShowRecs < 0 then ShowRecs := ShowRecs + 65536.0;
  295.     if CH = 'C' then GetConstant
  296.       else RC := 1.0;
  297.     ClrScr;
  298.     ClearKey(BIndexF);                   { NextKey after ClearKey gives us }
  299.     NextKey(BIndexF,BRecNum,lookChunk);  { the very first key.             }
  300.     BOK := OK;
  301.     counter := 1;
  302.     matches := 0;
  303.     GetRec(BDatF,BRecNum,BR);            { We Get the Record corresponding }
  304.     while BOK do                         { to that first key.              }
  305.       begin
  306.         if counter mod 10 = 0 then
  307.           begin
  308.             GotoXY(1,1);CLrEOL;
  309.             write(counter:6,' out of ',ShowRecs:6:0);
  310.           end;
  311.         FindKey(IndexF,ARecNum,lookChunk);
  312.         if OK then                            { If that same key is in the   }
  313.           begin                               { index of the file into which }
  314.             matches := matches + 1;           { we're merging, combine the   }
  315.             GetRec(DatF,ARecNum,AR);          { frequency tables and write   }
  316.             combine(AR,BR);                   { combined table back to disk. }
  317.             PutRec(DatF,ARecNum,AR);          { . . .}
  318.           end
  319.         else
  320.           begin
  321.             AddRec(DatF,ARecNum,BR);          { Otherwise, Add the Record }
  322.             AddKey(IndexF,ARecNum,LookChunk); { and its Key.              }
  323.           end;
  324.         NextKey(BIndexF,BRecNum,LookChunk);   { Get the next key, . . .}
  325.         BOK := OK;
  326.         GetRec(BDatF,BRecNum,BR);             { . . . and its record,  }
  327.         counter := counter + 1;           { and increment the counter. }
  328.       end;
  329.     CloseFile(DatF);
  330.     CloseFile(BDatF);
  331.     CloseIndex(IndexF);
  332.     CloseIndex(BIndexF);
  333.   end;
  334.   {==========================================================================}
  335. begin
  336.   GotoXY(1,1);
  337.   DelLine;
  338.   WriteLn('MERGING');
  339.   initialize('O');
  340.   if worked then
  341.     initialize('B');
  342.   if worked then
  343.     begin
  344.       ClrScr;
  345.       DoHeader('merging',BSourceName,' into ',SourceName);
  346.       window(1,4,80,25);
  347.       ClrScr;
  348.       WriteLn(SourceName,'''s DAT and INX files will be permanently changed.  You can');
  349.       WriteLn('multiply the frequencies of ',BSourceName,' by a constant from 1/100 to');
  350.       WriteLn('100, though a non-zero frequency will never be reduced to zero, nor will');
  351.       WriteLn('it grow larger than 255.');
  352.       WriteLn;
  353.       WriteLn('[G]o ahead, set a multiplying [C]onstant, or [Q]uit?');
  354.       repeat
  355.         read(Kbd,CH);
  356.       until UpCase(CH) in ['G','C','Q'];
  357.       CH := UpCase(CH);
  358.       if CH <> 'Q' then DoMerge;
  359.     end;
  360.   WriteLn;
  361.   writeLn(matches:1:0,' records matched existing records in ',DatName);
  362.   WriteLn('Press a key to return to main menu.');
  363.   repeat until Keypressed; Read(Kbd);
  364.   window(1,1,80,25);
  365. end;
  366. {@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
  367. procedure Analyze;
  368. var
  369.   NumOver           : integer;
  370.   OldRecs, MadeRecs : real;
  371.   {==========================================================================}
  372.   procedure ReadSource;
  373.   var
  374.     HoldThatLine  : Line;
  375.     linePos       : byte;
  376.     NxCh          : char;
  377.     {------------------------------------------------------------------}
  378.     procedure CleanUp(VAR aLine : line);
  379.     var
  380.       shortLine : boolean;
  381.     begin
  382.       while pos(#9,aLine) <> 0 do              { Replace TABs with five   }
  383.         begin                                  { spaces.  This is just for}
  384.           insert('     ',aLine,pos(#9,aLine)); { measuring line length.   }
  385.           delete(aLine,pos(#9,aLine),1);
  386.         end;
  387.       if length(aLine) < lineWidth then   { If the line is "short", then we }
  388.         shortLine := true                 { suppose it to end with a HARD   }
  389.       else ShortLine := false;            { Carriage Return (end paragraph).}
  390.       for co := 1 to length(aLine) do
  391.         begin
  392.           if aLine[co] in OkayChars then     { Okay characters get converted}
  393.             aLine[co] := LowCase(aLine[co])  { to lower case.               }
  394.           else
  395.             if aLine[co] = '"' then         { Double quotes turn into single}
  396.               aLine[co] := #39
  397.             else
  398.               if aLine[co] in PuncChars then  {Punctuation that is "not Okay" }
  399.                 aLine[co] := ' '              {gets spaced out. It is treated }
  400.                                               {separately because you might   }
  401.                                               {want to convert all punctuation}
  402.                                               {into, say, commas. }
  403.               else
  404.                 if aLine[co] in NumbChars then  { Numbers turn into # symbols}
  405.                   aLine[co] := '#'
  406.                 else aLine[co] := ' ';          { Anything else is spaced out.}
  407.         end;
  408.       while pos('  ',aLine) <> 0 do        { Eliminate multiple spaces }
  409.         delete(aLine,pos('  ',aLine),1);
  410.       while pos('##',aLine) <> 0 do        { Reduce numbers to a single "#"}
  411.         delete(aLine,pos('##',aLine),1);
  412.       while pos(' ,',aLine) <> 0 do        { Eliminate spaces AHEAD of commas}
  413.         delete(aLine,pos(' ,',aLine),1);
  414.       while pos(' .',aLine) <> 0 do        { . . . and periods }
  415.         delete(aLine,pos(' .',aLine),1);
  416.       aLine := ' ' + aLine;
  417.       if (ShortLine) or (aLine = ' ') then    { Add a paragraph symbol to  }
  418.         aLine := aLine + #20;                 { the end of any short lines.}
  419.     end;
  420.     {------------------------------------------------------------------}
  421.     procedure FeedIn(aLine : line);
  422.     begin
  423.       repeat
  424.         NxCh := aLine[linePos];                { Locate the NEXT character.  }
  425.         FindKey(IndexF, KeyNum, LookChunk);  { See if the current "chunk"  }
  426.                                                { is already on record.       }
  427.         if OK then                             { If it is, call up its record}
  428.           begin                                { and add one to the chances  }
  429.             GetRec(DatF,KeyNum,AR);       { of it begin followed by NxCh}
  430.                                                         { UNLESS the chances }
  431.             if AR[pos(NxCh,outChars)] < $FF then   { for NxCh are at the}
  432.               AR[pos(NxCh,outChars)] :=            { max of 255 already.}
  433.                AR[pos(NxCh,outChars)] + 1
  434.               else NumOver := NumOver + 1;
  435.             PutRec(DatF,KeyNum,AR);
  436.           end
  437.         else
  438.           begin
  439.                                                {If the "chunk" was not on}
  440.                                                { record yet, create it, }
  441.             AR := NoChance;               { set all the chances to }
  442.             AR[pos(NxCh,outChars)] := 1;  { zero, and set the NxCh }
  443.                                                { chance to one.         }
  444.             AddRec(DatF,KeyNum,AR);
  445.             AddKey(IndexF,KeyNum,LookChunk);
  446.           end;
  447.         LookChunk := copy(LookChunk,2,ordr-2); {Now drop the first char}
  448.         LookChunk := LookChunk + NxCh;        {of the chunk, add the NxCh}
  449.         LinePos := LinePos + 1;               {to it, and advance the LinePos}
  450.  
  451.       until (LinePos > length(aLine)); { Do it until the whole line is in,}
  452.       LinePos := 1;                    { then reset the LinePos.          }
  453.     end;
  454.     {------------------------------------------------------------------}
  455.   begin
  456.     NumOver := 0;
  457.     reset(source);
  458.     ReadLn(source,sourceLine);
  459.     CleanUp(sourceLine);
  460.     while length(sourceLine) < ordr  do          { To start, we must be sure }
  461.       begin                                      { to have a line long enough}
  462.         ReadLn(source,HoldThatLine);             { to extract a "chunk" from.}
  463.         sourceLine := sourceLine + HoldThatLine;
  464.         CleanUp(sourceLine);
  465.       end;
  466.     WriteLn(sourceLine);
  467.     LookChunk := copy(sourceLine,1,ordr-1);   { Extract the first chunk, and}
  468.     HoldThatLine  := LookChunk;               { save it to tack on the end. }
  469.     linePos := ordr;
  470.     NxCh  := sourceLine[LinePos];
  471.     FeedIn(sourceLine);
  472.     BreakOut := false;
  473.     while (not EOF(source)) and (not breakout) do
  474.       begin
  475.         ReadLn(source,sourceLine);
  476.         CleanUp(sourceLine);
  477.         WriteLn(sourceLine);
  478.         FeedIn(sourceLine);
  479.         if keypressed then BreakOut := true;  { The BreakDown can take a long
  480.                                                 time -- if you press a key,
  481.                                                 the program shuts down grace-
  482.                                                 fully, without losing what it
  483.                                                 has done.  }
  484.       end;
  485.     FeedIn(HoldThatLine);
  486.     WriteLn(HoldThatLine);
  487.     WriteLn; WriteLn;
  488.     Write('Successfully read in ',sourceName);
  489.     MadeRecs := UsedRecs(DatF);
  490.     if MadeRecs < 0 then MadeRecs := 65536. + MadeRecs;
  491.     if upCase(CH) = 'N' then
  492.       WriteLn('  Produced ',MadeRecs:1:0,' records.')
  493.     else WriteLn('  Added ',(MadeRecs - OldRecs):1:0,' records.');
  494.     if NumOver > 0 then
  495.       WriteLn(NumOver,' entries have hit the max of 255.');
  496.     CloseFile(DatF);
  497.     CloseIndex(IndexF);
  498.   end;
  499.   {==========================================================================}
  500. begin
  501.   GotoXY(1,1);
  502.   DelLine;
  503.   WriteLn('»»ANALYZING««');
  504.   WriteLn;
  505.   WriteLn('[N]ew source, or [A]dd to existing?');
  506.   repeat
  507.     read(Kbd,CH);
  508.   until upCase(CH) in ['N','A'];
  509.   case upCase(CH) of
  510.     'N': begin
  511.            initialize('M');
  512.            assign(source,sourceName);
  513.          end;
  514.     'A': begin
  515.            Write('Name of NEW source: ');
  516.            ReadLn(sourceName);
  517.            assign(source,sourceName);
  518.            initialize('O');
  519.            OldRecs := UsedRecs(DatF);
  520.            if OldRecs < 0 then OldRecs := 65536. + OldRecs;
  521.          end;
  522.   end;
  523.   if worked then
  524.     begin
  525.       DoHeader('analyzing',sourceName,'','');
  526.       window(1,4,80,25);
  527.       GotoXY(1,1);
  528.       ReadSource;
  529.     end;
  530.   WriteLn('Press a key to return to main menu.');
  531.   repeat until keypressed; Read(Kbd);
  532.   window(1,1,80,25);
  533. end;
  534. {@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
  535. procedure Generate;
  536.   {==========================================================================}
  537.   procedure WriteTravesty;
  538.   label
  539.     PunkOut;
  540.   var
  541.     NxCh                    : char;
  542.     aRecNum                 : integer;
  543.     RealTot, rando          : real;
  544.     NextCap, Done, Nearly   : boolean;
  545.     {------------------------------------------------------------------}
  546.     procedure CheckForCapsAndLineEnd;
  547.     begin
  548.       if NextCap then
  549.         if NxCh in ['a'..'z'] then  { If we're waiting to capitalize, do }
  550.           begin                     { it only to an alphabetic character.}
  551.             NxCh := UpCase(NxCh);
  552.             NextCap := false;
  553.           end;
  554.       if NxCh in ['.','?'] then    { Capitalize the next ALPHA character }
  555.         NextCap := true;           { after a . or a ?                    }
  556.       if NxCh = #20 then
  557.         begin                        {   If you hit a paragraph marker,  }
  558.           WriteLn(OutFile,SourceLine);  { end the line and print it out.    }
  559.           writeLn(SourceLine);
  560.           SourceLine := '';
  561.           NextCap := true;    { Capitalize the first char of the new line.}
  562.         end
  563.       else
  564.         begin
  565.           SourceLine := SourceLine + NxCh;
  566.           if (outChars[N] = ' ') and (length(SourceLine) > lineWidth) then
  567.             begin
  568.               WriteLn(OutFile,SourceLine); { End a line at the next space     }
  569.               writeLn(SourceLine);         { after max line width is reached. }
  570.               SourceLine := '';
  571.             end;
  572.         end;  { all about whether to end the line}
  573.       if Nearly then                   { "Nearly" means that the max char }
  574.         if NxCh = ' ' then             { count has been reached.  As soon }
  575.           begin                        { as we hit a space, we're done.   }
  576.             done := true;              { For good looks, we append a final}
  577.             SourceLine := SourceLine + '.';  { period.                          }
  578.           end;
  579.       if keypressed then BreakOut := true;
  580.     end;
  581.     {------------------------------------------------------------------}
  582.  
  583.   begin
  584.     Assign(outFile, outName);                    { We can't directly get the }
  585.     ReWrite(outFile);                            { KEY for a given record #, }
  586.     lookChunk := ' ' + chr(trunc(random(26))+97);{ so we use SearchKey, which}
  587.     SearchKey(IndexF,aRecNum,lookChunk);         { returns the KEY and # of  }
  588.     repeat                                       { first entry that's >= the }
  589.       NextKey(IndexF,aRecNum,LookChunk);          { string supplied.  Then we }
  590.     until LookChunk[1] = ' ';                     { NextKey 'til we find a    }
  591.     SourceLine := LookChunk;                      { suitable one.             }
  592.     SourceLine[2] := upCase(SourceLine[2]);     { Capitalize the first letter . . .}
  593.     Totl_to_out := ordr-1;
  594.     NextCap     := false;
  595.     randomize;
  596.     Breakout := false;
  597.     Nearly   := false;
  598.     Done     := false;
  599.     while (not DONE) and (not BreakOut) do
  600.       begin
  601.         Totl_to_out := Totl_to_out + 1;
  602.         if totl_to_out = chars_to_output then    { When the max is hit, set }
  603.           Nearly := true;                        { "nearly" to true.  At the}
  604.         RealTot := 0;                            { next space, you're DONE  }
  605.         FindKey(IndexF,KeyNum,LookChunk);
  606.         if OK then
  607.           begin
  608.             GetRec(DatF,KeyNum,AR);
  609.             for N := 1 to outCharNum do    { Total up all the  }
  610.               RealTot := RealTot + AR[N];  { "chances" figures }
  611.           end
  612.         else
  613.           begin                        { This should never happen, but }
  614.             WriteLn(SourceLine,'<<<'); { just in case . . .            }
  615.             Write(chr(7));
  616.             WriteLn('Didn''t find record of string >',LookChunk,'<');
  617.             Goto punkOut;
  618.           end;
  619.           rando := random*RealTot;   { Select a random number less than total}
  620.           N := 0;                    { and "count off" chances until you use }
  621.           repeat                     { it up -- that's the next character.   }
  622.               N := N + 1;
  623.               RealTot := RealTot - AR[N];
  624.           until (RealTot < rando) or (N > outCharNum);
  625.         if N > length(outChars) then   { This should never happen! }
  626.           begin
  627.             writeLn(chr(7),chr(7),'Error in chances table for >',LookChunk,'<');
  628.             Goto PunkOut;
  629.           end;
  630.         delete(LookChunk,1,1);         { Knock off the first character of the}
  631.         NxCh := outChars[N];           { current chunk, and tack on the newly}
  632.         LookChunk := LookChunk + NxCh; { chosen next character.              }
  633.         CheckForCapsAndLineEnd;
  634.  
  635.       end;  { of the big WHILE }
  636.     WriteLn(OutFile,SourceLine);      { Be sure to write the very last line! }
  637.     writeLn(SourceLine);
  638.     WriteLn; WriteLn;
  639.     Write('total number of chars output ',Totl_to_out);
  640.     WriteLn(' of requested ',chars_to_output);
  641.     PunkOut:
  642.     close(outFile);
  643.     closeFile(datF);
  644.     closeIndex(indexF);
  645.   end;
  646.   {==========================================================================}
  647. begin
  648.   GotoXY(1,1);
  649.   DelLine;
  650.   WriteLn('»»GENERATING««');
  651.   WriteLn;
  652.   initialize('G');
  653.   if worked then
  654.     begin
  655.       Write('How many characters to output?');
  656.       read(chars_to_output);
  657.       process(sourceName,outName, outDrive, '.OUT');
  658.       DoHeader('generating',OutName,'','');
  659.       window(1,4,80,25);
  660.       GotoXY(1,1);
  661.       WriteTravesty;
  662.     end;
  663.   WriteLn('Press a key to go back to menu.');
  664.   repeat until keypressed; Read(Kbd);
  665.   window(1,1,80,25);
  666. end;
  667. {@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
  668. procedure List;
  669.   {==========================================================================}
  670.   procedure DoList;
  671.   label
  672.     enough;
  673.   var
  674.     M        : integer;
  675.     StrRecs  : filename_type;
  676.   begin
  677.     Write('View a particular record?');
  678.     read(CH); WriteLn;
  679.     if upCase(CH) = 'Y' then
  680.       begin
  681.         WriteLn('Which ',ordr-1,'-letter sequence?');
  682.         lookChunk := '';
  683.         for N := 1 to ordr-1 do
  684.           begin
  685.             repeat
  686.               read(Kbd,CH);
  687.             until pos(CH,outChars) <> 0;
  688.             write(CH);
  689.             lookChunk := lookChunk + CH;
  690.           end;
  691.         FindKey(IndexF,M,lookChunk);
  692.         if not OK then
  693.           begin
  694.             Write(chr(7),'"',lookChunk,'" is not in this list.');
  695.             ClearKey(IndexF);
  696.             NextKey(IndexF,M,lookChunk);
  697.           end;
  698.       end
  699.     else
  700.       begin
  701.         ClearKey(IndexF);
  702.         NextKey(IndexF,M,LookChunk);
  703.       end;
  704.     AllRecs := UsedRecs(DatF);
  705.     ShowRecs := AllRecs;
  706.     if ShowRecs < 0 then ShowRecs := ShowRecs + 65536.0;
  707.     str(ShowRecs:1:0,StrRecs);
  708.     StrRecs := ':  ' + StrRecs;
  709.     DoHeader('listing',DatName,StrRecs,' records.');
  710.     textcolor(LightBlue);        { Blue = underlined on many mono monitors. }
  711.     write(rep(' ',ordr+1));      { Here we write a heading line. }
  712.     for N := 1 to outCharNum do
  713.       write(outChars[N]:2);
  714.     WriteLn;
  715.     window(1,5,80,25);
  716.     GotoXY(1,1);
  717.     co := 0;
  718.     while OK do
  719.       begin
  720.         co := co + 1;
  721.         GetRec(DatF,M,AR);                   { Get each record and show }
  722.                                              { the chunk it represents, }
  723.         Write('|',LookChunk:(ordr-1),'|');   { along with its chances.  }
  724.         for N := 1 to outCharNum do
  725.           if AR[N] <> 0 then write(AR[N]:2)
  726.             else write('  ');
  727.         WriteLn;
  728.         if co >= 20 then
  729.           begin
  730.             write('Press a key to see more--or [Q]uit');
  731.             repeat until keypressed;
  732.             read(Kbd,CH);
  733.             if upCase(CH) = 'Q' then GoTo enough;
  734.             ClrScr;
  735.             co := 0;
  736.           end;
  737.         NextKey(IndexF,M,LookChunk); { Go thru the list in order by taking
  738.                                        the Next Key again and again.      }
  739.       end;  {while}
  740.     Enough:
  741.     CH := ' ';
  742.     textColor(white);
  743.   end;
  744.   {==========================================================================}
  745. begin
  746.   GotoXY(1,1);
  747.   DelLine;
  748.   WriteLn('»»LISTING««');
  749.   WriteLn;
  750.   initialize('O');
  751.   if worked then DoList;
  752.   Write('Press a key to return to main menu.');
  753.   repeat until Keypressed; Read(Kbd);
  754.   window(1,1,80,25);
  755. end;
  756. {@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
  757. begin
  758.   PuncChars := ['!'..'&','('..'+',':'..'>','['..'`','{'..'~','@','/'];
  759.   NumbChars := ['0'..'9'];
  760.   OkayChars := ['a'..'z','-',#39,'A'..'Z','.',',','?'];
  761.   Outchars  := 'abcdefghijklmnopqrstuvwxyz -.,?#' + #20 + #39;
  762.   { NOTICE:  if you add a char to OutChars, change the constant OutCharNum }
  763.   for N := 1 to OutCharNum do noChance[N] := 0;
  764.   ClrScr;
  765.   PlayMessage(ofs(BreakMessage));
  766.   repeat until keypressed;
  767.   Read(Kbd);
  768.   oldName := '';
  769.   ClrScr;
  770.   repeat
  771.     InitIndex;
  772.     ClrScr;
  773.     RevVideo;
  774.     Write('[A]nalyze a text, [G]enerate a travesty, [L]ist, [M]erge,');
  775.     WriteLn(' or [Q]uit?');
  776.     HighVideo;
  777.     repeat
  778.       read(Kbd,CH);
  779.     until upCase(Ch) in ['A','G','L','M','Q'];
  780.     if UpCase(CH) <> 'Q' then
  781.       begin
  782.         repeat
  783.           Write('What "order"? (3..',MaxKeyLen+1,') ');
  784.           read(ordr);
  785.         until ordr in [3..MaxKeyLen+1];   { if you just hit <return> here, the
  786.                                             most recent "order" will be used.}
  787.         DelLine;
  788.       end;
  789.     case upCase(ch) of
  790.       'A': Analyze;
  791.       'M': Merge;
  792.       'G': Generate;
  793.       'L': List;
  794.     end;
  795.   until upCase(ch) = 'Q';
  796. end.
  797.  
  798.