summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--main/Test.hs15
-rw-r--r--src/Erebos/Storage/Graph.hs39
-rw-r--r--test/graph.et216
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:
generated by cgit v1.2.3 (git 2.25.1) at 2026-06-04 07:45:44 +0000