feat: Bank progress

hffp.cabal

@@ -47,6 +47,12 @@ library
       Ch21.Playground
       Ch22.ChapterEx
       Ch22.Playground
+      Ch23.ChapterEx
+      Ch23.Die
+      Ch23.MyState
+      Ch23.Playground
+      Ch25.ChapterEx
+      Ch25.Playgroud
       Ch8.Playground
       Ch9.Cipher
       Ch9.Playground
@@ -65,8 +71,10 @@ library
     , checkers
     , containers
     , hspec
+    , lens
     , random
     , time
+    , transformers
   default-language: Haskell2010
 
 executable hffp

package.yaml

@@ -43,6 +43,8 @@ library:
     - hspec
     - QuickCheck
     - checkers
+    - transformers
+    - lens
 
 executables:
   hffp:

src/Ch13/Person.hs

@@ -15,24 +15,24 @@ data PersonInvalid = NameEmpty | AgeTooLow | PersonInvalidUnknown String derivin
 
 mkPerson :: Name -> Age -> Either PersonInvalid Person
 mkPerson name age
-  | name /= "" && age > 0 = Right $ Person name age
-  | name == "" = Left NameEmpty
-  | age <= 0 = Left AgeTooLow
-  | otherwise = Left $ PersonInvalidUnknown $ "Name was: " ++ show name ++ " Age was: " ++ show age
+    | name /= "" && age > 0 = Right $ Person name age
+    | name == "" = Left NameEmpty
+    | age <= 0 = Left AgeTooLow
+    | otherwise = Left $ PersonInvalidUnknown $ "Name was: " ++ show name ++ " Age was: " ++ show age
 
 getInput :: String -> IO String
 getInput prompt = do
-  hSetBuffering stdout NoBuffering
-  putStr [fmt|{prompt}: |]
-  getLine
+    hSetBuffering stdout NoBuffering
+    putStr [fmt|{prompt}: |]
+    getLine
 
 gimmePerson :: IO ()
 gimmePerson = do
-  personName <- getInput "Name: "
-  personAge <- (read @Integer) <$> getInput "Age: "
-
-  case mkPerson personName personAge of
-    Right person -> putStrLn [fmt|Yay! Successfully got a person: {show person}|]
-    Left NameEmpty -> putStrLn "An error occurred. No name provided"
-    Left AgeTooLow -> putStrLn "An error occurred. Age provided is too low"
-    Left (PersonInvalidUnknown errText) -> putStrLn [fmt|An error occurred: {errText}|]
+    personName <- getInput "Name: "
+    personAge <- (read @Integer) <$> getInput "Age: "
+
+    case mkPerson personName personAge of
+        Right person -> putStrLn [fmt|Yay! Successfully got a person: {show person}|]
+        Left NameEmpty -> putStrLn "An error occurred. No name provided"
+        Left AgeTooLow -> putStrLn "An error occurred. Age provided is too low"
+        Left (PersonInvalidUnknown errText) -> putStrLn [fmt|An error occurred: {errText}|]

src/Ch23/ChapterEx.hs

@@ -0,0 +1,46 @@
+module Ch23.ChapterEx where
+
+import Control.Lens.Combinators
+import Control.Monad.Trans.State hiding (get, modify, put)
+
+get :: State s s
+get = state $ \s -> (s, s)
+
+--- >>> runState get "curryIsAmaze"
+-- ("curryIsAmaze","curryIsAmaze")
+
+put :: s -> State s ()
+put s = state $ const ((), s)
+
+--- >>> runState (put "blah") "woot"
+-- ((),"blah")
+
+exec :: State s a -> s -> s
+exec (StateT sa) = snd . runIdentity . sa
+
+--- >>> exec get "scooby papu"
+-- "scooby papu"
+
+--- >>> exec (put "wilma") "daphne"
+-- "wilma"
+
+eval :: State s a -> s -> a
+eval (StateT sa) = fst . runIdentity . sa
+
+--- >>> eval get "bunnicula"
+-- "bunnicula"
+
+--- >>> eval get "stake a bunny"
+-- "stake a bunny"
+
+modify :: (s -> s) -> State s ()
+modify f = state $ \s -> ((), f s)
+
+sampleModify :: State Integer ()
+sampleModify = modify (+ 1)
+
+--- >>> runState sampleModify 0
+-- ((),1)
+
+--- >>> runState (sampleModify >> sampleModify) 0
+-- ((),2)

