Create a gist now

Instantly share code, notes, and snippets.

@MartinKavik /LTree.elm
Last active Jun 27, 2018

Embed
What would you like to do?
Download ZIP
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.
Raw
LTree.elm
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
Raw
LTreeTest.elm
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