diff --git a/examples/jbeam-edit.yaml b/examples/jbeam-edit.yaml index e8c5a01d..906ae8ea 100644 --- a/examples/jbeam-edit.yaml +++ b/examples/jbeam-edit.yaml @@ -1,4 +1,4 @@ -z-sorting-threshold: 0.05 +y-sorting-threshold: 0.05 support-threshold: 96 max-support-coordinates: 3 diff --git a/src-extra/transformation/JbeamEdit/Transformation.hs b/src-extra/transformation/JbeamEdit/Transformation.hs index 98811a81..34681f0e 100644 --- a/src-extra/transformation/JbeamEdit/Transformation.hs +++ b/src-extra/transformation/JbeamEdit/Transformation.hs @@ -130,9 +130,19 @@ addVertexTreeToForest newNames tf grouped forest forestAcc t = . addPrefixComments t . fmap (sortVertices t newNames tf) $ groupByPrefix origTree groupsForT - in Right (M.insert t tree forestAcc) + in Right (M.insertWith mergeOMap1Trees t tree forestAcc) Nothing -> Right forestAcc +mergeOMap1Trees + :: OMap1 VertexTreeKey VertexTree + -> OMap1 VertexTreeKey VertexTree + -> OMap1 VertexTreeKey VertexTree +mergeOMap1Trees new existing = + foldl' go existing (OMap1.assocs new) + where + merge (VertexTree _ newVerts) (VertexTree ec ev) = VertexTree ec (ev <> newVerts) + go acc (k, v) = OMap1.insertWith merge k v acc + groupAnnotatedVertices :: XGroupBreakpoints -> AnnotatedVertex @@ -169,7 +179,7 @@ moveSupportVertices newNames tfCfg connMap vsPerType = ] brks = xGroupBreakpoints tfCfg - thr = zSortingThreshold tfCfg + thr = ySortingThreshold tfCfg assignSupportNames = assignNames newNames brks SupportTree @@ -218,22 +228,19 @@ moveVerticesInVertexForest topNode newNames tfCfg vertexTrees = vertexTrees brks = xGroupBreakpoints tfCfg in case mapM (groupAnnotatedVertices brks) allVertices of - Right movableVertices' -> do + Right movableVertices' -> let groupedVertices = M.fromListWith (++) movableVertices' - (badBeamNodes, conns) <- - vertexConns (maxSupportCoordinates tfCfg) topNode groupedVertices - let (supportForest, nonSupportVertices) = - moveSupportVertices - newNames - tfCfg - conns - groupedVertices - newForest <- - foldM - (addVertexTreeToForest newNames tfCfg nonSupportVertices vertexTrees) - supportForest - treesOrder - Right (badBeamNodes, newForest) + in do + (badBeamNodes, conns) <- + vertexConns (maxSupportCoordinates tfCfg) topNode groupedVertices + let (supportForest, nonSupportVertices) = + moveSupportVertices newNames tfCfg conns groupedVertices + newForest <- + foldM + (addVertexTreeToForest newNames tfCfg nonSupportVertices vertexTrees) + supportForest + treesOrder + Right (badBeamNodes, newForest) Left err -> Left err getVertexNamesInForest @@ -335,8 +342,8 @@ compareAV thr treeType vertex1 vertex2 = y2 = vY . aVertex $ vertex2 compareZ = comparing (vZ . aVertex) vertex1 vertex2 compareY = - let zDiff = abs $ y1 - y2 - in bool EQ (compare y1 y2) (zDiff > thr) + let yDiff = abs $ y1 - y2 + in bool EQ (compare y1 y2) (yDiff > thr) compareX = on compare (vX . aVertex) vertex1 vertex2 in mconcat [ supportNameCompare @@ -397,7 +404,7 @@ sortVertices -> VertexTree -> VertexTree sortVertices treeType newNames tfCfg (VertexTree comments vertices) = - let thr = zSortingThreshold tfCfg + let thr = ySortingThreshold tfCfg brks = xGroupBreakpoints tfCfg sortedGroups = NE.sortBy (compareAV thr treeType) vertices diff --git a/src-extra/transformation/JbeamEdit/Transformation/Config.hs b/src-extra/transformation/JbeamEdit/Transformation/Config.hs index db68c94f..1070f9b7 100644 --- a/src-extra/transformation/JbeamEdit/Transformation/Config.hs +++ b/src-extra/transformation/JbeamEdit/Transformation/Config.hs @@ -64,7 +64,7 @@ defaultBreakpoints = ] data TransformationConfig = TransformationConfig - { zSortingThreshold :: Scientific + { ySortingThreshold :: Scientific , xGroupBreakpoints :: XGroupBreakpoints , supportThreshold :: Double , maxSupportCoordinates :: Natural @@ -137,7 +137,7 @@ parseSupportThreshold o = do instance FromJSON TransformationConfig where parseJSON = withObject "TransformationConfig" $ \o -> TransformationConfig - <$> o .:? "z-sorting-threshold" .!= defaultSortingThreshold + <$> o .:? "y-sorting-threshold" .!= defaultSortingThreshold <*> o .:? "x-group-breakpoints" .!= defaultBreakpoints <*> parseSupportThreshold o <*> o .:? "max-support-coordinates" .!= defaultMaxSupportCoordinates diff --git a/src-extra/transformation/JbeamEdit/Transformation/OMap1.hs b/src-extra/transformation/JbeamEdit/Transformation/OMap1.hs index 14a2e98f..aa4aa587 100644 --- a/src-extra/transformation/JbeamEdit/Transformation/OMap1.hs +++ b/src-extra/transformation/JbeamEdit/Transformation/OMap1.hs @@ -7,6 +7,7 @@ module JbeamEdit.Transformation.OMap1 ( lookup, assocs, consOMap, + insertWith, singleton, head, snoc, @@ -74,6 +75,16 @@ uncons (OMap1 (firstK, firstV) rest) = Just newFirst@(newFirstK, _) -> (firstK, firstV, newFirst OMap.<| OMap.delete newFirstK rest) Nothing -> (firstK, firstV, OMap.empty) +insertWith :: Ord k => (v -> v -> v) -> k -> v -> OMap1 k v -> OMap1 k v +insertWith f k v omap = + case lookup k omap of + Nothing -> fromList (assocs omap <> [(k, v)]) + Just existing -> + fromList $ + map + (\(k', v') -> if k' == k then (k', f v existing) else (k', v')) + (assocs omap) + snoc :: Ord k => k -> v -> OMap1 k v -> OMap1 k v snoc newLastK newLastV (OMap1 oldFirst rest) | fst oldFirst == newLastK = OMap1 (newLastK, newLastV) rest diff --git a/src-extra/transformation/JbeamEdit/Transformation/VertexExtraction.hs b/src-extra/transformation/JbeamEdit/Transformation/VertexExtraction.hs index a3298741..38ae1dae 100644 --- a/src-extra/transformation/JbeamEdit/Transformation/VertexExtraction.hs +++ b/src-extra/transformation/JbeamEdit/Transformation/VertexExtraction.hs @@ -146,14 +146,10 @@ getVertexTreePrefix vt = maybe SupportKey PrefixKey (getVertexPrefix . anVertexN insertTreeInMap :: VertexTree -> OMap1 VertexTreeKey VertexTree -> OMap1 VertexTreeKey VertexTree -insertTreeInMap (VertexTree newComments newVertexGroups) = +insertTreeInMap (VertexTree newComments newVertexGroups) omap = let vType = getVertexTreePrefix newVertexGroups - vertexTree = - VertexTree - { tComments = newComments - , tAnnotatedVertices = newVertexGroups - } - in OMap1.snoc vType vertexTree + merge _ (VertexTree ec ev) = VertexTree ec (ev <> newVertexGroups) + in OMap1.insertWith merge vType (VertexTree newComments newVertexGroups) omap isSupportVertex :: Vertex -> Bool isSupportVertex v =