excalc.red 3.5 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117
  1. module excalc; % header for EXCALC, a differential geometry package.
  2. % Author: Eberhard Schruefer
  3. %*********************************************************************;
  4. %*********************************************************************;
  5. % Differential Geometry Package ;
  6. %*********************************************************************;
  7. % This version runs in REDUCE 3.6 ;
  8. %*********************************************************************;
  9. % Version: 2.5 ;
  10. % E. Schruefer 09/20/93, 05/29/95 ;
  11. %*********************************************************************;
  12. % Last version 2 release. ;
  13. %*********************************************************************;
  14. % Eberhard Schruefer ;
  15. % German National Research Center for Information Technology (GMD) ;
  16. % Institut SCAI.ALG ;
  17. % Schloss Birlinghoven ;
  18. % 53754 St. Augustin ;
  19. % Germany ;
  20. %*********************************************************************;
  21. % E-mail: schruefer@gmd.de FAX: +49 2241 14 2618 ;
  22. %*********************************************************************;
  23. create!-package('(excalc exintro exaux degform exdf forder frames hodge
  24. idexf indices indsymm indxprin innerprd liedf
  25. lievalfm partdf partitsf vardf vecanlys exlists
  26. wedge),
  27. '(contrib excalc));
  28. %************ patches ***************;
  29. % Meaning of ^ and # changed. !!!! BE AWARE OF THIS "!!!
  30. remprop('!^,'newnam);
  31. % plus and difference changed because we are dealing with non-
  32. % homogenous terms
  33. deflist('
  34. ((difference getrtypeor)
  35. (plus getrtypeor)
  36. ),'rtypefn);
  37. fluid '(depl!*); % !*ignoreeol
  38. global '(bndeq!* detm!*);
  39. share bndeq!*,detm!*;
  40. global '(lftshft!*);
  41. % !*ignoreeol := t; % To allow for Excalc's special constructs.
  42. % Smacros used by more than one EXCALC module:
  43. smacro procedure ldpf u;
  44. %selector for leading standard form in patitioned sf;
  45. caar u;
  46. smacro procedure tpsf u;
  47. %selector for leading term in partitioned sf;
  48. car u;
  49. smacro procedure !*k2pf u;
  50. u .* (1 ./ 1) .+ nil;
  51. smacro procedure negpf u;
  52. multpfsq(u,(-1) ./ 1);
  53. smacro procedure lowerind u;
  54. list('minus,u);
  55. smacro procedure lwf u;
  56. %selector for leading factor in wedge.
  57. car u;
  58. smacro procedure rwf u;
  59. %selector for the rest of factors in wedge.
  60. cdr u;
  61. smacro procedure lftshftp u;
  62. smemqlp(lftshft!*,u);
  63. smacro procedure get!-impfun!-args u;
  64. % Get dependencies of id u.
  65. cdr assoc(u,depl!*);
  66. smacro procedure get!*fdeg u;
  67. (if x then car x else nil) where x = get(u,'fdegree);
  68. smacro procedure get!*ifdeg u;
  69. (if x then cdr x else nil)
  70. where x = assoc(length cdr u,get(car u,'ifdegree));
  71. %%% This macro from fmprint.red needed for independent compilation.
  72. symbolic macro procedure fancy!-level u;
  73. % unwind-protect for special output functions.
  74. {'prog,'(pos fl w),
  75. '(setq pos fancy!-pos!*),
  76. '(setq fl fancy!-line!*),
  77. {'setq,'w,cadr u},
  78. '(cond ((eq w 'failed)
  79. (setq fancy!-line!* fl)
  80. (setq fancy!-pos!* pos))),
  81. '(return w)};
  82. endmodule;
  83. end;