Last active
June 27, 2018 19:48
-
-
Save MartinKavik/8a7b650698d70b28e4a2b9bb6e603ddb to your computer and use it in GitHub Desktop.
LTree.elm & LTreeTest.elm - multiway tree in Elm (not refactored, not complete), written for desktop app FusionD (pre-alpha screenshot: https://prnt.sc/k03m71). Little bit inspired by http://patshaughnessy.net/2017/12/13/saving-a-tree-in-postgres-using-ltree.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
module Utils.LTree | |
exposing | |
( Forest | |
, Label | |
, Node | |
, createEmptyForest | |
, createForest | |
, createNode | |
, deleteNode | |
, filterNodes | |
, filterNodesByLabel | |
, forestToContents | |
, getNode | |
, getNodeAncestorsLabels | |
, getNodeByPath | |
, getNodeChildren | |
, getNodeChildrenAsDict | |
, getNodeContent | |
, getNodeDegree | |
, getNodeLabel | |
, getNodeParent | |
, getNodePath | |
, getNodeWithAncestors | |
, getRoots | |
, getRootsCount | |
, getSingleRoot | |
, hasNodeChildren | |
, isNodeAncestorOf | |
, isNodeRoot | |
, nodeToForest | |
, rebuildNodeDescendants | |
, updateNodeAncestorsLabels | |
, updateNodeChildren | |
, updateNodeContent | |
, updateNodeLabel | |
, upsertNode | |
, upsertNodeIntoParent | |
) | |
import Dict exposing (Dict) | |
type alias Label = | |
String | |
type alias AncestorsLabels = | |
List Label | |
type alias Forest a = | |
Nodes a | |
type alias Nodes a = | |
Dict Label (Node a) | |
type alias Node a = | |
{ ancestorsLabels : AncestorsLabels | |
, label : Label | |
, content : a | |
, type_ : NodeType a | |
} | |
type NodeType a | |
= Branch (Nodes a) | |
| Leaf | |
stripListPrefix : List a -> List a -> Maybe (List a) | |
stripListPrefix prefix list = | |
let | |
step e m = | |
case m of | |
Nothing -> | |
Nothing | |
Just [] -> | |
Nothing | |
Just (x :: remainingList) -> | |
if e == x then | |
Just remainingList | |
else | |
Nothing | |
in | |
List.foldl step (Just list) prefix | |
listIsPrefixOf : List a -> List a -> Bool | |
listIsPrefixOf list prefix = | |
List.take (List.length prefix) list == prefix | |
createEmptyForest : Forest a | |
createEmptyForest = | |
Dict.empty | |
nodeTypeMap : (Nodes a -> Nodes b) -> NodeType a -> NodeType b | |
nodeTypeMap f nodeType = | |
case nodeType of | |
Branch nodeType -> | |
Branch (f nodeType) | |
Leaf -> | |
Leaf | |
upsertNodeIntoParent : Node a -> Node a -> Node a | |
upsertNodeIntoParent node parentNode = | |
let | |
parentType = | |
case parentNode.type_ of | |
Branch children -> | |
Branch children | |
Leaf -> | |
Branch createEmptyForest | |
in | |
{ parentNode | type_ = nodeTypeMap (Dict.insert node.label node) parentType } | |
createNode : AncestorsLabels -> (a -> Label) -> a -> Node a | |
createNode ancestorsLabels contentToLabel content = | |
Node ancestorsLabels (content |> contentToLabel) content Leaf | |
upsertNode : Node a -> Forest a -> Forest a | |
upsertNode node forest = | |
upsertNodeIntoSubForest [] node forest | |
upsertNodeIntoSubForest : List Label -> Node a -> Forest a -> Forest a | |
upsertNodeIntoSubForest ancestorsLabelsFromParentForest node forest = | |
case stripListPrefix ancestorsLabelsFromParentForest node.ancestorsLabels of | |
Just strippedAncestorsLabels -> | |
case getNodeWithAncestors strippedAncestorsLabels Nothing forest of | |
Just ancestors -> | |
propagateTreeChangeToRoots False (node :: ancestors) forest | |
Nothing -> | |
forest | |
Nothing -> | |
forest | |
propagateTreeChangeToRoots : Bool -> List (Node a) -> Forest a -> Forest a | |
propagateTreeChangeToRoots deleteFirstNode nodes forest = | |
case nodes of | |
[] -> | |
forest | |
[ node ] -> | |
if not deleteFirstNode then | |
Dict.insert node.label node forest | |
else | |
Dict.remove node.label forest | |
node :: parent :: ancestors -> | |
let | |
updatedParent = | |
if not deleteFirstNode then | |
upsertNodeIntoParent node parent | |
else | |
updateNodeChildren (Dict.remove node.label) parent | |
in | |
propagateTreeChangeToRoots False (updatedParent :: ancestors) forest | |
getNodeWithAncestors : AncestorsLabels -> Maybe Label -> Forest a -> Maybe (List (Node a)) | |
getNodeWithAncestors = | |
doGetNodeWithAncestors [] | |
doGetNodeWithAncestors : | |
List (Node a) | |
-> AncestorsLabels | |
-> Maybe Label | |
-> Forest a | |
-> Maybe (List (Node a)) | |
doGetNodeWithAncestors nodes ancestorsLabels label forest = | |
case ancestorsLabels of | |
[] -> | |
case label of | |
Just label -> | |
case Dict.get label forest of | |
Just node -> | |
Just <| node :: nodes | |
Nothing -> | |
Nothing | |
Nothing -> | |
Just nodes | |
parentLabel :: ancestorsLabels -> | |
case Dict.get parentLabel forest of | |
Just node -> | |
case node.type_ of | |
Branch children -> | |
doGetNodeWithAncestors (node :: nodes) ancestorsLabels label children | |
Leaf -> | |
case label of | |
Just label -> | |
Nothing | |
Nothing -> | |
Just <| node :: nodes | |
Nothing -> | |
Nothing | |
getNode : AncestorsLabels -> Label -> Forest a -> Maybe (Node a) | |
getNode ancestorsLabels label forest = | |
case ancestorsLabels of | |
[] -> | |
Dict.get label forest | |
parentLabel :: ancestorsLabels -> | |
case Dict.get parentLabel forest of | |
Just node -> | |
case node.type_ of | |
Branch children -> | |
getNode ancestorsLabels label children | |
Leaf -> | |
Nothing | |
Nothing -> | |
Nothing | |
getNodeByPath : List Label -> Forest a -> Maybe (Node a) | |
getNodeByPath path forest = | |
case List.reverse path of | |
label :: ancestorsLabels -> | |
getNode (List.reverse ancestorsLabels) label forest | |
[] -> | |
Nothing | |
getNodeChildren : Node a -> List (Node a) | |
getNodeChildren node = | |
node |> getNodeChildrenAsDict |> Dict.values | |
getNodeChildrenAsDict : Node a -> Dict Label (Node a) | |
getNodeChildrenAsDict node = | |
case node.type_ of | |
Branch children -> | |
children | |
Leaf -> | |
Dict.empty | |
updateNodeChildren : (Dict Label (Node a) -> Dict Label (Node a)) -> Node a -> Node a | |
updateNodeChildren f node = | |
let | |
updatedChildren = | |
case node.type_ of | |
Branch children -> | |
f children | |
Leaf -> | |
f Dict.empty | |
in | |
if Dict.isEmpty updatedChildren then | |
{ node | type_ = Leaf } | |
else | |
{ node | type_ = Branch updatedChildren } | |
getRoots : Forest a -> List (Node a) | |
getRoots forest = | |
forest | |
|> Dict.values | |
getNodeDegree : Node a -> Int | |
getNodeDegree node = | |
case node.type_ of | |
Branch children -> | |
Dict.size children | |
Leaf -> | |
0 | |
getSingleRoot : Forest a -> Maybe (Node a) | |
getSingleRoot forest = | |
case getRoots forest of | |
[ root ] -> | |
Just root | |
_ -> | |
Nothing | |
hasNodeChildren : Node a -> Bool | |
hasNodeChildren node = | |
getNodeDegree node > 0 | |
getNodeContent : Node a -> a | |
getNodeContent = | |
.content | |
updateNodeContent : (a -> a) -> Node a -> Node a | |
updateNodeContent f node = | |
{ node | content = f node.content } | |
getNodeLabel : Node a -> Label | |
getNodeLabel = | |
.label | |
getNodeAncestorsLabels : Node a -> List Label | |
getNodeAncestorsLabels = | |
.ancestorsLabels | |
getNodePath : Node a -> List Label | |
getNodePath node = | |
node.ancestorsLabels ++ [ node.label ] | |
getRootsCount : Forest a -> Int | |
getRootsCount forest = | |
Dict.size forest | |
createForest : | |
List a | |
-> (( a, c ) -> ( a, c )) | |
-> c | |
-> (a -> Label) | |
-> (a -> List a) | |
-> (a -> b) | |
-> ( Forest b, c ) | |
createForest rootContents contentUpdate contentUpdateCustomAcc contentToLabel getContentChildren cleanContent = | |
createSubForest | |
[] | |
rootContents | |
contentUpdate | |
contentUpdateCustomAcc | |
contentToLabel | |
getContentChildren | |
cleanContent | |
createSubForest : | |
List Label | |
-> List a | |
-> (( a, c ) -> ( a, c )) | |
-> c | |
-> (a -> Label) | |
-> (a -> List a) | |
-> (a -> b) | |
-> ( Forest b, c ) | |
createSubForest ancestorsLabelsFromParentForest rootContents contentUpdate contentUpdateCustomAcc contentToLabel getContentChildren cleanContent = | |
let | |
( nodes, finalCustomAcc ) = | |
convertContentsToNodes | |
ancestorsLabelsFromParentForest | |
rootContents | |
contentUpdate | |
contentUpdateCustomAcc | |
contentToLabel | |
getContentChildren | |
in | |
( nodes | |
|> List.map (\n -> Node n.ancestorsLabels n.label (cleanContent n.content) Leaf) | |
|> List.foldl (upsertNodeIntoSubForest ancestorsLabelsFromParentForest) createEmptyForest | |
, finalCustomAcc | |
) | |
convertContentsToNodes : | |
List Label | |
-> List a | |
-> (( a, c ) -> ( a, c )) | |
-> c | |
-> (a -> Label) | |
-> (a -> List a) | |
-> ( List (Node a), c ) | |
convertContentsToNodes rootsAncestorsLabels rootContents contentUpdate contentUpdateCustomAcc contentToLabel getContentChildren = | |
let | |
( nodes, finalCustomAcc ) = | |
doConvertContentsToNodes | |
rootContents | |
contentUpdate | |
contentUpdateCustomAcc | |
contentToLabel | |
getContentChildren | |
rootsAncestorsLabels | |
[] | |
in | |
( nodes | |
|> List.sortWith | |
(\treeA treeB -> | |
compare (List.length treeA.ancestorsLabels) (List.length treeB.ancestorsLabels) | |
) | |
, finalCustomAcc | |
) | |
doConvertContentsToNodes : | |
List a | |
-> (( a, c ) -> ( a, c )) | |
-> c | |
-> (a -> Label) | |
-> (a -> List a) | |
-> AncestorsLabels | |
-> List (Node a) | |
-> ( List (Node a), c ) | |
doConvertContentsToNodes contents contentUpdate contentUpdateCustomAcc contentToLabel getContentChildren ancestorsLabels nodes = | |
case contents of | |
[] -> | |
( nodes, contentUpdateCustomAcc ) | |
contents -> | |
contents | |
|> List.foldl | |
(\content ( accNodes, accCustom ) -> | |
let | |
( updatedContent, updatedAccCustom ) = | |
contentUpdate ( content, accCustom ) | |
node = | |
updatedContent |> createNode ancestorsLabels contentToLabel | |
contentChildren = | |
getContentChildren updatedContent | |
in | |
doConvertContentsToNodes | |
contentChildren | |
contentUpdate | |
updatedAccCustom | |
contentToLabel | |
getContentChildren | |
(ancestorsLabels ++ [ contentToLabel updatedContent ]) | |
(node :: nodes) | |
|> Tuple.mapFirst ((++) accNodes) | |
) | |
( [], contentUpdateCustomAcc ) | |
filterNodesByLabel : Label -> Forest a -> List (Node a) | |
filterNodesByLabel label forest = | |
filterNodes (\node -> getNodeLabel node == label) forest | |
filterNodes : (Node a -> Bool) -> Forest a -> List (Node a) | |
filterNodes filter forest = | |
let | |
results = | |
forest | |
|> Dict.filter (\_ node -> filter node) | |
|> Dict.values | |
childrenResults = | |
forest | |
|> Dict.map | |
(\_ node -> | |
case node.type_ of | |
Branch children -> | |
filterNodes filter children | |
Leaf -> | |
[] | |
) | |
|> Dict.values | |
|> List.concat | |
in | |
results ++ childrenResults | |
forestToContents : Forest a -> List a | |
forestToContents forest = | |
let | |
results = | |
forest | |
|> Dict.values | |
|> List.map getNodeContent | |
childrenResults = | |
forest | |
|> Dict.map | |
(\_ node -> | |
case node.type_ of | |
Branch children -> | |
forestToContents children | |
Leaf -> | |
[] | |
) | |
|> Dict.values | |
|> List.concat | |
in | |
results ++ childrenResults | |
isNodeRoot : Node a -> Bool | |
isNodeRoot = | |
.ancestorsLabels >> List.isEmpty | |
isNodeAncestorOf : Node a -> Node a -> Bool | |
isNodeAncestorOf descendant ancestor = | |
let | |
descendantAncestors = | |
descendant |> getNodeAncestorsLabels | |
ancestorPath = | |
ancestor |> getNodePath | |
in | |
ancestorPath |> listIsPrefixOf descendantAncestors | |
deleteNode : Node a -> Forest a -> Forest a | |
deleteNode node forest = | |
case getNodeWithAncestors node.ancestorsLabels Nothing forest of | |
Just ancestors -> | |
propagateTreeChangeToRoots True (node :: ancestors) forest | |
Nothing -> | |
forest | |
updateNodeLabel : (Label -> Label) -> Bool -> Node a -> Node a | |
updateNodeLabel f rebuildDescendants node = | |
let | |
updatedNode = | |
{ node | label = f node.label } | |
in | |
if rebuildDescendants then | |
updatedNode | |
|> rebuildNodeDescendants identity Nothing | |
|> Tuple.first | |
else | |
updatedNode | |
updateNodeAncestorsLabels : (List Label -> List Label) -> Bool -> Node a -> Node a | |
updateNodeAncestorsLabels f rebuildDescendants node = | |
let | |
updatedNode = | |
{ node | ancestorsLabels = f node.ancestorsLabels } | |
in | |
if rebuildDescendants then | |
updatedNode | |
|> rebuildNodeDescendants identity Nothing | |
|> Tuple.first | |
else | |
updatedNode | |
rebuildForest : (( Node a, c ) -> ( Node a, c )) -> c -> Forest a -> ( Forest a, c ) | |
rebuildForest nodeUpdate nodeUpdateCustomAcc forest = | |
rebuildSubForest [] nodeUpdate nodeUpdateCustomAcc forest | |
rebuildSubForest : List Label -> (( Node a, c ) -> ( Node a, c )) -> c -> Forest a -> ( Forest a, c ) | |
rebuildSubForest ancestorsLabelsFromParentForest nodeUpdate nodeUpdateCustomAcc forest = | |
createSubForest | |
ancestorsLabelsFromParentForest | |
(getRoots forest) | |
nodeUpdate | |
nodeUpdateCustomAcc | |
getNodeLabel | |
getNodeChildren | |
getNodeContent | |
rebuildNodeDescendants : (( Node a, c ) -> ( Node a, c )) -> c -> Node a -> ( Node a, c ) | |
rebuildNodeDescendants nodeUpdate nodeUpdateCustomAcc node = | |
let | |
( updatedChildren, finalCustomAcc ) = | |
node | |
|> getNodeChildrenAsDict | |
|> rebuildSubForest | |
(node |> getNodePath) | |
nodeUpdate | |
nodeUpdateCustomAcc | |
in | |
( node |> updateNodeChildren (always updatedChildren), finalCustomAcc ) | |
nodeToForest : Maybe (Node a) -> Forest a | |
nodeToForest node = | |
case node of | |
Just node -> | |
Dict.singleton (getNodeLabel node) node | |
Nothing -> | |
createEmptyForest | |
getNodeParent : Node a -> Forest a -> Maybe (Node a) | |
getNodeParent node forest = | |
getNodeByPath (getNodeAncestorsLabels node) forest |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
module Utils.LTreeTest exposing (..) | |
import Expect exposing (Expectation) | |
import Test exposing (..) | |
import Utils.LTree as LTree | |
type alias Model = | |
{ trainings : LTree.Forest NodeContent | |
} | |
type NodeContent | |
= Training_tc Training | |
| Day_tc Day | |
| BodyPart_tc BodyPart | |
type alias Training = | |
{ id : String | |
, name : String | |
, description : String | |
, days : List Day | |
} | |
type alias Day = | |
{ id : String | |
, name : String | |
, bodyParts : List BodyPart | |
} | |
type alias BodyPart = | |
{ id : String | |
, name : String | |
, completed : Bool | |
} | |
getModel : Model | |
getModel = | |
Model LTree.createEmptyForest | |
training_1 : Training | |
training_1 = | |
{ id = "t_1" | |
, name = "Super training" | |
, description = "Mega super training" | |
, days = [ day_1, day_2 ] | |
} | |
training_2 : Training | |
training_2 = | |
{ id = "t_2" | |
, name = "Light training" | |
, description = "Training zero" | |
, days = [ day_2 ] | |
} | |
day_1 : Day | |
day_1 = | |
{ id = "d_1" | |
, name = "Monday" | |
, bodyParts = [ bodyPart_1 ] | |
} | |
day_2 : Day | |
day_2 = | |
{ id = "d_2" | |
, name = "Rest day" | |
, bodyParts = [] | |
} | |
bodyPart_1 : BodyPart | |
bodyPart_1 = | |
{ id = "bp_1" | |
, name = "Chest" | |
, completed = True | |
} | |
contentUpdate = | |
identity | |
contentUpdateCustomAcc = | |
Nothing | |
contentToLabel : NodeContent -> LTree.Label | |
contentToLabel content = | |
case content of | |
Training_tc t -> | |
t.id | |
Day_tc d -> | |
d.id | |
BodyPart_tc bp -> | |
bp.id | |
getContentChildren : NodeContent -> List NodeContent | |
getContentChildren parent = | |
case parent of | |
Training_tc t -> | |
List.map Day_tc t.days | |
Day_tc d -> | |
List.map BodyPart_tc d.bodyParts | |
BodyPart_tc bp -> | |
[] | |
cleanContent : NodeContent -> NodeContent | |
cleanContent content = | |
case content of | |
Training_tc t -> | |
Training_tc { t | days = [] } | |
Day_tc d -> | |
Day_tc { d | bodyParts = [] } | |
BodyPart_tc _ -> | |
content | |
suite : Test | |
suite = | |
describe "Nodes tests" | |
-------------------- | |
[ test "Can create root nodes" <| | |
\_ -> | |
let | |
childrenCount = | |
getModel.trainings | |
|> (LTree.createNode [] contentToLabel (Training_tc training_1) |> LTree.upsertNode) | |
|> (LTree.createNode [] contentToLabel (Training_tc training_2) |> LTree.upsertNode) | |
|> LTree.getRootsCount | |
in | |
childrenCount |> Expect.equal 2 | |
-------------------- | |
, test "Tree with the same Id should be updated" <| | |
\_ -> | |
let | |
childrenCount = | |
getModel.trainings | |
|> (LTree.createNode [] contentToLabel (Training_tc training_1) |> LTree.upsertNode) | |
|> (LTree.createNode [] contentToLabel (Training_tc training_1) |> LTree.upsertNode) | |
|> LTree.getRootsCount | |
in | |
childrenCount |> Expect.equal 1 | |
-------------------- | |
, test "Can create sub-trees" <| | |
\_ -> | |
let | |
childrenCount = | |
getModel.trainings | |
|> (LTree.createNode [] contentToLabel (Training_tc training_1) |> LTree.upsertNode) | |
|> (LTree.createNode [ "t_1" ] contentToLabel (Day_tc day_1) |> LTree.upsertNode) | |
|> (LTree.createNode [ "t_1" ] contentToLabel (Day_tc day_2) |> LTree.upsertNode) | |
|> LTree.getNodeByPath [ "t_1" ] | |
|> Maybe.andThen (Just << LTree.getNodeDegree) | |
|> Maybe.withDefault -1 | |
in | |
childrenCount |> Expect.equal 2 | |
-------------------- | |
, test "Can create sub-sub-trees" <| | |
\_ -> | |
let | |
childrenCount = | |
getModel.trainings | |
|> (LTree.createNode [] contentToLabel (Training_tc training_1) |> LTree.upsertNode) | |
|> (LTree.createNode [ "t_1" ] contentToLabel (Day_tc day_1) |> LTree.upsertNode) | |
|> (LTree.createNode [ "t_1", "d_1" ] contentToLabel (BodyPart_tc bodyPart_1) | |
|> LTree.upsertNode | |
) | |
|> LTree.getNodeByPath [ "t_1", "d_1" ] | |
|> Maybe.andThen (Just << LTree.getNodeDegree) | |
|> Maybe.withDefault -1 | |
in | |
childrenCount |> Expect.equal 1 | |
-------------------- | |
, test "Can build forest from prepared data" <| | |
\_ -> | |
let | |
rootContents = | |
[ training_1, training_2 ] |> List.map Training_tc | |
( forest, _ ) = | |
LTree.createForest | |
rootContents | |
contentUpdate | |
contentUpdateCustomAcc | |
contentToLabel | |
getContentChildren | |
cleanContent | |
testChildrenCount = | |
forest | |
|> LTree.getNode [ "t_1" ] "d_1" | |
|> Maybe.andThen (Just << LTree.getNodeDegree) | |
|> Maybe.withDefault -1 | |
in | |
testChildrenCount |> Expect.equal 1 | |
-------------------- | |
, test "Can filter nodes by label" <| | |
\_ -> | |
let | |
rootContents = | |
[ training_1, training_2 ] |> List.map Training_tc | |
( forest, _ ) = | |
LTree.createForest | |
rootContents | |
contentUpdate | |
contentUpdateCustomAcc | |
contentToLabel | |
getContentChildren | |
cleanContent | |
nodesLabels = | |
forest | |
|> LTree.filterNodesByLabel "d_1" | |
|> List.map LTree.getNodeLabel | |
in | |
nodesLabels |> Expect.equal [ "d_1" ] | |
, test "Can filter nodes" <| | |
\_ -> | |
let | |
rootContents = | |
[ training_1, training_2 ] |> List.map Training_tc | |
( forest, _ ) = | |
LTree.createForest | |
rootContents | |
contentUpdate | |
contentUpdateCustomAcc | |
contentToLabel | |
getContentChildren | |
cleanContent | |
nodesLabels = | |
forest | |
|> LTree.filterNodes (always True) | |
|> List.map LTree.getNodeLabel | |
in | |
nodesLabels |> Expect.equal [ "t_1", "t_2", "d_1", "d_2", "bp_1", "d_2" ] | |
] |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment