Jason Aller Floppy Collection/180.img/TURBOD.ZIP/TPDEMO.PAS

Pascal/Delphi Source File | 1989-05-02 | 5KB | 228 lines

{$N+,E+}

{  File: TPDEMO.PAS

   Turbo Pascal Demonstration program to show off Turbo Debugger

   Reads words from standard input, analyzes letter and word frequency.
   Uses linked list to store commandline parameters on heap.

   Uses the following data types:

     Boolean,
     Char, Byte,
     Integer, Word,
     LongInt,
     Extended (8087 type, links in emulator)
     String,
     Array,
     Record,
     Set,
     Pointer
}
program TPDemo;

const
  BufSize    = 128;    { length of line buffer }
  MaxWordLen =  10;    { maximum word length allowed }

type
  BufferStr = String[BufSize];

  LInfoRec = record
    Count : Word;               { number of occurrences of this letter }
    FirstLetter : Word;         { number of times as first letter of a }
  end;


var
  NumLines, NumWords : Word;                     { counters }
  NumLetters : LongInt;
  WordLenTable : array [1..MaxWordLen] of Word;  { info for each word }
  LetterTable : array['A'..'Z'] of LInfoRec;     { info for each letter }
  Buffer : BufferStr;

procedure ShowResults;

procedure ShowLetterInfo(FromLet, ToLet : Char);
{ Dump letter information }
var
  ch : Char;
begin
  Writeln;
  Write('Letter:     ');
  for ch := FromLet to ToLet do                   { column titles }
    Write(ch:5);
  Writeln;

  Write('Frequency:  ');
  for ch := FromLet to ToLet do                 { letter count }
    Write(LetterTable[ch].Count:5);
  Writeln;
  Write('Word starts:');
  for ch := FromLet to ToLet do                 { first letter count }
    Write(LetterTable[ch].FirstLetter:5);
  Writeln;
end; { ShowLetterInfo }

var
  i : Integer;
  AvgWords : Extended;

begin { ShowResults }
  if NumLines <> 0 then
    AvgWords := NumWords / NumLines
  else
    AvgWords := 0;
  Writeln;
  Writeln(NumLetters, ' char(s) in ',
          NumWords, ' word(s) in ',
          NumLines, ' line(s)');
  Writeln('Average of ', AvgWords:0:2, ' words per line');
  Writeln;

  { Dump word count }
  Write('Word length:');
  for i := 1 to MaxWordLen do
    Write(i:4);
  Writeln;

  Write('Frequency:  ');
  for i := 1 to MaxWordLen do
    Write(WordLenTable[i]:4);
  Writeln;

  { Dump letter counts }
  ShowLetterInfo('A', 'M');
  ShowLetterInfo('N', 'Z');
end; { ShowResults }

procedure Init;
begin
  NumLines := 0; NumWords := 0; NumLetters := 0;
  FillChar(LetterTable, SizeOf(LetterTable), 0);
  FillChar(WordLenTable, SizeOf(WordLenTable), 0);
  Writeln('Enter a string to process, an empty string quits.');
end; { Init }

procedure ProcessLine(var S : BufferStr);

function IsLetter(ch : Char) : Boolean;
begin
  IsLetter := UpCase(ch) in ['A'..'Z'];
end; { IsLetter }

var
  i : Integer;
  WordLen : Word;

begin { ProcessLine }
  Inc(NumLines);
  i := 1;
  while i <= Length(S) do
  begin
    { Skip non-letters }
    while (i <= Length(S)) and not IsLetter(S[i]) do
      Inc(i);

    { Find end of word, bump letter & word counters }
    WordLen := 0;
    while (i <= Length(S)) and IsLetter(S[i]) do
    begin
      Inc(NumLetters);
      Inc(LetterTable[UpCase(S[i])].Count);
      if WordLen = 0 then                    { bump counter }
        Inc(LetterTable[UpCase(S[i])].FirstLetter);
      Inc(i);
      Inc(WordLen);
    end;

    { Bump word count info }
    if WordLen > 0 then
    begin
      Inc(NumWords);
      if WordLen <= MaxWordLen then
        Inc(WordLenTable[WordLen]);
    end;
  end; { while }
end; { ProcessLine }

function GetLine : BufferStr;
var
  S : BufferStr;
begin
  Write('String: ');
  Readln(S);
  GetLine := S;
end;

procedure ParmsOnHeap;
{ Builds a linked list of commandline parameters on the heap.
  Note that the zero'th parameter, ParamStr(0), returns the
  Exec name of the program on Dos 3.xx only.
}
type
  ParmRecPtr = ^ParmRec;
  ParmRec = record
    Parm : ^String;
    Next : ParmRecPtr;
  end;
var
  Head, Tail, Temp : ParmRecPtr;
  i : Integer;
  s : String;
begin
  Head := nil;
  for i := 0 to ParamCount do
  begin
    { Get next commandline parameter }
    s := ParamStr(i);
    if MaxAvail < SizeOf(ParmRec) + Length(s) + 1 then  { room on heap? }
    begin
      Writeln('Heap full, procedure aborting...');
      Exit;
    end;

    { Add to linked list }
    New(Temp);                         { another Parm record }
    with Temp^ do
    begin
      GetMem(Parm, Length(s) + 1);     { string + length byte }
      Parm^ := s;
      Next := nil;
    end;
    if Head = nil then                 { initialize list pointer }
      Head := Temp
    else
      Tail^.Next := Temp;              { add to end }
    Tail := Temp;                      { update tail pointer }
  end; { for }

  { Dump list }
  Writeln;
  with Head^ do
    if Parm^ <> '' then
      Writeln('Program name: ', Parm^);
  Write('Command line parameters: ');
  Tail := Head^.Next;
  while Tail <> nil do
    with Tail^ do
    begin
      Write(Parm^, ' ');
      Tail := Next;
    end;
  Writeln;
end; { ParmsOnHeap }

begin { program }
  Init;
  Buffer := GetLine;
  while Buffer <> '' do
  begin
    ProcessLine(Buffer);
    Buffer := GetLine;
  end;
  ShowResults;
  ParmsOnHeap;
end.