okasaki

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

Leftist.hs (2437B)

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