{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Neuron.Zettelkasten.Graph
  ( -- * Graph type
    ZettelGraph,

    -- * Construction
    mkZettelGraph,

    -- * Algorithms
    backlinks,
    topSort,
    zettelClusters,
    dfsForestFrom,
    dfsForestBackwards,
    obviateRootUnlessForest,
  )
where

import qualified Algebra.Graph.AdjacencyMap as AM
import qualified Algebra.Graph.AdjacencyMap.Algorithm as Algo
import qualified Algebra.Graph.Labelled.AdjacencyMap as LAM
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Tree (Forest, Tree (..))
import Neuron.Zettelkasten.ID
import Neuron.Zettelkasten.Link.Action (extractLinks, linkActionConnections)
import Neuron.Zettelkasten.Store (ZettelStore)
import Neuron.Zettelkasten.Type
import Relude

-- | The Zettelkasten graph
type ZettelGraph = LAM.AdjacencyMap [Connection] ZettelID

-- | Build the Zettelkasten graph from the given list of note files.
mkZettelGraph :: ZettelStore -> ZettelGraph
mkZettelGraph :: ZettelStore -> ZettelGraph
mkZettelGraph store :: ZettelStore
store =
  [Zettel]
-> (Zettel -> ZettelID)
-> (Zettel -> [([Connection], ZettelID)])
-> ([Connection] -> Bool)
-> ZettelGraph
forall e v a.
(Eq e, Monoid e, Ord v) =>
[a]
-> (a -> v) -> (a -> [(e, v)]) -> (e -> Bool) -> AdjacencyMap e v
mkGraphFrom (ZettelStore -> [Zettel]
forall k a. Map k a -> [a]
Map.elems ZettelStore
store) Zettel -> ZettelID
zettelID Zettel -> [([Connection], ZettelID)]
zettelEdges [Connection] -> Bool
forall (f :: * -> *).
(DisallowElem f, Foldable f) =>
f Connection -> Bool
connectionWhitelist
  where
    -- Exclude ordinary connection when building the graph
    --
    -- TODO: Build the graph with all connections, but induce a subgraph when
    -- building category forests. This way we can still show ordinary
    -- connetions in places (eg: a "backlinks" section) where they are
    -- relevant. See #34
    connectionWhitelist :: f Connection -> Bool
connectionWhitelist cs :: f Connection
cs =
      Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Connection
OrdinaryConnection Connection -> f Connection -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` f Connection
cs
    -- Get the outgoing edges from this zettel
    --
    -- TODO: Handle conflicts in edge monoid operation (same link but with
    -- different connection type), and consequently use a sensible type other
    -- than list.
    zettelEdges :: Zettel -> [([Connection], ZettelID)]
    zettelEdges :: Zettel -> [([Connection], ZettelID)]
zettelEdges Zettel {..} =
      let outgoingLinks :: [ZettelConnection]
outgoingLinks = ZettelStore -> MarkdownLink -> [ZettelConnection]
linkActionConnections ZettelStore
store (MarkdownLink -> [ZettelConnection])
-> [MarkdownLink] -> [ZettelConnection]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
`concatMap` MMark -> [MarkdownLink]
extractLinks MMark
zettelContent
       in (Connection -> [Connection])
-> ZettelConnection -> ([Connection], ZettelID)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Connection -> [Connection]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ZettelConnection -> ([Connection], ZettelID))
-> [ZettelConnection] -> [([Connection], ZettelID)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ZettelConnection]
outgoingLinks

-- | Return the backlinks to the given zettel
backlinks :: ZettelID -> ZettelGraph -> [ZettelID]
backlinks :: ZettelID -> ZettelGraph -> [ZettelID]
backlinks zid :: ZettelID
zid =
  Set ZettelID -> [ZettelID]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Set ZettelID -> [ZettelID])
-> (ZettelGraph -> Set ZettelID) -> ZettelGraph -> [ZettelID]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZettelID -> ZettelGraph -> Set ZettelID
forall a e. Ord a => a -> AdjacencyMap e a -> Set a
LAM.preSet ZettelID
zid

topSort :: ZettelGraph -> Either (NonEmpty ZettelID) [ZettelID]
topSort :: ZettelGraph -> Either (NonEmpty ZettelID) [ZettelID]
topSort = AdjacencyMap ZettelID -> Either (NonEmpty ZettelID) [ZettelID]
forall a. Ord a => AdjacencyMap a -> Either (Cycle a) [a]
Algo.topSort (AdjacencyMap ZettelID -> Either (NonEmpty ZettelID) [ZettelID])
-> (ZettelGraph -> AdjacencyMap ZettelID)
-> ZettelGraph
-> Either (NonEmpty ZettelID) [ZettelID]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZettelGraph -> AdjacencyMap ZettelID
forall a e. Ord a => AdjacencyMap e a -> AdjacencyMap a
LAM.skeleton

-- | Get the graph without the "index" zettel.
-- This is unused, but left for posterity.
_withoutIndex :: ZettelGraph -> ZettelGraph
_withoutIndex :: ZettelGraph -> ZettelGraph
_withoutIndex = (ZettelID -> Bool) -> ZettelGraph -> ZettelGraph
forall a e. (a -> Bool) -> AdjacencyMap e a -> AdjacencyMap e a
LAM.induce ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= "index") (Text -> Bool) -> (ZettelID -> Text) -> ZettelID -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZettelID -> Text
unZettelID)

zettelClusters :: ZettelGraph -> [NonEmpty ZettelID]
zettelClusters :: ZettelGraph -> [NonEmpty ZettelID]
zettelClusters = AdjacencyMap ZettelID -> [NonEmpty ZettelID]
forall a. Ord a => AdjacencyMap a -> [NonEmpty a]
mothers (AdjacencyMap ZettelID -> [NonEmpty ZettelID])
-> (ZettelGraph -> AdjacencyMap ZettelID)
-> ZettelGraph
-> [NonEmpty ZettelID]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZettelGraph -> AdjacencyMap ZettelID
forall a e. Ord a => AdjacencyMap e a -> AdjacencyMap a
LAM.skeleton

-- | Compute the dfsForest from the given zettels.
dfsForestFrom :: [ZettelID] -> ZettelGraph -> Forest ZettelID
dfsForestFrom :: [ZettelID] -> ZettelGraph -> Forest ZettelID
dfsForestFrom zids :: [ZettelID]
zids g :: ZettelGraph
g =
  [ZettelID] -> AdjacencyMap ZettelID -> Forest ZettelID
forall a. Ord a => [a] -> AdjacencyMap a -> Forest a
Algo.dfsForestFrom [ZettelID]
zids (AdjacencyMap ZettelID -> Forest ZettelID)
-> AdjacencyMap ZettelID -> Forest ZettelID
forall a b. (a -> b) -> a -> b
$ ZettelGraph -> AdjacencyMap ZettelID
forall a e. Ord a => AdjacencyMap e a -> AdjacencyMap a
LAM.skeleton ZettelGraph
g

-- | Compute the dfsForest ending in the given zettel.
--
-- Return the forest flipped, such that the given zettel is the root.
dfsForestBackwards :: ZettelID -> ZettelGraph -> Forest ZettelID
dfsForestBackwards :: ZettelID -> ZettelGraph -> Forest ZettelID
dfsForestBackwards fromZid :: ZettelID
fromZid =
  [ZettelID] -> ZettelGraph -> Forest ZettelID
dfsForestFrom [ZettelID
fromZid] (ZettelGraph -> Forest ZettelID)
-> (ZettelGraph -> ZettelGraph) -> ZettelGraph -> Forest ZettelID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZettelGraph -> ZettelGraph
forall e a.
(Monoid e, Ord a) =>
AdjacencyMap e a -> AdjacencyMap e a
LAM.transpose

-- -------------
-- Graph Helpers
-- -------------

-- | Get the clusters in a graph, as a list of the mother vertices in each
-- cluster.
mothers :: Ord a => AM.AdjacencyMap a -> [NonEmpty a]
mothers :: AdjacencyMap a -> [NonEmpty a]
mothers g :: AdjacencyMap a
g =
  [NonEmpty a] -> [a] -> [NonEmpty a]
go [] ([a] -> [NonEmpty a]) -> [a] -> [NonEmpty a]
forall a b. (a -> b) -> a -> b
$ AdjacencyMap a -> [a]
forall a. Ord a => AdjacencyMap a -> [a]
motherVertices AdjacencyMap a
g
  where
    go :: [NonEmpty a] -> [a] -> [NonEmpty a]
go acc :: [NonEmpty a]
acc = \case
      [] -> [NonEmpty a]
acc
      v :: a
v : ([a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList -> Set a
vs) ->
        let reach :: Set a
reach = a -> AdjacencyMap a -> Set a
forall a. Ord a => a -> AdjacencyMap a -> Set a
reachableUndirected a
v AdjacencyMap a
g
            covered :: Set a
covered = Set a
vs Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` Set a
reach
            rest :: Set a
rest = Set a
vs Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set a
reach
         in [NonEmpty a] -> [a] -> [NonEmpty a]
go ((a
v a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| Set a -> [a]
forall a. Set a -> [a]
Set.toList Set a
covered) NonEmpty a -> [NonEmpty a] -> [NonEmpty a]
forall a. a -> [a] -> [a]
: [NonEmpty a]
acc) (Set a -> [a]
forall a. Set a -> [a]
Set.toList Set a
rest)

-- | Get the vertexes reachable (regardless of direction) from the given vertex.
reachableUndirected :: Ord a => a -> AM.AdjacencyMap a -> Set a
reachableUndirected :: a -> AdjacencyMap a -> Set a
reachableUndirected v :: a
v =
  [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList ([a] -> Set a)
-> (AdjacencyMap a -> [a]) -> AdjacencyMap a -> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> AdjacencyMap a -> [a]
forall a. Ord a => a -> AdjacencyMap a -> [a]
Algo.reachable a
v (AdjacencyMap a -> [a])
-> (AdjacencyMap a -> AdjacencyMap a) -> AdjacencyMap a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdjacencyMap a -> AdjacencyMap a
forall a. Ord a => AdjacencyMap a -> AdjacencyMap a
toUndirected
  where
    toUndirected :: AdjacencyMap a -> AdjacencyMap a
toUndirected g :: AdjacencyMap a
g = AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a
forall a.
Ord a =>
AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a
AM.overlay AdjacencyMap a
g (AdjacencyMap a -> AdjacencyMap a)
-> AdjacencyMap a -> AdjacencyMap a
forall a b. (a -> b) -> a -> b
$ AdjacencyMap a -> AdjacencyMap a
forall a. Ord a => AdjacencyMap a -> AdjacencyMap a
AM.transpose AdjacencyMap a
g

motherVertices :: Ord a => AM.AdjacencyMap a -> [a]
motherVertices :: AdjacencyMap a -> [a]
motherVertices =
  ((a, [a]) -> Maybe a) -> [(a, [a])] -> [a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(v :: a
v, es :: [a]
es) -> if [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
es then a -> Maybe a
forall a. a -> Maybe a
Just a
v else Maybe a
forall a. Maybe a
Nothing)
    ([(a, [a])] -> [a])
-> (AdjacencyMap a -> [(a, [a])]) -> AdjacencyMap a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdjacencyMap a -> [(a, [a])]
forall a. AdjacencyMap a -> [(a, [a])]
AM.adjacencyList
    (AdjacencyMap a -> [(a, [a])])
-> (AdjacencyMap a -> AdjacencyMap a)
-> AdjacencyMap a
-> [(a, [a])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdjacencyMap a -> AdjacencyMap a
forall a. Ord a => AdjacencyMap a -> AdjacencyMap a
AM.transpose

-- | If the input is a tree with the given root node, return its children (as
-- forest). Otherwise return the input as is.
obviateRootUnlessForest :: (Show a, Eq a) => a -> [Tree a] -> [Tree a]
obviateRootUnlessForest :: a -> [Tree a] -> [Tree a]
obviateRootUnlessForest root :: a
root = \case
  [Node v :: a
v ts :: [Tree a]
ts] ->
    if a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
root
      then [Tree a]
ts
      else Text -> [Tree a]
forall a t. (HasCallStack, IsText t) => t -> a
error "Root mismatch"
  nodes :: [Tree a]
nodes ->
    [Tree a]
nodes

-- Build a graph from a list objects that contains information about the
-- corresponding vertex as well as the outgoing edges.
mkGraphFrom ::
  (Eq e, Monoid e, Ord v) =>
  -- | List of objects corresponding to vertexes
  [a] ->
  -- | Make vertex from an object
  (a -> v) ->
  -- | Outgoing edges, and their vertex, for an object
  (a -> [(e, v)]) ->
  -- | A function to filter relevant edges
  (e -> Bool) ->
  LAM.AdjacencyMap e v
mkGraphFrom :: [a]
-> (a -> v) -> (a -> [(e, v)]) -> (e -> Bool) -> AdjacencyMap e v
mkGraphFrom xs :: [a]
xs vertexFor :: a -> v
vertexFor edgesFor :: a -> [(e, v)]
edgesFor edgeWhitelist :: e -> Bool
edgeWhitelist =
  let vertices :: [v]
vertices =
        a -> v
vertexFor (a -> v) -> [a] -> [v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
xs
      edges :: [(e, v, v)]
edges =
        ((a -> [(e, v, v)]) -> [a] -> [(e, v, v)])
-> [a] -> (a -> [(e, v, v)]) -> [(e, v, v)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> [(e, v, v)]) -> [a] -> [(e, v, v)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [a]
xs ((a -> [(e, v, v)]) -> [(e, v, v)])
-> (a -> [(e, v, v)]) -> [(e, v, v)]
forall a b. (a -> b) -> a -> b
$ \x :: a
x ->
          a -> [(e, v)]
edgesFor a
x
            [(e, v)] -> ((e, v) -> (e, v, v)) -> [(e, v, v)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(edge :: e
edge, v2 :: v
v2) ->
              (e
edge, a -> v
vertexFor a
x, v
v2)
   in AdjacencyMap e v -> AdjacencyMap e v -> AdjacencyMap e v
forall e a.
(Eq e, Monoid e, Ord a) =>
AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a
LAM.overlay
        ([v] -> AdjacencyMap e v
forall a e. Ord a => [a] -> AdjacencyMap e a
LAM.vertices [v]
vertices)
        ([(e, v, v)] -> AdjacencyMap e v
forall e a.
(Eq e, Monoid e, Ord a) =>
[(e, a, a)] -> AdjacencyMap e a
LAM.edges ([(e, v, v)] -> AdjacencyMap e v)
-> [(e, v, v)] -> AdjacencyMap e v
forall a b. (a -> b) -> a -> b
$ ((e, v, v) -> Bool) -> [(e, v, v)] -> [(e, v, v)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(e :: e
e, _, _) -> e -> Bool
edgeWhitelist e
e) [(e, v, v)]
edges)