Skip to content

Commit e536965

Browse files
webdevredwebdevred
committed
Good steps
- improved building the vertex tree - added code for filtering out vertices to move
1 parent 96b6d69 commit e536965

File tree

1 file changed

+93
-43
lines changed

1 file changed

+93
-43
lines changed

‎src/Transformation.hs

Lines changed: 93 additions & 43 deletions
Original file line numberDiff line numberDiff line change
@@ -2,23 +2,18 @@ module Transformation (
22
transform,
33
) where
44

5-
import Control.Arrow ((&&&))
6-
import Control.Monad (guard)
75
import Core.Node
86
import Data.Char (isDigit)
9-
import Data.Foldable1 (maximumBy)
107
import Data.Function (on)
11-
import Data.List.NonEmpty (NonEmpty, (<|))
12-
import Data.Map (Map)
13-
import Data.Maybe (fromJust, fromMaybe, isJust, isNothing, mapMaybe)
8+
import Data.List (partition)
9+
import Data.List.NonEmpty (NonEmpty, toList)
10+
import Data.Maybe (fromJust, isJust, isNothing, mapMaybe)
1411
import Data.Scientific (Scientific)
15-
import Data.Sequence (Seq (..))
1612
import Data.Text (Text)
17-
import Data.Vector (Vector, (!), (!?), (//))
1813
import GHC.IsList (fromList)
1914

20-
import Core.NodeCursor qualified as NC
2115
import Core.NodePath qualified as NP
16+
import Data.Foldable qualified as F (foldr, maximumBy)
2217
import Data.List.NonEmpty qualified as NE
2318
import Data.Map qualified as M
2419
import Data.Text qualified as T
@@ -34,13 +29,15 @@ data VertexTreeType
3429
data VertexTreeEntry
3530
= VertexEntry Vertex
3631
| MetaEntry Node
37-
| MiscEntry Node
32+
| HeaderEntry Node
33+
deriving (Show)
3834

3935
data VertexTree = VertexTree
4036
{ tNodes :: NonEmpty VertexTreeEntry
4137
, tRest :: Maybe VertexTree
4238
, tType :: VertexTreeType
4339
}
40+
deriving (Show)
4441

4542
data Vertex = Vertex
4643
{ vName :: Text
@@ -69,45 +66,50 @@ hasVerticePrefix verticePrefix node =
6966
let verticeName = vName <$> newVertice node
7067
in verticeName == Just verticePrefix
7168

72-
getFirstVerticeName :: [Node] -> Text
73-
getFirstVerticeName (node : _) = vName . fromJust . newVertice $ node
69+
getFirstVerticeName :: [Node] -> Maybe Text
70+
getFirstVerticeName (node : _) = vName <$> newVertice node
71+
getFirstVerticeName _ = Nothing
7472

75-
breakVertices :: Text -> [Node] -> ([Node], [Node])
76-
breakVertices verticePrefix = f []
73+
breakVertices :: Maybe Text -> [Node] -> ([Node], [Node])
74+
breakVertices Nothing = error "expected at least one Vertex"
75+
breakVertices (Just verticePrefix) = go []
7776
where
78-
typeForVerticeList = mostCommon . NE.map (determineGroup . vX)
79-
f acc nodes =
80-
case nodes of
81-
[] -> (acc, [])
82-
(node : rest)
83-
| hasVerticePrefix verticePrefix node -> (node : acc, nodes)
84-
| isNonVertice node -> (node : acc, nodes)
85-
| isVertice node ->
86-
let (metaNodesNext, currentNodes) = span isNonVertice acc
87-
in (currentNodes, metaNodesNext ++ (node : rest))
77+
go acc [] = (reverse acc, [])
78+
go acc (node : rest)
79+
| isNonVertice node = go (node : acc) rest
80+
| hasVerticePrefix verticePrefix node = go (node : acc) rest
81+
| isVertice node =
82+
let (metaBefore, currentTree) = span isNonVertice acc
83+
in if null currentTree
84+
then ([node], reverse metaBefore ++ rest)
85+
else (reverse currentTree, reverse metaBefore ++ (node : rest))
86+
| otherwise = go (node : acc) rest
8887

8988
toVertexTreeEntry :: Node -> VertexTreeEntry
90-
toVertexTreeEntry node
91-
| isJust vertice = VertexEntry (fromJust vertice)
92-
| isNothing vertice && isObjectNode node = MetaEntry node
93-
| otherwise = MiscEntry node
94-
where
95-
vertice = newVertice node
89+
toVertexTreeEntry node =
90+
case newVertice node of
91+
Just vertice -> VertexEntry vertice
92+
Nothing
93+
| isObjectNode node -> MetaEntry node
94+
| otherwise -> HeaderEntry node
9695

97-
typeForNodes = undefined
96+
mostCommon :: NonEmpty VertexTreeType -> VertexTreeType
97+
mostCommon = NE.head . F.maximumBy (compare `on` length) . NE.group1 . NE.sort
9898

9999
nodesListToTree :: NonEmpty Node -> VertexTree
100100
nodesListToTree nodes =
101-
let (nonVertices, rest) = NE.break isNonVertice nodes
102-
verticePrefix = T.dropWhileEnd isDigit $ getFirstVerticeName rest
103-
(vertices, rest') = breakVertices verticePrefix rest
104-
in VertexTree
105-
{ tNodes =
106-
NE.fromList
107-
(map toVertexTreeEntry (nonVertices ++ reverse vertices))
108-
, tRest = nodesListToTree <$> NE.nonEmpty rest'
109-
, tType = typeForNodes vertices
110-
}
101+
let (nonVertices, rest) = NE.span isNonVertice nodes
102+
verticePrefix = T.dropWhileEnd isDigit <$> getFirstVerticeName rest
103+
(vertexNodes, rest') = breakVertices verticePrefix rest
104+
vertices = mapMaybe newVertice vertexNodes
105+
in case NE.nonEmpty vertices of
106+
Nothing -> error "expected at least one Vertex"
107+
Just vs ->
108+
VertexTree
109+
{ tNodes = NE.fromList (map toVertexTreeEntry (nonVertices ++ vertexNodes))
110+
, tRest = nodesListToTree <$> NE.nonEmpty rest'
111+
, tType = mostCommon $ NE.map (determineGroup . vX) vs
112+
}
111113

112114
getVertexTree :: Node -> VertexTree
113115
getVertexTree topNode =
@@ -122,14 +124,61 @@ getVertexTree topNode =
122124
| otherwise -> nodesListToTree . NE.fromList . V.toList $ ns
123125
bad -> error $ show bad
124126

125-
updateVertices = undefined
127+
vertexInCorrectTree :: VertexTreeType -> Vertex -> Bool
128+
vertexInCorrectTree ttype vertex =
129+
ttype == determineGroup (vX vertex)
130+
131+
determineGroup :: Scientific -> VertexTreeType
132+
determineGroup x
133+
| x < -0.09 = RightTree
134+
| x < 0.09 = MiddleTree
135+
| otherwise = LeftTree
136+
137+
filterVerticesToMove :: VertexTree -> ([Vertex], Maybe VertexTree)
138+
filterVerticesToMove (VertexTree entries maybeRest ttype) =
139+
let (removedHere, keptHere) = F.foldr step ([], []) (toList entries)
140+
step entry (remAcc, keepAcc) = case entry of
141+
VertexEntry v ->
142+
if vertexInCorrectTree ttype v
143+
then (remAcc, entry : keepAcc)
144+
else (v : remAcc, keepAcc)
145+
_ -> (remAcc, entry : keepAcc)
146+
(removedRest, newRest) = case maybeRest of
147+
Nothing -> ([], Nothing)
148+
Just subTree ->
149+
let (rs, newSub) = filterVerticesToMove subTree
150+
in (rs, newSub)
151+
allRemoved = removedHere ++ removedRest
152+
in case NE.nonEmpty keptHere of
153+
Nothing -> (allRemoved, newRest)
154+
Just kept -> (allRemoved, Just (VertexTree kept newRest ttype))
155+
156+
moveVertices :: [Vertex] -> VertexTree -> VertexTree
157+
moveVertices vsToMove (VertexTree nodes restTree ttype) =
158+
let sameTreeType vertex = determineGroup (vX vertex) == ttype
159+
(toThisGroup, toOtherGroup) = partition sameTreeType vsToMove
160+
vertexEntries = map VertexEntry toThisGroup
161+
in VertexTree
162+
{ tNodes = nodes `NE.appendList` vertexEntries
163+
, tRest = moveVertices toOtherGroup <$> restTree
164+
, tType = ttype
165+
}
166+
167+
updateVertices :: VertexTree -> VertexTree
168+
updateVertices vertexTree =
169+
let (vsToMove, vertexTree') = filterVerticesToMove vertexTree
170+
in moveVertices vsToMove (fromJust vertexTree')
126171

127172
verticeQuery :: NP.NodePath
128173
verticeQuery = fromList [NP.ObjectIndex 0, NP.ObjectKey "nodes"]
129174

175+
possiblyVertice :: VertexTreeEntry -> Maybe Vertex
130176
possiblyVertice (VertexEntry v) = Just v
131177
possiblyVertice _ = Nothing
132178

179+
getVertexNamesInTree
180+
:: VertexTree
181+
-> M.Map (Scientific, Scientific, Scientific) Text
133182
getVertexNamesInTree vertexTree@(VertexTree {tNodes = vs}) =
134183
let verticeCordNamePair vertice = ((vX vertice, vY vertice, vZ vertice), vName vertice)
135184
getVertexNames =
@@ -140,9 +189,10 @@ getVertexNamesInTree vertexTree@(VertexTree {tNodes = vs}) =
140189
VertexTree {tRest = Nothing} -> M.empty
141190
in M.union (getVertexNames vs) restNames
142191

192+
transform :: Node -> Node
143193
transform topNode =
144194
let vertexTree = getVertexTree topNode
145195
vertexNames = getVertexNamesInTree vertexTree
146196
updatedVertexTree = updateVertices vertexTree
147197
updatedVertexNames = getVertexNamesInTree vertexTree
148-
in undefined
198+
in error $ show updatedVertexTree

0 commit comments

Comments
 (0)