progp

Best algorithm for LZW ..C language

               NewOuter(2);
	       OK:=false;{fail after both alternatives tried}
	    end
         end
   else{Sr=1,2}
   if Adjacent(R0)
   then begin{two adjacent points - needs special care}
      if (hi.edge=hin) and (hi.cardinality=finite) then
      begin
         case Sr of
	 1:begin lo:=hi; lo.edge:=lin;
	   end;
	 2:hi.edge:=hout;
	 end;
         AtEnd;
      end
      else if (lo.edge=lin) and (lo.cardinality=finite) then 
      begin
         case Sr of
	 1:lo.edge:=lout;
	 2:begin hi:=lo; hi.edge:=hin;
	   end;
	 end;
         AtEnd;
      end else {cant be narrowed} Sr:=-1;
   end{adjacent} else
   begin
      if (lo.mantissa < 0) and (hi.mantissa > 0) then
      begin
         MidM:=0; MidE:=0;
      end else
      begin
         AlignUp(hi.exp,hi.mantissa,lo.exp,-lo.mantissa,EDiff,M0,M1,Dummy);
         MDiff:=M0+M1;
         MidM:=MDiff div 2 - M1;
	 MidE:=EDiff;
      end;
      if MidM >= 0 then NormalizeDn(MidE,MidM,Mid,Dummy)
      		   else NormalizeUp(MidE,MidM,Mid,Dummy);
      case Sr of
      1:begin lo:=Mid; lo.edge:=lin;
        end;
      2:begin hi:=Mid; hi.edge:=hout;
        end;
      end;
      
      AtEnd;
   end;{if Sr}

   AlignUp(hi.exp,hi.mantissa,lo.exp,-lo.mantissa,EDiff,M0,M1,Dummy);
   MDiff:=M0+M1;
   DCurr.RHalve[OldPC]:=GetReal(EDiff,MDiff);

 end;{with}
end;{execlinh}

procedure execmult(var Sr:State;T0,T1,T2:Int;var R0,R1,R2:Int;var OK:boolean);
var Q0,Q1,Q2:Int;

   procedure multS(S0,S1:Sreal;var U,D:Sreal);
   var M,E:integer;
       Closed,Clu,Cld:boolean;
   begin
      M:=S0.mantissa*S1.mantissa;
(*DumpS(S0);write('//');DumpS(S1);write(M);*)
      Closed:=(S0.edge in [hin,lin]) and (S1.edge in [hin,lin]);
      if ((S0.mantissa=0) and (S0.edge in [hin,lin])) or
         ((S1.mantissa=0) and (S1.edge in [hin,lin]))
      then Closed:=true; 
      Clu:=Closed; Cld:=Closed;
      if (S0.cardinality=infinite) or (S1.cardinality=infinite) then
      begin
         if M < 0 then begin D:=MinusInfS; U:=MinusInfS; end else
	 if M > 0 then begin D:=PlusInfS; U:=PlusInfS; end else
	 begin {M=0} D:=ZeroS; U:=ZeroS; end;
	 Closed:=((S0.cardinality=infinite)and(S0.edge in [hin,lin]))or
	         ((S1.cardinality=infinite)and(S1.edge in [hin,lin]));
	 Clu:=Closed;Cld:=Closed;
      end
      else{everybody finite}
      begin
         E:=S0.exp+S1.exp-Digits;
	 NormalizeUp(E,M,U,Clu);
	 NormalizeDn(E,M,D,Cld);
      end;
      if Clu then U.edge:=hin else U.edge:=hout;
      if Cld then D.edge:=lin else D.edge:=lout;      
