Haskellでpaiza「彼女をつくる」に挑戦

https://paiza.jp/poh/ando
にHaskellで挑戦してみた。

こういう書き方がある。
そんな書き方Haskellらしくないなど
コメント頂けるとうれしいです。

水着が完成してないです。
難しい。。。(´・ω・` )

2016/04/05　追記
問題（猫、　猫耳、　メイド服）が増えたので挑戦した

---

##目
###つり目

ann :: String -> String
ann s = concat $ replicate (read s) "Ann"

main = getLine >>= putStrLn . ann

###眼帯

import Data.List

type Owns = [Int]
type NonOwns = [Int]
type InputList = (Owns, NonOwns)
type BuyList = [Int]

select :: InputList-> BuyList
select (o, no) = no \\ o

createInputList :: String -> InputList
createInputList = ci . lines
    where
        ci :: [String] -> InputList
        ci (_:_:owns:_:nonOwns:[]) = (convert owns,convert nonOwns)
        convert :: String -> [Int]
        convert = map read . nub . words
buy :: BuyList -> String
buy [] = "None"
buy xs = intercalate " " $ map show  $ sort xs

gantai :: String -> String
gantai = buy . select . createInputList

main = getContents >>= putStrLn . gantai

###猫耳

import qualified Data.Text as T
import Data.List

word = "cat"

wordCount :: String -> Int
wordCount xs = T.count  (T.pack word) inputWord
  where
    inputWord = T.pack xs
    

--実装してみた
wordCount2 :: String -> Int
wordCount2 = wordCount' 0
  where
    wordLength = length word
    dropWord = drop wordLength
    wordCount' :: Int -> String -> Int
    wordCount' n xs
      | word `isPrefixOf` xs = wordCount' (succ n) $ dropWord xs
      | wordLength < length xs = wordCount' n $ tail xs
      | otherwise = n
    

main = getLine >>= print . wordCount

###猫

import qualified Data.Text as T

data WordCounts = WordCounts {
                     cCount :: Int
                    ,aCount :: Int
                    ,tCount :: Int
                    } deriving (Show)

data Result = Result {
                     catWords  :: Int -- 完全に作れる個数
                    ,shortageC :: Int -- 必要な "c" の個数
                    ,shortageA :: Int -- 必要な "a" の個数
                    ,shortageT :: Int -- 必要な "t" の個数
                    }

instance Show Result where
  show (Result w c a t) = show w ++ "\r\n" 
                          ++ show c ++ "\r\n"
                          ++ show a ++ "\r\n"
                          ++ show t ++ "\r\n"

createWordCounts :: String -> WordCounts
createWordCounts xs = WordCounts countC countA countT
  where
    countx x = T.count (T.pack x) $ T.pack xs
    countC = countx "c"
    countA = countx "a"
    countT = countx "t"

aggregate :: WordCounts -> Result
aggregate wc = Result (minWordCount wc)
                      (maxCount - cCount wc)
                      (maxCount - aCount wc)
                      (maxCount - tCount wc)
  where
    maxCount = maxWordCount wc

maxWordCount, minWordCount :: WordCounts -> Int
maxWordCount wc = maximum [cCount wc, aCount wc, tCount wc]
minWordCount wc = minimum [cCount wc, aCount wc, tCount wc]

main = getLine >>= print . aggregate . createWordCounts

##髪
###ショートヘア

lineAdd :: String -> Int
lineAdd = sum . map read . lines

main = getContents >>= print . lineAdd

###ロングヘア

import Control.Monad.State

data VoteResult = Yes Int | No Int deriving (Show)
type Vote = [String]
type VoteState = (VoteResult, VoteResult)
type Result = String

majorityRule :: Vote -> State VoteState Result
majorityRule [] = get >>= \((Yes m), (No n)) -> case compare m n of
                        EQ -> return ""
                        GT -> return "yes"
                        LT -> return "no"
majorityRule (x:xs) = do
    (Yes m,No n) <- get
    case x of
        "yes" -> put (Yes (m+1), No n)
        "no"  -> put (Yes m,    No (n+1))
    majorityRule xs

vote :: Vote -> Result
vote xs = evalState (majorityRule xs) (Yes 0, No 0)

main = getContents >>= putStrLn . vote . lines

###ポニーテール

import Data.List

countDown :: Int -> [String]
countDown n = reverse . (:) "0!!" $ map show [1..n]

main = getLine >>= mapM_ putStrLn . countDown . read

###ツインテール

costperformance :: (Fractional a, Ord a) => [a] -> Int
costperformance (d1Caffeine:d1Price:
                d2Caffeine:d2Price:[]) = select p1 p2
    where
        p1 = d1Caffeine / d1Price
        p2 = d2Caffeine / d2Price
        select a1 a2
            | a1 > a2 = 1
            | a1 < a2 = 2

main = getContents >>= print . costperformance . map read . words

##服
###セーラー服

import Data.List

main = getContents >>= putStrLn . concat . intersperse "_" . tail . lines

###カーディガン

myProduct :: Int -> Int
myProduct n = product [1..n]

main = getLine >>= print . myProduct . read

###縞ニーソ

stripedPattern :: [Int] -> String
stripedPattern (w:m:[]) = concat $ take m sp
    where
        widte = replicate w
        sp    = cycle (widte "R" ++ widte "W")

main = getContents >>= putStrLn . stripedPattern . map read . lines

###メイド服

--メイド服
module Main where

import Data.Time.Calendar
import Data.Time.Clock
import Data.Time.LocalTime
import Data.Time.Format
import System.Locale

--　時間だけを操作する方法がわからないため UTCTime を操作している
referenceBedtime :: UTCTime
referenceBedtime = UTCTime
                  (fromGregorian 216 4 1)
                  (timeOfDayToTime $ TimeOfDay 1 0 0)

outputFormat :: UTCTime -> String
outputFormat = formatTime defaultTimeLocale "%H:%M"

differenceMinuteTime :: NominalDiffTime -> UTCTime -> UTCTime 
differenceMinuteTime n = addUTCTime ((-60) * n)

bedtime :: String -> String
bedtime x = outputFormat 
              $ differenceMinuteTime minute referenceBedtime
  where
    minute = fromInteger (read x `div` 3) :: NominalDiffTime

main = getContents >>= putStrLn . unlines . map bedtime . tail . lines

##その他
###めがね

import Control.Monad
import Control.Applicative
import Data.List

type Filed = [[String]]
type X = Int -- x座標
type Y = Int -- y座標

extraction :: Int -> Filed -> [((Y, X), Filed)]
extraction n xs = concatMap  (yExtraction n 0) $ xExtraction n 0 xs

xExtraction:: Int -> Int -> Filed -> [(X, Filed)]
xExtraction a b xs 
    | length xs < a + b = []
    | otherwise        = (b, ex) : xExtraction a (b+1) xs
    where
        ex = map (take a . drop b) xs

yExtraction :: Int -> Int -> (X, Filed) -> [((Y, X), Filed)]
yExtraction a b  xs'@(x, xs)
    | length xs < a + b = []
    | otherwise        = ((b, x), ex) : yExtraction a (b + 1) xs'
    where
        ex = take a $ drop b xs

main = do
    q <- getFiled =<< readLn
    n <- readLn
    p <- getFiled n
    putStrLn $ concatMap (format . fst) $ matchPattern p $ extraction n q
    where
        getFiled n = map words <$> replicateM n getLine
        matchPattern p = filter (\t -> p == snd t)

format (y, x)  = show y ++ " " ++ show x

###サンタ服

import Control.Applicative
import Control.Monad
import Data.List

data Block =  Block {x1 :: Int, x2 :: Int,
                     y1 :: Int, y2 :: Int} deriving (Show)

instance Eq Block 
    where 
        a == b = diffX a + diffY a == diffX b + diffY b

instance Ord Block 
    where 
        compare a b = compare (diffX a + diffY a) (diffX b + diffY b)

diffX, diffY :: Block -> Int
diffX b = x2 b - x1 b
diffY b = y2 b - y1 b

main = do
    [x, y, z, n] <- map read . words <$> getLine
    cutPosition <- map words <$> replicateM n getLine
    let b = minimum $ foldl cut [Block 0 x 0 y] cutPosition
    print $ (diffX b) * (diffY b) * z

cut :: [Block] -> [String] -> [Block]
cut xs [a, b] 
    | a == "0" = concatMap (cutX $ read b) xs
    | a == "1" = concatMap (cutY $ read b) xs

cutX, cutY :: Int -> Block -> [Block]
cutX a b = if isCut x1 x2 a b then [b {x2 = a}, b {x1 = a}] else [b]
cutY a b = if isCut y1 y2 a b then [b {y2 = a}, b {y1 = a}] else [b]

isCut p1 p2 a block = p1 block <= a && a <= p2 block

###水着（できてない）
test case4以降で失敗
時間切れ

fact :: Integer -> Integer
fact n = product [1..n]

headTrim :: String -> String
headTrim = dropWhile (== '0')

tailTrim :: String -> String
tailTrim  = twirl headTrim

extraction :: [a] -> [a]
extraction = twirl (take 9)

twirl f = reverse . f . reverse

main = do
    n <- readLn
    putStrLn $ headTrim . extraction . tailTrim . show $ fact n