Graph: common ancestors search

3 files changed, 267 insertions, 3 deletions

diff --git a/main/Test.hs b/main/Test.hs
index e67d0b5..ad4cb0b 100644
--- a/main/Test.hs
+++ b/main/Test.hs
@@ -51,6 +51,7 @@ import Erebos.Set
 import Erebos.State
 import Erebos.Storable
 import Erebos.Storage
+import Erebos.Storage.Graph
 import Erebos.Storage.Head
 import Erebos.Storage.Merge
 import Erebos.Sync
@@ -291,6 +292,7 @@ commands =
     , ( "stored-roots", cmdStoredRoots )
     , ( "stored-set-add", cmdStoredSetAdd )
     , ( "stored-set-list", cmdStoredSetList )
+    , ( "stored-common-ancestors", cmdStoredCommonAncestors )
     , ( "stored-difference", cmdStoredDifference )
     , ( "head-create", cmdHeadCreate )
     , ( "head-replace", cmdHeadReplace )
@@ -461,6 +463,19 @@ cmdStoredSetList = do
         cmdOut $ "stored-set-item" ++ concatMap ((' ':) . show . refDigest . storedRef) item
     cmdOut $ "stored-set-done"
 
+cmdStoredCommonAncestors :: Command
+cmdStoredCommonAncestors = do
+    st <- asks tiStorage
+    ( trefs1, "|" : trefs2 ) <- span (/= "|") <$> asks tiParams
+
+    let loadObjs = mapM (maybe (fail "invalid ref") (return . wrappedLoad @Object) <=< liftIO . readRef st . encodeUtf8)
+    objs1 <- loadObjs trefs1
+    objs2 <- loadObjs trefs2
+
+    forM_ (commonAncestors objs1 objs2) $ \item -> do
+        cmdOut $ "stored-common-ancestors-item " ++ (show $ refDigest $ storedRef item)
+    cmdOut $ "stored-common-ancestors-done"
+
 cmdStoredDifference :: Command
 cmdStoredDifference = do
     st <- asks tiStorage