(*writeln(E);DumpS(U);write('::');DumpS(D);writeln;*)
   end;{multS}
         
   procedure mult(Ta,Tb:Int;var R:Int);
   var U0,U1,U2,U3,U4,U5,D0,D1,D2,D3,D4,D5:Sreal;
   begin
      multS(Ta.hi,Tb.hi,U0,D0);
      multS(Ta.hi,Tb.lo,U1,D1);
      multS(Ta.lo,Tb.hi,U2,D2);
      multS(Ta.lo,Tb.lo,U3,D3);
      maxS(U0,U1,U4);maxS(U2,U3,U5);maxS(U4,U5,R.hi);
      minS(D0,D1,D4);minS(D2,D3,D5);minS(D4,D5,R.lo);
   end;
   
   procedure InvS(S:Sreal;var W:Sreal);
   var E,M,Rem:integer;
       Closed:boolean;
   begin
      Closed:= S.edge in [hin,lin];
      if (S.cardinality = infinite) then
         W:=ZeroS
      else
      if (S.mantissa = 0) then
         case S.edge of
	 hin,hout:W:=MinusInfS;
	 lin,lout:W:=PlusInfS;
	 end
      else
      begin
         M:=(Maxinf*Maxinf) div S.mantissa;
	 Rem:=(Maxinf*Maxinf) mod S.mantissa;
	 if Rem < 0 then halt;
	 E:=-S.exp;
	 case S.edge of
	 lin,lout: begin 
	     	      if (Rem > 0) and (M > 0) then 
		      begin M:=M+1;Closed:=false; 
		      end;
		      NormalizeUp(E,M,W,Closed);
	           end;
	 hin,hout: begin 
	     	      if (Rem > 0) and (M < 0) then 
		      begin M:=M-1;Closed:=false;
		      end;
		      NormalizeDn(E,M,W,Closed);
	           end;
	 end;
      end;
      
      if Closed then
         case S.edge of
         hin:W.edge:=lin;
         lin:W.edge:=hin;
         end
      else
         case S.edge of
	 hin,hout:W.edge:=lout;
	 lin,lout:W.edge:=hout;
	 end;

      
   end;{InvS}	 
   
   procedure Inv(T:Int;var X:Int;Pos:boolean);
   {1/T positive -> X}
   {If 1/T splits to two intervals then use Pos to select which to use}
   begin
      if (T.lo.mantissa < 0) and (T.hi.mantissa > 0) then
         if (T.lo.cardinality=infinite) and (T.hi.cardinality=infinite) then
	    X:=All
	 else if Pos then
	 begin InvS(T.hi,X.lo); X.hi:=PlusInfS; X.hi.edge:=hin;
	 end else 
	 begin InvS(T.lo,X.hi); X.lo:=MinusInfS; X.lo.edge:=lin;
	 end
      else
      begin InvS(T.hi,X.lo); InvS(T.lo,X.hi);
      end;
   end;{Inv}
   
   procedure divi(Ta,Tb:Int;var R:Int);
   var X:Int;
   begin
      if (Tb.lo.mantissa < 0) and (Tb.hi.mantissa > 0) then
         if (Ta.lo.mantissa < 0) and (Ta.hi.mantissa > 0) then
	 { need do nothing as R will be set to [inf,inf]}
	 else
	 
         begin
	    {if both same sign get positive side of inverse}
	    {else get negative}
	    Inv(Tb,X,(Ta.hi.mantissa <= 0) = (R.hi.mantissa <= 0));
	    mult(Ta,X,R);
	 end
      else {Tb wont give split inverse}
      begin
         Inv(Tb,X,true);
	 mult(Ta,X,R);
      end;
(*
DumpInt(Tb);writeln('//');DumpInt(X);writeln;
DumpInt(Ta);writeln('\\');DumpInt(R);writeln;
*)
   end;
   
   function Split(T:Int):boolean;
   begin
      Split:=(T.lo.mantissa<0) and (T.hi.mantissa>0) 
      	      and ((T.lo.cardinality=finite) or (T.hi.cardinality=finite));
   end;{Split}

   function Zin(T:Int):boolean;
   {check if 0 in range of interval}
   begin
      if (T.lo.mantissa > 0) then Zin:=false else
      if (T.lo.mantissa = 0) then
	 Zin:=(T.lo.edge=lin) else
      if (T.hi.mantissa < 0) then Zin:=false else
      if (T.hi.mantissa = 0) then
         Zin:=(T.hi.edge=hin) 
      else
         Zin:=true;
   end;{Zin}
   
begin{execmult}
   case Sr of
   0,10:begin
        if T2=Zero then
           if (T1=Zero) or (T0=Zero) then Sr:=-1
           else
	   if not Zin(T0) then begin R1:=Zero; Sr:=-1; end else
	   if not Zin(T1) then begin R0:=Zero; Sr:=-1; end 
	   else
           begin
              NewOuter(11); NewOuter(12);OK:=false;     
           end
        else if (Sr=0) then
        begin
	   if (T0.hi.mantissa > 0) and (T0.lo.mantissa < 0) and Split(T1) 
           then  begin NewOuter(1); NewOuter(2); OK:=false; end
           else if (T1.hi.mantissa > 0) and 
	           (T1.lo.mantissa < 0) and Split(T0) 
                then  begin NewOuter(3); NewOuter(4); OK:=false; end;
	end;
     end;
   1:begin R0.lo:=ZeroS; R0.lo.edge:=lin; T0:=R0; Sr:=10;
     end;
   2:begin R0.hi:=ZeroS; R0.hi.edge:=hout; T0:=R0; Sr:=10;
     end;
   3:begin R1.lo:=ZeroS; R1.lo.edge:=lin; T1:=R1; Sr:=10;
     end;
   4:begin R1.hi:=ZeroS; R1.hi.edge:=hout; T1:=R1; Sr:=10;
     end;
   11:begin R0:=Zero; Sr:=-1;
      end;
   12:begin R1:=Zero; Sr:=-1;
      end;
   end;
   
   if OK and (Sr<>-1) then
   begin
      mult(T0,T1,Q2); Inter(R2,Q2,R2);
      Q1:=R1; divi(T2,T0,Q1); Inter(R1,Q1,R1);
      Q0:=R0; divi(T2,T1,Q0); Inter(R0,Q0,R0);
      Sr:=10;
   end;
end;{execmult}

procedure execadd(T0,T1,T2:Int;var R0,R1,R2:Int);
  procedure addhi(S0,S1:Sreal; var S2:Sreal);
  var Closed:boolean;  Exp,M0,M1:integer;
  begin{addhi}
  with S2 do
  begin
     if (S0.cardinality=infinite)or(S1.cardinality=infinite) then
     begin  
        S2:=PlusInfS;
        Closed:=((S0.cardinality=infinite)and(S0.edge=hin))or
	        ((S1.cardinality=infinite)and(S1.edge=hin));
     end else
     begin
        Closed:=(S0.edge=hin)and(S1.edge=hin);
        AlignUp(S0.exp,S0.mantissa,S1.exp,S1.mantissa,Exp,M0,M1,Closed);
	NormalizeUp(Exp,M0+M1,S2,Closed)
     end;
     if Closed then S2.edge:=hin else S2.edge:=hout;
  end;
  end;{addhi}
  
  procedure addlo(S0,S1:Sreal; var S2:Sreal);
  var Closed:boolean;  Exp,M0,M1:integer;
  begin{addlo}
  with S2 do
  begin
     if (S0.cardinality=infinite)or(S1.cardinality=infinite) then
     begin  
        S2:=MinusInfS;
        Closed:=((S0.cardinality=infinite)and(S0.edge=lin))or
	        ((S1.cardinality=infinite)and(S1.edge=lin));
     end else
     begin
        Closed:=(S0.edge=lin)and(S1.edge=lin);
        AlignUp(S0.exp,-S0.mantissa,S1.exp,-S1.mantissa,Exp,M0,M1,Closed);
	NormalizeUp(Exp,M0+M1,S2,Closed); mantissa:=-mantissa;
     end;
     if Closed then S2.edge:=lin else S2.edge:=lout;
  end;
  end;{addlo}
  
  procedure subhi(S0,S1:Sreal; var S2:Sreal);
  var Closed:boolean;  Exp,M0,M1:integer;
  begin{subhi}
  with S2 do
  begin
     if (S0.cardinality=infinite)or(S1.cardinality=infinite) then
     begin  
        S2:=PlusInfS;
        Closed:=((S0.cardinality=infinite)and(S0.edge=hin))or
	        ((S1.cardinality=infinite)and(S1.edge=lin));
     end else
     begin
        Closed:=(S0.edge=hin)and(S1.edge=lin);
        AlignUp(S0.exp,S0.mantissa,S1.exp,-S1.mantissa,Exp,M0,M1,Closed);
	NormalizeUp(Exp,M0+M1,S2,Closed);
     end;
     if Closed then S2.edge:=hin else S2.edge:=hout;
  end;
  end;{subhi}
  
  procedure sublo(S0,S1:Sreal; var S2:Sreal);
  var Closed:boolean;  Exp,M0,M1:integer;
  begin{sublo}
  with S2 do
  begin
     if (S0.cardinality=infinite)or(S1.cardinality=infinite) then
     begin  
        S2:=MinusInfS;
        Closed:=((S0.cardinality=infinite)and(S0.edge=lin))or
	        ((S1.cardinality=infinite)and(S1.edge=hin));
     end else
     begin
        Closed:=(S0.edge=lin)and(S1.edge=hin);
        AlignUp(S0.exp,-S0.mantissa,S1.exp,S1.mantissa,Exp,M0,M1,Closed);
	NormalizeUp(Exp,M0+M1,S2,Closed);mantissa:=-mantissa;
     end;
     if Closed then S2.edge:=lin else S2.edge:=lout;
  end;
  end;{sublo}
  