src/Ch23/Die.hs

@@ -0,0 +1,65 @@
+module Ch23.Die where
+
+import Control.Applicative (liftA3)
+import Control.Lens.Combinators
+import Control.Monad (replicateM, unless)
+import Control.Monad.Trans.State
+import Data.Bifunctor (bimap, second)
+import System.Random
+
+data Die = DieOne | DieTwo | DieThree | DieFour | DieFive | DieSix deriving (Eq, Show, Ord, Enum)
+
+rollDie :: State StdGen Die
+rollDie = toEnum . subtract 1 <$> state (randomR (1, 6))
+
+rollDieThreeTimes :: State StdGen (Die, Die, Die)
+rollDieThreeTimes = liftA3 (,,) rollDie rollDie rollDie
+
+infiniteRoll :: Int -> State StdGen [Die]
+infiniteRoll n = replicateM n rollDie
+
+rollsToGetTwenty' :: StdGen -> Int
+rollsToGetTwenty' = go 0 0
+  where
+    go :: Int -> Int -> StdGen -> Int
+    go sum count gen
+        | sum >= 20 = count
+        | otherwise =
+            let (die, nextGen) = randomR (1, 6) gen
+             in go (sum + die) (count + 1) nextGen
+
+rollsToGetN :: Int -> StdGen -> Int
+rollsToGetN n = go 0 0
+  where
+    go :: Int -> Int -> StdGen -> Int
+    go sum count gen
+        | sum >= n = count
+        | otherwise =
+            let (die, nextGen) = randomR (1, 6) gen
+             in go (sum + die) (count + 1) nextGen
+
+rollsCountLogged :: Int -> StdGen -> (Int, [Die])
+rollsCountLogged n = go 0 0 []
+  where
+    go :: Int -> Int -> [Int] -> StdGen -> (Int, [Die])
+    go sum count diesRolled gen
+        | sum >= n = (count, map toEnum diesRolled)
+        | otherwise =
+            let (die, nextGen) = randomR (1, 6) gen
+             in go (sum + die) (count + 1) (die : diesRolled) nextGen
+
+rollsToGetToTwenty :: State (StdGen, (Int, Int, [Die])) (Int, [Die])
+rollsToGetToTwenty = do
+    dieRoll <- zoom _1 rollDie
+    let dieInt = fromEnum dieRoll
+    modify (\(seed, (rollSum, count, rolls)) -> (seed, (rollSum + dieInt, count + 1, dieRoll : rolls)))
+    (resultantSum, count, allRolls) <- gets snd
+    if resultantSum >= 20 then pure (count, allRolls) else rollsToGetToTwenty
+
+rollsToGetToN :: Int -> State (StdGen, (Int, Int, [Die])) (Int, [Die])
+rollsToGetToN n = do
+    dieRoll <- zoom _1 rollDie
+    let dieInt = fromEnum dieRoll
+    modify (\(seed, (rollSum, count, rolls)) -> (seed, (rollSum + dieInt, count + 1, dieRoll : rolls)))
+    (resultantSum, count, allRolls) <- gets snd
+    if resultantSum >= n then pure (count, reverse allRolls) else rollsToGetToTwenty

src/Ch23/MyState.hs

