Annotation of OpenXM/src/kan96xx/Doc/Old/cv2.sm1, Revision 1.1.1.1
1.1 maekawa 1: (../Kan/module1.sm1) run
2:
3: ( ) message
4: (cv2.sm1 11/15, 1994. This program computes characteristic varieties) message
5: ( and multiplicities.) message
6: (The program automatically generate the file t.t for a work-file.) message
7: (Revised: 4/2, 1995.) message
8: (Type in charv and multi to see a demo.) message
9:
10: %%%%%%%%%%%%%%%%%% How to use %%%%%%%%%%%%%
11: % 0. Make sure that you installed old sm1 of Version 1.x (x >= 940217) with
12: % the name "sm0". It is used to compute Hilbert function.
13: % 1. Set your differential equation in Part A
14: % 2. Start sm1 and read this file.
15: % 3. Type in
16: % charv
17: % to get the characteristic variety.
18: % 4. Next set the localization rule by the command
19: % /locRule locRule1 def
20: % 5. And type in
21: % multi
22: % 6. to get the multiplicty.
23: % 7. goto 4
24: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
25: % example
26: % sm1>charv ;
27: % sm1>/locRule locRule1 def multi ;
28: % sm1>/locRule locRule2 def multi ;
29: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
30:
31:
32: %%%%%%%%%%Change here %%% set your data %%%%%%%%%%%%%%%%%%%%%%%%%%
33: %%% [Part A]
34: %%% Define variables
35: (x,y) /vars set
36: (a,b,b',c) /parameters set % Don't use t,e,H,h,E. They are reserved.
37: %%% Set your equations
38: [ ( Dx*(x*Dx+y*Dy+c-1)-(x*Dx+y*Dy+a)*(x*Dx+b) )
39: ( Dy*(x*Dx+y*Dy+c-1)-(x*Dx+y*Dy+a)*(y*Dy+b') )
40: ] /ff0 set
41: %%% If you can't get the result for general parameters, specialize
42: %%% the parameters.
43: [[$a$ $a$] [$b$ $b$]] /prule set
44: %%% [Part B] localization rules
45: %%% localization at the point x=2 y=3 Dx=0, Dy=0 on T^*_M M.
46: [[(x) (x+2)] [(y) (y+3)]] /locRule1 set %example 2
47: %%% localization at the point x=2 Dy=3 Dx=0, y=0 on T^*_V M where V={(x,0)}.
48: [[(x) (x+2)] [(Dy) (Dy+3)]] /locRule2 set %exmaple 2'
49: /locRule locRule1 def
50: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
51:
52:
53: %%%%%%%%%%%%%% You don't need read the below.
54: /charv {
55: [ [vars to_records pop parameters to_records pop] { (,) 1 cat_n } map cat
56: ring_of_differential_operators
57: dvars elimination_order 0] swap01 define_ring
58: ff0 { . } map /ff set
59: ff { [[$h$. $1$.]] replace } map /ff set
60: ff { prule { {. } map } map replace } map /ff set
61: /ff ff homogenize def
62: [ff] groebner /ans set
63: ans 0 get {[[$h$. $1$.]] replace} map /gg set
64: (Now, you get the characteristic variety) message
65: gg characteristic print ( ) message ( ) message
66: gg characteristic 0 get {(string) data_conversion} map
67: /gg0 set
68: } def
69:
70:
71: /multi {
72: (Computing the multiplicity along T^*_Y M...) message
73:
74: (t) ring_of_differential_operators3 (t) lexicographic_order3 /r1 set
75: % t must be the most expensive.
76: dvars vars 2 cat_n
77: ring_of_polynomials2 ( ) elimination_order2 /r2 set
78:
79: parameters ring_of_polynomials2 ( ) elimination_order2 /r3 set
80: (H,h) ring_of_polynomials2 (H,h) lexicographic_order2 /r4 set
81: [r1 r2 add_rings r3 add_rings r4 add_rings 0] addSwap0k define_ring
82:
83: gg0 { . locRule {{ . } map} map replace} map
84:
85: (grade) (firstvec) switch_function
86: { homogenize [[$h$. $t$.]] replace (string) data_conversion } map /gg2 set
87:
88: [gg2 {.} map] groebner /gg2b set
89: gg2b 0 get {init} map { [[$t$. $1$.]] replace } map /gg3 set
90: gg3 {(string) data_conversion} map print
91: ( ) message
92: gg3 { parameters makeRule replace } map
93: {(string) data_conversion} map
94: execSm0
95: (grade) (module1) switch_function
96: } def
97:
98: /execSm0 {
99: /monoms set
100: (t.t) (w) file /fd set
101: fd ( ${-p,0}$ options ) writestring
102: fd ( $) writestring
103: ${$ dvars vars $}$ 4 cat_n /tmp set
104: fd tmp writestring
105: fd ($ ) writestring
106: fd ( polynomial_ring set_up_ring ${-proof}$ options ) writestring
107: %%fd [$x$ $y$] writeArray
108: fd monoms writeArray
109: fd ( /ff = ff yaGroebner /gg = gg hilbert2 :: quit) writestring
110: fd closefile
111: ( ) message
112: (sm0 -f t.t) system
113: (When the output is [$ a V^k + ... $ $p!$], the multiplicity is ) message
114: $ (k! a)/p! $ message
115: ( ) message
116: } def
117:
118:
119: /cat {
120: /arg1 set
121: [/n /arr /k] pushVariables
122: [
123: /arr arg1 def
124: 0 1 arr length 1 sub
125: {
126: /k set
127: arr k get
128: } for
129: arr length
130: cat_n /arg1 set
131: ] pop
132: popVariables
133: arg1
134: } def
135:
136: [vars to_records pop] { (D) 2 1 roll 2 cat_n (,) 2 cat_n } map cat /dvars set
137:
138:
139: /makeRule {
140: /arg1 set
141: [arg1 to_records pop] { [ 2 1 roll . $1$.] } map
142: } def
143:
144: /writeArray {
145: /arg2 set /arg1 set
146: [/fd /arr /k] pushVariables
147: [ /fd arg1 def
148: /arr arg2 def
149: fd ([ ) writestring
150: 0 1 arr length 1 sub
151: {
152: /k set
153: fd ($ ) writestring
154: fd arr k get writestring
155: fd ($ ) writestring
156: } for
157: fd ( ] ) writestring
158: ] pop
159: popVariables
160: } def
161:
162: /addSwap0k {
163: /arg1 set
164: [/rg /ch /tmp] pushVariables
165: [
166: arg1 0 get /rg set % ring
167: arg1 1 get /ch set % characteristics
168: [rg 0 get , rg 1 get , rg 2 get ,
169:
170: << rg 3 get length >>
171: matid
172: << rg 3 get length >>
173: 4 1 d_ij add %% add 1st row and 4th row
174: << rg 3 get >> mul /tmp set
175:
176: << rg 3 get length >>
177: 0 4 e_ij
178: tmp mul %% swap 1st row and 4 th row
179: ] /rg set
180: /arg1 [ rg ch ] def
181: ] pop
182: popVariables
183: arg1
184: } def
185:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to cv2.sm1 CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM / src / kan96xx / Doc / Old