From 84b23e7ba7ae2f3aade60715b54ee214054a2041 Mon Sep 17 00:00:00 2001 From: Balazs Komuves Date: Wed, 22 Apr 2026 17:05:00 +0200 Subject: [PATCH] add the option of using the "new" round constants in Poseidon2 reference implementation (the Haskell one) --- reference/haskell/cli/testMain.hs | 3 + reference/haskell/src/DataSet.hs | 29 ++-- reference/haskell/src/Poseidon2.hs | 1 + reference/haskell/src/Poseidon2/Example.hs | 18 ++- reference/haskell/src/Poseidon2/Merkle.hs | 114 ++++++++------- .../haskell/src/Poseidon2/Permutation.hs | 42 ++++-- .../haskell/src/Poseidon2/RoundConstsNew.hs | 131 ++++++++++++++++++ .../{RoundConsts.hs => RoundConstsOld.hs} | 2 +- reference/haskell/src/Poseidon2/Sponge.hs | 20 ++- reference/haskell/src/Sampling.hs | 7 +- reference/haskell/src/Slot.hs | 40 +++--- reference/haskell/src/TestVectors.hs | 52 ++++--- reference/haskell/storage-proof-ref.cabal | 3 +- 13 files changed, 334 insertions(+), 128 deletions(-) create mode 100644 reference/haskell/src/Poseidon2/RoundConstsNew.hs rename reference/haskell/src/Poseidon2/{RoundConsts.hs => RoundConstsOld.hs} (99%) diff --git a/reference/haskell/cli/testMain.hs b/reference/haskell/cli/testMain.hs index 0006830..ce5efb6 100644 --- a/reference/haskell/cli/testMain.hs +++ b/reference/haskell/cli/testMain.hs @@ -3,6 +3,7 @@ module Main where -------------------------------------------------------------------------------- +import Poseidon2 ( Flavour(..) ) import Slot ( SlotIdx(..) , DataSource(..) , Seed(..) ) import DataSet import Sampling @@ -19,6 +20,7 @@ smallDataSetCfg = MkDataSetCfg , _nCells = 256 -- 64 , _nSamples = 10 , _dataSrc = FakeData (Seed 12345) + , _hashFlavour = HorizenLabsOld } bigDataSetCfg :: DataSetCfg @@ -31,6 +33,7 @@ bigDataSetCfg = MkDataSetCfg , _nCells = 512 , _nSamples = 5 , _dataSrc = FakeData (Seed 666) + , _hashFlavour = HorizenLabsOld } -------------------------------------------------------------------------------- diff --git a/reference/haskell/src/DataSet.hs b/reference/haskell/src/DataSet.hs index 844cb53..3324e72 100644 --- a/reference/haskell/src/DataSet.hs +++ b/reference/haskell/src/DataSet.hs @@ -10,19 +10,21 @@ import System.FilePath import Slot hiding ( MkSlotCfg(..) ) import qualified Slot as Slot +import Poseidon2 ( Flavour(..) ) import Misc -------------------------------------------------------------------------------- data DataSetCfg = MkDataSetCfg - { _maxDepth :: Int -- ^ @nCells@ must fit into this many bits - , _maxLog2NSlots :: Int -- ^ @nSlots@ must fit into this many bits - , _nSlots :: Int -- ^ number of slots per dataset - , _cellSize :: Int -- ^ cell size in bytes - , _blockSize :: Int -- ^ slot size in bytes - , _nCells :: Int -- ^ number of cells per slot - , _nSamples :: Int -- ^ number of cells we sample in a proof - , _dataSrc :: DataSource + { _maxDepth :: Int -- ^ @nCells@ must fit into this many bits + , _maxLog2NSlots :: Int -- ^ @nSlots@ must fit into this many bits + , _nSlots :: Int -- ^ number of slots per dataset + , _cellSize :: Int -- ^ cell size in bytes + , _blockSize :: Int -- ^ slot size in bytes + , _nCells :: Int -- ^ number of cells per slot + , _nSamples :: Int -- ^ number of cells we sample in a proof + , _hashFlavour :: Flavour + , _dataSrc :: DataSource } deriving Show @@ -31,11 +33,12 @@ fieldElemsPerCell cfg = (DataSet._cellSize cfg + 30) `div` 31 dataSetSlotCfg :: DataSetCfg -> SlotIdx -> SlotConfig dataSetSlotCfg dsetCfg idx = Slot.MkSlotCfg - { Slot._cellSize = DataSet._cellSize dsetCfg - , Slot._blockSize = DataSet._blockSize dsetCfg - , Slot._nCells = DataSet._nCells dsetCfg - , Slot._nSamples = DataSet._nSamples dsetCfg - , Slot._dataSrc = parametricSlotDataSource (DataSet._dataSrc dsetCfg) idx + { Slot._cellSize = DataSet._cellSize dsetCfg + , Slot._blockSize = DataSet._blockSize dsetCfg + , Slot._nCells = DataSet._nCells dsetCfg + , Slot._nSamples = DataSet._nSamples dsetCfg + , Slot._hashFlavour = DataSet._hashFlavour dsetCfg + , Slot._dataSrc = parametricSlotDataSource (DataSet._dataSrc dsetCfg) idx } -------------------------------------------------------------------------------- diff --git a/reference/haskell/src/Poseidon2.hs b/reference/haskell/src/Poseidon2.hs index d11f740..df815bf 100644 --- a/reference/haskell/src/Poseidon2.hs +++ b/reference/haskell/src/Poseidon2.hs @@ -3,6 +3,7 @@ module Poseidon2 ( Fr + , Flavour(..) , sponge1 , sponge2 , calcMerkleRoot , calcMerkleTree , MerkleTree(..) , depthOf , merkleRootOf , treeBottomLayer diff --git a/reference/haskell/src/Poseidon2/Example.hs b/reference/haskell/src/Poseidon2/Example.hs index 2015167..5064db1 100644 --- a/reference/haskell/src/Poseidon2/Example.hs +++ b/reference/haskell/src/Poseidon2/Example.hs @@ -10,15 +10,25 @@ import Poseidon2.Permutation -------------------------------------------------------------------------------- -- BN254 example test vector -exInput, exOutput :: (Fr,Fr,Fr) +exInput, exOutputOld, exOutputNew :: (Fr,Fr,Fr) exInput = (0,1,2) -exOutput = + +exOutputOld = ( 0x30610a447b7dec194697fb50786aa7421494bd64c221ba4d3b1af25fb07bd103 , 0x13f731d6ffbad391be22d2ac364151849e19fa38eced4e761bcd21dbdc600288 , 0x1433e2c8f68382c447c5c14b8b3df7cbfd9273dd655fe52f1357c27150da786f ) -kats :: Bool -kats = permutation exInput == exOutput +exOutputNew = + ( 0x0bb61d24daca55eebcb1929a82650f328134334da98ea4f847f760054f4a3033 + , 0x303b6f7c86d043bfcbcc80214f26a30277a15d3f74ca654992defe7ff8d03570 + , 0x1ed25194542b12eef8617361c3ba7c52e660b145994427cc86296242cf766ec8 + ) + +katsOld :: Bool +katsOld = permutation HorizenLabsOld exInput == exOutputOld + +katsNew :: Bool +katsNew = permutation HorizenLabsNew exInput == exOutputNew -------------------------------------------------------------------------------- diff --git a/reference/haskell/src/Poseidon2/Merkle.hs b/reference/haskell/src/Poseidon2/Merkle.hs index e89207b..081b343 100644 --- a/reference/haskell/src/Poseidon2/Merkle.hs +++ b/reference/haskell/src/Poseidon2/Merkle.hs @@ -33,12 +33,12 @@ import Poseidon2.Permutation -- -- Note the first layer is the bottom (widest) layer, and the last layer is the top (root). -- -newtype MerkleTree - = MkMerkleTree (Array Int (Array Int Fr)) +data MerkleTree + = MkMerkleTree !Flavour !(Array Int (Array Int Fr)) deriving Show merkleRootOf :: MerkleTree -> Fr -merkleRootOf (MkMerkleTree outer) +merkleRootOf (MkMerkleTree flavour outer) | c == d = inner ! c | otherwise = error "merkleRootOf: topmost layer is not singleton" where @@ -51,11 +51,11 @@ merkleRootOf (MkMerkleTree outer) -- NOTE: this is one less than the actual number of layers! -- depthOf :: MerkleTree -> Int -depthOf (MkMerkleTree outer) = b-a where +depthOf (MkMerkleTree flavour outer) = b-a where (a,b) = bounds outer treeBottomLayer :: MerkleTree -> [Fr] -treeBottomLayer (MkMerkleTree arr) = elems (arr!0) +treeBottomLayer (MkMerkleTree flavour arr) = elems (arr!0) {- calcMerkleTree' :: [Fr] -> [[Fr]] @@ -66,29 +66,30 @@ calcMerkleTree' = go where go xs = xs : go (map compressPair $ pairs xs) -} -calcMerkleTree' :: [Fr] -> [[Fr]] -calcMerkleTree' input = +calcMerkleTree' :: Flavour -> [Fr] -> [[Fr]] +calcMerkleTree' flavour input = case input of [] -> error "calcMerkleTree': input is empty" - [z] -> [[keyedCompression (nodeKey BottomLayer OddNode) z 0]] + [z] -> [[keyedCompression flavour (nodeKey BottomLayer OddNode) z 0]] zs -> go layerFlags zs where go :: [LayerFlag] -> [Fr] -> [[Fr]] go _ [x] = [[x]] - go (f:fs) xs = xs : go fs (map (evenOddCompressPair f) $ eiPairs xs) + go (f:fs) xs = xs : go fs (map (evenOddCompressPair flavour f) $ eiPairs xs) -calcMerkleTree :: [Fr] -> MerkleTree -calcMerkleTree = MkMerkleTree . go1 . calcMerkleTree' where +calcMerkleTree :: Flavour -> [Fr] -> MerkleTree +calcMerkleTree flavour = MkMerkleTree flavour . go1 . calcMerkleTree' flavour where go1 outer = listArray (0, length outer-1) (map go2 outer) go2 inner = listArray (0, length inner-1) inner -------------------------------------------------------------------------------- data MerkleProof = MkMerkleProof - { _leafIndex :: Int -- ^ linear index of the leaf we prove, 0..dataSize-1 - , _leafData :: Fr -- ^ the data on the leaf - , _merklePath :: [Fr] -- ^ the path up the root - , _dataSize :: Int -- ^ number of leaves in the tree + { _flavour :: !Flavour -- ^ which hash function + , _leafIndex :: !Int -- ^ linear index of the leaf we prove, 0..dataSize-1 + , _leafData :: !Fr -- ^ the data on the leaf + , _merklePath :: [Fr] -- ^ the path up the root + , _dataSize :: !Int -- ^ number of leaves in the tree } deriving (Eq,Show) @@ -97,7 +98,7 @@ arrayLength arr = (b - a + 1) where (a,b) = bounds arr -- | Returns the leaf and Merkle path of the given leaf extractMerkleProof :: MerkleTree -> Int -> MerkleProof -extractMerkleProof tree@(MkMerkleTree outer) idx = MkMerkleProof idx leaf path size where +extractMerkleProof tree@(MkMerkleTree flavour outer) idx = MkMerkleProof flavour idx leaf path size where leaf = (outer!0)!idx size = arrayLength (outer!0) depth = depthOf tree @@ -112,12 +113,12 @@ extractMerkleProof_ :: MerkleTree -> Int -> [Fr] extractMerkleProof_ tree idx = _merklePath (extractMerkleProof tree idx) reconstructMerkleRoot :: MerkleProof -> Fr -reconstructMerkleRoot (MkMerkleProof idx leaf path size) = go layerFlags size idx leaf path where +reconstructMerkleRoot (MkMerkleProof flavour idx leaf path size) = go layerFlags size idx leaf path where go _ !sz 0 !h [] = h go (f:fs) !sz !j !h !(p:ps) = case (j.&.1, j==sz-1) of - (0, False) -> go fs sz' j' (evenOddCompressPair f $ Right (h,p)) ps - (0, True ) -> go fs sz' j' (evenOddCompressPair f $ Left h ) ps - (1, _ ) -> go fs sz' j' (evenOddCompressPair f $ Right (p,h)) ps + (0, False) -> go fs sz' j' (evenOddCompressPair flavour f $ Right (h,p)) ps + (0, True ) -> go fs sz' j' (evenOddCompressPair flavour f $ Left h ) ps + (1, _ ) -> go fs sz' j' (evenOddCompressPair flavour f $ Right (p,h)) ps where sz' = shiftR (sz+1) 1 j' = shiftR j 1 @@ -133,18 +134,18 @@ reconstructMerkleRoot (MkMerkleProof idx leaf path) = go idx leaf path where -------------------------------------------------------------------------------- -testAllMerkleProofs :: Int -> IO () -testAllMerkleProofs nn = forM_ [1..nn] $ \k -> do - let ok = if testMerkleProofs k then "OK." else "FAILED!!" - putStrLn $ "testing Merkle proofs for a tree with " ++ show k ++ " leaves: " ++ ok +testAllMerkleProofs :: Flavour -> Int -> IO () +testAllMerkleProofs flavour nn = forM_ [1..nn] $ \k -> do + let ok = if testMerkleProofs flavour k then "OK." else "FAILED!!" + putStrLn $ "testing Merkle proofs [" ++ show flavour ++ "] for a tree with " ++ show k ++ " leaves: " ++ ok -testMerkleProofs :: Int -> Bool -testMerkleProofs = and . testMerkleProofs' +testMerkleProofs :: Flavour -> Int -> Bool +testMerkleProofs flavour = and . testMerkleProofs' flavour -testMerkleProofs' :: Int -> [Bool] -testMerkleProofs' n = oks where +testMerkleProofs' :: Flavour -> Int -> [Bool] +testMerkleProofs' flavour n = oks where input = map fromIntegral [1001..1000+n] :: [Fr] - tree = calcMerkleTree input + tree = calcMerkleTree flavour input root = merkleRootOf tree oks = [ reconstructMerkleRoot prf == root | j<-[0..n-1] @@ -174,33 +175,33 @@ nodeKey BottomLayer EvenNode = 0x01 nodeKey OtherLayer OddNode = 0x02 nodeKey BottomLayer OddNode = 0x03 -evenOddCompressPair :: LayerFlag -> Either Fr (Fr,Fr) -> Fr -evenOddCompressPair !lf (Right (x,y)) = keyedCompression (nodeKey lf EvenNode) x y -evenOddCompressPair !lf (Left x ) = keyedCompression (nodeKey lf OddNode ) x 0 +evenOddCompressPair :: Flavour -> LayerFlag -> Either Fr (Fr,Fr) -> Fr +evenOddCompressPair !flavour !lf (Right (x,y)) = keyedCompression flavour (nodeKey lf EvenNode) x y +evenOddCompressPair !flavour !lf (Left x ) = keyedCompression flavour (nodeKey lf OddNode ) x 0 layerFlags :: [LayerFlag] layerFlags = BottomLayer : repeat OtherLayer -calcMerkleRoot :: [Fr] -> Fr -calcMerkleRoot input = +calcMerkleRoot :: Flavour -> [Fr] -> Fr +calcMerkleRoot flavour input = case input of [] -> error "calcMerkleRoot: input is empty" - [z] -> keyedCompression (nodeKey BottomLayer OddNode) z 0 + [z] -> keyedCompression flavour (nodeKey BottomLayer OddNode) z 0 zs -> go layerFlags zs where go :: [LayerFlag] -> [Fr] -> Fr go _ [x] = x - go (f:fs) xs = go fs (map (evenOddCompressPair f) $ eiPairs xs) + go (f:fs) xs = go fs (map (evenOddCompressPair flavour f) $ eiPairs xs) -------------------------------------------------------------------------------- type Key = Fr -keyedCompressPair :: Key -> (Fr,Fr) -> Fr -keyedCompressPair !key (!x,!y) = keyedCompression key x y +keyedCompressPair :: Flavour -> Key -> (Fr,Fr) -> Fr +keyedCompressPair !flavour !key (!x,!y) = keyedCompression flavour key x y -keyedCompression :: Key -> Fr -> Fr -> Fr -keyedCompression !key !x !y = case permutation (x,y,key) of (z,_,_) -> z +keyedCompression :: Flavour -> Key -> Fr -> Fr -> Fr +keyedCompression !flavour !key !x !y = case permutation flavour (x,y,key) of (z,_,_) -> z eiPairs :: [Fr] -> [Either Fr (Fr,Fr)] eiPairs [] = [] @@ -209,11 +210,11 @@ eiPairs (x:y:rest) = Right (x,y) : eiPairs rest -------------------------------------------------------------------------------- -compressPair :: (Fr,Fr) -> Fr -compressPair (x,y) = compression x y +compressPair :: Flavour -> (Fr,Fr) -> Fr +compressPair !flavour !(x,y) = compression flavour x y -compression :: Fr -> Fr -> Fr -compression x y = case permutation (x,y,0) of (z,_,_) -> z +compression :: Flavour -> Fr -> Fr -> Fr +compression !flavour !x !y = case permutation flavour (x,y,0) of (z,_,_) -> z {- pairs :: [Fr] -> [(Fr,Fr)] @@ -224,14 +225,25 @@ pairs (x:y:rest) = (x,y) : pairs rest -------------------------------------------------------------------------------- +printExampleMerkleRoots' :: Flavour -> IO () +printExampleMerkleRoots' flavour = do + putStrLn $ "Merkle root for [1.. 1] = " ++ show (calcMerkleRoot flavour $ map fromInteger [1.. 1]) + putStrLn $ "Merkle root for [1.. 2] = " ++ show (calcMerkleRoot flavour $ map fromInteger [1.. 2]) + putStrLn $ "Merkle root for [1.. 4] = " ++ show (calcMerkleRoot flavour $ map fromInteger [1.. 4]) + putStrLn $ "Merkle root for [1.. 16] = " ++ show (calcMerkleRoot flavour $ map fromInteger [1.. 16]) + putStrLn $ "Merkle root for [1.. 64] = " ++ show (calcMerkleRoot flavour $ map fromInteger [1.. 64]) + putStrLn $ "Merkle root for [1.. 256] = " ++ show (calcMerkleRoot flavour $ map fromInteger [1.. 256]) + putStrLn $ "Merkle root for [1..1024] = " ++ show (calcMerkleRoot flavour $ map fromInteger [1..1024]) + printExampleMerkleRoots :: IO () printExampleMerkleRoots = do - putStrLn $ "Merkle root for [1.. 1] = " ++ show (calcMerkleRoot $ map fromInteger [1.. 1]) - putStrLn $ "Merkle root for [1.. 2] = " ++ show (calcMerkleRoot $ map fromInteger [1.. 2]) - putStrLn $ "Merkle root for [1.. 4] = " ++ show (calcMerkleRoot $ map fromInteger [1.. 4]) - putStrLn $ "Merkle root for [1.. 16] = " ++ show (calcMerkleRoot $ map fromInteger [1.. 16]) - putStrLn $ "Merkle root for [1.. 64] = " ++ show (calcMerkleRoot $ map fromInteger [1.. 64]) - putStrLn $ "Merkle root for [1.. 256] = " ++ show (calcMerkleRoot $ map fromInteger [1.. 256]) - putStrLn $ "Merkle root for [1..1024] = " ++ show (calcMerkleRoot $ map fromInteger [1..1024]) + + putStrLn "using the \"old\" constants:" + putStrLn "--------------------------" + printExampleMerkleRoots' HorizenLabsOld + + putStrLn "using the \"new\" constants:" + putStrLn "--------------------------" + printExampleMerkleRoots' HorizenLabsNew -------------------------------------------------------------------------------- diff --git a/reference/haskell/src/Poseidon2/Permutation.hs b/reference/haskell/src/Poseidon2/Permutation.hs index 49077df..0c00a30 100644 --- a/reference/haskell/src/Poseidon2/Permutation.hs +++ b/reference/haskell/src/Poseidon2/Permutation.hs @@ -1,23 +1,33 @@ -- | The Poseidon2 permutation +{-# LANGUAGE BangPatterns #-} module Poseidon2.Permutation where -------------------------------------------------------------------------------- import ZK.Algebra.Curves.BN128.Fr.Mont (Fr) -import Poseidon2.RoundConsts +import qualified Poseidon2.RoundConstsOld as Old +import qualified Poseidon2.RoundConstsNew as New + +-------------------------------------------------------------------------------- + +-- | Which set of round constants +data Flavour + = HorizenLabsOld + | HorizenLabsNew + deriving (Eq, Show) -------------------------------------------------------------------------------- sbox :: Fr -> Fr -sbox x = x4*x where +sbox !x = x4*x where x2 = x *x x4 = x2*x2 internalRound :: Fr -> (Fr,Fr,Fr) -> (Fr,Fr,Fr) -internalRound c (x,y,z) = +internalRound !c (x,y,z) = ( 2*x' + y + z , x' + 2*y + z , x' + y + 3*z @@ -26,22 +36,34 @@ internalRound c (x,y,z) = x' = sbox (x + c) externalRound :: (Fr,Fr,Fr) -> (Fr,Fr,Fr) -> (Fr,Fr,Fr) -externalRound (cx,cy,cz) (x,y,z) = (x'+s , y'+s , z'+s) where +externalRound !(cx,cy,cz) !(x,y,z) = (x'+s , y'+s , z'+s) where x' = sbox (x + cx) y' = sbox (y + cy) z' = sbox (z + cz) s = x' + y' + z' linearLayer :: (Fr,Fr,Fr) -> (Fr,Fr,Fr) -linearLayer (x,y,z) = (x+s, y+s, z+s) where s = x+y+z +linearLayer !(x,y,z) = (x+s, y+s, z+s) where s = x+y+z -------------------------------------------------------------------------------- -permutation :: (Fr,Fr,Fr) -> (Fr,Fr,Fr) -permutation - = (\state -> foldl (flip externalRound) state finalRoundConsts ) - . (\state -> foldl (flip internalRound) state internalRoundConsts) - . (\state -> foldl (flip externalRound) state initialRoundConsts ) +permutationOld :: (Fr,Fr,Fr) -> (Fr,Fr,Fr) +permutationOld + = (\state -> foldl (flip externalRound) state Old.finalRoundConsts ) + . (\state -> foldl (flip internalRound) state Old.internalRoundConsts) + . (\state -> foldl (flip externalRound) state Old.initialRoundConsts ) . linearLayer + +permutationNew :: (Fr,Fr,Fr) -> (Fr,Fr,Fr) +permutationNew + = (\state -> foldl (flip externalRound) state New.finalRoundConsts ) + . (\state -> foldl (flip internalRound) state New.internalRoundConsts) + . (\state -> foldl (flip externalRound) state New.initialRoundConsts ) + . linearLayer + +permutation :: Flavour -> (Fr,Fr,Fr) -> (Fr,Fr,Fr) +permutation HorizenLabsOld = permutationOld +permutation HorizenLabsNew = permutationNew + -------------------------------------------------------------------------------- diff --git a/reference/haskell/src/Poseidon2/RoundConstsNew.hs b/reference/haskell/src/Poseidon2/RoundConstsNew.hs new file mode 100644 index 0000000..9af81b6 --- /dev/null +++ b/reference/haskell/src/Poseidon2/RoundConstsNew.hs @@ -0,0 +1,131 @@ + +-- | BN256 prime, and t = 3 + +module Poseidon2.RoundConstsNew where + +-------------------------------------------------------------------------------- + +import ZK.Algebra.Curves.BN128.Fr.Mont + +-------------------------------------------------------------------------------- + +{- +matDiag3 :: [[Fr]] +matDiag3 = + [ [1,0,0] + , [0,1,0] + , [0,0,2] + ] + +matInternal3 :: [[Fr]] +matInternal3 = + [ [2,1,1] + , [1,2,1] + , [1,1,3] + ] +-} + +-------------------------------------------------------------------------------- + +initialRoundConsts :: [(Fr,Fr,Fr)] +initialRoundConsts = + [ ( 0x1d066a255517b7fd8bddd3a93f7804ef7f8fcde48bb4c37a59a09a1a97052816 + , 0x29daefb55f6f2dc6ac3f089cebcc6120b7c6fef31367b68eb7238547d32c1610 + , 0x1f2cb1624a78ee001ecbd88ad959d7012572d76f08ec5c4f9e8b7ad7b0b4e1d1 + ) + , ( 0x0aad2e79f15735f2bd77c0ed3d14aa27b11f092a53bbc6e1db0672ded84f31e5 + , 0x2252624f8617738cd6f661dd4094375f37028a98f1dece66091ccf1595b43f28 + , 0x1a24913a928b38485a65a84a291da1ff91c20626524b2b87d49f4f2c9018d735 + ) + , ( 0x22fc468f1759b74d7bfc427b5f11ebb10a41515ddff497b14fd6dae1508fc47a + , 0x1059ca787f1f89ed9cd026e9c9ca107ae61956ff0b4121d5efd65515617f6e4d + , 0x02be9473358461d8f61f3536d877de982123011f0bf6f155a45cbbfae8b981ce + ) + , ( 0x0ec96c8e32962d462778a749c82ed623aba9b669ac5b8736a1ff3a441a5084a4 + , 0x292f906e073677405442d9553c45fa3f5a47a7cdb8c99f9648fb2e4d814df57e + , 0x274982444157b86726c11b9a0f5e39a5cc611160a394ea460c63f0b2ffe5657e + ) + ] + +internalRoundConsts :: [Fr] +internalRoundConsts = + [ 0x1a1d063e54b1e764b63e1855bff015b8cedd192f47308731499573f23597d4b5 + , 0x26abc66f3fdf8e68839d10956259063708235dccc1aa3793b91b002c5b257c37 + , 0x0c7c64a9d887385381a578cfed5aed370754427aabca92a70b3c2b12ff4d7be8 + , 0x1cf5998769e9fab79e17f0b6d08b2d1eba2ebac30dc386b0edd383831354b495 + , 0x0f5e3a8566be31b7564ca60461e9e08b19828764a9669bc17aba0b97e66b0109 + , 0x18df6a9d19ea90d895e60e4db0794a01f359a53a180b7d4b42bf3d7a531c976e + , 0x04f7bf2c5c0538ac6e4b782c3c6e601ad0ea1d3a3b9d25ef4e324055fa3123dc + , 0x29c76ce22255206e3c40058523748531e770c0584aa2328ce55d54628b89ebe6 + , 0x198d425a45b78e85c053659ab4347f5d65b1b8e9c6108dbe00e0e945dbc5ff15 + , 0x25ee27ab6296cd5e6af3cc79c598a1daa7ff7f6878b3c49d49d3a9a90c3fdf74 + , 0x138ea8e0af41a1e024561001c0b6eb1505845d7d0c55b1b2c0f88687a96d1381 + , 0x306197fb3fab671ef6e7c2cba2eefd0e42851b5b9811f2ca4013370a01d95687 + , 0x1a0c7d52dc32a4432b66f0b4894d4f1a21db7565e5b4250486419eaf00e8f620 + , 0x2b46b418de80915f3ff86a8e5c8bdfccebfbe5f55163cd6caa52997da2c54a9f + , 0x12d3e0dc0085873701f8b777b9673af9613a1af5db48e05bfb46e312b5829f64 + , 0x263390cf74dc3a8870f5002ed21d089ffb2bf768230f648dba338a5cb19b3a1f + , 0x0a14f33a5fe668a60ac884b4ca607ad0f8abb5af40f96f1d7d543db52b003dcd + , 0x28ead9c586513eab1a5e86509d68b2da27be3a4f01171a1dd847df829bc683b9 + , 0x1c6ab1c328c3c6430972031f1bdb2ac9888f0ea1abe71cffea16cda6e1a7416c + , 0x1fc7e71bc0b819792b2500239f7f8de04f6decd608cb98a932346015c5b42c94 + , 0x03e107eb3a42b2ece380e0d860298f17c0c1e197c952650ee6dd85b93a0ddaa8 + , 0x2d354a251f381a4669c0d52bf88b772c46452ca57c08697f454505f6941d78cd + , 0x094af88ab05d94baf687ef14bc566d1c522551d61606eda3d14b4606826f794b + , 0x19705b783bf3d2dc19bcaeabf02f8ca5e1ab5b6f2e3195a9d52b2d249d1396f7 + , 0x09bf4acc3a8bce3f1fcc33fee54fc5b28723b16b7d740a3e60cef6852271200e + , 0x1803f8200db6013c50f83c0c8fab62843413732f301f7058543a073f3f3b5e4e + , 0x0f80afb5046244de30595b160b8d1f38bf6fb02d4454c0add41f7fef2faf3e5c + , 0x126ee1f8504f15c3d77f0088c1cfc964abcfcf643f4a6fea7dc3f98219529d78 + , 0x23c203d10cfcc60f69bfb3d919552ca10ffb4ee63175ddf8ef86f991d7d0a591 + , 0x2a2ae15d8b143709ec0d09705fa3a6303dec1ee4eec2cf747c5a339f7744fb94 + , 0x07b60dee586ed6ef47e5c381ab6343ecc3d3b3006cb461bbb6b5d89081970b2b + , 0x27316b559be3edfd885d95c494c1ae3d8a98a320baa7d152132cfe583c9311bd + , 0x1d5c49ba157c32b8d8937cb2d3f84311ef834cc2a743ed662f5f9af0c0342e76 + , 0x2f8b124e78163b2f332774e0b850b5ec09c01bf6979938f67c24bd5940968488 + , 0x1e6843a5457416b6dc5b7aa09a9ce21b1d4cba6554e51d84665f75260113b3d5 + , 0x11cdf00a35f650c55fca25c9929c8ad9a68daf9ac6a189ab1f5bc79f21641d4b + , 0x21632de3d3bbc5e42ef36e588158d6d4608b2815c77355b7e82b5b9b7eb560bc + , 0x0de625758452efbd97b27025fbd245e0255ae48ef2a329e449d7b5c51c18498a + , 0x2ad253c053e75213e2febfd4d976cc01dd9e1e1c6f0fb6b09b09546ba0838098 + , 0x1d6b169ed63872dc6ec7681ec39b3be93dd49cdd13c813b7d35702e38d60b077 + , 0x1660b740a143664bb9127c4941b67fed0be3ea70a24d5568c3a54e706cfef7fe + , 0x0065a92d1de81f34114f4ca2deef76e0ceacdddb12cf879096a29f10376ccbfe + , 0x1f11f065202535987367f823da7d672c353ebe2ccbc4869bcf30d50a5871040d + , 0x26596f5c5dd5a5d1b437ce7b14a2c3dd3bd1d1a39b6759ba110852d17df0693e + , 0x16f49bc727e45a2f7bf3056efcf8b6d38539c4163a5f1e706743db15af91860f + , 0x1abe1deb45b3e3119954175efb331bf4568feaf7ea8b3dc5e1a4e7438dd39e5f + , 0x0e426ccab66984d1d8993a74ca548b779f5db92aaec5f102020d34aea15fba59 + , 0x0e7c30c2e2e8957f4933bd1942053f1f0071684b902d534fa841924303f6a6c6 + , 0x0812a017ca92cf0a1622708fc7edff1d6166ded6e3528ead4c76e1f31d3fc69d + , 0x21a5ade3df2bc1b5bba949d1db96040068afe5026edd7a9c2e276b47cf010d54 + , 0x01f3035463816c84ad711bf1a058c6c6bd101945f50e5afe72b1a5233f8749ce + , 0x0b115572f038c0e2028c2aafc2d06a5e8bf2f9398dbd0fdf4dcaa82b0f0c1c8b + , 0x1c38ec0b99b62fd4f0ef255543f50d2e27fc24db42bc910a3460613b6ef59e2f + , 0x1c89c6d9666272e8425c3ff1f4ac737b2f5d314606a297d4b1d0b254d880c53e + , 0x03326e643580356bf6d44008ae4c042a21ad4880097a5eb38b71e2311bb88f8f + , 0x268076b0054fb73f67cee9ea0e51e3ad50f27a6434b5dceb5bdde2299910a4c9 + ] + +finalRoundConsts :: [(Fr,Fr,Fr)] +finalRoundConsts = + [ ( 0x1acd63c67fbc9ab1626ed93491bda32e5da18ea9d8e4f10178d04aa6f8747ad0 + , 0x19f8a5d670e8ab66c4e3144be58ef6901bf93375e2323ec3ca8c86cd2a28b5a5 + , 0x1c0dc443519ad7a86efa40d2df10a011068193ea51f6c92ae1cfbb5f7b9b6893 + ) + , ( 0x14b39e7aa4068dbe50fe7190e421dc19fbeab33cb4f6a2c4180e4c3224987d3d + , 0x1d449b71bd826ec58f28c63ea6c561b7b820fc519f01f021afb1e35e28b0795e + , 0x1ea2c9a89baaddbb60fa97fe60fe9d8e89de141689d1252276524dc0a9e987fc + ) + , ( 0x0478d66d43535a8cb57e9c1c3d6a2bd7591f9a46a0e9c058134d5cefdb3c7ff1 + , 0x19272db71eece6a6f608f3b2717f9cd2662e26ad86c400b21cde5e4a7b00bebe + , 0x14226537335cab33c749c746f09208abb2dd1bd66a87ef75039be846af134166 + ) + , ( 0x01fd6af15956294f9dfe38c0d976a088b21c21e4a1c2e823f912f44961f9a9ce + , 0x18e5abedd626ec307bca190b8b2cab1aaee2e62ed229ba5a5ad8518d4e5f2a57 + , 0x0fc1bbceba0590f5abbdffa6d3b35e3297c021a3a409926d0e2d54dc1c84fda6 + ) + ] + +-------------------------------------------------------------------------------- + diff --git a/reference/haskell/src/Poseidon2/RoundConsts.hs b/reference/haskell/src/Poseidon2/RoundConstsOld.hs similarity index 99% rename from reference/haskell/src/Poseidon2/RoundConsts.hs rename to reference/haskell/src/Poseidon2/RoundConstsOld.hs index ba5b484..5c03406 100644 --- a/reference/haskell/src/Poseidon2/RoundConsts.hs +++ b/reference/haskell/src/Poseidon2/RoundConstsOld.hs @@ -1,7 +1,7 @@ -- | BN256 prime, and t = 3 -module Poseidon2.RoundConsts where +module Poseidon2.RoundConstsOld where -------------------------------------------------------------------------------- diff --git a/reference/haskell/src/Poseidon2/Sponge.hs b/reference/haskell/src/Poseidon2/Sponge.hs index 06e2d37..671fecf 100644 --- a/reference/haskell/src/Poseidon2/Sponge.hs +++ b/reference/haskell/src/Poseidon2/Sponge.hs @@ -1,5 +1,11 @@ -module Poseidon2.Sponge where +{-# LANGUAGE BangPatterns #-} +module Poseidon2.Sponge + ( Flavour(..) + , sponge1 + , sponge2 + ) + where -------------------------------------------------------------------------------- @@ -10,8 +16,8 @@ import Poseidon2.Permutation -------------------------------------------------------------------------------- -- | Sponge construction with rate=1 (capacity=2), zero IV and 10* padding -sponge1 :: [Fr] -> Fr -sponge1 input = go (0,0,civ) (pad input) where +sponge1 :: Flavour -> [Fr] -> Fr +sponge1 !flavour input = go (0,0,civ) (pad input) where -- domain separation: capacity IV = 2^64 + 256*t + rate civ = fromInteger (2^64 + 0x0301) @@ -22,13 +28,13 @@ sponge1 input = go (0,0,civ) (pad input) where go (sx,_ ,_ ) [] = sx go (sx,sy,sz) (a:as) = go state' as where - state' = permutation (sx+a, sy, sz) + state' = permutation flavour (sx+a, sy, sz) -------------------------------------------------------------------------------- -- | Sponge construction with rate=2 (capacity=1), zero IV and 10* padding -sponge2 :: [Fr] -> Fr -sponge2 input = go (0,0,civ) (pad input) where +sponge2 :: Flavour -> [Fr] -> Fr +sponge2 !flavour input = go (0,0,civ) (pad input) where -- domain separation: capacity IV = 2^64 + 256*t + rate civ = fromInteger (2^64 + 0x0302) @@ -40,7 +46,7 @@ sponge2 input = go (0,0,civ) (pad input) where go (sx,_ ,_ ) [] = sx go (sx,sy,sz) (a:b:rest) = go state' rest where - state' = permutation (sx+a, sy+b, sz) + state' = permutation flavour (sx+a, sy+b, sz) -------------------------------------------------------------------------------- diff --git a/reference/haskell/src/Sampling.hs b/reference/haskell/src/Sampling.hs index aa9349f..b897223 100644 --- a/reference/haskell/src/Sampling.hs +++ b/reference/haskell/src/Sampling.hs @@ -30,7 +30,7 @@ type Entropy = Fr -- cell index to sample sampleCellIndex :: SlotConfig -> Entropy -> Hash -> Int -> CellIdx sampleCellIndex cfg entropy slotRoot counter = CellIdx (fromInteger idx) where - u = sponge2 [entropy , slotRoot , fromIntegral counter] :: Fr + u = sponge2 (Slot._hashFlavour cfg) [entropy , slotRoot , fromIntegral counter] :: Fr idx = (Fr.from u) `mod` n :: Integer n = (fromIntegral $ Slot._nCells cfg) :: Integer @@ -62,12 +62,13 @@ data CircuitInput = MkInput calculateCircuitInput :: DataSetCfg -> SlotIdx -> Entropy -> IO CircuitInput calculateCircuitInput dataSetCfg slotIdx@(SlotIdx sidx) entropy = do let nslots = _nSlots dataSetCfg + let flavour = DataSet._hashFlavour dataSetCfg let slotCfgs = [ dataSetSlotCfg dataSetCfg (SlotIdx i) | i <- [0..nslots-1] ] slotTrees <- mapM calcSlotTree slotCfgs let !slotRoots = map slotTreeRoot slotTrees - let !dsetTree = calcMerkleTree slotRoots - let !dsetRoot = merkleRootOf dsetTree + let !dsetTree = calcMerkleTree flavour slotRoots + let !dsetRoot = merkleRootOf dsetTree let ourSlotCfg = slotCfgs !! sidx let ourSlotRoot = slotRoots !! sidx diff --git a/reference/haskell/src/Slot.hs b/reference/haskell/src/Slot.hs index e319842..f091a1d 100644 --- a/reference/haskell/src/Slot.hs +++ b/reference/haskell/src/Slot.hs @@ -49,11 +49,12 @@ data DataSource deriving Show data SlotConfig = MkSlotCfg - { _cellSize :: Int -- ^ cell size in bytes (eg. 2048) - , _blockSize :: Int -- ^ block size in bytes (eg. 65536) - , _nCells :: Int -- ^ number of cells per slot (should be power of two) - , _nSamples :: Int -- ^ how many cells we sample - , _dataSrc :: DataSource -- ^ slot data source + { _cellSize :: Int -- ^ cell size in bytes (eg. 2048) + , _blockSize :: Int -- ^ block size in bytes (eg. 65536) + , _nCells :: Int -- ^ number of cells per slot (should be power of two) + , _nSamples :: Int -- ^ how many cells we sample + , _hashFlavour :: Flavour -- ^ which hash function instance to use + , _dataSrc :: DataSource -- ^ slot data source } deriving Show @@ -71,11 +72,12 @@ blocksPerSlot cfg = case divMod (_nCells cfg) (cellsPerBlock cfg) of -- | Example slot configuration exSlotCfg :: SlotConfig exSlotCfg = MkSlotCfg - { _cellSize = 256 - , _blockSize = 4096 - , _nCells = 1024 - , _nSamples = 20 - , _dataSrc = FakeData (Seed 12345) + { _cellSize = 256 + , _blockSize = 4096 + , _nCells = 1024 + , _nSamples = 20 + , _hashFlavour = HorizenLabsOld + , _dataSrc = FakeData (Seed 12345) } fieldElemsPerCell :: SlotConfig -> Int @@ -153,7 +155,7 @@ calcBlockTree cfg idx = do block <- loadBlockData cfg idx let cells = splitBlockToCells cfg block let cellHashes = map (hashCell cfg) cells - let tree = calcMerkleTree cellHashes + let tree = calcMerkleTree (_hashFlavour cfg) cellHashes return tree calcAllBlockTrees :: SlotConfig -> IO (Array Int MerkleTree) @@ -175,7 +177,7 @@ slotTreeRoot = merkleRootOf . _bigTree calcSlotTree :: SlotConfig -> IO SlotTree calcSlotTree cfg = do minitrees <- calcAllBlockTrees cfg - let bigtree = calcMerkleTree $ map merkleRootOf $ elems minitrees + let bigtree = calcMerkleTree (_hashFlavour cfg) $ map merkleRootOf $ elems minitrees return $ MkSlotTree minitrees bigtree extractCellProof :: SlotConfig -> SlotTree -> CellIdx -> [Hash] @@ -201,13 +203,15 @@ checkCellProof cfg slotTree (CellIdx cellIdx) cellHash path inBlockCellIdx = cellIdx .&. (k-1) smallProof = MkMerkleProof - { _leafIndex = inBlockCellIdx + { _flavour = _hashFlavour cfg + , _leafIndex = inBlockCellIdx , _leafData = cellHash , _merklePath = take logK path , _dataSize = k } bigProof = MkMerkleProof - { _leafIndex = blockIdx + { _flavour = _hashFlavour cfg + , _leafIndex = blockIdx , _leafData = blockHash , _merklePath = drop logK path , _dataSize = m @@ -222,10 +226,12 @@ checkCellProof cfg slotTree (CellIdx cellIdx) cellHash path hashCell :: SlotConfig -> CellData -> Hash hashCell cfg (CellData rawdata) | B.length rawdata /= _cellSize cfg = error "hashCell: invalid cell data size" - | otherwise = hashCell_ rawdata + | otherwise = hashCell_ flavour rawdata + where + flavour = _hashFlavour cfg -hashCell_ :: ByteString -> Hash -hashCell_ rawdata = sponge2 (cellDataToFieldElements $ CellData rawdata) +hashCell_ :: Flavour -> ByteString -> Hash +hashCell_ flavour rawdata = sponge2 flavour (cellDataToFieldElements $ CellData rawdata) -------------------------------------------------------------------------------- diff --git a/reference/haskell/src/TestVectors.hs b/reference/haskell/src/TestVectors.hs index 321d6b4..826d1e5 100644 --- a/reference/haskell/src/TestVectors.hs +++ b/reference/haskell/src/TestVectors.hs @@ -18,60 +18,70 @@ import ZK.Algebra.Curves.BN128.Fr.Mont (Fr) -------------------------------------------------------------------------------- +allTestVectors :: IO () allTestVectors = do - testVectorsSponge - testVectorsHash - testVectorsMerkle + putStrLn "\nTEST VECTORS FOR *OLD* ROUND CONSTANTS" + putStrLn "======================================" + allTestVectors' HorizenLabsOld + putStrLn "\nTEST VECTORS FOR *NEW* ROUND CONSTANTS" + putStrLn "======================================" + allTestVectors' HorizenLabsNew + +allTestVectors' :: Flavour -> IO () +allTestVectors' flavour = do + testVectorsSponge flavour + testVectorsHash flavour + testVectorsMerkle flavour -------------------------------------------------------------------------------- -testVectorsSponge :: IO () -testVectorsSponge = do +testVectorsSponge :: Flavour -> IO () +testVectorsSponge flavour = do putStrLn "" - putStrLn "test vectors for sponge of field elements with rate=1" - putStrLn "-----------------------------------------------------" + putStrLn $ "test vectors for sponge of field elements with rate=1 | " ++ show flavour + putStrLn "-------------------------------------------------------------------" forM_ [0..8] $ \n -> do let input = map fromIntegral [1..n] :: [Fr] - putStrLn $ "hash of [1.." ++ show n ++ "] :: [Fr] = " ++ show (sponge1 input) + putStrLn $ "hash of [1.." ++ show n ++ "] :: [Fr] = " ++ show (sponge1 flavour input) putStrLn "" - putStrLn "test vectors for sponge of field elements with rate=2" - putStrLn "-----------------------------------------------------" + putStrLn $ "test vectors for sponge of field elements with rate=2 | " ++ show flavour + putStrLn "-------------------------------------------------------------------" forM_ [0..8] $ \n -> do let input = map fromIntegral [1..n] :: [Fr] - putStrLn $ "hash of [1.." ++ show n ++ "] :: [Fr] = " ++ show (sponge2 input) + putStrLn $ "hash of [1.." ++ show n ++ "] :: [Fr] = " ++ show (sponge2 flavour input) -------------------------------------------------------------------------------- -testVectorsHash :: IO () -testVectorsHash = do +testVectorsHash :: Flavour -> IO () +testVectorsHash flavour = do putStrLn "" - putStrLn "test vectors for hash (padded sponge with rate=2) of bytes" + putStrLn $ "test vectors for hash (padded sponge with rate=2) of bytes | " ++ show flavour putStrLn "----------------------------------------------------------" forM_ [0..80] $ \n -> do let input = map fromIntegral [1..n] :: [Word8] let bs = B.pack input - putStrLn $ "hash of [1.." ++ show n ++ "] :: [Byte] = " ++ show (hashCell_ bs) + putStrLn $ "hash of [1.." ++ show n ++ "] :: [Byte] = " ++ show (hashCell_ flavour bs) -------------------------------------------------------------------------------- -testVectorsMerkle :: IO () -testVectorsMerkle = do +testVectorsMerkle :: Flavour -> IO () +testVectorsMerkle flavour = do putStrLn "" - putStrLn "test vectors for Merkle roots of field elements" + putStrLn $ "test vectors for Merkle roots of field elements | " ++ show flavour putStrLn "-----------------------------------------------" forM_ [1..40] $ \n -> do let input = map fromIntegral [1..n] :: [Fr] - putStrLn $ "Merkle root of [1.." ++ show n ++ "] :: [Fr] = " ++ show (calcMerkleRoot input) + putStrLn $ "Merkle root of [1.." ++ show n ++ "] :: [Fr] = " ++ show (calcMerkleRoot flavour input) putStrLn "" - putStrLn "test vectors for Merkle roots of sequence of bytes" + putStrLn $ "test vectors for Merkle roots of sequence of bytes | " ++ show flavour putStrLn "--------------------------------------------------" forM_ [0..80] $ \n -> do let input = map fromIntegral [1..n] :: [Word8] let bs = B.pack input let flds = cellDataToFieldElements (CellData bs) - putStrLn $ "Merkle root of [1.." ++ show n ++ "] :: [Byte] = " ++ show (calcMerkleRoot flds) + putStrLn $ "Merkle root of [1.." ++ show n ++ "] :: [Byte] = " ++ show (calcMerkleRoot flavour flds) -------------------------------------------------------------------------------- diff --git a/reference/haskell/storage-proof-ref.cabal b/reference/haskell/storage-proof-ref.cabal index 0ce8b95..c761e56 100644 --- a/reference/haskell/storage-proof-ref.cabal +++ b/reference/haskell/storage-proof-ref.cabal @@ -41,7 +41,8 @@ Library Poseidon2.Example Poseidon2.Merkle Poseidon2.Permutation - Poseidon2.RoundConsts + Poseidon2.RoundConstsOld + Poseidon2.RoundConstsNew Poseidon2.Sponge Misc TestVectors