File r37/packages/defint/defintj.red artifact 2a8cf67588 part of check-in trunk

module defintj;

flag('(mylessp),'boolean);

algebraic procedure mylessp(a,b);

%
% Test the validity of the following :-
%
%      a < b*pi
%

begin scalar !*rounded;

if transform_tst neq 't then

<< on rounded;
   if a < b*pi then << off rounded; return t>>
   else << off rounded; return nil>>;
>>
else << transform_mylessp(); return t>>;
end;


symbolic procedure transform_mylessp();

  begin scalar temp,cond_test;

  temp := lispeval '(list 'lessp (list 'mod (list 'arg 'eta)) 
				(list 'times 'pi 'delta)); 
  if listp spec_cond then
	for each i in spec_cond do  if i = temp then cond_test := t;
  if cond_test neq t then spec_cond := temp . spec_cond;
end;


symbolic operator transform_mylessp;

flag('(arg_test),'boolean);

algebraic procedure arg_test(a,b);

%
% Test the validity of the following :-
%
%      a = (b + 2*k)*pi    k arbitrary integer
%

begin scalar temp;

if transform_tst neq t then
<< temp := (a - b*pi)/(2*pi); temp := symbolic (fixp temp);
   if temp = t  then return t else return nil>>
else << transform_arg_test(); return t>>;
end;

symbolic procedure transform_arg_test();

begin scalar temp,cond_test;

temp := lispeval '(list 'equal (list 'arg 'eta) (list 'times 
			(list 'plus 'delta (list 'times 2 'k)) 'pi));

if listp spec_cond then
 for each i in spec_cond do  if i = temp then cond_test := t;
if cond_test neq t then spec_cond := temp . spec_cond;
end;

symbolic operator transform_arg_test;

flag('(arg_test1),'boolean);

algebraic procedure arg_test1(a,b);

%
% Test the validity of the following :-
%
%      a = (b - 2*k)*pi    k = 0,1,....,[b/2]
%

begin scalar temp,int_test;

temp := (a - b*pi)/(-2*pi);
int_test := symbolic (fixp temp);

if int_test = t and  temp <= b/2 and temp >= 0 then return t
else return nil;
end;

flag('(arg_test2),'boolean);

algebraic procedure arg_test2(a,b);

% Test the validity of the following :-
%
%      a = b*pi     b > 0

if transform_tst neq t then
	if a/(b*pi) = 1 and b > 0 then t else nil
else 
<< transform_arg_test2(); t>>;

symbolic procedure transform_arg_test2();

begin scalar temp,cond_test;
 
temp := lispeval '(list 'equal (list 'mod (list 'arg 'eta)) 
				(list 'times 'pi 'delta)); 
if pairp spec_cond then

<< for each i in spec_cond do
   << if i = temp then cond_test := 't>>; >>;

if cond_test neq 't then spec_cond := temp . spec_cond;
end;

symbolic operator transform_arg_test2;

flag('(arg_test3),'boolean);

algebraic procedure arg_test3(a,b);

%
% Test the validity of the following :-
%
%      a = (b + 2*k)*pi     k >= 0 or k <= -(1 + b)  k an integer
%

begin scalar temp,int_test;
if transform_tst neq 't then

<< temp := (a - b*pi)/(2*pi);
   int_test := symbolic (fixp temp);

   if int_test = 't and (temp >= 0 or temp <= -(1+b)) then
       return 't else return nil>>
else << transform_arg_test3(); return 't>>;
end;

flag('(arg_test3a),'boolean);

algebraic procedure arg_test3a(a,b);

% Test the validity of the following :-
%
%      a = b*pi     b >= 0

if transform_tst neq t then

<< if a - b*pi = 0 then t else nil>>
else << transform_arg_test3(); t>>;

symbolic procedure transform_arg_test3();

begin scalar temp,cond_test;

temp := lispeval '(list 'equal (list 'arg 'eta) (list 'plus 'm
   (list 'difference 'n (list 'times (list 'quotient 1 2) 
   (list 'plus 'p 'q) 'pi))));

if listp spec_cond then
 for each i in spec_cond do if i = temp then cond_test := t;
if cond_test neq t then spec_cond := temp . spec_cond;
end;

symbolic operator transform_arg_test3;

flag('(arg_test4),'boolean);

algebraic procedure arg_test4(a,b);

% Test the validity of the following :-
%
%      (b + 2*k - 1)*pi < a < (b + 2*k)*pi     k arbitrary integer 

begin scalar l1,l2,new_l1,new_l2;

l1 := (a - b*pi)/(2*pi);
new_l1 := ceiling(l1);

if new_l1 = l1 then new_l1 := new_l1 + 1;

l2 := (a - b*pi + pi)/(2*pi);
new_l2 := floor(l2);
if new_l2 = l2 then new_l2 := new_l2 - 1;
if new_l1 = new_l2 then return 't else return nil;
end;

flag('(arg_test5),'boolean);

algebraic procedure arg_test5(a,b,xi);

% Test the validity of the following :-
%
%      (b + 2*k)*pi <= a < (b + 2*k + 1)*pi    -xi < k < 0 k an integer

begin scalar l1,l2,new_l2;

l1 := floor((a - b*pi)/(2*pi));
l2 := (a - b*pi - pi)/(2*pi);
new_l2 := ceiling(l2);
if l1 = new_l2 and l1 < 0 and -xi < l1 then return t else return nil;
end;

flag('(arg_test6),'boolean);

algebraic procedure arg_test6(a,b,xi);

% Test the validity of the following :-
%
%      a = (b + 2*k - 1)*pi     1-xi < k < 1   k an integer

begin scalar l,int_test;

l := (a - b*pi + pi)/(2*pi);
int_test := symbolic (fixp l);
if int_test = t and l < 1 and l > 1 - xi then return t else return nil;
end;

flag('(arg_test6a),'boolean);

algebraic procedure arg_test6a(a,b,xi);

% Test the validity of the following :-
%
%      a = (b + 2*k - 1)*pi     1-xi <= k <= 0

begin scalar l,int_test;

l := (a - b*pi + pi)/(2*pi);
int_test := symbolic (fixp l);
if l <= 0 and l >= 1 - xi then return t else return nil;
end;

flag('(arg_test7),'boolean);

algebraic procedure arg_test7(a,b,xi);

% Test the validity of the following :-
%
%      a = (b + 2*k)*pi     k >= 0 or k <= -xi   k an integer

begin scalar temp,int_test;

temp := (a - b*pi)/(2*pi);
int_test := symbolic (fixp temp);
if int_test=t and (temp >= 0 or temp <= -xi) then return t
else return nil;
end;

flag('(arg_test8),'boolean);

algebraic procedure arg_test8(a,b);

% Test the validity of the following :-
%
%      a = (b + 2*k - 1)*pi     k arbitrary integer

begin scalar temp,int_test;

temp := (a - b*pi + pi)/(2*pi);
int_test := symbolic (fixp temp);
if int_test = t then return t else return nil;
end;

flag('(arg_test8a),'boolean);

algebraic procedure arg_test8a(a,b,xi);

% Test the validity of the following :-
%
%      a = (b + 2*k - 1)*pi     k >= 1 k <= 1 - xi  k an integer

begin scalar temp,int_test;

temp := (a - b*pi + pi)/(2*pi);
int_test := symbolic (fixp temp);
if int_test = t and (temp >= 1 or temp <= 1 - xi) then return t
else return nil
end;

flag('(arg_test9),'boolean);

algebraic procedure arg_test9(a,b);

% Test the validity of the following :-
%
%      (b + 2*k - 2)*pi < a < (b + 2*k)*pi     k arbitrary

begin scalar l1,l2,new_l1,new_l2;

l1 := (a - b*pi)/(2*pi);
new_l1 := ceiling(l1);
if new_l1 = l1 then new_l1 := new_l1 + 1;
l2 := (a - b*pi + 2*pi)/(2*pi);
new_l2 := floor(l2);
if new_l2 = l2 then new_l2 := new_l2 - 1;
if new_l1 = new_l2 then return t else return nil;
end;

flag('(arg_test9a),'boolean);

algebraic procedure arg_test9a(a,b);

% Test the validity of the following :-
%
%      (b + 2*k - 2)*pi < a < (b + 2*k)*pi     1 - b <= k <= 0
%							k arbitrary

begin scalar l1,l2,new_l1,new_l2;

l1 := (a - b*pi)/(2*pi);
new_l1 := ceiling(l1);
if new_l1 = l1 then new_l1 := new_l1 + 1;
l2 := (a - b*pi + 2*pi)/(2*pi);
new_l2 := floor(l2);
if new_l2 = l2 then new_l2 := new_l2 - 1;
if new_l1 = new_l2 and (1 - b <= new_l1 or new_l1 <= 0) then 
    return t else return nil;
end;

symbolic procedure transform_test2(n1,n2);

begin scalar lst,temp,cond_test;

if transform_tst neq t then return t else 
<< if n1 then temp := lispeval cdr assoc(n1,transform_lst) . temp;
   if n2 then temp := lispeval cdr assoc(n2,transform_lst) . temp;

   temp := 'and . temp;
   for each j in spec_cond do  if j = temp then cond_test := t;
   if cond_test neq t then spec_cond := temp . spec_cond; 
   return nil;
>>;
end;

symbolic operator transform_test2;

endmodule;
end;