Wednesday, May 2, 2012

Turbo Pascal 6 circa 1992

Found this old sample program written in Turbo Pascal 6. My recollection is that it would process a file received from a factory in Italy and print a report. Notice the first line of code  for declaring the amount of memory? Umm…those are BYTES in the first line, as in minimum of 8K, maximum of 384K

{$M 8192, 0, 384000}
{************************************************************
  Program:  ITALYSUM
  Purpose:  Print a list of styles with a summary by style
  Author :  John H. Watson III
  Compile:  Borland Turbo Pascal 6.0

  Changed:  11/09/92 John Watson
            Use extended syntax on WriteLn to format numeric
              output right-adjusted. (e.g. "PairsNum:5"
              instead of just "PairsNum").

  Changed:  11/15/92 John Watson
            Added style description to detail & summary print.
            Removed hardcoding of field lengths in ProcessData
              and replaced with constants.
            Replaced hardcoded page titles with constants.
            Change test of result of collection from "> 0"
              to "<> -1".  Zero is a valid location in the
              collection and IndexOf will return a -1 if the
              search doesn't find anything.
 ************************************************************}
PROGRAM ITALYSUM;

USES Dos, Printer, Objects, StdPrint;

CONST
  CopyrightText = 'Copyright (c) 1992 by John H. Watson III';
  DetailTitle  : String = 'Italy Data File Listing - Detail';
  SummaryTitle : String = 'Italy Data File Listing - Summary';

VAR
  CopyrightStr : String[40];

CONST
  MaxLines = 60;
  Pagesize = 66;

{********************************************************************
  Define Objects
 ********************************************************************}

TYPE
  pSummary = ^TSummary;
  TSummary = OBJECT(TObject)
    Pairs : Integer;
    Style : String[10];
    SDesc : String[30];
    CONSTRUCTOR Init(iPairs: Integer; iStyle: String; iSDesc: String);
    PROCEDURE Print;
    PROCEDURE Accumulate(iPairs: Integer);
  END;

  PStyleSummary = ^TStyleSummary;
  TStyleSummary = OBJECT(TSortedCollection)
    FUNCTION KeyOf(Item: Pointer): Pointer; VIRTUAL;
    FUNCTION Compare(Key1, Key2: Pointer): Integer; VIRTUAL;
  END;

{********************************************************************
  Global Variables
 ********************************************************************}

VAR
  ErrorCode   : Integer;
  F           : File;
  GrandTotal  : Longint;
  Path        : PathStr;
  SummaryList : pStyleSummary;  { define global instance }

