```Date: Jul 31, 2005 1:37 AM
Author: Peter Pein
Subject: Re: Add terms surrounded by zero together in matrix

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 differentiationsand applied MakeNames only to positive elements. Additionally I tried tomanage 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[[{i-1,i},{j-1,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 PeinBerlin
```