
Re: Add terms surrounded by zero together in matrix
Posted:
Jul 31, 2005 1:37 AM


Andrzej Kozlowski schrieb: > Here is a slightly improved version. (I just removed unnecessary > inner Blocks and a unnecessary conversion of the final expression to > List before applying Cases, which of course is never needed). > > Andrzej Kozlowski > > > SumsOfTermsSurroundedByZero[AA_] := > Block[{d, MakeNames, A = AA, p = First[Dimensions[ > AA]], q = Last[Dimensions[AA]]}, > MakeNames[1, 1] := A[[1, 1]] = Unique[z]*A[[1, 1]]; MakeNames[1, > i_] := > A[[1, i]] = If[(d = Variables[A[[1, i  1]]]) != {}, First[d]*A > [[1, i]], > > Unique[z]*A[[1, i]]]; MakeNames[i_, 1] := > A[[i, 1]] = Which[(d = Variables[A[[i  1, 1]]]) != {}, > First[ > d]*A[[i, 1]], (d = Variables[A[[i  1, 2]]]) != {}, First[d]*A > [[i, 1]], > True, Unique[z]*A[[i, 1]]]; MakeNames[i_, q] := > A[[i, q]] = Which[(d = Variables[A[[i  1, q  1]]]) != {}, > First[d]*A[[i, 5]], (d = Variables[A[[i  1, q]]]) != {}, > First[d]*A[[i, q]], > (d = Variables[A[[i, q  1]]]) != {}, First[d]*A[[i, q]], True, > Unique[z]*A[[i, q]]]; MakeNames[i_, j_] := > A[[i, j]] = Which[(d = Variables[A[[i  1, j  1]]]) != {}, > First[d]*A[[i, j]], ( > d = Variables[A[[i  1, j]]]) != {}, First[d]*A[[i, j]], > (d = Variables[A[[i  1, j + 1]]]) != {}, First[d]*A[[i, j]], > (d = Variables[A[[i, j  1]]]) != {}, First[d]*A[[i, j]], True, > Unique[z]*A[[i, j]]]; Do[MakeNames[i, j], {i, p}, {j, q}]; > Cases[Plus @@ Flatten[A], _?NumericQ, Infinity]] > > > > > > On 29 Jul 2005, at 20:55, Andrzej Kozlowski wrote: > > >>On 29 Jul 2005, at 06:42, mchangun@gmail.com wrote: >> >> >> >>>Hi All, >>> >>>I think this is a rather tough problem to solve. I'm stumped and >>>would >>>really appreciated it if someone can come up with a solution. >>> >>>What i want to do is this. Suppose i have the following matrix: >>> >>>0 0 0 1 0 >>>0 0 1 2 0 >>>0 0 0 2 1 >>>1 3 0 0 0 >>>0 0 0 0 0 >>>0 0 0 0 0 >>>0 0 1 1 0 >>>5 0 3 0 0 >>>0 0 0 0 0 >>>0 0 0 3 1 >>> >>>I'd like to go through it and sum the elements which are >>>surrounded by >>>zeros. So for the above case, an output: >>> >>>[7 4 5 5 4] >>> >>>is required. The order in which the groups surrounded by zero is >>>summed does not matter. >>> >>>The elements are always integers greater than 0. >>> >>>Thanks for any help! >>> >>> >>> >> >> >>O.K., Here is a solution. I think the algorithm is rather nice but >>the implementation certainly isn't, with a nasty procedural Do >>loop, nested Blocks etc, but I can't really afford the time to try >>to make it nicer. Perhaps someone else will. >> >>Here is the function: >> >> >>SumsOfTermsSurroundedByZero[AA_] := >> Block[{MakeNames, A = AA, p = First[Dimensions[AA]], q = Last >>[Dimensions[AA]]}, >> MakeNames[1, 1] := A[[1,1]] = Unique[z]*A[[1,1]]; MakeNames[1, >>i_] := >> A[[1,i]] = Block[{d}, If[(d = Variables[A[[1,i  1]]]) != {}, >>First[d]*A[[1,i]], >> Unique[z]*A[[1,i]]]]; MakeNames[i_, 1] := >> A[[i,1]] = Block[{d}, Which[(d = Variables[A[[i  1,1]]]) != {}, >> First[d]*A[[i,1]], (d = Variables[A[[i  1,2]]]) != {}, >>First[d]*A[[i,1]], >> True, Unique[z]*A[[i,1]]]]; MakeNames[i_, q] := >> A[[i,q]] = Block[{d}, Which[(d = Variables[A[[i  1,q  1]]]) ! >>= {}, >> First[d]*A[[i,5]], (d = Variables[A[[i  1,q]]]) != {}, >>First[d]*A[[i,q]], >> (d = Variables[A[[i,q  1]]]) != {}, First[d]*A[[i,q]], True, >> Unique[z]*A[[i,q]]]]; MakeNames[i_, j_] := >> A[[i,j]] = Block[{d}, Which[(d = Variables[A[[i  1,j  1]]]) ! >>= {}, >> First[d]*A[[i,j]], (d = Variables[A[[i  1,j]]]) != {}, >>First[d]*A[[i,j]], >> (d = Variables[A[[i  1,j + 1]]]) != {}, First[d]*A[[i,j]], >> (d = Variables[A[[i,j  1]]]) != {}, First[d]*A[[i,j]], True, >> Unique[z]*A[[i,j]]]]; Do[MakeNames[i, j], {i, p}, {j, q}]; >> Cases[List @@ Plus @@ Flatten[A], _?NumericQ, Infinity]] >> >>Here is your matrix defined using proper Mathematica syntax: >> >>AA = {{0,0 , 0 , 1, 0}, {0, 0 , 1 , 2, 0}, {0, 0, 0, 2 , 1}, {1, 3, >>0 , 0 , 0}, {0, >> 0, 0, 0 , 0}, {0 , 0, 0 , 0, 0}, {0, 0 , 1 , 1, 0}, {5 , 0, 3, >>0 , 0}, {0, >> 0, 0, 0, 0}, {0, 0, 0, 3, 1}} >> >>And here is the solution: >> >>In[3]:= >>SumsOfTermsSurroundedByZero[AA] >> >>Out[3]= >>{7,4,5,5,4} >> >> >>I have not tested it on other examples but your own but it should >>work in all cases. >> >>Andrzej Kozlowski >> >> >> > >
Wow, a nice trick!
I surrounded the array by zeros to get rid of the case differentiations and applied MakeNames only to positive elements. Additionally I tried to manage the case of "V"shaped patterns:
SumsOfTermsSurroundedByZero[AA_]:= Block[{d,MakeNames,A}, A=Prepend[Flatten[{0,#,0}]&/@AA,Table[0,{2+Length[AA[[1]]]}]]; MakeNames[i_,j_]:=A[[i,j]]*= If[(d=Variables[A[[{i1,i},{j1,j,j+1}]]])==={}, Unique[z], If[Length[d]>1, Set[#,First[d]]&/@Rest[d]]; First[d] ]; (*Do[MakeNames[i,j],{i,p},{j,q}];*) (*Cases[Plus@@Flatten[A],_?NumericQ,Infinity]*) MakeNames@@@Position[A,_?Positive]; Coefficient[Plus@@Flatten[A],#]&/@Variables[A] ]
Regards, Peter
 Peter Pein Berlin