VAR
  FTime       : Longint;        { file time }
  FDT         : DateTime;       { DOS' date/time record structure }

{********************************************************************
  TSummary Object Methods
 ********************************************************************}

CONSTRUCTOR TSummary.Init(iPairs: Integer; iStyle: String; iSDesc: String);
BEGIN
  TObject.Init;         { call ancestor's init first }
  Pairs := iPairs;
  Style := iStyle;
  SDesc := iSDesc;
END;

PROCEDURE TSummary.Accumulate(iPairs: Integer);
BEGIN
  Pairs := Pairs + iPairs;
END;

PROCEDURE TSummary.Print;
BEGIN
  WRITELN(LST,Pairs:5, ' ', Style, ' ', SDesc);
END;

{********************************************************************
  TStyleSummary Methods
 ********************************************************************}

    { Define the key field for the collection.  Since KeyOf expects
      a pointer and Style is a simple string we must use the "@"
      (address of) operator to generate the address (pointer).  If
      Style was a pString, this would not be necessary. }

FUNCTION TStyleSummary.KeyOf(Item: Pointer): Pointer;
BEGIN
  KeyOf := @pSummary(Item)^.Style;
END;

FUNCTION TStyleSummary.Compare(Key1, Key2: Pointer): Integer;
BEGIN
  IF pString(Key1)^ = pString(Key2)^ THEN
    Compare := 0
  ELSE IF pString(Key1)^ < pString(Key2)^ THEN
         Compare := -1
       ELSE
         Compare := +1;
END;

{********************************************************************
  Miscellaneous Procedures and Functions
 ********************************************************************}

FUNCTION OpenFile(VAR F:File; iName:PathStr): BOOLEAN;
BEGIN
    ASSIGN(F, iName);
    {$I-} RESET(F, 1); {$I+}
    OpenFile := IOResult = 0;
END {Open};

PROCEDURE Initialize;
VAR
  Dir  : DirStr;
  Name : NameStr;
  Extn : ExtStr;
BEGIN
  CopyrightStr := CopyrightText;
  IF ParamCount = 0
    THEN Path := 'ITALYDTA'
    ELSE Path := ParamStr(1);
  Path := FExpand(Path);  { expand into full path string }
  FSplit(Path, Dir, Name, Extn);  { split into components }
  IF (Name = '') OR NOT OpenFile(F, Path) THEN BEGIN
    WRITELN('ERROR:  File not found (', Name, ').');
    HALT(1);
    END;
  GetFTime(F, FTime);
  UnpackTime(FTime, FDT);
  GrandTotal := 0;
  LineCount := PageSize;
  SummaryList := New(pStyleSummary, Init(200, 50)); { create collection }
END {Initialize};

PROCEDURE Terminate;
BEGIN
  Close(F);
  Close(LST);
  Dispose(SummaryList, Done);
END;

PROCEDURE PrintHeading(iTitle: String);
BEGIN
  IF NOT FirstPrint THEN EjectPage;
  VerticalTab(1);
  WriteLn(LST, iTitle);
  VerticalTab(1);
  IF FirstPrint THEN BEGIN
     WriteLn(LST, 'File: ', Path);
     WriteLn(LST, 'Date: ',FDT.Month,'/',FDT.Day,'/',FDT.Year,
                '  Time: ',FDT.Hour,':',FDT.Min);
     VerticalTab(1);
     END;
  IF FirstPrint
     THEN LineCount := 6
     ELSE LineCount := LineCount + 3;
  FirstPrint := False;
END;

    { Use ForEach iterator to display Summary information }

PROCEDURE PrintSummary;
    PROCEDURE PrintSummaryObject(p : pSummary); FAR;
    BEGIN
      IF LineCount >= MaxLines THEN BEGIN
         PrintHeading(SummaryTitle);
         WriteLn(LST, 'Pairs Style      Description');
         WriteLn(LST, '----- ---------- -----------');
         VerticalTab(1);
         LineCount := LineCount + 3;
         END;
      p^.Print;   { Call object's print method }
      GrandTotal := GrandTotal + p^.Pairs;
      LineCount := LineCount + 1;
    END;
BEGIN
  LineCount := MaxLines; { force initial headings to print }
  SummaryList^.ForEach(@PrintSummaryObject);
  VerticalTab(1);
  WriteLn(LST, GrandTotal:5, ' Grand Total');
  EjectPage;
END;

  { This procedure will read enough bytes to fill a record buffer.
    Since the record length exceeds 255 bytes, we cannot use ReadLn to
    read a record.  To overcome this, the file is processed as an untyped
    file and BlockRead is used to fill the buffer. }

PROCEDURE ProcessData;
CONST
  PairsPos  : Integer = 578;  PairsLen : Integer = 5;
  OrdNoPos  : Integer = 2;    OrdNoLen : Integer = 9;
  RegNoPos  : Integer = 131;  RegNoLen : Integer = 6;
  SDescPos  : Integer = 588;  SDescLen : Integer = 30;
  StylePos  : Integer = 313;  StyleLen : Integer = 10;
VAR
  Buffer    : ARRAY[1..905] OF Char; { includes two extra bytes for CR/LF }
  BytesRead : Word;
  Location  : Integer;  { location in collection of existing summary object }
  NewObj, OldObj : pSummary;
  PairsNum  : Integer;
  PairsStr  : String[5];
  OrdNo     : String[9];
  RegNo     : String[6];
  Style     : String[10];
  SDesc     : String[30];

BEGIN
  BlockRead(F, Buffer, SizeOf(Buffer), BytesRead);
  WHILE (NOT EOF(F)) DO BEGIN

      { Extract individual fields from record buffer }
    Move(Buffer[StylePos], Style[1], StyleLen);
    Style[0] := Char(StyleLen);             { force the proper string size }
    Move(Buffer[SDescPos], SDesc[1], SDescLen);
    SDesc[0] := Char(SDescLen);
    Move(Buffer[OrdNoPos], OrdNo[1], OrdNoLen);
    OrdNo[0] := Char(OrdNoLen);
    Move(Buffer[RegNoPos], RegNo[1], RegNoLen);
    RegNo[0] := Char(RegNoLen);
    Move(Buffer[PairsPos], PairsStr[1], PairsLen);
    PairsStr[0] := Char(PairsLen);
    Val(PairsStr, PairsNum, ErrorCode);  { convert string to numeric }

      { Print detail line }
    IF LineCount >= MaxLines THEN BEGIN
       PrintHeading(DetailTitle);
       WriteLn(LST, 'Order No  Reg No Pairs Style      Description');
       WriteLn(LST, '--------- ------ ----- ---------- -----------');
       VerticalTab(1);
       LineCount := LineCount + 3;
       END;
    WRITELN(LST, OrdNo, ' ', RegNo, ' ', PairsNum:5, ' ', Style, ' ', SDesc);
    LineCount := LineCount + 1;

      { Now create a new instance of a summary object with these values }
    NewObj := New(pSummary, Init(PairsNum, Style, SDesc));

      { Search the collection to see if it already exists }
    Location := SummaryList^.IndexOf(NewObj);
    IF Location <> -1 THEN BEGIN    { If found, accumulate pairs }
       OldObj := SummaryList^.AT(Location); { get ptr to obj @ location }
       OldObj^.Accumulate(PairsNum); { call that obj's accumulate method }
       END
    ELSE SummaryList^.Insert(NewObj); { else add to collection }

    BlockRead(F, Buffer, SizeOf(Buffer), BytesRead);
    END;

END {ProcessData};

BEGIN
  Initialize;
  ProcessData;
  PrintSummary;
  Terminate;
END.

No comments:

Post a Comment