LL Decade 君ならどう書く Online

DoukakuOnline.hs

import Numeric
import Data.Char
import Control.Monad
import Control.Applicative hiding (many, (<|>))
import Text.Parsec
import Text.Parsec.String

data LLVal = IPv4 | IPv6 | MAC | Etc
    deriving (Show, Eq)

main :: IO ()
main = do
  llvalues <- parseLLValus
  putStrLn . toString $ toBinary llvalues

parseLLValus :: IO [LLVal]
parseLLValus = do
    contents <- getContents
    let ls = lines contents
    return $ map readCipher ls

toString :: String -> String
toString ss
  | length ss < 4 = []
  | otherwise     = let (subjet, rems) = splitAt 8 ss in
                        chr (bin2dig subjet) : toString rems

toBinary :: [LLVal] -> String
toBinary = foldr (\x acc -> llval2Bin x ++ acc) []
  where
    llval2Bin MAC  = "00"
    llval2Bin IPv4 = "01"
    llval2Bin IPv6 = "10"
    llval2Bin Etc  = "11"

readCipher :: String -> LLVal
readCipher input = case parse parseCipher "cipher" input of
    Right val -> val
    Left _    -> error "Should not come here."

parseCipher :: Parser LLVal
parseCipher = try parseIPv4
    <|> try parseIPv6
    <|> try parseMac
    <|> parseEtc

parseIPv4 :: Parser LLVal
parseIPv4 = do
    ips <- sepBy1 digits $ char '.'
    when (any (>255) ips) $ unexpected "IPv4 should be 0-255"
    when (length ips /= 4) $ unexpected "IPv4 should be 4 Numbers"
    eof
    return IPv4

parseIPv6 :: Parser LLVal
parseIPv6 = do
    ips <- sepBy1 ipv6HexDigits $ char ':'
    when (length ips /= 8) $ unexpected "IPv6 should be 8 Numbers"
    eof
    return IPv6

parseMac :: Parser LLVal
parseMac = do
    try (sepByChar ':') <|> sepByChar '-'
    eof
    return MAC
  where
    sepByChar ch = do
        ns <- sepBy1 macHexDigits $ char ch
        when (length ns /=6) $ unexpected "MAC should be 6 Numbers"
        return ns

parseEtc :: Parser LLVal
parseEtc = do
    skipMany $ oneOf ['!'..'~']
    return Etc

macHexDigits :: Parser Int
macHexDigits = do
    hs <- count 2 hexDigit
    return $ readh hs

digits :: Parser Int
digits = read <$> many1 digit

ipv6HexDigits :: Parser Int
ipv6HexDigits = nonZero <|> zero
  where
    zero = char '0' >> return 0
    nonZero = do
        h  <- oneOf $ ['1'..'9'] ++ ['A'..'F'] ++ ['a'..'f']
        hs <- many hexDigit
        when (length hs > 3) $ unexpected "too long."
        return $ readh (h:hs)

readh :: String -> Int
readh hstr = fst $ (readHex hstr) !! 0

bin2dig :: (Eq a, Num a) => String -> a
bin2dig = bin2dig' 0
  where
    bin2dig' digint [] = digint
    bin2dig' digint (x:xs)
        | x == '0'  = bin2dig' (2 * digint + 0) xs
        | otherwise = bin2dig' (2 * digint + 1) xs