Remove redundant dependencies from a directed acyclic graph

Let $A$ be the adjacency matrix of the graph to be reduced. $A$ is also the reachability matrix for 1 hop, and $A^2$ for 2 hops and so on, if we substitue logical and ($\land$) for multiplication and logical or ($\lor$) for addition in multiplying two matrices. $A^k$ ($k<n$) will eventually be all zeros because we cannot have a path of $n$ hops or more where $n$ is the number of vertices (assuming no cycles).

Let $S = A^2 \lor A^3 \lor \cdots \lor A^k$ be the reachability matrix of 2 or more hops. To reduce $A$, we need to remove $i \rightarrow j$ in $A$ if it is also in $S$. The reduced adjacency matrix is therefore $A \land \lnot S$.

To put the above into code, note that we can just use normal multiplication and addition, after all, if we only look at the sign. This has a huge performance boost because we will be using highly optimized matrix multiplications on machine integers. We'll use Unitize to keep the intermediate results within the range of machine intergers:

reduce[a_] := a (1 - FixedPoint[Unitize[a.(a + #)] &, a.a])

I do not have experience with graphs and built-in functions related to them, but maybe something based on fact that the following is a Tautology:

$(a\Rightarrow b)\land (b\Rightarrow c)\Rightarrow (a\Rightarrow c)$

 And[Implies[a, b], Implies[b, c]]~Implies~Implies[a, c] // Simplify

True

Edit I've added temporary replacement for 1 and 0 which can cause a problems since they are interpreted by Simplify as True and False. More there: Simplify assumes..

list = {DirectedEdge[a, b], DirectedEdge[b, c], DirectedEdge[a, c]}; 

reduce[list_] := Module[{a, b}, With[{impl = Implies @@@ list /. {1 -> a, 0 -> b}},
     DirectedEdge @@@ MapIndexed[
                         If[TrueQ @ Simplify @ Implies[And @@ Drop[impl, #2], #1], 
                            Unevaluated[Sequence[]], #1] &
                         , impl]
                       ] /. {a -> 1, b -> 0}]

reduce[list]

{DirectedEdge[a, b], DirectedEdge[b, c]}

Edit by m_goldberg

I think it is is worth looking at some graphs a little more complex than the one the OP mentioned, both before and after reduce is applied to them.

dag2 = DirectedEdge @@@ {{a, b}, {b, c}, {a, c}, {e, b}, {e, c}};
dag3 = DirectedEdge @@@ {{a, b}, {b, c}, {a, c}, {e, b}, {e, c}, {e, f}, {f, c}};
dag4 = DirectedEdge @@@ {{2, 1}, {3, 1}, {3, 2}, {4, 1}, {4, 2}, {4, 3}, {5, 1}, 
                         {5, 2}, {5, 3}, {5, 4}}; (*István's example*)


dags = {#, reduce[#]} & /@ {dag2, dag3, dag4}
gridData = Prepend[
             Map[Graph[#, VertexLabels -> "Name", GraphLayout -> "SpringEmbedding"] &,
                 dags, {2}], 
             {"Before", "After"}];
Grid[gridData, Frame -> All]

I used this generator algorithm for DAGs (by Szabolcs):

{vertices, edges} = {7, 10};
elems = RandomSample@PadRight[ConstantArray[1, edges], vertices (vertices-1)/2];
adj = Take[FoldList[RotateLeft, elems, Range[0, vertices-2]], All, 
           vertices]~LowerTriangularize~-1;
g = AdjacencyGraph[adj, DirectedEdges -> True];
EdgeList@g

{2 -> 1, 3 -> 1, 3 -> 2, 4 -> 1, 4 -> 2, 4 -> 3, 5 -> 1, 5 -> 2, 5 -> 3, 5 -> 4}

Removing redundant edges iteratively:

new = Graph[Flatten[If[GraphDistance[EdgeDelete[g, #], First@#, 
            Last@#] < Infinity, {}, #] & /@ EdgeList@g], 
         VertexLabels -> "Name", ImagePadding -> 10];
Row@{HighlightGraph[g, new, VertexLabels -> "Name", ImagePadding -> 10], new}

For some graphs, the remaining graph is simply the path graph of the topologically sorted vertices:

g = Graph[{2->1, 3->1, 3->2, 4->1, 4->2, 4->3, 5->1, 5->2, 5->3, 5->4}];

Note that this method removes unconnected singletons.

---

Adjacency matrix version

Here is a version that works directly on adjacency matrices. This should be faster than working on huge Graph objects directly.

The removableQ function recursively tests if the node from has an alternative route to to than the direct one, by collecting children nodes. The moment the function finds another edge terminating at to, exits from the loop, as it is unnecessary to check further.

removableQ[m_, {from_, to_}] := Module[{children},
   children = Flatten@Position[m[[from]], 1];
   If[MemberQ[children, to], Throw@to, 
    Do[removableQ[m, {i, to}], {i, children}]; None]
   ];

The wrapper reduce iterates through all edges in the matrix:

reduce[adj_] := Module[{edgeList = Position[adj, 1], rem},
   rem = DeleteCases[{First@#, 
        Catch@removableQ[ReplacePart[adj, # -> 0], #]} & /@ 
      edgeList, {_, None}];
   ReplacePart[adj, Thread[rem -> 0]]
   ];

Let's call reduce on a random DAG's adjecency matrix:

g = DirectedGraph[RandomGraph[{6, 10}], "Acyclic"];
EdgeList@g

{1 -> 3, 1 -> 4, 1 -> 5, 1 -> 6, 2 -> 3, 2 -> 4, 2 -> 5, 3 -> 5, 4 -> 6, 5 -> 6}

adj = Normal@AdjacencyMatrix@g
new = reduce@adj;
Row@{g, AdjacencyGraph@new}

Note that this method does not remove unconnected singletons.