okasaki

Okasaki's Purely Functional Data Structures
git clone git://git.jtobin.io/okasaki.git
Log | Files | Refs | LICENSE

Weighted.hs (2537B)

      1 {-# OPTIONS_GHC -fno-warn-orphans #-}
      2 
      3 module Heap.Weighted (
      4     bleftist
      5   , decorated
      6   , heap
      7   , size
      8 
      9   , tests
     10   ) where
     11 
     12 import Control.Monad (foldM, replicateM)
     13 import Data.Fix (Fix(..))
     14 import Data.Functor.Foldable (project, para, cata)
     15 import Data.Monoid
     16 import qualified Okasaki.Heap.Leftist.Weighted as H
     17 import Test.QuickCheck
     18 import Test.Tasty (TestTree)
     19 import Test.Tasty.QuickCheck (testProperty)
     20 
     21 tests :: [TestTree]
     22 tests = [
     23     testProperty "decorations accurate" decorated
     24   , testProperty "weight-biased leftist property invariant" bleftist
     25   , testProperty "heap order invariant" heap
     26   , testProperty "correct right-spine length" size
     27   ]
     28 
     29 
     30 dec :: H.Heap a -> Bool
     31 dec h = H.siz h == H.wyt h
     32 
     33 spi :: H.Heap a -> Int
     34 spi = cata $ \case
     35   H.LeafF         -> 0
     36   H.NodeF _ _ _ r -> succ r
     37 
     38 mos :: H.Heap a -> Bool
     39 mos h =
     40   let n = getSum (H.wyt h)
     41   in  spi h <= floor (logBase 2 ((fromIntegral (succ n)) :: Double))
     42 
     43 wef :: H.Heap a -> Bool
     44 wef = para $ \case
     45   H.LeafF -> True
     46   H.NodeF _ _ (l, c) (r, d) -> H.siz l >= H.siz r && c && d
     47 
     48 hor :: Ord a => H.Heap a -> Bool
     49 hor = para $ \case
     50   H.LeafF -> True
     51   H.NodeF _ a (l, c) (r, d) -> case (project l, project r) of
     52     (H.LeafF, H.LeafF)                 -> True && c && d
     53     (H.LeafF, H.NodeF _ v _ _)         -> a <= v && c && d
     54     (H.NodeF _ v _ _, H.LeafF)         -> a <= v && c && d
     55     (H.NodeF _ u _ _, H.NodeF _ v _ _) -> a <= u && a <= v && c && d
     56 
     57 data Act k =
     58     Put k
     59   | Cut
     60   deriving (Eq, Show)
     61 
     62 act :: Arbitrary k => Gen (Act k)
     63 act = frequency [
     64     (10, Put <$> arbitrary)
     65   , (2, pure Cut)
     66   ]
     67 
     68 use :: Ord k => Act k -> H.Heap k -> Gen (H.Heap k)
     69 use a h = case a of
     70   Put k -> pure (H.put k h)
     71   Cut   -> pure (H.cut h)
     72 
     73 hep :: (Ord k, Arbitrary k) => Gen (H.Heap k)
     74 hep = do
     75   num  <- choose (0, 1000)
     76   acts <- replicateM num act
     77   foldM (flip use) H.lef acts
     78 
     79 lil :: Arbitrary k => H.Heap k -> [H.Heap k]
     80 lil h = case project h of
     81   H.LeafF -> mempty
     82   H.NodeF _ a l r -> mconcat [
     83       [H.lef]
     84     , [l, r]
     85     , [ Fix (H.NodeF (1 <> H.siz k <> H.siz s) b k s) |
     86         (b, k, s) <- (,,) <$> shrink a <*> lil l <*> lil r]
     87     ]
     88 
     89 instance (Ord k, Arbitrary k) => Arbitrary (H.Heap k) where
     90   arbitrary = hep
     91   shrink = lil
     92 
     93 decorated :: Property
     94 decorated = forAllShrink (hep :: Gen (H.Heap Int)) lil dec
     95 
     96 bleftist :: Property
     97 bleftist = forAllShrink (hep :: Gen (H.Heap Int)) lil wef
     98 
     99 heap :: Property
    100 heap = forAllShrink (hep :: Gen (H.Heap Int)) lil hor
    101 
    102 size :: Property
    103 size = forAllShrink (hep :: Gen (H.Heap Int)) lil mos