Re: Solve[] doesn't
- To: mathgroup at smc.vnet.net
- Subject: [mg90636] Re: Solve[] doesn't
- From: Hauke Reddmann <fc3a501 at uni-hamburg.de>
- Date: Thu, 17 Jul 2008 05:34:27 -0400 (EDT)
- References: <g5kil1$8lf$1@smc.vnet.net>
Addendum - "Faked Example" of course means exactly that -
my problem looks *like* the one I gave (of course
Mathematica solves THAT :-) in general structure.
It's hard to come up with actual code because I work
"on the fly" and so I won't exclude sheer stupidity
or a typo on my side.
I can give my basic code, though, it's just state model
knot theory work:
ClearAll["Global`*"];
(*Set Dimension*) n=3;fl=Floor[n/2];ce=Floor[(n-1)/2];
(*Define Closure*) cl[x_]:=Simplify[pc.x.qc/oo];
(*Define Convert1*) mt[x_]:=Nest[Partition[#,n]&,Flatten[x],3];
(*Define Convert2*) tm[x_]:=Partition[Flatten[x],n*n];
(*Define Rotation*) ro[x_]:=tm[Transpose[p.mt[x].q,{3,1,4,2}]];
(*Define Tidy Up*) ti[x_]:=x//Flatten//Together//Numerator//Factor//Sort//Union;
(*Actual Example*)
(*Set Cup and Cap*) q={{1/2,1,1},{-1,-1,0},{1,0,0}};
p=Inverse[q];
(*Set S Matrix *) s={
{s1111,s1112,s1113,s1121,s1122,s1123,s1131,s1132,s1133},
{s1211,s1212,s1213,s1221,s1222,s1223,s1231,s1232,s1233},
{s1311,s1312,s1313,s1321,s1322,s1323,s1331,s1332,s1333},
{s2111,s2112,s2113,s2121,s2122,s2123,s2131,s2132,s2133},
{s2211,s2212,s2213,s2221,s2222,s2223,s2231,s2232,s2233},
{s2311,s2312,s2313,s2321,s2322,s2323,s2331,s2332,s2333},
{s3111,s3112,s3113,s3121,s3122,s3123,s3131,s3132,s3133},
{s3211,s3212,s3213,s3221,s3222,s3223,s3231,s3232,s3233},
{s3311,s3312,s3313,s3321,s3322,s3323,s3331,s3332,s3333}};
(*Define R Matrix via Whirl 1*) r=ro[s];
(*Whirl 2*) nul1=Flatten[s-ro[r]];
(*Cap as Vector*) pc=Flatten[p];
(*Cup as Vector*) qc=Flatten[q];
(*Twist*) nul2a=Flatten[pc.s-pc*f];
(*Twist*) nul2b=Flatten[pc.r-pc/f];
(*Id*) kr=IdentityMatrix[n^2];
(*Poke*) nul3=Flatten[s.r-kr];
(*Id*) id=IdentityMatrix[n];
(*S x Id*) s1=Partition[Flatten[Transpose[Outer[Times,s,id],{1,3,2,4}]],n^3];
(*Id x S*) s2=Partition[Flatten[Transpose[Outer[Times,id,s],{1,3,2,4}]],n^3];
(*Slide*) nul4=Flatten[s1.s2.s1-s2.s1.s2];
(* Now solve for sijkl - if you dare! *)
(* nul1 and nul2a/b are linear, try them first. *)
g=(Sqrt[5]+1)/2;
f=I*(2*g+1);
S=I*{
{g-1,0,-g/2,0,g/2,g/2,-g/2,-g/2,-g/4},
{0,g-1,-g,0,g,g,-g,-g,-g/2},
{0,0,-1,0,g,g,-g,-g,-g/2},
{0,0,g,g-1,-g,-g,g,g,g/2},
{0,0,g,0,-1,-g,g,g,g/2},
{0,0,0,0,0,g-1,0,0,0},
{0,0,-g,0,g,g,-1,-g,-g/2},
{0,0,0,0,0,0,0,g-1,0},
{0,0,0,0,0,0,0,0,g-1}};
(* s=S is a solution I know but sometimes not find. *)
HTH.
--
Hauke Reddmann <:-EX8 fc3a501 at uni-hamburg.de
Er-a svo gott sem gott kveða
öl alda sonum, því að færra veit
er fleira drekkur síns til geðs gumi.