okasaki

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

CPS.hs (2127B)

      1 {-# OPTIONS_GHC -Wall -fno-warn-unused-top-binds #-}
      2 
      3 module Okasaki.Stack.CPS (
      4     StackF(..)
      5   , Stack
      6   , nil
      7   , put
      8   , pop
      9   , jab
     10   , non
     11 
     12   , map
     13   , run
     14 
     15   , gas
     16   , tap
     17   , cat
     18   , suf
     19   ) where
     20 
     21 import Data.Fix hiding (cata, ana, hylo)
     22 import Data.Functor.Foldable
     23 import Prelude hiding (map)
     24 
     25 newtype StackF a r = StackF (forall e. e -> (a -> r -> e) -> e)
     26   deriving Functor
     27 
     28 type Stack a = Fix (StackF a)
     29 
     30 nilF :: StackF a r
     31 nilF = StackF const
     32 
     33 putF :: a -> r -> StackF a r
     34 putF h t = StackF (\_ c -> c h t)
     35 
     36 -- | O(1)
     37 nil :: Stack a
     38 nil = Fix nilF
     39 
     40 -- | O(1)
     41 put :: a -> Stack a -> Stack a
     42 put h t = Fix (putF h t)
     43 
     44 -- | O(1)
     45 pop :: Stack a -> Maybe (a, Stack a)
     46 pop (project -> StackF c) = c Nothing b where
     47   b h t = Just (h, t)
     48 
     49 -- | O(1)
     50 non :: Stack a -> Bool
     51 non (project -> StackF c) = c True (\_ _ -> False)
     52 
     53 -- | O(n) for n = length input
     54 gas :: [a] -> Stack a
     55 gas = ana $ \case
     56   []      -> nilF
     57   (h : t) -> putF h t
     58 
     59 -- | O(n) for n = length input
     60 tap :: Stack a -> [a]
     61 tap = ana lag where
     62   lag (project -> StackF c) = c Nil Cons
     63 
     64 -- | O(n) for n = length input
     65 map :: (a -> b) -> Stack a -> Stack b
     66 map f = ana lag where
     67   lag (project -> StackF c) = c nilF b
     68   b h t = putF (f h) t
     69 
     70 -- | O(n) for n = length input
     71 run :: (a -> b -> b) -> b -> Stack a -> b
     72 run f o = cata $ \case
     73   StackF c -> c o f
     74 
     75 -- | O(n) for n = length l
     76 cat :: Stack a -> Stack a -> Stack a
     77 cat l r = apo lag (project l) where
     78   lag (StackF c) = c a b
     79 
     80   a = fmap Left (project r)
     81 
     82   b h (project -> StackF c) =
     83     let d     = putF h (Left r)
     84         e f g = putF h (Right (putF f g))
     85     in  c d e
     86 
     87 -- | O(n)
     88 jab :: Int -> a -> Stack a -> Stack a
     89 jab n x s = apo lag (n, s) where
     90   lag (j, project -> StackF c) = c nilF (b j)
     91 
     92   b j h t
     93     | j <= 0    = putF x (Left t)
     94     | otherwise = putF h (Right (pred j, t))
     95 
     96 -- exercise 2.1
     97 
     98 -- | O(n) for n = length input
     99 suf :: Stack a -> Stack (Stack a)
    100 suf = ana lag where
    101   lag (project -> StackF c) = c nilF b
    102   b _ t = putF t t
    103 
    104 -- test
    105 
    106 test0 :: Stack Int
    107 test0 = gas [1..3]
    108 
    109 test1 :: Stack Int
    110 test1 = gas [4..7]
    111 
    112 test2 :: Stack Int
    113 test2 = jab 3 100 (cat test0 test1)