Haskell 代码片断

实现 Read 类

一个简单的示例：

data CoinState = Front | Back | Empty deriving (Show, Eq)

instance Read CoinState where
  readsPrec a (x:rest) = case x of
    '0' -> [(Back, rest)]
    '1' -> [(Front, rest)]
    '2' -> [(Empty, rest)]

质数判定

使用试除法进行质数判定：

import System.Environment (getArgs)

isPrime :: Integer -> Bool
isPrime 2 = True
isPrime x
      | x <= 1 || even x = False
      | otherwise = and [x `mod` i /= 0 | i <- [3, 5..truncate $ sqrt $ fromIntegral x]]

main = print . isPrime . read . head =<< getArgs

使用已知的质数来求质数列表

import Control.Monad
isPrime = ap (all.((0 /=).).mod) $ flip takeWhile primes . (.join(*)) . flip (<=)
primes = 2 : filter isPrime [3,5..]

isPrime :: Integral a => a -> Bool
primes :: Integral a => [a]
isPrime x = let prime_useful = takeWhile (\y -> y*y <= x) primes
            in all (\y -> x `mod` y /= 0) prime_useful
primes = 2 : filter isPrime [3, 5..]

斐波那契数列

fibs = 0 : 1 : zipWith (+) fibs (tail fibs)

八皇后问题

import Control.Monad
 
-- given n, "queens n" solves the n-queens problem, returning a list of all the
-- safe arrangements. each solution is a list of the columns where the queens are
-- located for each row
queens :: Int -> [[Int]]
queens n = foldM oneMoreQueen [] [1..n]
-- foldM folds in the list monad, which is convenient for "nondeterminstically"
-- finding "all possible solutions" of something. the initial value [] corresponds
-- to the only safe arrangement of queens in 0 rows
 
  where -- given a safe arrangement y of queens in the first i rows,
        -- "add_queen y _" returns a list of all the safe arrangements of queens
        -- in the first (i+1) rows
        oneMoreQueen y _ = [ x : y | x <- [1..n], safe x y 1]
 
-- "safe x y n" tests whether a queen at column x would be safe from previous
-- queens in y where the first element of y is n rows away from x, the second
-- element is (n+1) rows away from x, etc.
safe x [] n = True
safe x (c:y) n = and [ x /= c , x /= c + n , x /= c - n , safe x y (n+1)]
-- we only need to check for queens in the same column, and the same diagonals;
-- queens in the same row are not possible by the fact that we only pick one
-- queen per row
 
 
 
-- prints what the board looks like for a solution; with an extra newline
printSolution y = do mapM_ (\x -> putStrLn [if z == x then 'Q' else '.' | z <- [1..n]]) y
                     putStrLn ""
  where n = length y
 
-- prints all the solutions for 6 queens
main = mapM_ printSolution $ queens 6

信号处理

import System.Posix.Signals (sigTERM, sigINT, installHandler, Handler(..))
import Control.Concurrent (threadDelay)
import System.Posix.Process (getProcessID)

main = do
  installHandler sigTERM (Catch (putStrLn "SIGTERM received!")) Nothing
  installHandler sigINT (Catch (putStrLn "SIGINT received!")) Nothing
  getProcessID >>= print
  threadDelay 10000000

中国公民身份证校验位

import Data.Char (digitToInt)

getid = (!!) "10X98765432" . (`mod` 11) . sum . map (\(b,a) -> (digitToInt a) * ((ord b) - 47)) . zip "68947310526894731"
-- 去掉不需要的空格：
getid=(!!)"10X98765432".(`mod`11).sum.map(\(b,a)->(digitToInt a)*((ord b)-47)).zip"68947310526894731"

欧拉项目

欧拉项目第 36 题：

import Numeric (showIntAtBase)
import Data.Char (intToDigit)

isBothPalindromic :: Int -> Bool
isBothPalindromic x = isIntPalindromicBy show x && isIntPalindromicBy int2bin x
-- slower
-- isBothPalindromic = and . mapM isIntPalindromicBy [show, int2bin]

isIntPalindromicBy :: (Int -> String) -> Int -> Bool
isIntPalindromicBy f x = isPalindromic $ f x

isPalindromic :: String -> Bool
isPalindromic s = s == reverse s
-- slower:
-- isPalindromic = ap (==) reverse

int2bin :: Int -> String
int2bin i = showIntAtBase 2 intToDigit i ""

main = print $ sum $ takeWhile (< 1000 * 1000) $ filter isBothPalindromic [1..]

二进制文件解包

格式描述：Total War: Rome II Pack file Specification - Charming Eye's Watching - 学而不思则罔，思而不学则殆。

在网上的版本：parse pack file :: lpaste — Lambda pastebin。

import Prelude hiding (writeFile)
import Control.Applicative ((<$>))
import Control.Monad (liftM2, foldM_)
import qualified Data.ByteString.Lazy as L
import Data.List (intercalate)
import Data.List.Split (splitOn)
import Data.Tuple (swap)
import System.Directory (createDirectoryIfMissing)
import System.Environment (getArgs)
import Text.Parsec (parse, getInput)
import Text.Parsec.Char
import Text.Parsec.ByteString.Lazy
import Text.Parsec.Combinator

import Data.Struct (toInt32le)
import Text.String (trChar)

headerParser :: Parser Int
headerParser = do
  string "PFH4"
  count 4 anyChar
  count 4 anyChar
  count 4 anyChar
  n <- toInt32le <$> count 4 anyChar
  count 4 anyChar
  count 4 anyChar
  return n

indexItem :: Parser (String, Int)
indexItem = swap <$> liftM2 (,) (toInt32le <$> count 4 anyChar) (manyTill anyChar (char '\0'))

allFiles :: Int -> Parser ([(String, Int)], L.ByteString)
allFiles n = liftM2 (,) (count n indexItem) getInput

parseIt = headerParser >>= allFiles

writeFile :: L.ByteString -> (String, Int) -> IO L.ByteString
writeFile d (path', len) = do
  let path = trChar '\\' '/' path'
  createDirectoryIfMissing True $ intercalate "/" $ init $ splitOn "/" path
  let (content, rest) = L.splitAt (fromIntegral len) d
  putStrLn $ "Writing to file " ++ path ++ " with length " ++ show len ++ "."
  L.writeFile path content
  return rest

main = do
  f <- head <$> getArgs
  res <- parseFromFile headerParser f
  L.readFile f >>= \file -> case parse parseIt f file of
    Left err -> print err >> error "Failed."
    Right res -> foldM_ writeFile (snd res) (fst res)

参见

• Haskell