Set13b.hs

{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Use tuple-section" #-}
module Set13b where

import Control.Monad
import Control.Monad.Trans.State
import Data.Char
import Data.IORef
import Data.List
import Mooc.Todo

------------------------------------------------------------------------------
-- Ex 1: implement the function ifM, that takes three monadic
-- operations. If the first of the operations returns True, the second
-- operation should be run. Otherwise the third operation should be
-- run.
--
-- Note the polymorphic `Monad m =>` type signature. Your operation
-- should work on all monads, and thus needs to be implemented with
-- Monad operations like do and >>=. Don't try to pattern match on
-- Maybes.
--
-- Examples (test is defined below):
--   In the Maybe Monad:
--     ifM (Just True) (Just '1') (Just '2')  ==>  Just '1'
--     ifM (Just False) (Just '1') (Just '2') ==>  Just '2'
--     ifM Nothing (Just '1') (Just '2')      ==>  Nothing
--     ifM (Just True) (Just '1') Nothing     ==>  Just '1'
--   In the State Monad (test is defined below):
--     runState (ifM get (return 'a') (return 'b')) False
--       ==> ('b',False)
--     runState (put 11 >> ifM test (return 'a') (return 'b')) 0
--       ==> ('b',11)
--     runState (put 9 >> ifM test (return 'a') (return 'b')) 0
--       ==> ('a',9)

test :: State Int Bool
test = do
  x <- get
  return (x < 10)

ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM opBool opThen opElse = opBool >>= \val -> if val then opThen else opElse

------------------------------------------------------------------------------
-- Ex 2: the standard library function Control.Monad.mapM defines a
-- monadic map operation. Some examples of using it (safeDiv is defined
-- below):
--
-- mapM (safeDiv 10.0) [1.0,5.0,2.0]  =>  Just [10.0,2.0,5.0]
-- mapM (safeDiv 10.0) [1.0,0.0,2.0]  =>  Nothing
--
-- Your task is to implement the function mapM2 that works like mapM,
-- but there are two lists and the operation takes two arguments. More
-- concretely, running `mapM2 op xs ys` should run `op`, giving it the
-- first element of xs and the first element of ys. Then, it should
-- run `op` on the second elements of xs and ys, and so forth.
-- Finally, all the values produced by `op` are returned, in order, as
-- a list.
--
-- If the lists are of different length, you can stop processing them
-- once the shorter one ends.
--
-- Examples:
--  mapM2 safeDiv [6.0,10.0,12.0] [3.0,2.0,4.0]
--    ==> Just [2.0,5.0,3.0]
--  mapM2 safeDiv [6.0,10.0,12.0] [3.0,0.0,4.0]
--    ==> Nothing
--  mapM2 (\x y -> Just (x+y)) [1,2,3] [6,7]
--    ==> Just [7,9]
--  runState (mapM2 perhapsIncrement [True,False,True] [1,2,4]) 0
--    ==> ([(),(),()],5)

-- Do not change safeDiv or perhapsIncrement, they're used by the
-- examples & test outputs.
safeDiv :: Double -> Double -> Maybe Double
safeDiv x 0.0 = Nothing
safeDiv x y = Just (x / y)

perhapsIncrement :: Bool -> Int -> State Int ()
perhapsIncrement True x = modify (+ x)
perhapsIncrement False _ = return ()

mapM2 :: Monad m => (a -> b -> m c) -> [a] -> [b] -> m [c]
mapM2 op [] _ = return []
mapM2 op _ [] = return []
-- mapM2 op [] [] = return []
mapM2 op (x : xs) (y : ys) = do
  val <- op x y
  oth <- mapM2 op xs ys
  return (val : oth)

------------------------------------------------------------------------------
-- Ex 3: Finding paths.
--
-- In this exercise, you'll process mazes, described as lists like this:

maze1 :: [(String, [String])]
maze1 =
  [ ("Entry", ["Pit", "Corridor 1"]),
    ("Pit", []),
    ("Corridor 1", ["Entry", "Dead end"]),
    ("Dead end", ["Corridor 1"]),
    ("Corridor 2", ["Corridor 3"]),
    ("Corridor 3", ["Corridor 2"])
  ]

-- This means that you can get from Entry to Pit or Corridor 1, and
-- from Corridor 1 you can get back to Entry or the Dead end, and so
-- forth. Here's a drawing of what maze1 looks like. Note how you
-- can't get out of the Pit, and Corridors 2 and 3 aren't connected to
-- the Entry.
--
--  Entry <--> Corridor 1 <--> Dead end
--   |
--   v         Corridor 2 <--> Corridor 3
--  Pit
--
-- Your task is to implement the function path that checks if there is
-- a path from one location to another.
--
--   path maze1 "Entry" "Pit"        ==> True
--   path maze1 "Entry" "Dead end"   ==> True
--   path maze1 "Pit"   "Entry"      ==> False
--   path maze1 "Entry" "Corridor 2" ==> False
--
-- To implement path, we'll need some helper functions. We'll work in
-- the State monad, with a state of type [String]. This tracks which
-- places we've been to.
--
-- The operation `visit maze place1` should work like this:
--   * if place1 is in the state (i.e. we've visited it before), do nothing
--   * otherwise, add place1 to the state (it has now been visited), and:
--      * for all neighbouring places of place1, run visit
--
-- PS. You might recognize this as a Depth-First Search, but if you
-- haven't heard the term, don't worry.
--
-- Examples:
--   runState (visit maze1 "Pit") []
--     ==> ((),["Pit"])
--   runState (visit maze1 "Corridor 2") []
--     ==> ((),["Corridor 3","Corridor 2"])
--   runState (visit maze1 "Entry") []
--     ==> ((),["Dead end","Corridor 1","Pit","Entry"])
--   runState (visit maze1 "Entry") ["Corridor 1"]
--     ==> ((),["Pit","Entry","Corridor 1"])

check :: [String] -> String -> Bool
check list place = place `elem` list

getNeigbors :: [(String, [String])] -> String -> [String]
getNeigbors list place = classifys (find (\(a, b) -> a == place) list)
  where
    classifys Nothing = []
    classifys (Just (a, b)) = b

visit :: [(String, [String])] -> String -> State [String] ()
visit maze place = do
  places <- get
  if check places place
    then return ()
    else do
      put (place : places)
      go maze (getNeigbors maze place)
  where
    go maze [] = return ()
    go maze (x : xs) = do
      visit maze x
      go maze xs

-- Now you should be able to implement path using visit. If you run
-- visit on a place using an empty state, you'll get a state that
-- lists all the places that are reachable from the starting place.

path :: [(String, [String])] -> String -> String -> Bool
path maze place1 place2 = place2 `elem` execState (visit maze place1) []

------------------------------------------------------------------------------
-- Ex 4: Given two lists, ks and ns, find numbers i and j from ks,
-- such that their sum i+j=n is in ns. Return all such triples
-- (i,j,n).
--
-- Use the list monad!
--
-- Examples:
--  findSum2 [1,2,3,4] [6,7]
--    ==> [(2,4,6),(3,3,6),(3,4,7),(4,2,6),(4,3,7)]
--
-- PS. The tests don't care about the order of results.

findSum2 :: [Int] -> [Int] -> [(Int, Int, Int)]
findSum2 ks ns = do
  i <- ks
  j <- ks
  [(i, j, i + j) | i + j `elem` ns]

------------------------------------------------------------------------------
-- Ex 5: compute all possible sums of elements from the given
-- list. Use the list monad.
--
-- Hint! a list literal like [True,False] or [x,0] can be useful when
-- combined with do-notation!
--
-- The order of the returned list does not matter and it may contain
-- duplicates.
--
-- Examples:
--   allSums []
--     ==> [0]
--   allSums [1]
--     ==> [1,0]
--   allSums [1,2,4]
--     ==> [7,3,5,1,6,2,4,0]

subsets :: [Int] -> [[Int]]
subsets [] = [[]]
subsets (x : xs) = subsets xs ++ map (x :) (subsets xs)

allSums :: [Int] -> [Int]
allSums [] = [0]
allSums xs = do
  let y = subsets xs
  map sum y

-- let val2 = sum (drop ((length xs - start) + 1) xs)
-- [1]

------------------------------------------------------------------------------
-- Ex 6: the standard library defines the function
--
--   foldM :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
--
-- This function behaves like foldr, but the operation used is
-- monadic. foldM f acc xs works by running f for each element in xs,
-- giving it also the result of the previous invocation of f.
--
-- Your task is to implement the functions f1 and f2 so that the
-- functions sumBounded and sumNotTwice work.
--
-- Do not change the definitions of sumBounded and sumNotTwice. The
-- tests have their own copies of the definitions anyway.

-- sumBounded computes the sum of a list. However if the sum at any
-- point during the execution goes over the given bound, Nothing is
-- returned.
--
-- Examples:
--  sumBounded 5 [1,2,1,-2,3]
--    ==> Just 5
--  sumBounded 5 [1,2,3,1,-2]   -- 1+2+3=6 which results in Nothing
--    ==> Nothing
sumBounded :: Int -> [Int] -> Maybe Int
sumBounded k = foldM (f1 k) 0

f1 :: Int -> Int -> Int -> Maybe Int
f1 bound acc x
  | (acc + x) > bound = Nothing
  | otherwise = Just (acc + x)

-- sumNotTwice computes the sum of a list, but counts only the first
-- occurrence of each value.
--
-- Examples:
--  sumNotTwice [1,2,3]          ==> 6
--  sumNotTwice [1,1,2,3,2,2,3]  ==> 6
--  sumNotTwice [3,-2,3]         ==> 1
--  sumNotTwice [1,2,-2,3]       ==> 4
sumNotTwice :: [Int] -> Int
sumNotTwice xs = evalState (foldM f2 0 xs) []

f2 :: Int -> Int -> State [Int] Int
f2 acc x = do
  state <- get
  if x `elem` state
    then return acc
    else do
      put (x : state)
      return (acc + x)

------------------------------------------------------------------------------
-- Ex 7: here is the Result type from Set12. Implement a Monad Result
-- instance that behaves roughly like the Monad Maybe instance.
--
-- That is,
--   1. MkResult behave like Just
--   2. If part of computation produces NoResult, the whole computation
--      produces NoResult (just like Nothing)
--   3. Similarly, if we get a Failure "reason" value, the whole
--      computation produces Failure "reason"
--
-- Examples:
--   MkResult 1 >> Failure "boom" >> MkResult 2
--     ==> Failure "boom"
--   MkResult 1 >> NoResult >> Failure "not reached"
--     ==> NoResult
--   MkResult 1 >>= (\x -> MkResult (x+1))
--     ==> MkResult 2

data Result a = MkResult a | NoResult | Failure String deriving (Show, Eq)

instance Functor Result where
  -- The same Functor instance you used in Set12 works here.
  fmap _ NoResult = NoResult
  fmap _ (Failure a) = Failure a
  fmap f (MkResult a) = MkResult (f a)

-- This is an Applicative instance that works for any monad, you
-- can just ignore it for now. We'll get back to Applicative later.
instance Applicative Result where
  pure = return
  (<*>) = ap

instance Monad Result where
  -- implement return and >>=
  return x = MkResult x
  NoResult >>= _ = NoResult
  (Failure s) >>= _ = Failure s
  (MkResult a) >>= f = f a

------------------------------------------------------------------------------
-- Ex 8: Here is the type SL that combines the State and Logger
-- types. Implement an instance Monad SL, that behaves like the
-- combination of State and Logger. That is, state is propagated from
-- one operation to the next, and log messages are stored in the order
-- they are produced.
--
-- To simplify the type signatures, the type of the state has been set
-- to Int, instead of being a parameter like in the standard State
-- monad.
--
-- This is a tough one, probably the hardest exercise on this course!
-- You can come back to it later if you don't get it now.
--
-- You might find it easier to start with the Functor instance
--
-- Examples:
--   runSL (putSL 2 >> msgSL "hello" >> getSL) 0
--      ==> (2,2,["hello"])
--   runSL (replicateM_ 5 (modifySL (+1) >> getSL >>= \x -> msgSL ("got "++show x))) 1
--      ==> ((),6,["got 2","got 3","got 4","got 5","got 6"])

data SL a = SL (Int -> (a, Int, [String]))

-- Run an SL operation with the given starting state
runSL :: SL a -> Int -> (a, Int, [String])
runSL (SL f) = f

-- Write a log message
msgSL :: String -> SL ()
msgSL msg = SL (\s -> ((), s, [msg]))

-- Fetch the state
getSL :: SL Int
getSL = SL (\s -> (s, s, []))

-- Overwrite the state
putSL :: Int -> SL ()
putSL s' = SL (const ((), s', []))

