{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Neuron.Zettelkasten.Graph
(
ZettelGraph,
mkZettelGraph,
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
type ZettelGraph = LAM.AdjacencyMap [Connection] ZettelID
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
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
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
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
_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
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
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
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)
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
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
mkGraphFrom ::
(Eq e, Monoid e, Ord v) =>
[a] ->
(a -> v) ->
(a -> [(e, v)]) ->
(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)