@@ -0,0 +1,22 @@
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
+{-# HLINT ignore "Use tuple-section" #-}
+module Ch23.MyState where
+
+import Data.Bifunctor (first)
+
+newtype MyState s a = MyState {runMyState :: s -> (a, s)}
+
+instance Functor (MyState s) where
+    fmap f (MyState g) = MyState $ first f . g
+
+instance Applicative (MyState s) where
+    pure a = MyState $ \s -> (a, s)
+
+    (MyState f) <*> (MyState g) = MyState $ \s ->
+        let (mapFn, newS) = f s
+            (output, finalS) = g newS
+         in (mapFn output, finalS)
+
+instance Monad (MyState s) where
+    (MyState f) >>= g = MyState $ \s -> let (a, newS) = f s in runMyState (g a) newS

src/Ch23/Playground.hs

@@ -0,0 +1,13 @@
+module Ch23.Playground where
+
+fizzBuzz :: Integer -> String
+fizzBuzz n | n `mod` 15 == 0 = "FizzBuzz"
+  | n `mod` 5== 0 = "Buzz"
+  | n `mod` 3== 0 = "Fizz"
+  | otherwise= show n
+
+fizzbuzzFromTo :: Integer -> Integer -> [String]
+fizzbuzzFromTo from to = map fizzBuzz [from..to]
+
+main :: IO ()
+main = mapM_ putStrLn (fizzbuzzFromTo 1 100)

src/Ch23/README.md

@@ -0,0 +1 @@
+# Chapter 23

src/Ch24/.gitkeep

@@ -0,0 +1 @@
+Will get back to this

src/Ch25/ChapterEx.hs

@@ -0,0 +1,29 @@
+module Ch25.ChapterEx where
+
+import Data.Bifunctor
+
+-- TODO: Use the checkers library to write tests for these instances
+
+newtype Compose f g a = Compose {runCompose :: f (g a)} deriving (Eq, Show)
+
+instance (Functor f, Functor g) => Functor (Compose f g) where
+    fmap f (Compose fga) = Compose $ (fmap . fmap) f fga
+
+instance (Applicative f, Applicative g) => Applicative (Compose f g) where
+    pure = Compose . pure . pure
+
+    (Compose fgf) <*> (Compose fga) = Compose $ liftA2 (<*>) fgf fga
+
+instance (Foldable f, Foldable g) => Foldable (Compose f g) where
+    foldMap f (Compose fga) = (foldMap . foldMap) f fga
+
+instance (Traversable f, Traversable g) => Traversable (Compose f g) where
+    traverse f (Compose fga) = Compose <$> (traverse . traverse) f fga
+
+data Deux a b = Deux a b deriving (Eq, Show)
+
+instance Functor (Deux a) where
+    fmap f (Deux a b) = Deux a (f b)
+
+instance Bifunctor Deux where
+    bimap f g (Deux a b) = Deux (f a) (g b)

src/Ch25/Playgroud.hs

@@ -0,0 +1,44 @@
+module Ch25.Playground where
+
+-- TODO: Use the checkers library to write tests for these instances
+-- Skip checks for the Compose' newtype
+
+newtype One f a = One {getOne :: f a} deriving (Eq, Show)
+
+newtype Compose' f g a = Compose' {runCompose' :: f (g a)} deriving (Eq, Show)
+
+newtype Three f g h a = Three {getThree :: f (g (h a))} deriving (Eq, Show)
+
+newtype Four f g h j a = Four {getFour :: f (g (h (j a)))} deriving (Eq, Show)
+
+instance (Functor f) => Functor (One f) where
+    fmap f (One fa) = One $ fmap f fa
+
+instance (Functor f, Functor g) => Functor (Compose' f g) where
+    fmap f (Compose' fga) = Compose' $ (fmap . fmap) f fga
+
+instance (Functor f, Functor g, Functor h) => Functor (Three f g h) where
+    fmap f (Three fgha) = Three $ (fmap . fmap . fmap) f fgha
+
+instance (Functor f, Functor g, Functor h, Functor j) => Functor (Four f g h j) where
+    fmap f (Four fghja) = Four $ (fmap . fmap . fmap . fmap) f fghja
+
+instance (Applicative f) => Applicative (One f) where
+    pure = One . pure
+
+    (One ff) <*> (One fa) = One $ ff <*> fa
+
+instance (Applicative f, Applicative g) => Applicative (Compose' f g) where
+    pure = Compose' . pure . pure
+
+    (Compose' fgf) <*> (Compose' fga) = Compose' $ liftA2 (<*>) fgf fga
+
+instance (Applicative f, Applicative g, Applicative h) => Applicative (Three f g h) where
+    pure = Three . pure . pure . pure
+
+    (Three fghf) <*> (Three fgha) = Three $ liftA2 (liftA2 (<*>)) fghf fgha
+
+instance (Applicative f, Applicative g, Applicative h, Applicative j) => Applicative (Four f g h j) where
+    pure = Four . pure . pure . pure . pure
+
+    (Four fghjf) <*> (Four fghja) = Four $ liftA2 (liftA2 (liftA2 (<*>))) fghjf fghja