Annotation of OpenXM/src/kan96xx/Doc/Old/cv2.sm1, Revision 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