diff options
author | William Carroll <wpcarro@gmail.com> | 2020-07-01T09·42+0100 |
---|---|---|
committer | William Carroll <wpcarro@gmail.com> | 2020-07-01T09·42+0100 |
commit | ee1aeee5f8536c35fb9f1580174facd33698ad50 (patch) | |
tree | 22a001789253ae867845e72631ce20553d949f68 /scratch | |
parent | c4fe3c92c7e18a58630edc2a5d9a334075af985f (diff) |
Complete exercises for Reader and State chapters
It's beautiful how State is just Reader that returns a tuple of (a, r) instead of just a, allowing you to modify the environment (i.e. state). ```haskell newtype Reader r a = Reader { runReader :: r -> a } newtype State s a = State { runState :: s -> (a, s) } ```
Diffstat (limited to 'scratch')
-rw-r--r-- | scratch/haskell-programming-from-first-principles/reader.hs | 149 | ||||
-rw-r--r-- | scratch/haskell-programming-from-first-principles/state.hs | 93 |
2 files changed, 242 insertions, 0 deletions
diff --git a/scratch/haskell-programming-from-first-principles/reader.hs b/scratch/haskell-programming-from-first-principles/reader.hs new file mode 100644 index 000000000000..7cb7b4a1bbc1 --- /dev/null +++ b/scratch/haskell-programming-from-first-principles/reader.hs @@ -0,0 +1,149 @@ +module Reader where + +import Data.Char +import Data.Function ((&)) +import Data.Functor ((<&>)) +import qualified Control.Applicative as A +import qualified Data.Maybe as MB + +cap :: String -> String +cap xs = xs <&> toUpper + +rev :: String -> String +rev = reverse + +compose :: String -> String +compose xs = xs & rev . cap + +fmapped :: String -> String +fmapped xs = xs & rev <$> cap + +tupled :: String -> (String, String) +tupled xs = A.liftA2 (,) cap rev $ xs + +tupled' :: String -> (String, String) +tupled' = do + capResult <- cap + revResult <- rev + pure (revResult, capResult) + +-------------------------------------------------------------------------------- + +newtype Reader r a = Reader { runReader :: r -> a } + +ask :: Reader a a +ask = Reader id + +-------------------------------------------------------------------------------- + +newtype HumanName = HumanName String + deriving (Eq, Show) + +newtype DogName = DogName String + deriving (Eq, Show) + +newtype Address = Address String + deriving (Eq, Show) + +data Person + = Person + { humanName :: HumanName + , dogName :: DogName + , address :: Address + } deriving (Eq, Show) + +data Dog + = Dog + { dogsName :: DogName + , dogsAddress :: Address + } deriving (Eq, Show) + +pers :: Person +pers = + Person (HumanName "Big Bird") + (DogName "Barkley") + (Address "Sesame Street") + +chris :: Person +chris = + Person (HumanName "Chris Allen") + (DogName "Papu") + (Address "Austin") + +getDog :: Person -> Dog +getDog p = + Dog (dogName p) (address p) + +getDogR :: Person -> Dog +getDogR = + A.liftA2 Dog dogName address + +-------------------------------------------------------------------------------- + +myLiftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c +myLiftA2 f x y = + f <$> x <*> y + +asks :: (r -> a) -> Reader r a +asks f = Reader f + +-------------------------------------------------------------------------------- + +instance Functor (Reader a) where + fmap f (Reader ab) = Reader $ f . ab + +instance Applicative (Reader a) where + pure x = Reader $ \_ -> x + (Reader rab) <*> (Reader ra) = Reader $ do + ab <- rab + fmap ab ra + +-------------------------------------------------------------------------------- + +instance Monad (Reader r) where + return = pure + -- (>>=) :: Reader r a -> (a -> Reader r b) -> Reader r b + (Reader x) >>= f = undefined + +-------------------------------------------------------------------------------- + +x = [1..3] +y = [4..6] +z = [7..9] + +xs :: Maybe Integer +xs = zip x y & lookup 3 + +ys :: Maybe Integer +ys = zip y z & lookup 6 + +zs :: Maybe Integer +zs = zip x y & lookup 4 + +z' :: Integer -> Maybe Integer +z' n = zip x y & lookup n + +x1 :: Maybe (Integer, Integer) +x1 = A.liftA2 (,) xs ys + +x2 :: Maybe (Integer, Integer) +x2 = A.liftA2 (,) ys zs + +x3 :: Integer -> (Maybe Integer, Maybe Integer) +x3 n = (z' n, z' n) + +summed :: Num a => (a, a) -> a +summed (x, y) = x + y + +bolt :: Integer -> Bool +bolt x = x > 3 && x < 8 + +main :: IO () +main = do + print $ sequenceA [Just 3, Just 2, Just 1] + print $ sequenceA [x, y] + print $ sequenceA [xs, ys] + print $ summed <$> ((,) <$> xs <*> ys) + print $ bolt 7 + print $ bolt <$> z + print $ sequenceA [(>3), (<8) ,even] 7 diff --git a/scratch/haskell-programming-from-first-principles/state.hs b/scratch/haskell-programming-from-first-principles/state.hs new file mode 100644 index 000000000000..f63e0ecdf11c --- /dev/null +++ b/scratch/haskell-programming-from-first-principles/state.hs @@ -0,0 +1,93 @@ +module StateScratch where + +-------------------------------------------------------------------------------- +import System.Random +-- import Control.Monad.Trans.State +import Data.Function ((&)) + +import qualified Control.Applicative as Ap +import qualified Control.Monad as M +-------------------------------------------------------------------------------- + +data Die + = DieOne + | DieTwo + | DieThree + | DieFour + | DieFive + | DieSix + deriving (Eq, Show) + +intToDie :: Integer -> Maybe Die +intToDie 1 = Just DieOne +intToDie 2 = Just DieTwo +intToDie 3 = Just DieThree +intToDie 4 = Just DieFour +intToDie 5 = Just DieFive +intToDie 6 = Just DieSix +intToDie _ = Nothing + +rollDie :: Moi StdGen Die +rollDie = do + (n, s) <- randomR (1, 6) + case intToDie n of + Just d -> pure (d, s) + Nothing -> pure (DieOne, s) + +rollsToGetN :: Integer -> StdGen -> [Die] +rollsToGetN n g = go 0 [] g + where + go sum result gen + | sum >= n = result + | otherwise = + let (dice, nextGen) = randomR (1, 6) gen + in case intToDie dice of + Nothing -> go (sum + dice) result nextGen + Just d -> go (sum + dice) (d : result) nextGen + +-------------------------------------------------------------------------------- + +newtype Moi s a = Moi { runMoi :: s -> (a, s) } + +instance Functor (Moi s) where + fmap f (Moi run) = + Moi $ \s -> let (x, t) = run s + in (f x, t) + +instance Applicative (Moi s) where + pure x = Moi $ \s -> (x, s) + (Moi f) <*> (Moi run) = + Moi $ \s -> let (g, t) = f s + (x, u) = run t + in (g x, u) + +instance Monad (Moi s) where + (Moi run1) >>= f = + Moi $ \s -> let (x, t) = run1 s + (Moi run2) = f x + in run2 t + +-------------------------------------------------------------------------------- + +fizzBuzz :: Integer -> String +fizzBuzz n | n `mod` 15 == 0 = "FizzBuzz" + | n `mod` 5 == 0 = "Buzz" + | n `mod` 3 == 0 = "Fizz" + | otherwise = show n + +-------------------------------------------------------------------------------- + +get :: Moi s s +get = Moi $ \s -> (s, s) + +put :: s -> Moi s () +put x = Moi $ \s -> ((), x) + +exec :: Moi s a -> s -> s +exec (Moi run) x = x & run & snd + +eval :: Moi s a -> s -> a +eval (Moi run) x = x & run & fst + +modify :: (s -> s) -> Moi s () +modify f = Moi $ \s -> ((), f s) |