-- Modify the state
modifySL :: (Int -> Int) -> SL ()
modifySL f = SL (\s -> ((), f s, []))

fst3 :: (a, b, c) -> a
fst3 (x, _, _) = x

fst2 :: (a, b, c) -> b
fst2 (_, y, _) = y

fst1 :: (a, b, c) -> c
fst1 (_, _, y) = y

instance Functor SL where
  fmap f (SL g) = SL run
    where
      run y = (f (fst3 (g y)), fst2 (g y), fst1 (g y))

-- This is an Applicative instance that works for any monad, you
-- can just ignore it for now. We'll get back to Applicative later.
instance Applicative SL where
  pure = return
  (<*>) = ap

instance Monad SL where
  -- implement return and >>=
  return x = SL (\y -> (x, y, []))
  op >>= f = SL run
    where
      run y =
        let (val, new_state, log) = runSL op y
            op2 = f val
         in appendLog (runSL op2 new_state) log

appendLog :: (a, Int, [String]) -> [String] -> (a, Int, [String])
appendLog (a, latest_state, new_log) log = (a, latest_state, log ++ new_log)

------------------------------------------------------------------------------
-- Ex 9: Implement the operation mkCounter that produces the IO operations
-- inc :: IO () and get :: IO Int. These operations should work like this:
--
--   get returns the number of times inc has been called
--
-- In other words, a simple stateful counter. Use an IORef to store the count.
--
-- Note: this is an IO operation that produces two IO operations. Thus
-- the type of mkCounter is IO (IO (), IO Int).
--
-- This exercise is tricky. Feel free to leave it until later.
--
-- An example of how mkCounter works in GHCi:
--
--  *Set11b> (inc,get) <- mkCounter
--  *Set11b> inc
--  *Set11b> inc
--  *Set11b> get
--  2
--  *Set11b> inc
--  *Set11b> inc
--  *Set11b> get
--  4

ourGet :: IORef Int -> IO Int
ourGet ref = do
  readIORef ref

inc :: IORef Int -> IO ()
inc ref = do
  modifyIORef ref (+ 1)

mkCounter :: IO (IO (), IO Int)
mkCounter = do
  y <- newIORef 0
  return (inc y, ourGet y)