Services & Resources / Wolfram Forums
-----
 /
MathGroup Archive
2005
*January
*February
*March
*April
*May
*June
*July
*August
*September
*October
*November
*December
*Archive Index
*Ask about this page
*Print this page
*Give us feedback
*Sign up for the Wolfram Insider

MathGroup Archive 2005

[Date Index] [Thread Index] [Author Index]

Search the Archive

Re: Add terms surrounded by zero together in matrix

  • To: mathgroup at smc.vnet.net
  • Subject: [mg59165] Re: Add terms surrounded by zero together in matrix
  • From: Peter Pein <petsie at dordos.net>
  • Date: Sun, 31 Jul 2005 01:30:39 -0400 (EDT)
  • References: <200507290442.AAA03344@smc.vnet.net> <D57F24FF-09B6-45B0-9D84-3F12DC801571@mimuw.edu.pl> <dcf3bm$lg6$1@smc.vnet.net>
  • Sender: owner-wri-mathgroup at wolfram.com

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 at 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


  • Prev by Date: fit a tube around a trajectory
  • Previous by thread: Re: Add terms surrounded by zero together in matrix
  • Next by thread: Re: Add terms surrounded by zero together in matrix