diff --git a/src/Erebos/Storage/Graph.hs b/src/Erebos/Storage/Graph.hs
index 7f9fbd9..79e25bc 100644
--- a/src/Erebos/Storage/Graph.hs
+++ b/src/Erebos/Storage/Graph.hs
@@ -9,6 +9,7 @@ module Erebos.Storage.Graph (
     precedes,
     precedesOrEquals,
     filterAncestors,
+    commonAncestors,
     storedRoots,
     walkAncestors,
 
@@ -23,6 +24,7 @@ module Erebos.Storage.Graph (
     graphToList,
 ) where
 
+import Control.Arrow
 import Control.Concurrent.MVar
 
 import Data.ByteString.Char8 qualified as BC
@@ -31,6 +33,7 @@ import Data.List
 import Data.List.NonEmpty (NonEmpty)
 import Data.List.NonEmpty qualified as NE
 import Data.Maybe
+import Data.Ord
 import Data.Set (Set)
 import Data.Set qualified as S
 
@@ -126,6 +129,37 @@ filterAncestors xs = let xs' = uniq $ sort xs
                                                 in helper remains' $ uniq $ sort (px ++ filter (/=x) walk)
                                      Nothing -> remains
 
+commonAncestors :: Storable a => [ Stored a ] -> [ Stored a ] -> StoredTips a
+commonAncestors [] _ = []
+commonAncestors _ [] = []
+commonAncestors oxs oys = sort $ gom oxs' oys'
+  where
+    maximumGen = maximumBy (comparing (\(Generation n) ->  n))
+    oxs' = map (storedGeneration &&& id) oxs
+    oys' = map (storedGeneration &&& id) oys
+
+    gom [] _ = []
+    gom _ [] = []
+    gom xs ys = go (maximumGen (map fst xs ++ map fst ys)) xs ys
+
+    go g xs ys =
+        let ( cxs, nxs ) = partition ((g ==) . fst) xs
+            ( cys, nys ) = partition ((g ==) . fst) ys
+            ( common, ( cxs', cys' ) ) = takeCommon (uniq $ sort $ map snd cxs) (uniq $ sort $ map snd cys)
+            pxs = map (storedGeneration &&& id) $ concatMap previous cxs'
+            pys = map (storedGeneration &&& id) $ concatMap previous cys'
+         in case ( pxs, pys ) of
+                ( [], [] ) -> common ++ gom nxs nys
+                ( _ , _  ) -> common ++ go (maximumGen (map fst pxs ++ map fst pys)) (pxs ++ nxs) (pys ++ nys)
+
+    takeCommon (x : xs) (y : ys)
+        | x < y = second (first  (x :)) $ takeCommon xs (y : ys)
+        | y < x = second (second (y :)) $ takeCommon (x : xs) ys
+        | otherwise = first (x :) $ takeCommon xs ys
+    takeCommon [] ys = ( [], ( [], ys ))
+    takeCommon xs [] = ( [], ( xs, [] ))
+
+
 storedRoots :: Storable a => Stored a -> [Stored a]
 storedRoots x = do
     let st = refStorage $ storedRef x
@@ -188,9 +222,8 @@ graphFromTips h = Graph h []
 
 graphRemoveTips :: Storable a => StoredTips a -> Graph a -> Graph a
 graphRemoveTips remove g =
-    let gtails = if null (graphTail g) then remove
-                                       else filterAncestors $ graphTail g ++ remove
-        gheads = filter (\h -> not $ any (h `precedesOrEquals`) gtails) (graphHead g)
+    let gheads = filter (\h -> not $ any (h `precedesOrEquals`) remove) (graphHead g)
+        gtails = commonAncestors gheads $ graphTail g ++ remove
      in Graph { graphHead = gheads, graphTail = gtails }
 
 graphSize :: Storable a => Graph a -> Int
diff --git a/test/graph.et b/test/graph.et
index 38ec3c4..059b0cc 100644
--- a/test/graph.et
+++ b/test/graph.et
@@ -1,5 +1,221 @@
 module graph
 
+
+test FilterCommon:
+    spawn as p
+    with p:
+        send:
+            "store rec"
+            "num:i 1"
+            ""
+        expect /store-done (blake2#[0-9a-f]*)/ capture r1_1
+
+        send:
+            "store rec"
+            "num:i 1"
+            "PREV:r $r1_1"
+            ""
+        expect /store-done (blake2#[0-9a-f]*)/ capture r2_1
+
+        send:
+            "store rec"
+            "num:i 1"
+            "PREV:r $r2_1"
+            ""
+        expect /store-done (blake2#[0-9a-f]*)/ capture r3_1
+
+        send:
+            "store rec"
+            "num:i 1"
+            "PREV:r $r3_1"
+            ""
+        expect /store-done (blake2#[0-9a-f]*)/ capture r4_1
+
+        # r4_1
+        #  |
+        # r3_1
+        #  |
+        # r2_1
+        #  |
+        # r1_1
+
+        send "stored-common-ancestors $r2_1 | $r4_1"
+        expect /stored-common-ancestors-item $r2_1/
+        local:
+            expect /stored-common-ancestors-(.*)/ capture done
+            guard (done == "done")
+
+
+        send:
+            "store rec"
+            "num:i 2"
+            "PREV:r $r2_1"
+            ""
+        expect /store-done (blake2#[0-9a-f]*)/ capture r3_2
+
+        send:
+            "store rec"
+            "num:i 2"
+            "PREV:r $r3_2"
+            ""
+        expect /store-done (blake2#[0-9a-f]*)/ capture r4_2
+
+        # r4_1  r4_2
+        #  |     |
+        # r3_1  r3_2
+        #   \   /
+        #    r2_1
+        #     |
+        #    r1_1
+
+        send "stored-common-ancestors $r4_1 | $r4_2"
+        expect /stored-common-ancestors-item $r2_1/
+        local:
+            expect /stored-common-ancestors-(.*)/ capture done
+            guard (done == "done")
+
+
+        send:
+            "store rec"
+            "num:i 3"
+            ""
+        expect /store-done (blake2#[0-9a-f]*)/ capture r1_3
+
+        send:
+            "store rec"
+            "num:i 3"
+            "PREV:r $r1_3"
+            ""
+        expect /store-done (blake2#[0-9a-f]*)/ capture r2_3
+
+        # r4_1  r4_2
+        #  |     |
+        # r3_1  r3_2
+        #   \   /
+        #    r2_1     r2_3
+        #     |        |
+        #    r1_1     r1_2
+
+        send "stored-common-ancestors $r4_1 $r4_2 | $r2_3"
+        local:
+            expect /stored-common-ancestors-(.*)/ capture done
+            guard (done == "done")
+
+
+        send:
+            "store rec"
+            "num:i 1"
+            "PREV:r $r4_1"
+            "PREV:r $r4_2"
+            ""
+        expect /store-done (blake2#[0-9a-f]*)/ capture r5_1
+
+        #    r5_1
+        #   /   \
+        # r4_1  r4_2
+        #  |     |
+        # r3_1  r3_2
+        #   \   /
+        #    r2_1
+        #     |
+        #    r1_1
+
+        send "stored-common-ancestors $r5_1 | $r3_2"
+        expect /stored-common-ancestors-item $r3_2/
+        local:
+            expect /stored-common-ancestors-(.*)/ capture done
+            guard (done == "done")
+
+
+        send:
+            "store rec"
+            "num:i 2"
+            "PREV:r $r4_2"
+            ""
+        expect /store-done (blake2#[0-9a-f]*)/ capture r5_2
+
+        #    r5_1   r5_2
+        #   /   \   /
+        # r4_1  r4_2
+        #  |     |
+        # r3_1  r3_2
+        #   \   /
+        #    r2_1
+        #     |
+        #    r1_1
+
+        send "stored-common-ancestors $r5_1 | $r5_2 $r3_1"
+        expect /stored-common-ancestors-item $r3_1/
+        expect /stored-common-ancestors-item $r4_2/
+        local:
+            expect /stored-common-ancestors-(.*)/ capture done
+            guard (done == "done")
+
+
+        send:
+            "store rec"
+            "num:i 3"
+            "PREV:r $r2_3"
+            ""
+        expect /store-done (blake2#[0-9a-f]*)/ capture r3_3
+
+        send:
+            "store rec"
+            "num:i 4"
+            "PREV:r $r2_3"
+            ""
+        expect /store-done (blake2#[0-9a-f]*)/ capture r3_4
+
+        # r4_1  r4_2
+        #  |     |
+        # r3_1  r3_2  r3_3  r3_4
+        #   \   /       \   /
+        #    r2_1        r2_3
+        #     |           |
+        #    r1_1        r1_2
+
+        send "stored-common-ancestors $r4_1 $r3_3 | $r4_2 $r3_4"
+        expect /stored-common-ancestors-item $r2_1/
+        expect /stored-common-ancestors-item $r2_3/
+        local:
+            expect /stored-common-ancestors-(.*)/ capture done
+            guard (done == "done")
+
+
+        send:
+            "store rec"
+            "num:i 1"
+            "PREV:r $r4_2"
+            "PREV:r $r3_3"
+            ""
+        expect /store-done (blake2#[0-9a-f]*)/ capture r5_3
+
+        send:
+            "store rec"
+            "num:i 1"
+            "PREV:r $r4_1"
+            "PREV:r $r3_4"
+            ""
+        expect /store-done (blake2#[0-9a-f]*)/ capture r5_4
+
+        #    ->   r5_3   <--r5_4
+        #   /    /   \       |
+        # r4_1  r4_2  \      |
+        #  |     |     |     |
+        # r3_1  r3_2  r3_3  r3_4
+        #   \   /       \   /
+        #    r2_1        r2_3
+        #     |           |
+        #    r1_1        r1_2
+
+        send "stored-common-ancestors $r5_3 | $r5_4"
+        expect /stored-common-ancestors-item $r2_1/
+        expect /stored-common-ancestors-item $r2_3/
+        local:
+            expect /stored-common-ancestors-(.*)/ capture done
+            guard (done == "done")
+
+
 test StoredDifference:
     spawn as p1
     with p1: