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 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[[{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 Pein

Berlin