Ndtyjky

Suppose I have a list of simple expressions, something like:

list = {{a-b-2c-d+e+2f},{-a-2b-c+d+2e+f},{-2a-b+c+2d+e-f},{x-y-z},{-x+y-z},{-x-y+z}};

These expressions are going to become elements in a linear combination. But notice that the third element in this list is itself already a linear combination of the first two. Therefore, my "basis" really should be this list without one of the first three elements (it doesn't matter which one goes away, but for consistency I would like to remove the third of them). Is there an automated way in Mathematica to search a list of expressions like this, identify when elements are linear combinations of others, and then remove the extraneous elements?

Take your list and fix it so that the 3rd element dependent on the first two:

list[[3]] = (list[[2]] + list[[1]])/3 // Expand;

list

(*

  {{2a + b - c - 2d - e + f}, {a + 2b + c - d - 2 e - f}, {-a + b + 2c + d - e - 2f},

   {x - y - z}, {-x + y - z}, {-x - y + z}}

*)

Convert system of linear functions to a matrix:

vars = Variables@list;

linsys = CoefficientArrays[Flatten@list, vars][[2]];

Extract linearly independent elements of list:

Extract[list, 

 FirstPosition[#, 1, Nothing] & /@ RowReduce[Transpose@linsys]]

(*

  {{a - b - 2 c - d + e + 2 f}, {-a - 2 b - c + d + 2 e + f},

   {x - y - z}, {-x + y - z}, {-x - y + z}}

*)

Or row reduce to get an equivalent basis:

RowReduce[linsys].vars // DeleteCases[0]

(*  {a - c - d + f, b + c - e - f, x, y, z}  *)

What I would do is replace symbols by numeric vectors with a function like

ClearAll[toNumbers];

toNumbers[list_, vars_] := 

  list /. Thread[vars -> IdentityMatrix[Length[vars]]];



toNumbers[{a, b, a + b}, {a, b}]

(*{{1, 0}, {0, 1}, {1, 1}}*)

then perform some linear algebra and convert the result back into symbols with something like

ClearAll[fromNumbers];

fromNumbers[list_, vars_] := Replace[

 list,

 x_ :> x.vars,

 {1}

];



fromNumbers[{{1, 0}, {0, 1}, {1, 1}}, {a, b}]

(*{a, b, a + b}*)

The linear algebra logic can be something like Fold which checks a vector and appends it to a list if it is linear independent form the vectors in the list:

Fold[

 f,

 {},

 {{1, 1, 0}, {0, 1, 0}, {1, 1, 1}}

]

where

ClearAll[f];

f[vecs_, vec_] := With[

   {

    vecs2 = Append[vecs, vec]

   },

   vecs2 /; MatrixRank[vecs2] == Length[vecs2]

];

f[vecs_, vec_] := vecs;

Gathering all together (except f):

ClearAll[leaveLinearIndependent];

leaveLinearIndependent[list_, vars_] := Replace[

  Fold[

   f,

   {},

   list /. Thread[vars -> IdentityMatrix[Length[vars]]]

   ],

 x_ :> x.vars,

 {1}

 ];



leaveLinearIndependent[{a, a + b, b, c}, {a, b, c}]

(*{a, a + b, c}*)

list = {{a-b-2c-d+e+2f},{-a-2b-c+d+2e+f},

  {-2a-b+c+2d+e-f},{x-y-z},{-x+y-z},{-x-y+z}};

First extract coefficient arrays.

coeffArrays = Normal[CoefficientArrays[list]][[2,All,1]]               



(* ut[29]= {{1, -1, -2, -1, 1, 2, 0, 0, 0},

   {-1, -2, -1, 1, 2, 1, 0, 0, 0}, 

   {-2, -1, 1, 2, 1, -1, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 1, -1, -1}, 

   {0, 0, 0, 0, 0, 0, -1, 1, -1}, {0, 0, 0, 0, 0, 0, -1, -1, 1}} *)

Find null vectors of the transpose.

nulls = NullSpace[Transpose@dd]                                        



(* Out[30]= {{1, -1, 1, 0, 0, 0}} *)

We want to remove vectors in positions of last nonzero value in each null vector (of which there is but one, in this case). We can automate the task of finding the list to remove as below.

Flatten[Length[nulls[[1]]] + 1 -

    Map[FirstPosition[#,Except[0],Heads->False]&,

      Map[Reverse,nulls]]]                                               



(* Out[41]= {3} *)