Artifact 2a8cf675886f8cdb7005d7a51f7f5b3cbb4eb34d0b0e1521ea3a85b5b1cb5ede:
- Executable file
r37/packages/defint/defintj.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 7776) [annotate] [blame] [check-ins using] [more...]
- Executable file
r38/packages/defint/defintj.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 7776) [annotate] [blame] [check-ins using]
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;