第二回オフラインリアルタイムどう書く Haskellでやってみた

あまりにひねりが無いので練習も兼ねてhspec使って見ました。
というのは嘘で、慣れないfoldrにハマってデバッグに間取っただけです。すんません。

bitris.hs

{-# LANGUAGE ViewPatterns, OverloadedStrings #-}

import Control.Monad
import Control.Applicative
import Data.Word
import Data.Bits
import Data.Either
import Data.List
import Data.Attoparsec.Char8
import Test.Hspec
import Test.Hspec.QuickCheck
import qualified Data.ByteString.Char8 as B8

bitrisParser :: Parser [Word8]
bitrisParser = hexadecimal `sepBy` (char '-')

showBitris :: [Word8] -> B8.ByteString
showBitris = B8.pack . concat . intersperse "-" . map tohex
  where
    tohex :: Word8 -> String
    tohex x = let hexs = "0123456789abcdef" :: [Char]
                  (d, m) = (fromIntegral x) `divMod` 16
               in [hexs!!d, hexs!!m]

remains :: [Word8] -> [Int]
remains xs = filter (not . testBit (foldr (.&.) 0xff xs)) [0..7]

folldown :: [Int] -> Word8 -> Word8
--folldown xs b = foldr (\n (flip shiftL 1 -> x) -> if testBit b n then x .|. 1 else x) 0 xs
--状態付き計算はキモイのでこっち使う
folldown xs b = foldr (\(n,m) x -> if testBit b n then setBit x m else x) 0 $ zip xs [0..]

bitris :: B8.ByteString -> B8.ByteString
bitris (either error id . parseOnly bitrisParser -> xs) = showBitris $ map (folldown $ remains xs) xs



main :: IO ()
main = hspec $ do
  describe "Parser" $ do
    it "normal case" $ parseOnly bitrisParser "ff-01-00-3b-a9" `shouldBe` Right [0xff,0x01,0x00,0x3b,0xa9]
  describe "Printer" $ do
    it "normal case" $ showBitris [0x7a,0x4e,0x0c,0x56] `shouldBe` "7a-4e-0c-56"
    it "show and parse" $ property $ \xs -> parseOnly bitrisParser (showBitris xs) == Right xs
  describe "Judge" $ do
    it "normal case" $ sort (remains [0x7a,0x4e]) `shouldBe` [0,2,4,5,7]
  describe "Folldown" $ do
    it "normal case" $ folldown [0,4,5] 0xff `shouldBe` 0x07
  describe "Play" $ do
    it "same length" $ property $
      \xs -> (either error length $ parseOnly bitrisParser $ bitris $ showBitris xs) == length xs
    forM_ tests $ (\(x,y) -> it (B8.unpack x) $  bitris x `shouldBe` y )
  where
    tests =[ ("ff-2f-23-f3-77-7f-3b", "1f-03-00-1c-0d-0f-06")
           , ("01", "00")
           , ("00", "00")
           , ("7a-4e", "0c-02")
           , ("56-b6", "08-14")
           , ("12-12-12", "00-00-00")
           , ("de-ff-7b", "0a-0f-05")
           , ("95-be-d0", "05-1e-20")
           , ("7c-b0-bb", "1c-20-2b")
           , ("7a-b6-31-6a", "3a-56-11-2a")
           , ("32-0e-23-82", "18-06-11-40")
           , ("ff-7f-bf-df-ef", "0f-07-0b-0d-0e")
           , ("75-df-dc-6e-42", "35-5f-5c-2e-02")
           , ("62-51-ef-c7-f8", "22-11-6f-47-78")
           , ("0c-47-8e-dd-5d-17", "04-23-46-6d-2d-0b")
           , ("aa-58-5b-6d-9f-1f", "52-28-2b-35-4f-0f")
           , ("ff-55-d5-75-5d-57", "0f-00-08-04-02-01")
           , ("fe-fd-fb-f7-ef-df-bf", "7e-7d-7b-77-6f-5f-3f")
           , ("fd-fb-f7-ef-df-bf-7f", "7e-7d-7b-77-6f-5f-3f")
           , ("d9-15-b5-d7-1b-9f-de", "69-05-55-67-0b-4f-6e")
           , ("38-15-fd-50-10-96-ba", "18-05-7d-20-00-46-5a")
           , ("fe-fd-fb-f7-ef-df-bf-7f", "fe-fd-fb-f7-ef-df-bf-7f")
	   ]