CodeIQ カボチャの種を数えて！ https://codeiq.jp/ace/ozy_halloween/q516 の解答

pumpkin.hs

module Main where

(^..^) = QB
($^-^) = Mami
(@.@=) = Charlotte
(?)    = App

main = print $ eval
    (((^..^)?((((^..^)?(@.@=))?((($^-^)?((((^..^)?((((^..^)
    ?((((^..^)?((((^..^)?((((^..^)?(@.@=))?((($^-^)?((((^..^)
    ?((((^..^)?((($^-^)?(^..^))))?((((^..^)?((($^-^)?($^-^))))
    ?((((^..^)?((($^-^)?(^..^))))?((((^..^)?((($^-^)?(((^..^)
    ?((($^-^)?(^..^))))))))?((((^..^)?((((^..^)?((($^-^)
    ?(^..^))))?((((^..^)?((($^-^)?(((^..^)?((($^-^)?(^..^))))))))
    ?((((^..^)?((($^-^)?(((^..^)?((($^-^)?($^-^))))))))
    ?((((^..^)?((((^..^)?((($^-^)?(^..^))))?((((^..^)?((($^-^)
    ?($^-^))))?(@.@=))))))?((($^-^)?(@.@=))))))))))))?((($^-^)
    ?((($^-^)?(@.@=))))))))))))))))?((($^-^)?((((^..^)?((($^-^)
    ?($^-^))))?((((^..^)?((($^-^)?($^-^))))?(@.@=))))))))))))))
    ?((($^-^)?((($^-^)?($^-^))))))))?((($^-^)?(@.@=))))))
    ?((($^-^)?(@.@=))))))?((($^-^)?((((^..^)?((($^-^)?(((^..^)
    ?((((^..^)?((($^-^)?(^..^))))?((((^..^)?((($^-^)?($^-^))))
    ?(@.@=))))))))))?((((^..^)?((((^..^)?((($^-^)?(^..^))))
    ?((((^..^)?((($^-^)?(((^..^)?((($^-^)?(^..^))))))))
    ?((((^..^)?((($^-^)?(((^..^)?((($^-^)?($^-^))))))))
    ?((((^..^)?((((^..^)?((($^-^)?(^..^))))?((((^..^)?((($^-^)
    ?($^-^))))?(@.@=))))))?((($^-^)?(@.@=))))))))))))?((($^-^)
    ?((($^-^)?(@.@=))))))))))))))))))?((($^-^)?((($^-^)
    ?(@.@=))))))
    "QQQQOQQQOO\
    \OQOOOQQQQQ\
    \OQQOQQOQOO\
    \QQOOOOQQQO\
    \QQOOQQOQQO\
    \QOQOOOQOOQ\
    \OOOQQOQQOQ\
    \OQQQOOQOOQ\
    \QQOOOQOOQO\
    \OQQOQOOQOQ"


data Expr =
    QB | Mami | Charlotte |
    App Expr Expr |
    Fun (Expr -> Expr) |
    Num Int |
    List [Char]


fun :: Expr -> Expr
fun QB = Fun $ \x -> Fun $ \y -> Fun $ \z -> (x `App` z) `App` (y `App` z)
fun Mami = Fun $ \x -> Fun $ \y -> x
fun Charlotte = Fun $ \x -> x

fun (a `App` b) = fun a `App` fun b

fun (Num 0) = Fun $ \f -> Fun $ \x -> x
fun (Num n) = Fun $ \f -> Fun $ \x -> f `App` (fun (Num $ n-1) `App` f `App` x)

fun (List []) = Fun $ \f -> Fun $ \n -> n
fun (List (h:t)) =
  Fun $ \f -> Fun $ \n ->
  f `App` (fun $ unChar h) `App` (fun (List t) `App` f `App` n)
  where
    unChar = Num . fromEnum


num e = unExpr $ eval' $ e `App` succ `App` (Num 0)
  where
    succ = Fun $ \e -> case eval' e of Num n -> Num (n+1)
    eval' (Fun f `App` e) = eval' $ f e
    eval' (a `App` b) = eval' $ (eval' a) `App` b
    eval' e = e
    unExpr (Num n) = n


eval e s = num $ fun $ e `App` List s