dint.red 3.1 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394
  1. module dint; % Definite integration support.
  2. % Author: Anthony C. Hearn.
  3. fluid '(!*precise);
  4. symbolic procedure simpdint u;
  5. begin scalar low,upp,fn,var,x,y;
  6. if length u neq 4
  7. then rerror(int,2,"Improper number of arguments to INT");
  8. load!-package 'defint;
  9. fn := car u;
  10. var := cadr u;
  11. low := caddr u;
  12. upp := cadddr u;
  13. low := reval low;
  14. upp := reval upp;
  15. if low = upp then return nil ./ 1
  16. else if null getd 'new_defint then nil
  17. else if upp = 'infinity
  18. then if low = 0
  19. then if not smemql('(infinity unknown),
  20. x := defint!* {fn,var})
  21. then return simp!* x else nil
  22. else if low = '(minus infinity)
  23. then return mkinfint(fn,var)
  24. else if freeof(var,low)
  25. then if not smemql('(infinity unknown),
  26. x := defint!* {fn,var})
  27. and not smemql('(infinity unknown),
  28. y := indefint!* {fn,var,low})
  29. then return simp!* {'difference,x,y} else nil
  30. else nil
  31. else if upp = '(minus infinity) or low = 'infinity
  32. then return negsq simpdint {fn,var,upp,low}
  33. else if low = '(minus infinity)
  34. then return
  35. simpdint{prepsq simp{'sub,{'equal,var,{'minus,var}},fn},
  36. var,{'minus,upp},'infinity}
  37. else if low = 0
  38. then if freeof(var,upp)
  39. and not smemql('(infinity unknown),
  40. x := indefint!* {fn,var,upp})
  41. then return simp!* x else nil
  42. else if freeof(var,upp) and freeof(var,low)
  43. and not smemq('(infinity unknown),
  44. x := indefint!* {fn,var,upp})
  45. and not smemql('(infinity unknown),
  46. y := indefint!* {fn,var,low})
  47. then return simp!* {'difference,x,y};
  48. return mkdint(fn,var,low,upp)
  49. end;
  50. symbolic procedure defint!* u;
  51. (if errorp x then 'unknown else car x)
  52. where x = errorset2 {'new_defint,mkquote u};
  53. symbolic procedure indefint!* u;
  54. (if errorp x or eqcar(car x,'indefint2) then 'unknown else car x)
  55. where x = errorset2 {'new_indefint,mkquote u};
  56. symbolic procedure mkdint(fn,var,low,upp);
  57. % This could be used as an entry point to other dint procedures.
  58. % Should we handle infinity, - infinity differently?
  59. begin scalar x,!*precise;
  60. if getd 'defint0
  61. and not((x := defint0 {fn,var,low,upp}) eq 'failed)
  62. then return simp x
  63. else if not smemq('infinity,low) and not smemq('infinity,upp)
  64. then <<x := prepsq!* simpint {fn,var};
  65. if not eqcar(x,'int)
  66. then return simp!* {'difference,
  67. subeval {{'equal,var,upp},x},
  68. subeval {{'equal,var,low},x}}>>;
  69. return mksq({'int,fn,var,low,upp},1)
  70. end;
  71. symbolic procedure mkinfint(fn,var);
  72. begin scalar x,y;
  73. if getd 'defint0
  74. and not((x := defint0 {fn,var,'(minus infinity),'infinity})
  75. eq 'failed) then return simp x;
  76. x := simpdint {fn,var,0,'infinity};
  77. y := simpdint {fn,var,'(minus infinity),0};
  78. if kernp x and eqcar(mvar numr x,'int)
  79. and kernp y and eqcar(mvar numr y,'int)
  80. then return mkdint(fn,var,'(minus infinity),'infinity)
  81. else return addsq(x,y)
  82. end;
  83. endmodule;
  84. end;