okasaki

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

Stack.hs (2291B)

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