diff --git a/agora-test/Spec/Utils.hs b/agora-test/Spec/Utils.hs index 16e62d9..596a6a3 100644 --- a/agora-test/Spec/Utils.hs +++ b/agora-test/Spec/Utils.hs @@ -7,7 +7,88 @@ Tests for utility functions in 'Agora.Utils'. -} module Spec.Utils (tests) where +import Agora.Utils (phalve, pmerge, pmsortOrd, tcmatch) +import Data.List (sort) import Test.Tasty (TestTree) +import Test.Tasty.QuickCheck (testProperty) tests :: [TestTree] -tests = [] +tests = + [ testProperty "Merge sort sorts a list properly" prop_msort_sorted + , testProperty "Two sorted lists are merged into one sorted list" prop_pmerge_sorted + , testProperty "Split a list in half as expected" prop_halve_properly + ] + +-------------------------------------------------------------------------------- + +prop_msort_sorted :: [Integer] -> Bool +prop_msort_sorted arr = sort arr == sorted + where + parr :: Term _ (PBuiltinList PInteger) + parr = pconstant arr + + psorted :: Term _ (PBuiltinList PInteger) + psorted = pmsortOrd # parr + + sorted :: [Integer] + sorted = plift psorted + +prop_pmerge_sorted :: ([Integer], [Integer]) -> Bool +prop_pmerge_sorted (a, b) = merge sa sb == merged + where + sa = sort a + sb = sort b + + merge xs [] = xs + merge [] ys = ys + merge sx@(x : xs) sy@(y : ys) + | x <= y = x : merge xs sy + | otherwise = y : merge sx ys + + psa :: Term _ (PBuiltinList PInteger) + psa = pconstant @(PBuiltinList PInteger) sa + psb :: Term _ (PBuiltinList PInteger) + psb = pconstant @(PBuiltinList PInteger) sb + + pmerged :: Term _ (PBuiltinList PInteger) + pmerged = pmerge # plam (#<) # psa # psb + + merged :: [Integer] + merged = plift pmerged + +prop_halve_properly :: [Integer] -> Bool +prop_halve_properly arr = halve arr == halved + where + halve xs = go xs xs + where + go xs [] = ([], xs) + go (x : xs) [_] = ([x], xs) + go (x : xs) (_ : _ : ys) = + let (first, last) = + go xs ys + in (x : first, last) + go [] _ = ([], []) + + parr :: Term _ (PBuiltinList PInteger) + parr = pconstant arr + + ppairFst :: Term _ (PPair a b :--> a) + ppairFst = phoistAcyclic $ + plam $ \p -> unTermCont $ do + PPair x _ <- tcmatch p + return x + + ppairSnd :: Term _ (PPair a b :--> b) + ppairSnd = phoistAcyclic $ + plam $ \p -> unTermCont $ do + PPair _ y <- tcmatch p + return y + + phalved :: Term _ (PPair (PBuiltinList PInteger) (PBuiltinList PInteger)) + phalved = phalve # parr + + halved :: ([Integer], [Integer]) + halved = + let f = plift $ ppairFst # phalved + s = plift $ ppairSnd # phalved + in (f, s) diff --git a/agora.cabal b/agora.cabal index 11bb2d7..c8ce871 100644 --- a/agora.cabal +++ b/agora.cabal @@ -119,6 +119,7 @@ common test-deps , tasty , tasty-hedgehog , tasty-hunit + , tasty-quickcheck common exe-opts ghc-options: -threaded -rtsopts -with-rtsopts=-N -O0 diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index 110899c..7ce3bf3 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -56,6 +56,8 @@ module Agora.Utils ( mustBePJust, mustBePDJust, validatorHashToAddress, + pmerge, + phalve, ) where -------------------------------------------------------------------------------- @@ -446,7 +448,7 @@ pmerge = phoistAcyclic $ pfix #$ plam pmerge' pif (comp # ah # bh) (pcons # ah #$ self # comp # at # b) - (pcons # bh #$ self # comp # at # bt) + (pcons # bh #$ self # comp # a # bt) -- | / O(nlogn) /. Merge sort, bottom-up version. pmsort :: (PIsListLike l a) => Term s ((a :--> a :--> PBool) :--> l a :--> l a)