Annotation of OpenXM/src/kan96xx/Doc/Old/int-d.sm1, Revision 1.1
1.1 ! maekawa 1: % int-d.sm1
! 2: %%
! 3: %%%
! 4:
! 5: (int-d.sm1: Aug 28, 1995.) message
! 6: ( New macros "integral-d" and "get0-d" are added.) message
! 7: ( Type in 3 0 demo.int-d to see a demo.) message
! 8:
! 9:
! 10: %% Usage, putUsages and showKeywords
! 11: %% The data should be automatically generated from int-d.txt
! 12: %% int-d.sm1 = int-d.sm + int-d.txt
! 13: [(integral-d)
! 14: [(ff n integral-d ffi )
! 15: ( ff is a list of operators,)
! 16: ( n is a number to specify the degree of approximation,)
! 17: ( ffi is the result list that will be the input to the "groebner")
! 18: ( to get the "sum" of the module ff.)
! 19: (Example: )
! 20: $ [(m) ring_of_difference_operators (Em) elimination_order 0] define_ring $
! 21: $ [((m-e+1) Em - (m+1)). ( (e+1) E - (m-e)).] 3 integral-d /ffi set$
! 22: ( [ffi] groebner 0 get get0-d ::)
! 23: ( )
! 24: (See also, groebner (option countdown) and get0-d.)
! 25: ]] putUsages
! 26:
! 27: [(get0-d)
! 28: [(ff get0 result)
! 29: ( ff is a list of operators. The operators in ff that does not)
! 30: ( contain "e" is stored in result.)
! 31: ( Note that "h" and "E" are set to 1.)
! 32: (See also integral-d)
! 33: (Example: )
! 34: $ [ (x h + E). (e+x).] get0-d :: $
! 35: ( [ x + 1 ] )
! 36: ]] putUsages
! 37:
! 38: %% You can use it as a template.
! 39: /demo.int-d {
! 40: /ccc set
! 41: /nnn set
! 42: %%%% Define the ring
! 43: [ (n) ring_of_difference_operators (En) elimination_order 0] define_ring
! 44:
! 45: %%%% Give the equations here.
! 46: %%%% E e = e E + E and "e" and "E" will be eliminated.
! 47: [ ((n-e+1)^2*En - (n+e+1)^2).
! 48: ((e+1)^4*E - (-1)^2*(n-e)^2*(n+e+1)^2). ] /ff set
! 49:
! 50: %%% Let's compute
! 51: ff nnn integral-d /ffi set
! 52: %% Give the lower and the upper bound of the degree.
! 53: %% /from-degree 0 def /to-degree 5 def
! 54: %%[ffi [(from) from-degree (to) to-degree]]
! 55: [ffi [(countDown) ccc]]
! 56: groebner 0 get get0-d /ans set
! 57: (Answer is in ans. ans = ) message
! 58: ans ::
! 59: (This is Apery's reccurence formula.) message
! 60: } def
! 61:
! 62: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 63: %%%%%%%%%%%% Don't touch below %%%%%%%%%%%%%%%%%%%%%%%%
! 64: %%%%%%%%%%%%%% e-vectors, integral-d, get0-d %%%%%%%%%%%%%%
! 65: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 66: %% (Try [f1 f2 ...] nnn integral-d /ff set) message
! 67: %% ([ff] groebner 0 get get0-d) message
! 68: %% number e-vectors
! 69: /e-vectors {
! 70: /arg1 set
! 71: [/ans] pushVariables
! 72: [
! 73: /ans [(e).] def
! 74: 1 1 << arg1 1 sub >>
! 75: { pop
! 76: /ans
! 77: [(e).] ans {(e). mul} map join
! 78: def
! 79: } for
! 80: /arg1 ans def
! 81: ] pop
! 82: popVariables
! 83: arg1
! 84: } def
! 85:
! 86:
! 87: %% [f1 f2 ...] nnn integral-d
! 88: /integral-d {
! 89: /arg2 set
! 90: /arg1 set
! 91: [/nnn /gens /m /ans /fff] pushVariables
! 92: [
! 93: /gens arg1 def
! 94: /nnn arg2 def
! 95: /m gens length def
! 96: /ans [ ] def
! 97: 0 1 << m 1 sub >> {
! 98: gens 2 1 roll get /fff set
! 99: %%fff ::
! 100: /ans
! 101: ans [fff] join nnn e-vectors {fff mul} map join
! 102: def
! 103: %%ans ::
! 104: } for
! 105: /ans
! 106: ans nnn e-vectors {(E-1). 2 1 roll mul} map join
! 107: def
! 108: /ans ans {[[(h). (1).]] replace} map def
! 109: /ans ans {homogenize} map def
! 110: /arg1 ans def
! 111: ] pop
! 112: popVariables
! 113: arg1
! 114: } def
! 115:
! 116: % [g1 g2 g3 ...] get0-d
! 117: /get0-d {
! 118: /arg1 set
! 119: [/gb /degs /ans /n /ff] pushVariables
! 120: [
! 121: /gb arg1 def
! 122: /degs gb {(e). degree} map def
! 123: /ans [
! 124: 0 1 << gb length 1 sub >> {
! 125: /n set
! 126: << degs n get >> 0 eq
! 127: { gb n get [[(E). (1).] [(h). (1).]] replace /ff set
! 128: ff (0). eq
! 129: { }
! 130: { ff } ifelse
! 131: }
! 132: { } ifelse
! 133: } for
! 134: ] def
! 135: /arg1 ans def
! 136: ] pop
! 137: popVariables
! 138: arg1
! 139: } def
! 140:
! 141: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 142: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 143:
! 144:
! 145:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>