この前のをHaskellで解いてみる。

最近はHaskellerらしからぬことばっかりやっていたので、
久しぶりにHaskellを使うことにした。
ここから、割合簡単なADIをHaskellで実装。
とりあえずリハビリということで。
しかし、副作用がないと良い。見通しが立てやすいね。

A問題

import Data.List
import Data.Char
import Control.Monad
import System.IO

data Tree = Leaf | Node [Tree]

buildTree s = inner s [] where
  inner [] (t:_) = t
  inner ('a':ss) stk = inner ss (Leaf:stk)
  inner (num:ss) stk = inner ss ((Node (reverse c)):r)
    where (c,r) = splitAt (ord num - ord '0') stk

optimize Leaf = (1,"a")
optimize (Node ls) = ret where
  os   = map optimize ls
  len  = length ls
  cand = [calc $ take len $ drop n os++os | n<-[0..len - 1]]
  calc ls = (dep,str) where
    dep = maximum [n+d | (n,(d,_)) <- zip [0..] ls]
    str = concat (map snd ls) ++ [chr (len + ord '0')]
  ret = minimumBy (\(a,_) (b,_) -> compare a b) cand

main = do
  h   <- openFile "chandelier.in" ReadMode
  num <- hGetLine h
  ls  <- replicateM (read num) (hGetLine h)
  let as = map (optimize . buildTree) ls
  mapM_ (\(n,s) -> print n >> putStrLn s) as

D問題

import Data.FiniteMap

main = readFile "game.in" >>=
  mapM (printAns.solve) . takeWhile (/=[0,0]) . map (map read . words) . lines

solve [n,m] = filt (==1) (ops!!m) $ foldl (flip $ filt (/=1)) s $ take m ops where
  s = [(a,b) | a<-[1..n], b<-[a+1..n]]
  ops = cycle [(+),( * )]

  filt cond op ls = 
    concat $ filter (cond.length) $ eltsFM $ addListToFM_C (++) emptyFM [(op a b,[(a,b)])| (a,b) <- ls]

printAns ls = do
  print $ length ls
  mapM_ (\(a,b) -> putStrLn $ show a ++ " " ++ show b) ls
  putStrLn ""

I問題

import Data.Char
import Control.Monad
import System.IO

data Tree = Node Char [Tree]

instance Show Tree where
  show (Node c []) = [c]
  show (Node c ls) = [c] ++ "(" ++ concat (map show ls) ++ ")"

main = openFile "org.in" ReadMode >>= inner where
  inner h = do
    n <- hGetLine h
    when (read n /= 0) $ do
      s <- hGetLine h
      t <- hGetLine h
      print $ solve (filter (not.isSpace) s) (filter (not.isSpace) t)
      inner h

solve [a] [b] = Node a []
solve (a:as@(aa:_)) (b:bs) = Node a child where
  roots = takeWhile (/=aa) bs ++ [aa]
  ar = reverse $ snd $ foldl slice (as,[]) $ tail (reverse roots) ++ "*"
  br = [filter (`elem` a) bs | a<-ar]
  child = reverse $ zipWith solve ar br
  slice (ss,ret) c = (sr,rr:ret)
    where (rr,sr) = span (/=c) ss

うーん…どれもHaskellならでは…な技を使えたわけでないなぁ。
いたって普通になってしもた。
コードはC++より抜群に短い。
C++のコードは長いので割愛。
A100行、D70行、I100行ぐらい。