[Back to TEXTFILE SWAG index] [Back to Main SWAG index] [Original]

    UNIT seq;

     (*  DESCRIPTION :
           Treatment of sequential files :
      * assign,open,read,selection and count of records,close in ONE Procedure
      * 3 control breaks possible ,either a data base field or a variable of
        type string[30]. Use conversion functions if necessary
      * user-defined selection function
      * heading procedure optional
      * 11 aggregate functions like totals,subtotals,first,last,maximum,minimum

         RELEASE     :  1.0
         DATE        :  17/11/91
         AUTHOR      :  Fernand LEMOINE
                        rue du Collge 34
                        B-6200 CHATELET
                        BELGIQUE
         All code granted to the public domain
         Questions and comments are welcome
         REQUIREMENT :  Turbo Pascal 5.0 or later : procedural parameters
         Compatible with Borland Pascal protected mode
      *)

    INTERFACE
    USES dos;
    CONST
      all = MaxLongInt;

    TYPE
      Boolfunc = FUNCTION(VAR buffer) : Boolean;
      Proc = PROCEDURE;
      PProc = PROCEDURE(VAR buffer);
      Str30 = String[30];

    VAR
      level : Byte;

    (* empty function or procedures for type Boolfunc *)
    FUNCTION NoSelect(VAR buffer) : Boolean;
    (* empty function or procedures for type PProc *)
    PROCEDURE NoPProc(VAR buffer);
    (* empty function or procedures for type Proc *)
    PROCEDURE NoProc;

    (* Number of records selected *)
    FUNCTION DCount : LongInt;

    (* Necessary in Detail_proc to prepare use of aggregate functions .
    increment novar for each numeric variable chosen for computation ,max=10 *)
    PROCEDURE DCalc(novar : Byte; nombre : Real);

    (* Here begins  aggregate functions *)
    (* Subtotal for the variable with the number novar *)
    FUNCTION DSum(novar : Byte) : Real;
    (* Grand total for the variable with the number novar *)
    FUNCTION DTotal(novar : Byte) : Real;
    (* Minimum     for the variable with the number novar *)
    FUNCTION DMin(novar : Byte) : Real;
    (* Maximum     for the variable with the number novar *)
    FUNCTION DMax(novar : Byte) : Real;
    (* The same as Dcount except for null value           *)
    FUNCTION DNCount(novar : Byte) : Real;
    (* The same as DMin   except for null value           *)
    FUNCTION DNMin(novar : Byte) : Real;
    (* Average     for the variable with the number novar *)
    FUNCTION DAvg(novar : Byte) : Real;
    (* The same as DAvg   except for null value           *)
    FUNCTION DNAvg(novar : Byte) : Real;
    (* Variance    for the variable with the number novar
      opt = 'P' = population
            'S' = sample    *)
    FUNCTION DVar(novar : Byte; opt : char) : Real;
    (* Standard deviation for the variable with the number novar
    opt = 'P' = population
            'S' = sample    *)
    FUNCTION DStd(novar : Byte; opt : char) : Real;
    (* The previous value of the variable with the number novar *)
    FUNCTION DOld(novar : Byte) : Str30;
    (* Here ends  aggregate functions *)

    (* Set control break in Break_Proc  : always of type string[30]  *)
    PROCEDURE Control(contr1, contr2, contr3 : Str30);

    (* Only detail lines (Detail_Proc) and total lines (Final_Proc).
      No control break
      User-defined selection function : boolean type
      Scope = all  : all the records read  otherwise a number of records
      reclen       : size of the record computed by the function sizeof
                                                                            *)

    PROCEDURE ReadFile(Name_File : PathStr; scope : LongInt;
                      Select_Func : Boolfunc; Detail_Proc : PProc;
                      Final_Proc : Proc; RecLen : Word);

    (*
    *  Detail lines (Detail_Proc).
    *  1/2/3 subtotal lines and total lines (Total_Proc ). The same procedure
        with the variable level varying from 3 - minor break -  to 0 - grand
        total
    *  Control break (Break_Proc)
    *  User-defined selection function (Select_Func) : boolean type
    *  Scope = all  : all the records read  otherwise a number of records
    *  reclen       : size of the record computed by the function sizeof
    *)

    PROCEDURE ReadBreakFile(Name_File : PathStr;  Break_Proc : PProc;
                           Select_Func : Boolfunc; Detail_Proc : PProc;
                           Heading_Proc, Total_Proc : Proc; RecLen : Word);

    IMPLEMENTATION
    CONST
     maxlevel = 3;
     maxvar = 10;
     maxcalc = 8;
     maxbuffer = 500;
    VAR
     FileSeq : FILE;
     RR : Word;
     Tab_Count : ARRAY[0..maxlevel] OF LongInt;
     Tab_Control, Old_Control : ARRAY[1..maxlevel] OF Str30;
     Old_Total : ARRAY[1..maxvar] OF Real;

     buffer : ARRAY[1..maxbuffer] OF Byte;
     Tab_Calc : ARRAY[1..maxvar, 1..maxcalc, 0..maxlevel] OF Real;
     Endfile  : Boolean;
     nbrlevel : Byte;

     FUNCTION NoSelect(VAR buffer) : Boolean;
     BEGIN
       NoSelect := True;
     END;

     PROCEDURE NoPProc(VAR buffer);
     BEGIN
     END;

     PROCEDURE NoProc;
     BEGIN
     END;

     FUNCTION DCount : LongInt;
     VAR i : Byte;
     BEGIN
       DCount := Tab_Count[level];
     END;

     PROCEDURE DCalc(novar : Byte; nombre : Real);
     VAR
       i : Byte;
     BEGIN
       FOR i := 0 TO nbrlevel DO
       BEGIN
         Tab_Calc[novar, 1, i] := Tab_Calc[novar, 1, i] + nombre;
         IF Tab_Calc[novar, 2, i] < nombre THEN
           Tab_Calc[novar, 2, i] := nombre;
         IF Tab_Count[i] = 1 THEN Tab_Calc[novar, 3, i] := nombre
         ELSE IF Tab_Calc[novar, 3, i] > nombre THEN
           Tab_Calc[novar, 3, i] := nombre;
         IF nombre <> 0 THEN
           Tab_Calc[novar, 4, i] := Tab_Calc[novar, 4, i] + 1;
         IF (Tab_Count[i] = 1) AND (nombre <> 0) THEN
           Tab_Calc[novar, 5, i] := nombre;
         IF Tab_Calc[novar, 5, i] = 0 THEN
           Tab_Calc[novar, 5, i] := nombre;
         IF (Tab_Calc[novar, 5, i] > nombre) AND (nombre <> 0) THEN
           Tab_Calc[novar, 5, i] := nombre;
         Tab_Calc[novar, 6, i] := Tab_Calc[novar, 6, i] + Sqr(nombre);
       END;
     END;

     PROCEDURE DCompute(novar : Byte; nombre : Real);
     BEGIN
       Old_Total[novar] := Old_Total[novar] + nombre;
     END;

     FUNCTION DTotal(novar : Byte) : Real;
     BEGIN
       IF Old_Total[novar] <> 0 THEN
         DTotal := Old_Total[novar]
       ELSE
         DTotal := Tab_Calc[novar, 1, 0];
     END;

     FUNCTION DSum(novar : Byte) : Real;
     BEGIN
       DSum := Tab_Calc[novar, 1, level];
     END;

     FUNCTION DOld(novar : Byte) : Str30;
     BEGIN
       DOld := Old_Control[novar];
     END;

     FUNCTION DMin(novar : Byte) : Real;
     BEGIN
       DMin := Tab_Calc[novar, 3, level];
     END;

     FUNCTION DMax(novar : Byte) : Real;
     BEGIN
       DMax := Tab_Calc[novar, 2, level];
     END;

     FUNCTION DNCount(novar : Byte) : Real;
     BEGIN
       DNCount := Tab_Calc[novar, 4, level];
     END;

     FUNCTION DNMin(novar : Byte) : Real;
     BEGIN
       DNMin := Tab_Calc[novar, 5, level];
     END;

     FUNCTION DAvg(novar : Byte) : Real;
     BEGIN
       IF DCount <> 0 THEN
         DAvg := Tab_Calc[novar, 1, level] / DCount
       ELSE
         DAvg := 0;
     END;

     FUNCTION DNAvg(novar : Byte) : Real;
     BEGIN
       IF DNCount(novar) <> 0 THEN
         DNAvg := Tab_Calc[novar, 1, level] / DNCount(novar)
       ELSE
         DNAvg := 0;
     END;

     FUNCTION DVar(novar : Byte; opt : char) : Real;
     VAR
       Int : Real;
     BEGIN
       Int := Sqr(Tab_Calc[novar, 1, level] / DCount);
       if upcase(opt)  = 'P' then
         DVar := (Tab_Calc[novar, 6, level] - Int) / DCount
       else
         DVar := (Tab_Calc[novar, 6, level] - Int) / (DCount - 1);
     END;

     FUNCTION DStd(novar : Byte; opt : char) : Real;
     VAR
       Int : Real;
     BEGIN
       Int := Sqr(Tab_Calc[novar, 1, level] / DCount);
       if upcase(opt)  = 'P' then
         DStd := Sqrt((Tab_Calc[novar, 6, level] - Int) / DCount)
       else
         DStd := Sqrt((Tab_Calc[novar, 6, level] - Int) / (DCount - 1));
      END;

     (* ---------------------------------------------------------------------- *)

      PROCEDURE ReadFile(Name_File : PathStr; scope : LongInt;
                         Select_Func : Boolfunc; Detail_Proc : PProc;
                         Final_Proc : Proc; RecLen : Word);

        PROCEDURE Debut(Name_File : PathStr);
        VAR i, j, k : Byte;
        BEGIN
          level := 0; nbrlevel := 0;
          Assign(FileSeq, Name_File);
          Reset(FileSeq, RecLen);
          Tab_Count[level] := 0;
          FOR i := 1 TO maxvar DO
            FOR j := 1 TO maxcalc DO
              FOR k := 0 TO maxlevel DO
                Tab_Calc[i, j, k] := 0;
          BlockRead(FileSeq, buffer, 1, RR);
          Endfile := EoF(FileSeq);

        END;

        PROCEDURE rec (Select_Func : Boolfunc; Detail_Proc : PProc);
          PROCEDURE Trait(Detail_Proc : PProc);
          BEGIN
            Tab_Count[level] := Tab_Count[level] + 1;
            Detail_Proc(buffer);
          END;

          PROCEDURE fin_rec ;
          BEGIN
            IF EoF(FileSeq) THEN Endfile := True
            ELSE BlockRead(FileSeq, buffer, 1, RR);
          END;

        BEGIN
          IF Select_Func(buffer) THEN
            Trait(Detail_Proc);
          fin_rec ;
        END;

        PROCEDURE fin(Final_Proc : Proc);
        BEGIN
          Final_Proc;
          Close(FileSeq);
        END;

      BEGIN
        Debut(Name_File);
        WHILE (NOT Endfile) AND (DCount < scope)
        DO rec (Select_Func, Detail_Proc);
        fin(Final_Proc);
      END;
      (* ------------------------------------------------------------------*)
      PROCEDURE Control(contr1, contr2, contr3 : Str30);
      BEGIN
        IF contr1 <> '' THEN
        BEGIN
          Tab_Control[1] := contr1; nbrlevel := 1;
        END;
        IF contr2 <> '' THEN
        BEGIN
          Tab_Control[2] := contr2; nbrlevel := 2;
        END;
        IF contr3 <> '' THEN
        BEGIN
          Tab_Control[3] := contr3; nbrlevel := 3;
        END;
      END;

      PROCEDURE Transfert_Old;
      VAR i : Byte;
      BEGIN
        FOR i := 1 TO nbrlevel DO
          Old_Control[i] := Tab_Control[i];
      END;

      PROCEDURE Trans_Old;
      VAR i : Byte;
      BEGIN
        Old_Control[level] := Tab_Control[level];
      END;

      PROCEDURE Init_Tab(level : Byte);
      VAR
        i, j, k : Byte;
      BEGIN
        FOR i := 1 TO maxvar DO
          FOR j := 1 TO maxcalc DO
            FOR k := level TO nbrlevel DO
              Tab_Calc[i, j, k] := 0;
        FOR i := level TO nbrlevel DO Tab_Count[i] := 0;
      END;

      PROCEDURE ReadBreakFile(Name_File : PathStr; Break_Proc : PProc;
                              Select_Func : Boolfunc; Detail_Proc : PProc;
                              Heading_Proc, Total_Proc : Proc; RecLen : Word);
      VAR i : Byte;

        PROCEDURE Debut(Name_File : PathStr; Break_Proc : PProc);
        VAR i : Byte;
        BEGIN
          level := 0; nbrlevel := 0;
          Assign(FileSeq, Name_File);
          Reset(FileSeq, RecLen);
          BlockRead(FileSeq, buffer, 1, RR);
          Endfile := EoF(FileSeq);
          Break_Proc(buffer);
          Transfert_Old;
        END;

        PROCEDURE Detail(Select_Func : Boolfunc; Detail_Proc, Break_Proc : PProc;
                         VAR Endfile : Boolean);
        VAR i : Byte;
        BEGIN

          IF Select_Func(buffer) THEN
          BEGIN
            FOR i := 0 TO nbrlevel DO
              Tab_Count[i] := Tab_Count[i] + 1;
            Detail_Proc(buffer);
            Transfert_Old;
          END;
          IF EoF(FileSeq) THEN Endfile := True
          ELSE BlockRead(FileSeq, buffer, 1, RR);
          Break_Proc(buffer);
        END;

        PROCEDURE Fin(Total_Proc : Proc);
        BEGIN
          level := 0;
          Total_Proc;
          Close(FileSeq);
        END;

        PROCEDURE Debut_Niv(PLevel : Byte; Heading_Proc : Proc);
        BEGIN
          level := PLevel;
          Heading_Proc;
          Init_Tab(PLevel);
        END;

        PROCEDURE Fin_Niv(PLevel : Byte; Total_Proc : Proc);
        BEGIN
          level := PLevel;
          Total_Proc;
          Trans_Old;
        END;

        PROCEDURE Niv3(Heading_Proc : Proc; Select_Func : Boolfunc;
                       Detail_Proc, Break_Proc : PProc;
                       Total_Proc : Proc; VAR Endfile : Boolean);
        BEGIN
          Debut_Niv(3, Heading_Proc);

          WHILE (Tab_Control[1] = Old_Control[1]) AND
          (Tab_Control[2] = Old_Control[2]) AND
          (Tab_Control[3] = Old_Control[3]) AND
          (NOT Endfile) DO
            Detail(Select_Func, Detail_Proc, Break_Proc, Endfile);
          Fin_Niv(3, Total_Proc);
        END;

        PROCEDURE Niv2(Heading_Proc : Proc; Select_Func : Boolfunc;
                       Detail_Proc, Break_Proc : PProc;
                       Total_Proc : Proc; VAR Endfile : Boolean);
        BEGIN
          Debut_Niv(2, Heading_Proc);

          WHILE (Tab_Control[1] = Old_Control[1]) AND
          (Tab_Control[2] = Old_Control[2]) AND (NOT Endfile) DO
          BEGIN
            IF nbrlevel = 2 THEN Detail(Select_Func, Detail_Proc, Break_Proc, Endfile)
            ELSE Niv3(Heading_Proc, Select_Func, Detail_Proc,
                      Break_Proc, Total_Proc, Endfile);
          END;
          Fin_Niv(2, Total_Proc);
        END;

        PROCEDURE Niv1(Heading_Proc : Proc; Select_Func : Boolfunc;
                       Detail_Proc, Break_Proc : PProc;
                       Total_Proc : Proc; VAR Endfile : Boolean);
        BEGIN
          Debut_Niv(1, Heading_Proc);
          WHILE (Tab_Control[1] = Old_Control[1]) AND (NOT Endfile) DO
          BEGIN
            IF nbrlevel = 1 THEN Detail(Select_Func, Detail_Proc, Break_Proc, Endfile)
            ELSE Niv2(Heading_Proc, Select_Func, Detail_Proc,
                      Break_Proc, Total_Proc, Endfile);
          END;
          Fin_Niv(1, Total_Proc);
        END;

      BEGIN
        FOR i := 0 TO maxlevel DO Tab_Count[i] := 0;
        FOR i := 1 TO maxvar DO Old_Total[i] := 0;
        Init_Tab(0);

        FOR i := 0 TO maxlevel DO Tab_Count[i] := 0;
        Debut(Name_File, Break_Proc);
        WHILE NOT Endfile DO Niv1(Heading_Proc, Select_Func,
                                  Detail_Proc, Break_Proc, Total_Proc, Endfile);
        Fin(Total_Proc);
      END;

    END.

    { -------------------------   DEMO PROGRAM ----------------- }

    program demoseq;
    uses crt,seq,editform,opstring;
    const
     c_pay = 1;

    type                               (* cf file demo.dat  *)
            Rec = record
            name  : string[5];
            state : string[2];
            zip   : longint;
            pay   : real;
                 end;

        {$F+}        (* --->  necessary   or use far directive   *)

      Function Select (var Buffer): boolean;    (* can be modified by user *)
      begin
      Select := true;
      end;

      Procedure Control_Proc(var Buffer);
      begin
      with Rec(buffer) do
        Control(state,long2str(zip),'');
      end;

      Procedure Detail_Proc(var Buffer);
      begin
      with Rec(buffer) do
       begin
        DCalc(c_pay,pay);
        writeln(name,'   ',state,'  ',zip,'  ',RealForm('####.##',pay));
       end;
      end;

      Procedure Total_Proc;
      begin
      case level of
      0: begin write('Final  '); end;
      1: begin write('State subtotal  '); end;
      2: begin write('Zip subtotal  ');   end;
      end;

      writeln('Count : ',DCount,' STATE: ',Dold(1),' ZIP: ',Dold(2));
      writeln('Max  : ',RealForm('####.##',Dmax(c_pay)),
              ' Min : ',RealForm('####.##',Dmin(c_pay)),
              ' Avg : ',RealForm('#####.##',DAvg(c_pay)),
              ' Sum : ',RealForm('#####.##',DSum(c_pay)),
              ' Total : ',RealForm('#####.##',DTotal(c_pay)));
      if level = 2 then writeln;
      end;

       {$F-}

        begin
       Clrscr;
       Writeln('Demo seq unit , file : demo.dat '); writeln;
       ReadBreakFile('Demo.dat',Control_proc,NoSelect,
          Detail_Proc, Noproc,Total_Proc,SizeOf(Rec));
       delay (2500);
        end.

[Back to TEXTFILE SWAG index] [Back to Main SWAG index] [Original]