{%%%%%%%%% Copyright (c) 2018 Trevor Blight All rights reserved. %%%%%%%%%
#
   pascal set test program
   generate every combination of set ops for n sets, possibly with duplicates

}

program tgen(output, testFile);

label 99;

const
#if defined N
# if !defined M
#error "M == 2**N - 1 must be defined"
#endif

   n = N;    {nr sets in expression}
   m = M;    {nr elements needed in each set := 2**n - 1}

#else
   n = 4;    {nr sets in expression}
   m = 15;   {nr elements needed in each set := 2**n - 1}
#endif

type
   testSet  = set of 0..m;
   operator = (plus, minus, mul);
   nodeP    = ^node;
   node     = record
                 case isSet : boolean of
                    true   : (setNr: 1..n);
                    false  : (op :  operator;
                              ii :  integer;
                              left, right    : nodeP;)
                  end;
var
   testFile : text;
   s        : array[1..n] of testSet;
   result   : testSet;
   i,j,k    : integer;
   m1       : integer;
   root     : nodeP;
   exCount  : integer;


{evaluate a set expression}
procedure evalEx(myNode : nodeP; var result: testSet);
var
   lhs, rhs : testSet;
begin
   with myNode^ do begin
      if isSet then begin
         result := s[setNr];
      end
      else begin
         evalEx(left, lhs);
         evalEx(right, rhs);
         case op of
           plus  : result := lhs + rhs;
           minus : result := lhs - rhs;
           mul   : result := lhs * rhs;
         end; {case}
      end; {if}
   end; {with}
end; { evalex }


{print contents of a set}
procedure prs(s : testSet );
var
   first : boolean;
   i,r   : integer;
begin
   first := true;
   write(testFile, '[');
   i := 1;
   while i <= m do begin
      if i in s  then begin

         if not first then write(testFile, ', ', i:1)
         else write(testFile, 'i', i:1);
         first := false;

         r := i+1;
         while (r <= m) and (r in s) do r := r+1;
         if r = i+1 then i := r
         else if r = i+2 then begin
            i := r;
            write(testFile, ', ', r-1:1)
         end
         else if r >= i+3 then begin
            i := r;
            write(testFile, '..', r-1:1)
         end; {if}
      end {if i in s[ak]}
      else i := i+1;
   end; {while}
 write(testFile, ']');
end; { prs }


{print a set expression}
procedure prEx(myNode : nodeP);

function hasMinus(p : nodeP): boolean;
begin
   with p^ do begin
      if isSet then
         hasMinus := false
      else begin
         if op = minus then hasMinus := true
         else hasMinus := hasMinus(left);
      end; {if}
   end; {with}
end; { hasMinus }

begin
   {write(testFile, '<@', myNode, '>');}
   with myNode^ do begin
      if isSet then begin
         write(testFile, 's[', setnr:1, ']');
      end
      else begin
         case op of
           plus  : begin
               prex(left);

               write(testFile, ' + ');

               if hasMinus(right) then begin
                  write(testFile, '(');
                  prex(right);
                  write(testFile, ')');
               end
               else
                  prex(right);
             end;
           minus : begin
               prex(left);

               write(testFile, ' - ');

               if not right^.isSet and (right^.op <> mul) then begin
                  write(testFile, '(');
                  prex(right);
                  write(testFile, ')');
               end
               else
                  prex(right);
             end;
           mul   : begin
               if not ((left^.isSet) or (left^.op = mul)) then begin
                  write(testFile, '(');
                  prex(left);
                  write(testFile, ')');
               end
               else
                  prex(left);

               write(testFile, ' * ');

               if not ((right^.isSet) or (right^.op = mul)) then begin
                  write(testFile, '(');
                  prex(right);
                  write(testFile, ')');
               end
               else
                  prex(right);
             end; {mul}
         end; {case}
      end; {not isSet}
   end; {with}
end; { prEx }


{generate a node in a set expression
 the expression must use all sets a..b
 if myNode = nil, then start a new sequence,
 otherwise generate next node in sequence
 set myNode = nil when sequence finished}
procedure genEx(var myNode : nodeP; a,b :integer);
begin

   if myNode = nil then begin { --------------- start new sequence}
      if a=b then begin
         {must be a set}
         new(myNode, true);
         myNode^.isSet := true;
         myNode^.setnr := a;
         {write(testFile, ' />set ', a:1, '/ ');}
      end
      else begin
         {two or more sets, so generate an op node}
         new(myNode, true);
         with myNode^ do begin
            isSet := false;
            op := plus;
            ii := a;
            left := nil;
            right := nil;
            genex(left, a,ii);
            genex(right, ii+1,b);
         end; {with}
      end
   end
   else begin                { ---------------- bump to next in sequence}
      with myNode^ do begin
         if a = b then begin
            dispose(myNode);
            myNode := nil;
         end
         else if op <> mul then begin
            op := succ(op);
         end
         else begin
            op := plus;
            genex(right, ii+1,b);
            if right = nil then begin
               genex(left, a, ii);
               if left = nil then begin
                  if ii < b-1 then begin
                     ii := ii+1;
                     genex(left, a, ii);
                     genex(right, ii+1, b);
                  end
                  else begin
                     dispose(myNode);
                     mynode := nil;
                  end;
               end
               else genex(right, ii+1, b);
            end;
         end;
      end; {with}
   end; {if next sequence}
end; { genEx }


begin {tgen}
   m1 := 0;
   for i := 1 to n do begin
      m1 := m1*2+1;
      if ((i<n) and (m1 >= m)) or ((i=n) and (m1 <> m)) or (m1 > m) then begin
         writeln('error: constants m and n must agree, so that m+1 = 2**n-1');
         goto 99;
      end; {if}
   end; {for}

   rewrite(testFile);
   writeln(testFile, '{$d-  make code compile & run faster}');
   writeln(testFile, '{$w-  no warnings}');
   writeln(testFile, '{$z+  algebraic compare}');
   writeln(testFile, 'program test', n:1, '(output);');
   writeln(testFile, 'var s: array[1..', n:1, '] of set of 0..', m:1, ';');
   write(testFile, '    i0, ');
   for i := 1 to m-1 do write(testFile, 'i', i:1, ', ');
   writeln(testFile, 'i', m:1, ' : 0..', m:1, ';');
   writeln(testFile, 'begin');
   writeln(testFile, '  { need integers 0..', m:1,
                     ' to ensure every bit pattern in test expressions}');

   for i := 0 to m do writeln(testFile, '  i', i:1, ' := ', i:1, ';');
   writeln(testFile);

   for i := 1 to n do s[i] := [];

   for i := 1 to m do begin
      k := i;
      for j := 1 to n do begin
         if odd(k) then s[j] := s[j] + [i];
         k := k div 2;
      end; {for}
   end; {for}

{
   s[1] := [1,3,5,7,9,11,13,15];
   s[2] := [2,3,6,7,10,11,14,15];
   s[3] := [4..7, 12..15];
   s[4] := [8..15];
}

   for i := 1 to n do begin
      write(testFile, '  s[', i:1, '] := ');
      prs(s[i]);
      writeln(testFile, ';');
   end;
   writeln(testFile);

   exCount := 1;
   genEx(root, 1, n);
   while root <> nil do begin

      writeln(testFile, '  write(''test ', n:1, '-', exCount:1, ' '');' );
      write(testFile, '  if ');
      prEx(root);
      write(testFile, ' = ');
      evalEx(root, result);
      prs(result);
      writeln(testFile);
      writeln(testFile, '    then writeln('' passes'')');
      writeln(testFile, '    else  writeln('' fails'');');
      writeln(testFile);
      exCount := exCount+1;
      genex(root, 1, n);
   end; {while}

   writeln(testFile, 'end.');
99:
end. {tgen}


{%%%%%%%%%%%%%%%%%%%%%%%%%%%%% end of tgen.pas %%%%%%%%%%%%%%%%%%%%%%%%%%%%%}
