Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/BAFGAB.ZIP/TRAVESTY.PAS

Pascal/Delphi Source File | 1988-05-11 | 10.1 KB | 281 lines

PROGRAM travesty(input, output, f, o);                 {Kenner / O'Rourke 5/9/84}

{  Entered and modified by Sam Smith --- 3-Nov-1984                       }

{  This is based on Brian Hayes's article in Scientific American, 11/83.  }
{  It scans a text and generates an n-order simulation of its letter      }
{  combinations. For order n, the relation of input to output is exactly: }
{            " Any pattern n characters long in the output                }
{              has occurred somewhere in the input with                   }
{              about the same frequency."                                 }
{  Input should be ready on disk. Program asks how many characters of     }
{  output you want. It asks for the "Order" - i.e. how long a string of   }
{  characters will be cloned to the output when found. You are asked for  }
{  the name of the input file, and offered a "Verse" option. If you       }
{  select this, and if the input has a "|" character at the end of each   }
{  line, words that end lines in the original will terminate output       }
{  lines. Otherwise, output lines will average 50 characters in length.   }
{  Output may be directed to a disk file, to the console (file "CON") or  }
{  to a printer (file "PRN").                                             }

CONST
  ArraySize = 21000;                {Maximum number of text characters}
  MaxPat = 9;                       {Maximum pattern length}

VAR
  BigArray: PACKED ARRAY [1..ArraySize] of CHAR;
  FreqArray, StartSkip: ARRAY[' '..'|'] of INTEGER;
  Pattern: PACKED ARRAY [1..MaxPat] of CHAR;
  SkipArray: ARRAY [1..ArraySize] of INTEGER;
  OutChars: INTEGER;                 {Number of characters to be output}
  PatLength: INTEGER;
  f: TEXT;
  o: TEXT;
  CharCount: INTEGER;               {Characters output so far}
  Verse, NearEnd: BOOLEAN;
  NewChar: CHAR;
  TotalChars: INTEGER;              {Total chars input + wraparound}

PROCEDURE InParams;                 {Obtains user's instructions}
VAR
  InFile: STRING [12];
  OutFile: STRING [12];
  Response:CHAR;
BEGIN
  WRITELN('Number of characters to be output?');
  READLN(OutChars);
  REPEAT
    WRITELN('What order? <2-',MaxPat,'>');
    READLN(PatLength)
  UNTIL (PatLength IN [2..MaxPat]);
  PatLength := Patlength - 1;
  WRITELN('Name of input file?');
  READLN(InFile);
  ASSIGN(f,InFile);
  RESET(f);
  WRITELN('Name of output file?');
  READLN(OutFile);
  ASSIGN(o,OutFile);
  REWRITE(o);
  WRITELN('Prose or Verse? <p/v>');
  READLN(Response);
  IF(Response = 'V') OR (Response = 'v') then
    Verse := true
  ELSE Verse := false
END;                                {Procedure InParams}

PROCEDURE ClearFreq;
{ FreqArray is indexed by 93 probable ASCII characters, from " " to  }
{ "|". Its elements are all set to zero.                             }
VAR
  ch: CHAR;
BEGIN
  FOR ch := ' ' to '|' DO
    FreqArray[ch] := 0
END;                                {Procedure ClearFreq}

PROCEDURE NullArrays;
{ Fill BigArray and Pattern with nulls }
VAR
  j: INTEGER;
BEGIN
  FOR j := 1 TO ArraySize DO
    BigArray[j] := CHR(0);
  FOR j := 1 TO MaxPat DO
    Pattern[j] := CHR(0);
END;                                {Procedure NullArrays}

PROCEDURE FillArray;
{ Moves text file from disk into BigArray, cleaning it up and reducing  }
{ any run of blanks to a single blank. Then copies to end of array a    }
{ string of its opening characters as long as the Pattern, in effect    }
{ wrapping the end to the beginning.                                    }
VAR
  Blank : BOOLEAN;
  ch: CHAR;
  j: INTEGER;

  PROCEDURE Cleanup;
  {  Cleans Carriage Returns, Linefeeds, and Tabs out of input stream.  }
  {  All are changed to blanks.                                         }
  BEGIN
    IF ((ch = CHR(13))     {CR}
       OR (ch = CHR(10))   {LF}
       OR (ch = CHR(9))   {TAB}
       OR (ch = '_'))      {underscore}
    THEN ch := ' ';
    IF NOT (ch in [' '..'|']) THEN ch := ' '
  END;                              {Procedure Cleanup}

BEGIN                               {Procedure FillArray}
  j := 1;
  Blank := false;
  WHILE (NOT EOF(f)) AND (j <= (ArraySize-MaxPat)) DO
  BEGIN {While not EOF}
    READ (f,ch);
    ch := CHR(INTEGER(ch) MOD 128);
    Cleanup;
    BigArray[j] := ch;
    IF ch = ' ' THEN Blank := true;
    j := j + 1;
    WHILE (Blank AND (NOT EOF(f))
      AND (j <= (ArraySize-MaxPat))) DO
    BEGIN {While Blank}             {When a blank has just been printed, }
      READ(f,ch);                   {Blank is true. Succeeding blanks are}
      ch := CHR(INTEGER(ch) MOD 128);
      Cleanup;                      {skipped, thus stopping runs.        }
      IF ch <> ' ' THEN
      BEGIN {if}
        Blank := false;
        BigArray[j] := ch;          {To BigArray if not a blank          }
        j := j + 1
      END {if}
    END   {While Blank}
  END; {While Not EOF}
  TotalChars := j-1;
  IF BigArray[TotalChars] <> ' ' THEN
  BEGIN  {If no blank at end of text, append one}
    TotalChars := TotalChars + 1;
    BigArray[TotalChars] := ' ';
  END;
  { Copy front of array to back to simulate wraparound }
  FOR j := 1 to PatLength DO
    BigArray[TotalChars+j] := BigArray[j];
  TotalChars := TotalChars + PatLength;
  WRITELN('Characters read, plus wraparound = ',TotalChars:4)
END;                                {Procedure FillArray}

PROCEDURE FirstPattern;
{ User selects "order" of operation, an integer, n, in the range 1..9.    }
{ The input text will henceforth be scanned in n-sized chunks. The first  }
{ n-1 characters of the input file are placed in the "Pattern" array. The }
{ pattern is written at the head of output.                               }
VAR
  j: INTEGER;
BEGIN
  FOR j:= 1 TO PatLength DO
    Pattern[j] := BigArray[j];
  CharCount := PatLength;
  NearEnd := false;
  IF Verse THEN WRITE(o,' ');              { Align first line }
  FOR j := 1 to PatLength DO
    WRITE(o,Pattern[j])
END;                                {Procedure FirstPattern}

PROCEDURE InitSkip;
{ The i-th entry of SkipArray contains the smallest index j > i such that }
{ BigArray[j] = BigArray[i]. Thus SkipArray links together all identical  }
{ characters in BigArray. StartSkip contains the index of the first oc-   }
{ currence of each character. These two arrays are used to skip the match-}
{ ing array through the text, stopping only at locations whose character  }
{ matches the first character in pattern.                                 }
VAR
  ch: CHAR;
  j: INTEGER;
BEGIN
  FOR ch:= ' ' TO '|' DO
    StartSkip[ch] := TotalChars + 1;
  FOR j := TotalChars DOWNTO 1 DO
  BEGIN
    ch := BigArray[j];
    SkipArray[j] := StartSkip[ch];
    StartSkip[ch] := j
  END
END;                                {Procedure InitSkip}

PROCEDURE Match;
{ Checks BigArray for strings that match Pattern; for each match found,   }
{ notes following character and increments its count in FreqArray. Pos-   }
{ ition for first trial comes from StartSkip; thereafter positions are    }
{ taken from SkipArray. Thus no sequence is checked unless its first      }
{ character is already known to match first character of Pattern.         }
VAR
  i: INTEGER;       {One location before start of the match in BigArray}
  j: INTEGER;       {Index into Pattern}
  Found: BOOLEAN;   {True if there is a match from i+1 to i+j-1}
  ch1: CHAR;        {The first character in Pattern; used for skipping}
  NxtCh: CHAR;
BEGIN {Procedure Match}
  ch1 := Pattern[1];
  i := StartSkip[ch1]-1; {i is one to the left of the match start}
  WHILE (i <= TotalChars - PatLength - 1) DO
  BEGIN {while}
    j := 1;
    Found := true;
    WHILE (Found AND (j <= PatLength)) DO
      IF BigArray[i+j] <> Pattern[j]
        THEN Found := false   {Go through pattern till match fails}
        ELSE j := j + 1;
    IF Found THEN
    BEGIN                   {Note next char and increment FreqArray}
      NxtCh := BigArray[i + PatLength + 1];
      FreqArray[NxtCh] := FreqArray[NxtCh] + 1
    END;
    i := SkipArray[i+1] -1  {Skip to next matching position}
  END {while}
END; {Procedure Match}

Procedure WriteCharacter;
{ The next character is written. It is chosen at random from characters }
{ accumulated in FreqArray during last scan of input. Output lines will }
{ average 50 characters in length. If "Verse" option has been selected, }
{ a new line will commence after any word that ends with "|" in the     }
{ input file. Thereafter, lines will be indented until the 50-character }
{ average has been made up.                                             }
VAR
  Counter, Total, Toss: INTEGER;
  ch: CHAR;
BEGIN {Procedure WriteCharacter}
  Total := 0;
  FOR ch := ' ' TO '|' DO
    Total := Total + FreqArray[ch];  {Sum counts in FreqArray}
  Toss := TRUNC (Total * RANDOM)+1;
  Counter := 31;
  REPEAT
    Counter := Counter + 1;  {We begin with ' '}
    Toss := Toss - FreqArray[CHR(Counter)]
  UNTIL Toss <= 0;  {Char chosen by successive subtractions}
  NewChar := CHR(Counter);
  If NewChar <> '|' THEN
    WRITE(o,NewChar);
  CharCount := CharCount + 1;
  IF CharCount MOD 50 = 0 THEN NearEnd := true;
  IF ((Verse) AND (NewChar = '|')) THEN WRITELN(o);
  IF ((NearEnd) AND (NewChar = ' ')) THEN
  BEGIN  {If NearEnd}
    WRITELN(o);
    IF Verse THEN WRITE(o,'    ');
    NearEnd := false
  END {If NearEnd}
END;  {Procedure WriteCharacter}

PROCEDURE NewPattern;
{ This removes the first character of the Pattern and appends the character }
{ just printed. FreqArray is zeroed in preparation for a new scan.          }
VAR
  j: INTEGER;
BEGIN {Procedure NewPattern}
  FOR j := 1 to PatLength -1 DO
    Pattern[j] := Pattern[j+1];     {Move all chars leftward}
  Pattern[PatLength] := NewChar;    {Append NewChar}
  ClearFreq
END; {Procedure NewPattern}

BEGIN {Main Program}
  TextColor(White);
  TextBackground(Blue);
  ClrScr;
  ClearFreq;
  NullArrays;
  InParams;
  FillArray;
  FirstPattern;
  InitSkip;
  REPEAT
    Match;
    WriteCharacter;
    NewPattern
  UNTIL CharCount >= OutChars;
  CLOSE(o)
END. {Main Program}