(*                              Set Partitioning Problems

        INPUT   : The associated datafile is "SetbackDatafile".

                          1st number (M) represents number of elements
                                in the base set.
                          2nd number (N) represents # of subsets in the
                                family P.
                          3rd number (INF), represents maximal integer
                                number available in the system that is used.
(SEE "IMPORTANT" BELOW)   4th set of numbers SETS[1..N], represents
                                array of N records representing the family
                                of sets P. Each record consists of two fields
                                One is designated to hold the cardinality of
                                a set and the other is a linked list of
                                the set elements.
                          5th set of numbers SETLISTS[1..M], represents
                                array of M records representing index sets
                                {Fi}. Each record i consists of tw fields;
                                one holds the cardinality of Fi and the
                                other is a linked list of indices of sets
                                which contain element i.
                          6th set of numbers C[1..N], represents array
                                of the costs.

!!!    IMPORTANT	:  THE elements of lists SETS[1..N].LIST(4th set of numbers
			   are in DECREASING order.   OTHERWISE, The WHOLE PROGRAM
			   WILL NOT WORK!!!!



        OUTPUT  : Outputs are
                          1. NONFEASIBLE,  Boolean variable which has
                                value TRUE if no feasible solution is
                                found.  FALSE otherwise.
                          2. COVER[1..N],  array that define the
                                reduced problem.
                          3. COST, cost of the partial solution consisting
                                of those sets J for which COVER[J] = 1.
                          4. COUNT, number of forward moves performed
                                by the procedure.

        Algorithm       : The SETPARTBACKTRACK procedure finds the
                                optimal solution to the set-partitioning
                                problem.  The procedure is an implementation
                                of Implicit Enumeration Algorithm for
                                the SPP problem.
                          The computer representation of the problem is
                                the same as in the SETPARTRED procedure,
                                except that SETPARTBACKTRACK does not
                                use the constraint matrix A explicitly
                                and it assumes that elements in SETS[J}.LIST
                                and in SETLISTS[I].LIST are ordered for
                                every J and I.


                                                                        *)



program Enumeration_Alg (input,output,SetbackDatafile,SetbackOutfile);

const   maxelement = 50;
        maxsubset = 50;
        M1 = maxelement + 1;
        N1 = maxsubset + 1;

type    CHARFILE = file of char;
        ARRM = array [1..maxelement] of integer;
        ARRM1 = array [1..M1] of integer;
        ARRMB = array [1..maxelement] of boolean;
        ARRN = array [1..maxsubset] of integer;
        ARRN1 = array [1..N1] of integer;
        ARRNR = array [1..maxsubset] of real;
        ARRMM = array [1..maxelement, 1..maxelement] of integer;
        ARRN1R = array [1..N1] of real;
        POINTEL = ^ELEMENTLIST;
        ELEMENTLIST = record
                        ELEM : integer;
                        NEXT : POINTEL;
                      end;
        SETDATA = record
                    CARD : integer;
                    LIST : POINTEL;
                  end;
        INDEXSET = array [1..maxelement] of SETDATA;
        SETFAMILY = array [1..maxsubset] of SETDATA;

        records = record
                    key : real;
                    {       other : fields;  }
                    order_num : integer;
                  end;
        afile = array [0..50] of records;

var     M,N,INF : integer;
        SETS : SETFAMILY;
        SETLISTS : INDEXSET;
        C : ARRN;
        NONFEASIBLE : boolean;
        COST,COUNT : integer;
  	COVER : ARRN;
 	SetbackDatafile : CHARFILE;
	SetbackOutfile  : CHARFILE;
	Nextint : integer;




    n : integer;
    tree : afile;
    r : afile;
    count : integer;



procedure Infile (var M : integer;
		  var N : integer;
		  var INF : integer;
		  var SETS : SETFAMILY;
		  var SETLISTS : INDEXSET;
		  var C : ARRN;
		  var Nextint : integer);

var row : integer;
    newelement : POINTEL;

begin
  reset (SetbackDatafile);
  readln (SetbackDatafile,Nextint);
  M := Nextint;
  readln (SetbackDatafile,Nextint);
  N := Nextint;
  readln (SetbackDatafile,Nextint);
  INF := Nextint;
  for row := 1 to N do
  begin
    read (SetbackDatafile,Nextint);
    SETS[row].CARD := Nextint;
    while not eoln (SetbackDatafile) do
    begin
      new (newelement);
      read (SetbackDatafile,Nextint);
      newelement^.ELEM := Nextint;
      newelement^.NEXT := SETS[row].LIST;
      SETS[row].LIST := newelement;
    end; (* while loop *)
    readln (SetbackDatafile);
  end;
  for row := 1 to M do
  begin
    read(SetbackDatafile,Nextint);
    SETLISTS[row].CARD := Nextint;
    while not eoln(SetbackDatafile) do
    begin
      new (newelement);
      read (SetbackDatafile,Nextint);
      newelement^.ELEM := Nextint;
      newelement^.NEXT := SETLISTS[row].LIST;
      SETLISTS[row].LIST := newelement;
    end; (* while *)
    readln (SetbackDatafile);
  end;
  for row := 1to N do
  begin
    read (SetbackDatafile,Nextint);
    C[row] := Nextint;
  end;
  readln (SetbackDatafile);
end;



procedure SETPARTBACKTRACK(
        M,N,INF   :integer;
   var SETS       :SETFAMILY;
   var SETLISTS   :INDEXSET;
   var C          :ARRN;
   var NONFEASIBLE:boolean;
   var COST,COUNT :integer;
   var COVER      :ARRN);

   var CURRENTCOST,G,H,I,J,JK,K,L,MCOV,MIN,N1,OPTK:integer;
       CC,MINR                                    :real;
       B,MOVE,TOTALBC                             :boolean;
       P                                          :POINTEL;
       BLOCKSIZE,ELCOV,MINCBLOCK                  :ARRM;
       BLOCK                                      :ARRM1;
       BCBOOL                                     :ARRMB;
       COV,COV1,OPTCOV                            :ARRN;
       ORDER,INVORD                               :ARRN1;
       RATIO                                      :ARRNR;
       MINRATIO                                   :ARRN1R;
       BLOCKCOVER                                 :ARRMM;

   procedure SAVESOLUTION;
      { THIS procedure SAVES A CURRENT SOLUTIION AS THE BEST
        CURRENT SOLUTION. }
      var H:integer;
   begin
      NONFEASIBLE:=false;  COST:=CURRENTCOST;
      for H:=1 to K do OPTCOV[H]:=COV[H];
      OPTK:=K
   end;  { SAVE SOLUTION }

   function FEASIBLE(I:integer):boolean;
      { FEASIBLE IS true if CURRENTLY UNCOVERED ELEMENTS CAN BE
        COVERED BY SOME UNUSED SETS IN BLOCKS I, I+1, ..., M and
        false OTHERWISE. }
      var G:integer;
          B:boolean;
   begin
      if TOTALBC or BCBOOL[I] then FEASIBLE:=true
      else begin
         G:=I;
         repeat
            B:=(ELCOV[G] = 0) and (BLOCKCOVER[G,I] = 0);
            G:=G+1
         until  B or (G > M);
         FEASIBLE:= not B
      end  { else TOTALBC or ... }
   end;  { FEASIBLE }

   function FIT(J:integer):boolean;
      { FIT IS true if SET J DOES NOT OVERCOVER ELEMENTS COVERED
        BY A CURRENT PARTIAL SOLUTION, and false OTHERWISE. }
      var B:boolean;
          P:POINTEL;
   begin
      if SETS[J].CARD > MCOV then FIT:=false
      else begin
         B:=true;  P:=SETS[J].LIST;
         while (P <> nil) and B do begin
            B:=ELCOV[P^.ELEM] = 0;
            P:=P^.NEXT
         end;
         FIT:=B
      end  { else SETS[J].CARD > MCOV }
   end;  { FIT }

   procedure BACKWARDMOVE(var MOVE:boolean);
      { procedure MOVES THE SEARCH TO THE FIRST FROM THE end BLOCK
        WHICH STILL CONTAINS SOME UNUSED SETS. varIABLE MOVE BECOMES
        true if SUCH A BLOCK EXISTS and false OTHERWISE. }
      var P:POINTEL;

   begin
      if K = 0 then MOVE:=false
      else begin
         repeat  { until (K = 0) or MOVE }
            J:=COV[K];  I:=COV1[K];
            K:=K-1;
            P:=SETS[J].LIST;
            while P <> nil do begin
               ELCOV[P^.ELEM]:=0;
               P:=P^.NEXT;
            end;
            CURRENTCOST:=CURRENTCOST-C[J];
            MCOV:=MCOV+SETS[J].CARD;
            MOVE:=INVORD[J] < BLOCK[I+1]-1
         until (K = 0) or MOVE;
         if MOVE then begin
            JK:=INVORD[J]+1;  J:=ORDER[JK]
         end
      end  { else: K <> 0 }
   end;  { BACKWARD MOVE }

   procedure forWARDMOVE;
      { procedure ADDS SET J TO A CURRENT PARTIAL COVER. if ALL
        ELEMENTS ARE COVERED, procedure SAVESOLUTION UPDATES
        THE BEST CURRENT SOLUTION and BACKWARDMOVE IS CALLED.
        OTHERWISE, SEARCH for A FEASIBLE SET IS CONTINUED. }
      var P:POINTEL;
   begin
      COUNT:=COUNT+1;  K:=K+1;
      COV[K]:=J;  COV1[K]:=I;
      P:=SETS[J].LIST;
      while (P <> nil)   do begin
         ELCOV[P^.ELEM]:=1;  P:=P^.NEXT;
      end;
      CURRENTCOST:=CURRENTCOST+C[J];
      MCOV:=MCOV-SETS[J].CARD;
      if MCOV = 0 then begin             { ALL ELEMENTS ARE COVERED }
         SAVESOLUTION;       { A NEW BETTER SOLUTION HAS BEEN FOUND }
         BACKWARDMOVE(MOVE)
      end  { if MCOV = 0 }
      else begin
         while ELCOV[I] = 1 do I:=I+1;
         if not FEASIBLE(I) then BACKWARDMOVE(MOVE)
         else begin
            JK:=BLOCK[I];  J:=ORDER[JK];
            if (CURRENTCOST+MINCBLOCK[I] >= COST) or
               (trunc(CURRENTCOST+MCOV*MINRATIO[JK]) >= COST) then
               BACKWARDMOVE(MOVE)
            else MOVE:=true
         end;  { else: FEASIBLE(I) }
      end  { else: MCOV <> 0 }
   end;  { forWARD MOVE }


(*********************************************************************)
(*   My own modified heapsort algorithm  *)

procedure  adjust (var tree:afile;
                   i, n : integer);
{adjust the binary tree with root i to satisfy the heap property.
 The left and right subtrees of i, i.e. with root 2i and 2i+1
 already satisfy the heap property. No node has index greater
 than n. }

var j : integer;
    k : real;
    r : records;
    done : boolean;

begin
  done := false;
  r := tree[i];
  k := tree[i].key;
  j := 2*i;
  while ((j <= n) and not done) do
  begin { first find max of left and right child}
    if j < n then if tree[j].key < tree[j+1].key then j := j+1;
    {compare max.child with k. If k is max, then done.}
    if k >= tree[j].key
    then
      done := true
    else
    begin
      tree[j div 2] := tree[j]; {move jth record up the tree}
      j := 2*j;
    end;
  end;
  tree[j div 2] := r;
end; {of adjust}


procedure Heap(var r: afile;
                 n : integer);
{the file r=(r[1],...,r[n]) is sorted into nondescreasing order on
 the field key}

var i : integer;
    t : records;

begin
   for i := (n div 2) downto 1 do {conver r into a heap}
      adjust(r,i,n);
   for i := (n-1) downto 1 do {sort r}
   begin
      t := r[i+1]; {interchange r1 and rj+1}
      r[i+1] := r[1];
      r[1] := t;
      adjust(r,1,i); { recreate heap}
   end;
end; {of heapsort}


procedure heapsort(K:integer;
                   J:integer;
                   var RATIO:ARRNR;
                   var ORDER:ARRN1);


var temprecord : afile;
    i : integer;

begin
  for i := 1 to K do
  begin
    temprecord[i].key := RATIO[J+i-1];
    temprecord[i].order_num := ORDER[J+i-1];
  end;
  Heap(temprecord,K);
  for i := J to J+K-1 do  begin
     RATIO[i] := temprecord[i-J+1].key;
     ORDER[i] := temprecord[i-J+1].order_num;
  end;
end;



(***********************************************************************)


begin                                                   { MAIN BODY }
   N1:=N+1;                                         { ORDERING SETS }
   for I:=1 to M do BLOCKSIZE[I]:=0;
   for J:=1 to N do begin
      RATIO[J]:=C[J]/SETS[J].CARD;
      L:=SETS[J].LIST^.ELEM;
      BLOCKSIZE[L]:=BLOCKSIZE[L]+1;
   end;  { for J }
   L:=1;
   for I:=1 to M do begin
      BLOCK[I]:=L;  L:=L+BLOCKSIZE[I]
   end;
   BLOCK[M+1]:=L;
   for I:=1 to M do ELCOV[I]:=BLOCK[I];
   for J:=1 to N do begin
      L:=SETS[J].LIST^.ELEM;  K:=ELCOV[L];
      ORDER[K]:=J;  ELCOV[L]:=K+1
   end;
   ORDER[N1]:=N1;  INVORD[N1]:=N1;

(*
writeln('**************************************');
for I := 1 to M do
write (BLOCKSIZE[I]:3);
writeln;
for I := 1 to M+1 do
write (BLOCK[I]:3);
writeln;
for I := 1 to N do
write(RATIO[I]:5:2);
writeln;
writeln('**************************************');
writeln;
writeln;
*)


   J:=1;  I:=1;
   while J < N do begin
      K:=BLOCKSIZE[I];
      if K > 1 then heapsort(K,J,RATIO,ORDER);
      I:=I+1;  J:=BLOCK[I]
   end;  { while J < N }
   for J:=1 to N do INVORD[ORDER[J]]:=J;
   for I:=1 to M do begin { AUXILIARY VARIABLES for DOMINANCE TESTS }
      MIN:=INF;
      for J:=BLOCK[I] to BLOCK[I+1]-1 do begin
         K:=C[ORDER[J]];
         if K < MIN then MIN:=K
      end;
      MINCBLOCK[I]:=MIN
   end;  { for I }
   MINR:=INF;  MINRATIO[N1]:=MINR;
   for J:=N downto 1 do begin
      CC:=RATIO[ORDER[J]];
      if CC < MINR then MINR:=CC;
      MINRATIO[J]:=MINR
   end;  { for J }
   TOTALBC:=BLOCK[M] <= N;                { AUXILIARY VARIABLES for }
   BCBOOL[M]:=TOTALBC;                          { FEASIBILITY TESTS }
   if TOTALBC then BLOCKCOVER[M,M]:=1
   else BLOCKCOVER[M,M]:=0;
   L:=M;  B:=TOTALBC;
   for I:=M-1 downto 1 do
      if BLOCKSIZE[I] = 0 then begin
         B:=false;  BCBOOL[I]:=false;
         TOTALBC:=false;  BLOCKCOVER[I,I]:=0;
         for H:=I+1 to M do BLOCKCOVER[H,I]:=BLOCKCOVER[H,L];
         L:=I
      end  { if BLOCKSIZE[I] = 0 }
      else
         if B then begin
            BCBOOL[I]:=true;  BLOCKCOVER[I,L]:=1
         end
         else begin
            BLOCKCOVER[I,I]:=1;
            K:=1;
            for H:=I+1 to M do begin
               G:=BLOCKCOVER[H,L];
               BLOCKCOVER[H,I]:=G;
               K:=K+G
            end;  { for H }
            N1:=M-I+1;  J:=BLOCK[I];
            while (J < BLOCK[I+1]) and (K < N1) do begin
               H:=ORDER[J];
               P:=SETS[H].LIST^.NEXT;
               while (P <> nil) and (K < N1) do begin
                  G:=P^.ELEM;
                  if BLOCKCOVER[G,I] = 0 then begin
                     BLOCKCOVER[G,I]:=1; K:=K+1
                  end;
                  P:=P^.NEXT
               end;  { while (P <> nil) ... }
               J:=J+1
            end;  { while (J < BLOCK[I+1]) ... }
            B:=K = N1;  BCBOOL[I]:=B;  L:=I
         end;  { else: NOT B, for I }       { end OF INITIALIZATION }
   COUNT:=0;  NONFEASIBLE:=true;
   for L:=1 to M do ELCOV[L]:=0;
   if FEASIBLE(1) then begin
      I:=1;  K:=0;  JK:=1;
      J:=ORDER[1];
      COST:=INF;  CURRENTCOST:=0;
      MCOV:=M;               { MCOV  - NUMBER OF UNCOVERED ELEMENTS }
      forWARDMOVE;
      while MOVE do begin    { MOVE=true if SEARCH IS NOT EXHAUSTED }
         repeat  { until B or NOT MOVE }      { and false OTHERWISE }
            repeat
               B:=false;
               while (JK < BLOCK[I+1]) and (not B ) do begin
                  B:=(CURRENTCOST+C[J] < COST) and FIT(J);
                  if not B then begin
                     JK:=JK+1;  J:=ORDER[JK]
                  end
               end;  { while (JK < BLOCK[I+1]) ... }
               if JK = BLOCK[I+1] then BACKWARDMOVE(MOVE)
            until B or not MOVE;
            if B then
               B:=CURRENTCOST+C[J]+(MCOV-SETS[J].CARD)
                  *MINRATIO[JK+1] < COST;
            if MOVE and not B then begin
               JK:=JK+1;  J:=ORDER[JK]
            end
         until B or not MOVE;
         if B then forWARDMOVE
      end;  { while MOVE }
      if not NONFEASIBLE then begin
         for J:=1 to N do COVER[J]:=0;
         for J:=1 to OPTK do COVER[OPTCOV[J]]:=1
      end
   end  { if FEASIBLE(1) }
end;  { SETPARTBACKTRACK }



procedure Outfile (NONFEASIBLE : boolean;
		   COST : integer;
		   COUNT : integer;
		   COVER : ARRN);

var loop : integer;

begin
  rewrite(SetbackOutfile);
  writeln (SetbackOutfile,'The solution is ');
  writeln (SetbackOutfile,'NONFEASIBLE = ',NONFEASIBLE);
  writeln (SetbackOutfile,'COST = ',COST);
  writeln (SetbackOutfile,'COUNT = ',COUNT);
  write (SetbackOutfile,'COVER = ');
  for loop := 1 to N do
    write (SetbackOutfile,COVER[loop]:3);
  writeln;
end;


begin (* main *)
  Infile (M,N,INF,SETS,SETLISTS,C,Nextint);
  SETPARTBACKTRACK(M,N,INF,SETS,SETLISTS,C,NONFEASIBLE,COST,COUNT,COVER);
  Outfile(NONFEASIBLE,COST,COUNT,COVER);
end.