···11+module TreeUnfold (unfoldFullTree) where
22+33+import Papa
44+import Data.Tree.Lens
55+import Data.Tree
66+77+-- check if the root of tree matches to the incoming item
88+check :: Eq a => a -> Tree a -> Bool
99+check i = (== i) . rootLabel
1010+1111+-- create a traversal of plates as per the depth required by the unfold operation
1212+platesPerDepth :: (Plated a, Applicative f) => Int -> ((a -> f a) -> a -> f a)
1313+platesPerDepth i = foldl' (\g p -> plate . g) id [0..i]
1414+1515+fn :: Eq a => Int -> (Tree a, [a]) -> a -> (Tree a, [a])
1616+fn i (ts,ys) x = if isInLevel
1717+ then
1818+ (ts,ys) -- ^ if new node is already there then move on
1919+ else
2020+ (append ts,ys) -- ^ append the new node to the right parent
2121+ where
2222+ newNode = Node x [] -- ^ new node
2323+ parent = ys ^?! ix (i - 1) -- ^ parent index, required in case of a new child
2424+ isInLevel = isJust $ ts ^? platesPerDepth i . filtered (check x) -- ^ check if new node is already there in this level
2525+ append = bool (over (platesPerDepth (i - 1) . filtered (check parent)) (branches <>~ [newNode])) -- ^ add the new node as a new child to a specific parent
2626+ (over branches (<> [newNode])) -- ^ if first node then just add it there
2727+ (i == 0) -- ^ check if it's first node
2828+2929+3030+-- unfold a tree from list of lists where each list is for items that signifies
3131+-- the path of an element (last one of the list) right from the top of the tree
3232+--
3333+-- the function takes an initial tree as the container tree within which rest of the final tree is constructed
3434+--
3535+unfoldFullTree :: Eq a => Tree a -> [[a]] -> Tree a
3636+unfoldFullTree = foldl' (\t ys -> fst $ ifoldl' fn (t,ys) ys)
+162
Design2Html/TreeUnfold.ipynb
···11+{
22+ "cells": [
33+ {
44+ "cell_type": "code",
55+ "execution_count": 1,
66+ "metadata": {},
77+ "outputs": [],
88+ "source": [
99+ ":set -XNoImplicitPrelude"
1010+ ]
1111+ },
1212+ {
1313+ "cell_type": "code",
1414+ "execution_count": 2,
1515+ "metadata": {},
1616+ "outputs": [],
1717+ "source": [
1818+ "module TreeUnfold (unfoldFullTree) where\n",
1919+ "\n",
2020+ "import Papa\n",
2121+ "import Data.Tree.Lens\n",
2222+ "import Data.Tree\n",
2323+ "\n",
2424+ "-- check if the root of tree matches to the incoming item\n",
2525+ "check :: Eq a => a -> Tree a -> Bool\n",
2626+ "check i = (== i) . rootLabel\n",
2727+ "\n",
2828+ "-- create a traversal of plates as per the depth required by the unfold operation\n",
2929+ "platesPerDepth :: (Plated a, Applicative f) => Int -> ((a -> f a) -> a -> f a)\n",
3030+ "platesPerDepth i = foldl' (\\g p -> plate . g) id [0..i]\n",
3131+ "\n",
3232+ "fn :: Eq a => Int -> (Tree a, [a]) -> a -> (Tree a, [a])\n",
3333+ "fn i (ts,ys) x = if isInLevel \n",
3434+ " then \n",
3535+ " (ts,ys) -- ^ if new node is already there then move on\n",
3636+ " else \n",
3737+ " (append ts,ys) -- ^ append the new node to the right parent\n",
3838+ " where\n",
3939+ " newNode = Node x [] -- ^ new node\n",
4040+ " parent = ys ^?! ix (i - 1) -- ^ parent index, required in case of a new child\n",
4141+ " isInLevel = isJust $ ts ^? platesPerDepth i . filtered (check x) -- ^ check if new node is already there in this level\n",
4242+ " append = bool (over (platesPerDepth (i - 1) . filtered (check parent)) (branches <>~ [newNode])) -- ^ add the new node as a new child to a specific parent\n",
4343+ " (over branches (<> [newNode])) -- ^ if first node then just add it there\n",
4444+ " (i == 0) -- ^ check if it's first node\n",
4545+ "\n",
4646+ "\n",
4747+ "-- unfold a tree from list of lists where each list is for items that signifies\n",
4848+ "-- the path of an element (last one of the list) right from the top of the tree\n",
4949+ "-- \n",
5050+ "-- the function takes an initial tree as the container tree within which rest of the final tree is constructed\n",
5151+ "-- \n",
5252+ "unfoldFullTree :: Eq a => Tree a -> [[a]] -> Tree a\n",
5353+ "unfoldFullTree = foldl' (\\t ys -> fst $ ifoldl' fn (t,ys) ys)\n"
5454+ ]
5555+ },
5656+ {
5757+ "cell_type": "code",
5858+ "execution_count": 5,
5959+ "metadata": {},
6060+ "outputs": [
6161+ {
6262+ "data": {
6363+ "text/plain": [
6464+ "True"
6565+ ]
6666+ },
6767+ "metadata": {},
6868+ "output_type": "display_data"
6969+ },
7070+ {
7171+ "data": {
7272+ "text/plain": [
7373+ "True"
7474+ ]
7575+ },
7676+ "metadata": {},
7777+ "output_type": "display_data"
7878+ },
7979+ {
8080+ "data": {
8181+ "text/plain": [
8282+ "True"
8383+ ]
8484+ },
8585+ "metadata": {},
8686+ "output_type": "display_data"
8787+ },
8888+ {
8989+ "data": {
9090+ "text/plain": [
9191+ "True"
9292+ ]
9393+ },
9494+ "metadata": {},
9595+ "output_type": "display_data"
9696+ },
9797+ {
9898+ "data": {
9999+ "text/plain": [
100100+ "True"
101101+ ]
102102+ },
103103+ "metadata": {},
104104+ "output_type": "display_data"
105105+ },
106106+ {
107107+ "data": {
108108+ "text/plain": [
109109+ "True"
110110+ ]
111111+ },
112112+ "metadata": {},
113113+ "output_type": "display_data"
114114+ }
115115+ ],
116116+ "source": [
117117+ "-- Tests\n",
118118+ "import Papa\n",
119119+ "import Data.Tree\n",
120120+ "\n",
121121+ "tr1 = Node 0 []\n",
122122+ "\n",
123123+ "inp = [[1,2,4],[1,2],[1,2,4,5],[1],[1,2,3]]\n",
124124+ "unfoldFullTree tr1 inp == Node 0 [Node 1 [Node 2 [Node 4 [Node 5 []], Node 3 []]]]\n",
125125+ "\n",
126126+ "inp1 = [[1],[2],[3]]\n",
127127+ "unfoldFullTree tr1 inp1 == Node 0 [Node 1 [], Node 2 [], Node 3 []]\n",
128128+ "\n",
129129+ "inp2 = [[1,2,3], [2,3,4], [1,4,6]]\n",
130130+ "unfoldFullTree tr1 inp2 == Node 0 [Node 1 [Node 2 [Node 3 []], Node 4 [Node 6 []]], Node 2 [Node 3 [Node 4 []]]]\n",
131131+ "\n",
132132+ "inp3 = [[1,2],[1,3],[1,4],[1],[1,3,5]]\n",
133133+ "unfoldFullTree tr1 inp3 == Node 0 [Node 1 [Node 2 [], Node 3 [Node 5 []], Node 4 []]]\n",
134134+ "\n",
135135+ "inp4 = [[1,3],[1,2,5],[1,3,6,7],[1],[1,2]]\n",
136136+ "unfoldFullTree tr1 inp4 == Node 0 [Node 1 [Node 3 [Node 6 [Node 7 []]], Node 2 [Node 5 []]]]\n",
137137+ "\n",
138138+ "inp5 = [[1,2,3],[1,2],[1,3,2],[1,3],[1]]\n",
139139+ "unfoldFullTree tr1 inp5 == Node 0 [Node 1 [Node 2 [Node 3 []], Node 3 [Node 2 []]]]\n",
140140+ "\n",
141141+ "\n",
142142+ "\n"
143143+ ]
144144+ }
145145+ ],
146146+ "metadata": {
147147+ "kernelspec": {
148148+ "display_name": "Haskell",
149149+ "language": "haskell",
150150+ "name": "haskell"
151151+ },
152152+ "language_info": {
153153+ "codemirror_mode": "ihaskell",
154154+ "file_extension": ".hs",
155155+ "name": "haskell",
156156+ "pygments_lexer": "Haskell",
157157+ "version": "8.6.4"
158158+ }
159159+ },
160160+ "nbformat": 4,
161161+ "nbformat_minor": 2
162162+}