begin{execadd}
   addhi(T0.hi,T1.hi,R2.hi);
   addlo(T0.lo,T1.lo,R2.lo);
   
   subhi(T2.hi,T0.lo,R1.hi);
   sublo(T2.lo,T0.hi,R1.lo);
   
   subhi(T2.hi,T1.lo,R0.hi);
   sublo(T2.lo,T1.hi,R0.lo);
end;{execadd}




procedure execintgr(var Sr:State; var R:Int);
      
  procedure floor (var R : Sreal);
  var sign , dum : boolean ;
      E, M ,t    : integer ;
  
  begin
     sign := false ;
     with R do
        begin
           if (mantissa < 0) then
              begin
                 sign := true ;
                 mantissa := - mantissa ;
              end ;
           if (exp <= 0) then
              begin
                 if sign or ((mantissa = 0) & (edge = hout)) then
                    begin
                       M := 1 ; 
                       sign := true ;
                    end 
                 else
                    M := 0 ;
                 E := Digits ;
                 NormalizeUp (E,M,R,dum) ;
                 edge := hin ;
              end 
        
           else {exp >0}
              if (exp <= Digits) then
                 begin
                    M := 1 ;
                    E := exp ;
                    while (E < Digits) do
                       begin
                          M := M * 10 ;
                          E := E + 1 ;
                       end ;
                    t := mantissa mod M ;
                    M := mantissa div M ;
                    if (sign & ((edge = hout) or(t > 0))) then
                       M := M + 1 ; 
                    if (not sign & (t = 0)) & (edge = hout) then
                       M := M - 1 ;
                    E := Digits ;
                    NormalizeUp (E,M,R,dum) ;
                    edge := hin ;
                 end 
              else
                 if ((edge = hout)&(exp = (Digits+1))) & (not sign & (mantissa = Splitman)) then
                    begin
                       mantissa := Maxman ;
                       exp := Digits ;
                       edge := hin ;
                    end ;
           if sign then
              mantissa := - mantissa ;
        end ;{with R}
  end ; {floor} 
  procedure ceiling (var R : Sreal);
  var sign , dum : boolean ;
      E, M , t   : integer ;
  
  begin
     sign := false ;
     with R do
        begin
           if (mantissa < 0) then
              begin
                 sign := true ;
                 mantissa := - mantissa ;
              end ;
           if (exp <= 0) then
              begin
                 if sign or ((mantissa = 0) & (edge = lin)) then
                    M := 0 
                 else
                    M := 1 ;
                 E := Digits ;
                 NormalizeDn (E,M,R,dum) ;
                 edge := lin ;
              end 
        
           else {exp > 0}
              if (exp <= Digits) then
                 begin
                    M := 1 ;
                    E := exp ;
                    while (E < Digits) do
                       begin
                          M := M * 10 ;
                          E := E + 1 ;
                       end ;
                    t := mantissa mod M ;
                    M := mantissa div M ;
                    if ( not sign & ((edge = lout) or(t > 0))) then
                       M := M + 1 ;
                    if (sign & (t = 0)) & (edge = lout) then
                       M := M - 1 ;
                    E := Digits ;
                    NormalizeDn (E,M,R,dum) ;
                    edge := lin ;
                 end 
              else
                 if ((edge = lout)&(exp = (Digits+1))) & (sign & (mantissa = Splitman)) then
                    begin
                       mantissa := Maxman ;
                       exp := Digits ;
                       edge := lin ;
                    end ;
           if sign then
              mantissa := - mantissa ;
        end ;{with R}
  end ; {ceiling} 
begin
   with R do
      begin
(*         writeln ('IN EXECINTGR :') ;
         writeln ;
         writeln ('HI : ', hi.mantissa , hi.exp) ;
         writeln ;
         writeln ('LO : ', lo.mantissa , lo.exp) ;
         writeln ;
*)
         if (hi.cardinality <> infinite) then
            floor (hi) ;
         if (lo.cardinality <> infinite) then
            ceiling (lo) ;
         if ((hi.mantissa = lo.mantissa) & (hi.exp = lo.exp)) then
            Sr := - 1 ;
(*         writeln ('OUT EXECINTGR :') ;
         writeln ;
         writeln ('HI : ', hi.mantissa , hi.exp) ;
         writeln ;
         writeln ('LO : ', lo.mantissa , lo.exp) ;
         writeln ;
*)
      end ;
end;{execintgr}