Fix vertex loss in transformation for all-letter-ending node groups

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
 

src-extra/transformation/JbeamEdit/Transformation.hs

@@ -5,7 +5,7 @@
 import Data.Bool (bool)
 import Data.Foldable.Extra (notNull)
 import Data.Function (on)
 import Data.List (foldl', partition)
 import Data.List.NonEmpty (NonEmpty)
 import Data.List.NonEmpty qualified as NE
 import Data.Map (Map)
@@ -130,9 +130,19 @@
               . 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 @@
         ]
 
       brks = xGroupBreakpoints tfCfg
-      thr = zSortingThreshold tfCfg
+      thr = ySortingThreshold tfCfg
 
       assignSupportNames = assignNames newNames brks SupportTree
 
@@ -218,22 +228,19 @@
           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 @@
       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 @@
   -> 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
 

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

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

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 =