すごいHaskellたのしく学ぼう輪読会用

MyType.hs

import Data.Maybe (catMaybes)

data MyType = I Int | F Float | C Char
  deriving (Show)

-- 再帰を使う
filterC :: [MyType] -> [MyType]
filterC []           = []
filterC (x@(C _):xs) = x:filterC xs
filterC (_:xs)       = filterC xs

-- リスト内包表記を使う
filterC' :: [MyType] -> [MyType]
filterC' xs = [x | x@(C _) <- xs]

-- filter関数を使う
filterC'' :: [MyType] -> [MyType]
filterC'' = filter isC
  where
    isC (C _) = True
    isC _     = False

-- MaybeからのcatMaybes
filterC''' :: [MyType] -> [MyType]
filterC''' = catMaybes . map getC
  where
    getC x@(C _) = Just x
    getC _       = Nothing

rpn.hs

import Data.Maybe (fromJust, isJust)

evalRPN :: String -> Double
evalRPN = evalRPNTokens . words

evalRPNTokens :: [String] -> Double
evalRPNTokens = head . (foldl evalRPNToken [])

evalRPNToken :: (Floating a, Read a) => [a] -> String -> [a]
evalRPNToken (x1:x2:xs) w | isJust op = (fromJust op) x2 x1:xs where op = binOp w
evalRPNToken (x:xs) w     | isJust op = (fromJust op) x:xs     where op = uniOp w
evalRPNToken xs w         | isJust op = [(fromJust op) xs]     where op = listOp w
evalRPNToken xs s                     = (read s):xs

binOp :: Floating a => String -> Maybe (a -> a -> a)
binOp "+"  = Just (+)
binOp "-"  = Just (-)
binOp "*"  = Just (*)
binOp "/"  = Just (/)
binOp "**" = Just (**)
binOp _    = Nothing

uniOp :: Floating a => String -> Maybe (a -> a)
uniOp "exp" = Just $ exp
uniOp "log" = Just $ log
uniOp "sin" = Just $ sin
uniOp "cos" = Just $ cos
uniOp "tan" = Just $ tan
uniOp _     = Nothing

listOp :: Fractional a => String -> Maybe ([a] -> a)
listOp "sum"  = Just $ sum
listOp "mean" = Just $ (\n -> (sum n) / (fromIntegral $ length n))
listOp _      = Nothing

rpn2.hs

import Data.Maybe (fromJust, isJust)

evalRPN :: String -> Double
evalRPN = evalRPNTokens . words

evalRPNTokens :: [String] -> Double
evalRPNTokens = head . (foldl evalRPNToken [])

evalRPNToken :: [Double] -> String -> [Double]
evalRPNToken (x1:x2:xs) w | isJust op = (fromJust op) x2 x1:xs where op = lookup w binOps
evalRPNToken (x:xs) w     | isJust op = (fromJust op) x:xs     where op = lookup w uniOps
evalRPNToken xs w         | isJust op = [(fromJust op) xs]     where op = lookup w listOps
evalRPNToken xs s                     = (read s):xs

binOps :: [(String, Double -> Double -> Double)]
binOps = [("+", (+)), ("-", (-)), ("*", (*)), ("/", (/)), ("**", (**))]

uniOps :: [(String, Double -> Double)]
uniOps = [("exp", exp), ("log", log), ("sin", sin), ("cos", cos), ("tan", tan)]

listOps :: [(String, [Double] -> Double)]
listOps = [("sum", sum), ("mean", (\n -> (sum n) / (fromIntegral $ length n)))]

rpn3.hs

import Data.Maybe (fromJust, isJust)
import qualified Data.Map as M (fromList, lookup, Map)

data Op = BinOp (Double -> Double -> Double) | UniOp (Double -> Double) | ListOp ([Double] -> Double)

evalRPN :: String -> Double
evalRPN = evalRPNTokens . words

evalRPNTokens :: [String] -> Double
evalRPNTokens = head . (foldl evalRPNToken [])

evalRPNToken :: [Double] -> String -> [Double]
evalRPNToken (x1:x2:xs) w | isJust op = (fromJust op) x2 x1:xs where op = fmap (\(BinOp  op) -> op) $ M.lookup w opMap
evalRPNToken (x:xs) w     | isJust op = (fromJust op) x:xs     where op = fmap (\(UniOp  op) -> op) $ M.lookup w opMap
evalRPNToken xs w         | isJust op = [(fromJust op) xs]     where op = fmap (\(ListOp op) -> op) $ M.lookup w opMap
evalRPNToken xs s                     = (read s):xs

opMap :: M.Map String Op
opMap = M.fromList [
  ("+", BinOp (+)), ("-", BinOp (-)), ("*", BinOp (*)), ("/", BinOp (/)), ("**", BinOp (**)),
  ("exp", UniOp exp), ("log", UniOp log), ("sin", UniOp sin), ("cos", UniOp cos), ("tan", UniOp tan),
  ("sum", ListOp sum), ("mean", ListOp (\n -> (sum n) / (fromIntegral $ length n)))]

rpn4.hs

import qualified Data.Map as M (fromList, lookup, Map)

data Op = BinOp (Double -> Double -> Double) | UniOp (Double -> Double) | ListOp ([Double] -> Double)

evalRPN :: String -> Double
evalRPN = evalRPNTokens . words

evalRPNTokens :: [String] -> Double
evalRPNTokens = head . (foldl evalRPNToken [])

evalRPNToken :: [Double] -> String -> [Double]
evalRPNToken xs s = case M.lookup s opMap of
  Just op -> evalOp op xs
  Nothing -> (read s):xs

opMap :: M.Map String Op
opMap = M.fromList [
  ("+", BinOp (+)), ("-", BinOp (-)), ("*", BinOp (*)), ("/", BinOp (/)), ("**", BinOp (**)),
  ("exp", UniOp exp), ("log", UniOp log), ("sin", UniOp sin), ("cos", UniOp cos), ("tan", UniOp tan),
  ("sum", ListOp sum), ("mean", ListOp (\n -> (sum n) / (fromIntegral $ length n)))]

evalOp :: Op -> [Double] -> [Double]
evalOp (BinOp  op) (x1:x2:xs) = op x2 x1:xs
evalOp (UniOp  op) (x:xs)     = op x:xs
evalOp (ListOp op) xs         = [op xs]

TernaryOperator.hs

-- 三項演算子っぽい何か
infixl 2 .:
(.:) :: a -> a -> (a, a)
(.:) x y = (x, y)

infixl 1 ?
(?) :: Bool -> (a, a) -> a
(?) True (x, _) = x
(?) _    (_, y) = y

{-

> [x > 5 ? 1 .: 2 | x <- [1..10]]
[2,2,2,2,2,1,1,1,1,1]

-}