世界のナベアツにHaskellで挑戦する

import Nabeatsu
import Prelude hiding ((.))
import System (getArgs)
import qualified System.IO.UTF8 as U8 (putStrLn)

-- 基本のネタ
basic =
  1 `kara` 40 . madeKazoete .
  (3 `noBaisuu`) `to` (3 `gaTsukuSuuji`) `noTokiDake` ahoNi .
  narimasu

-- 凝ったネタ
arrange =
  1 `kara` 40 . madeKazoete .
  (3 `noBaisuu`) `to` (3 `gaTsukuSuuji`) `noTokiDake` ahoNi . natte .
  (5 `noBaisuu`) `noTokiDake` inuppoku . natte .
  (8 `noBaisuu`) `noTokiDake` kimochiYoku .
  narimasu

main = do
  args <- getArgs
  let neta = if null args then basic else arrange
  perform neta

perform = mapM_ U8.putStrLn

module Nabeatsu where

import Prelude hiding ((.))

infixl 8 .
a . f = f a

infixl 9 `to`
a `to` b = \x -> a x || b x

infixl 9 `kara`
a `kara` b = [a .. b]

madeKazoete = map (\x -> (x, yomi x))

n `noBaisuu` (x, s) = x `mod` n == 0
n `gaTsukuSuuji` (x, s) = (head $ show n) `elem` show x

pred `noTokiDake` f = map (\x -> if pred x then f x else x)

ahoNi (x, s) = (x, s1 ++ "～" ++ s2)
  where
    (s1, s2) = divide s
    divide (x:[]) = ([x], [])
    divide (x:y:xs)
      | komoji y  = ([x,y], xs)
      | otherwise  = ([x], y:xs)
    komoji c = c `elem` "ぁぃぅぇぉゃゅょ"
inuppoku (x, s) = (x, s ++ " Bow!")
kimochiYoku (x, s) = (x, s ++ gobi ++ "～～ッ")
  where
    gobi = ["ぅ", "ぃ", "ぃ", "", "", "ぉ", "ぅ", "ぁ", "ぃ", "ぅ"] !! (x `mod` 10)

natte = id
narimasu = map get
  where
    get (x, s)
      | yomi x /= s  = s
      | otherwise    = show x

yomi x
  | x < 10           = ["", "いち", "に", "さん", "よん", "ご", "ろく", "なな", "はち", "きゅう"] !! x
  | x `div` 10 == 1  = keta ++ yomi (x `mod` 10)
  | otherwise        = yomi (x `div` 10) ++ keta ++ yomi (x `mod` 10)
  where
    keta = "じゅう"