Functor, Applicative, Monad

gistfile1.hs

import Data.Functor( (<$>) )
import Control.Applicative( Applicative, (<*>) )
import Prelude hiding( Left, Right )

--
-- 計算の合成（未評価の計算を使った計算）
--

-- 
-- Functor 単項演算子の適応(map)
--

addExStr::String -> String
addExStr x = (++ " !") x

addExMaybeStr::Maybe String -> Maybe String
addExMaybeStr x = (++ " !") <$> x

addExListStr::[String] -> [String]
addExListStr x = (++ " !") <$> x

addExIOStr::IO String -> IO String
addExIOStr x = (++ " !") <$> x

addEx :: Functor f => f String -> f String
addEx x = (++  " !") <$> x

test_addEx = do
  print $ addExStr "foo"

  print $ addExMaybeStr $ Just "foo"
  print $ addExMaybeStr $ Nothing
  print $ addEx $ Just "foo"
  print $ addEx $ Nothing

  print $ addExListStr $ ["foo","bar"]
  print $ addExListStr $ []
  print $ addEx $ ["foo","bar"]
  print $ addEx $ []

  print =<< getLine
  print =<< addExIOStr getLine
  print =<< addEx getLine

  

-- 
-- Applicative 関数の適応(ap)
--
-- (パラメータは3個以上あってもよい)
--

joinByAtStr:: String -> String -> String
joinByAtStr x y = (\x y -> x ++ "@" ++ y) x y

joinByAtMaybeStr:: Maybe String -> Maybe String -> Maybe String
joinByAtMaybeStr x y = ( \x y -> x ++ "@" ++ y ) <$> x <*> y

joinByAtListStr:: [String] -> [String] -> [String]
joinByAtListStr x y = ( \x y -> x ++ "@" ++ y ) <$> x <*> y

joinByAtIOStr:: IO String -> IO String -> IO String
joinByAtIOStr x y = ( \x y -> x ++ "@" ++ y ) <$> x <*> y

joinByAt :: Applicative f => f String -> f String -> f String
joinByAt x y = ( \x y -> x ++ "@" ++ y ) <$> x <*> y

test_joinByAt = do
  print $ joinByAtStr "mitsuji" "na-s.jp"
  
  print $ joinByAtMaybeStr (Just "mitsuji") (Just "na-s.jp")
  print $ joinByAtMaybeStr Nothing Nothing
  print $ joinByAtMaybeStr (Just "mitsuji") Nothing
  print $ joinByAtMaybeStr Nothing (Just "na-s.jp")
  print $ joinByAt (Just "mitsuji") (Just "na-s.jp")
  print $ joinByAt Nothing Nothing
  print $ joinByAt (Just "mitsuji") Nothing
  print $ joinByAt Nothing (Just "na-s.jp")

  print $ joinByAtListStr ["mitsuji","tkms"] ["na-s.jp","mitsuji.org"]
  print $ joinByAtListStr [] []
  print $ joinByAtListStr ["mitsuji","tkms"] []
  print $ joinByAtListStr []  ["na-s.jp","mitsuji.org"]
  print $ joinByAt ["mitsuji","tkms"] ["na-s.jp","mitsuji.org"]
  print $ joinByAt [] []
  print $ joinByAt ["mitsuji","tkms"] []
  print $ joinByAt [] ["na-s.jp","mitsuji.org"]

  print =<< getLine
  print =<< joinByAtIOStr getLine getLine
  print =<< joinByAt getLine getLine



--
-- Monad 前の計算の結果に依存した計算(手続き)
--
--
--

data Heading = North | East | West | South deriving( Show, Read )
type Status = ( (Int, Int), Heading )
data Direction = Forward | Backward | Left | Right deriving( Read )

progress:: Direction -> Status -> Status
progress Forward  ((x, y), North) = (( x, y+1 ), North)
progress Backward ((x, y), North) = (( x, y-1 ), South)
progress Left     ((x, y), North) = (( x-1, y ), West )
progress Right    ((x, y), North) = (( x+1, y ), East )

progress Forward  ((x, y), East) = (( x+1, y ), East ) 
progress Backward ((x, y), East) = (( x-1, y ), West )
progress Left     ((x, y), East) = (( x, y+1 ), North)
progress Right    ((x, y), East) = (( x, y-1 ), South)

progress Forward  ((x, y), West) = (( x-1, y ), West )
progress Backward ((x, y), West) = (( x+1, y ), East )
progress Left     ((x, y), West) = (( x, y-1 ), South)
progress Right    ((x, y), West) = (( x, y+1 ), North)

progress Forward  ((x, y), South) = (( x, y-1 ), South)
progress Backward ((x, y), South) = (( x, y+1 ), North)
progress Left     ((x, y), South) = (( x+1, y ), East )
progress Right    ((x, y), South) = (( x-1, y ), West )


pf = progress Forward
pb = progress Backward
pl = progress Left
pr = progress Right


foo = pb $ pr $ pf $ pf $ pr $ pf $ pf $ ((0,0),North)

($>) = flip ($)
foof = ((0,0),North) $> pf $> pf $> pr $> pf $> pf $> pr $> pb

pf':: Monad m => Status -> m Status
pb':: Monad m => Status -> m Status
pl':: Monad m => Status -> m Status
pr':: Monad m => Status -> m Status
pf' = \x -> return( pf x )
pb' = \x -> return( pb x )
pl' = \x -> return( pl x )
pr' = \x -> return( pr x )

show' = \x -> return ( show x )

foo':: Monad m => m Status
foo' = return((0,0),North) >>= pf' >>= pf' >>= pr' >>= pf' >>= pf' >>= pr' >>= pb'



pm1 = \x -> Just Right >>= \y -> return( progress y x )
pm2 = \x -> Nothing    >>= \y -> return( progress y x )

foom1 = return((0,0),North) >>= pf' >>= pf' >>= pm1 >>= pf' >>= pf' >>= pr' >>= pb'
foom2 = return((0,0),North) >>= pf' >>= pf' >>= pm2 >>= pf' >>= pf' >>= pr' >>= pb'


pl1 = \x -> [Forward,Backward,Left] >>= \y -> return( progress y x )
pl2 = \x -> []                      >>= \y -> return( progress y x )


fool1 = return((0,0),North) >>= pf' >>= pf' >>= pl1 >>= pf' >>= pf' >>= pr' >>= pb'
fool2 = return((0,0),North) >>= pf' >>= pf' >>= pl2 >>= pf' >>= pf' >>= pr' >>= pb'


pio = \x-> getLine >>= \y-> return( read y ::Direction) >>= \y' -> return( progress y' x )

fooio = return((0,0),North) >>= pf' >>= pf' >>= pio >>= pf' >>= pf' >>= pr' >>= pb'>>= show'

fooio' = do
  x1 <-return((0,0),North)
  x2 <-pf'(x1)
  x3 <-pf'(x2)
  x4 <-pio(x3)
  x5 <-pf'(x4)
  x6 <-pf'(x5)
  x7 <-pr'(x6)
  x8 <-pb'(x7)
  show'(x8)