Exercices corrigés 05 : Haskell avancé

absMax :: (Num a, Ord a) => [a] -> a

combine :: Num b => (a -> b) -> (b -> b -> b) -> [a] -> b

count :: Eq a => a -> [a] -> Int
count _ [] = 0
count target (x:xs) =
  (if target == x then 1 else 0) + count target xs

import Data.List (foldl')

mapRec :: (a -> b) -> [a] -> [b]
mapRec _ [] = []
mapRec f (x:xs) = f x : mapRec f xs

filterRec :: (a -> Bool) -> [a] -> [a]
filterRec p = foldr step []
  where
    step x rest
      | p x       = x : rest
      | otherwise = rest

foldrRec :: (a -> b -> b) -> b -> [a] -> b
foldrRec _ z [] = z
foldrRec f z (x:xs) = f x (foldrRec f z xs)

count :: Eq a => a -> [a] -> Int
count target = foldr (\x n -> if x == target then n + 1 else n) 0

maximumSafe :: Ord a => [a] -> Maybe a
maximumSafe = foldr step Nothing
  where
    step x Nothing  = Just x
    step x (Just y) = Just (max x y)

reverseFast :: [a] -> [a]
reverseFast = foldl' (flip (:)) []

zipRec :: [a] -> [b] -> [(a,b)]
zipRec (x:xs) (y:ys) = (x,y) : zipRec xs ys
zipRec _ _ = []

repeatApply :: Int -> (a -> a) -> a -> a
repeatApply n f x
  | n <= 0    = x
  | otherwise = repeatApply (n - 1) f (f x)

multiply :: Int -> Int -> Int
multiply x y
  | y < 0     = negate (multiply x (negate y))
  | otherwise = repeatApply y (+ x) 0

powerNat :: Int -> Int -> Int
powerNat _ n | n < 0 = error "exposant négatif"
powerNat x n = repeatApply n (* x) 1

isPythagorean :: Integral a => a -> a -> a -> Bool
isPythagorean a b c =
  a > 0 && b > 0 && c > 0 && a*a + b*b == c*c

sameSign :: (Num a, Ord a) => a -> a -> Bool
sameSign a b = (a >= 0 && b >= 0) || (a < 0 && b < 0)

import qualified Data.Map.Strict as Map

data Cardinal = North | East | South | West
  deriving (Eq, Ord, Show)

data Turn = Left90 | Right90
  deriving (Eq, Show)

data Coord = Coord Int Int
  deriving (Eq, Ord, Show)

turn :: Turn -> Cardinal -> Cardinal
turn Left90  North = West
turn Left90  West  = South
turn Left90  South = East
turn Left90  East  = North
turn Right90 North = East
turn Right90 East  = South
turn Right90 South = West
turn Right90 West  = North

move :: Cardinal -> Int -> Coord -> Coord
move direction distance (Coord x y) =
  let d = max 0 distance
  in case direction of
       North -> Coord x (y + d)
       East  -> Coord (x + d) y
       South -> Coord x (y - d)
       West  -> Coord (x - d) y

data Vegetable = Bean | Carrot | Squash
  deriving (Eq, Ord, Show)

data Colour = Red | Yellow | Blue
  deriving (Eq, Ord, Show)

data Fruit = Apple | Pear | Plum
  deriving (Eq, Ord, Show)

data Plant
  = VegetablePlant Vegetable
  | Flower Colour
  | FruitTree Fruit
  deriving (Eq, Show)

data SpadeSize = Small | Medium | Large
  deriving (Eq, Show)

data Water = EmptyCan | Litres Int
  deriving (Eq, Show)

data Tool = Spade SpadeSize | Pickaxe | WateringCan Water
  deriving (Eq, Show)

data Basket = EmptyBasket | OneVegetable Vegetable | TwoVegetables Vegetable Vegetable
  deriving (Eq, Show)

data Object = PlantObject Plant | ToolObject Tool | BasketObject Basket
  deriving (Eq, Show)

data Cell = Tap | Contains Object | Vacant
  deriving (Eq, Show)

data Load = NothingLoaded | Carrying Object
  deriving (Eq, Show)

type Garden = Map.Map Coord Cell

data Robot = Robot
  { position  :: Coord
  , direction :: Cardinal
  , load      :: Load
  } deriving (Eq, Show)

data Action = MoveBy Int | TurnBy Turn | PickUp | PutDown | WaterBy Int
  deriving (Eq, Show)

place :: Coord -> Cell -> Garden -> Garden
place = Map.insert

import Data.List (intercalate)

data ArbreAlg a = ArbreAlg
  { feuilleAlg :: Int -> a
  , noeudAlg   :: [a] -> a
  }

foldArbre :: ArbreAlg a -> Arbre -> a
foldArbre alg (Feuille n) = feuilleAlg alg n
foldArbre alg (Noeud enfants) =
  noeudAlg alg (map (foldArbre alg) enfants)

sommeAlg :: ArbreAlg Int
sommeAlg = ArbreAlg id sum

hauteurAlg :: ArbreAlg Int
hauteurAlg = ArbreAlg (const 1) (\hs -> 1 + maximum (0 : hs))

listeAlg :: ArbreAlg [Int]
listeAlg = ArbreAlg (:[]) concat

renduAlg :: ArbreAlg String
renduAlg = ArbreAlg show (\xs -> "(" ++ intercalate "," xs ++ ")")

arbreExemple :: Arbre
arbreExemple =
  Noeud [Noeud [Feuille 4, Feuille 5], Feuille 2, Feuille 3]

import qualified Data.Map.Strict as Map
import Data.List (foldl')

data Trie = Trie
  { isWord   :: Bool
  , children :: Map.Map Char Trie
  } deriving (Eq, Show)

emptyTrie :: Trie
emptyTrie = Trie False Map.empty

insertWord :: String -> Trie -> Trie
insertWord [] (Trie _ kids) = Trie True kids
insertWord (c:cs) (Trie end kids) =
  let child = Map.findWithDefault emptyTrie c kids
      child' = insertWord cs child
  in Trie end (Map.insert c child' kids)

memberWord :: String -> Trie -> Bool
memberWord [] (Trie end _) = end
memberWord (c:cs) (Trie _ kids) =
  maybe False (memberWord cs) (Map.lookup c kids)

insertAll :: [String] -> Trie
insertAll = foldl' (flip insertWord) emptyTrie

allWords :: Trie -> [String]
allWords (Trie end kids) =
  (if end then [""] else []) ++
  [ c : suffix
  | (c, child) <- Map.toList kids
  , suffix <- allWords child
  ]

followPrefix :: String -> Trie -> Maybe Trie
followPrefix [] trie = Just trie
followPrefix (c:cs) (Trie _ kids) =
  Map.lookup c kids >>= followPrefix cs

wordsWithPrefix :: String -> Trie -> [String]
wordsWithPrefix prefix trie =
  maybe [] (map (prefix ++) . allWords)
        (followPrefix prefix trie)

dictionary :: Trie
dictionary = insertAll
  ["art", "article", "artifice", "balle", "ballon",
   "la", "langage", "langue"]

newtype Poly a = Poly [a]
  deriving (Eq, Show)

evalPoly :: Num a => Poly a -> a -> a
evalPoly (Poly coefficients) x =
  foldr (\coefficient acc -> coefficient + x * acc)
        0 coefficients

differentiate :: Num a => Poly a -> Poly a
differentiate (Poly []) = Poly []
differentiate (Poly (_:coefficients)) =
  Poly (zipWith (\degree coefficient ->
                   fromIntegral degree * coefficient)
                ([1..] :: [Int]) coefficients)

import Control.Monad.State.Strict
  (State, execState, get, put)

type Weights = [Double]
type Optimizer a = State Weights a

mockGradientUpdate :: Double -> Weights -> Weights
mockGradientUpdate delta = map (\weight -> weight - delta)

updateStep :: Double -> Optimizer ()
updateStep delta = do
  current <- get
  put (mockGradientUpdate delta current)

runOptimization :: [Double] -> Weights -> Weights
runOptimization deltas initial =
  execState (mapM_ updateStep deltas) initial

import Control.Monad.Writer.Strict
  (Writer, runWriter, tell)
import Data.List (maximumBy)
import Data.Ord (comparing)

type ResourceScore = (Double, Double, Double)
type DecisionLog = [String]
type DecisionAgent a = Writer DecisionLog a

logDecision :: String -> DecisionAgent ()
logDecision message = tell [message]

allocateResource :: ResourceScore -> DecisionAgent String
allocateResource (scoreA, scoreB, scoreC) = do
  let (name, score) =
        maximumBy (comparing snd)
          [("A", scoreA), ("B", scoreB), ("C", scoreC)]
  logDecision
    ("Allocation faite à la ressource " ++ name
       ++ " avec le score " ++ show score)
  pure name

sequentialDecisions
  :: ResourceScore -> ResourceScore
  -> DecisionAgent (String, String)
sequentialDecisions first second = do
  a <- allocateResource first
  b <- allocateResource second
  pure (a, b)

runDecisions
  :: ResourceScore -> ResourceScore
  -> ((String, String), DecisionLog)
runDecisions first second =
  runWriter (sequentialDecisions first second)

import Control.Monad.State.Strict
  (StateT, execStateT, get, put)
import Control.Monad.Trans.Class (lift)

type Weights = [Double]
type SafeOptimizer a = StateT Weights (Either String) a

applyBatch :: Double -> [Double] -> SafeOptimizer ()
applyBatch rate gradient = do
  weights <- get
  if length weights /= length gradient
    then lift (Left "Le gradient et les poids n'ont pas la même taille.")
    else put (zipWith (\weight g -> weight - rate * g)
                     weights gradient)

trainSafe
  :: Double -> [[Double]] -> Weights
  -> Either String Weights
trainSafe rate batches initial =
  execStateT (mapM_ (applyBatch rate) batches) initial