haskell代码片段

-- 经典的菲波纳契数列的函数定义，求每一个位置上的数值
fib 1 = 1
fib 2 = 1
fib n = fib(n-1) + fib(n-2)

-- 产生一个无限长的fib数列
fib_l n = fib n : fib_l (n+1)

take 10 (fib_l 1) ＝> [1,1,2,3,5,8,13,21,34,55]

--另一个更快解法

fibs = fibgen 1 1 
fibgen n1 n2 = n1 : fibgen n2 (n1+n2)

--求解素数的一个无限数列方法：

prime = sieve [2..]
sieve (x:xs) = x : sieve (filter (\y ->y `rem` x /= 0) xs)
take 25 prime => [2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97]

--打印头 100 个汉明数（以2、3、5 的阶乘为因子的正整数）

main = print (take 100 hamming)

hamming = 1 : (map (2*) hamming) ~~ (map (3*) hamming) ~~ (map (5*) hamming)
where
    xxs@(x:xs) ~~ yys@(y:ys)
        | x==y = (x : xs~~ys)
        | x<y = x:xs~~yys
        | otherwise = (y : xxs~~ys)

--克拉兹(Collatz)问题

module Main where 

import Data.Tuple
import Data.List (sortBy)
import Data.Function (on)

chain' :: Integer -> [Integer]
chain' 1 = [1]
chain' n
  | n <= 0 = []
  | even n = n : chain' (n `div` 2)
  | odd n = n : chain' (n * 3 + 1)

main :: IO ()
main = do
  let seqx = map (\x -> (x, length $ chain' x)) [999999,999997..3]
  print . fst .head $ sortBy (flip compare `on` snd) seqx

--更快的解法

module Main where

import Data.Tuple
import Data.List (sortBy, iterate)
import Data.Function (on)

chain' :: Integer -> Int
chain' n 
  | n < 1 = 0
  | otherwise = 1 + (length $ (takeWhile (> 1) $ iterate (\x ->if even x then x `div` 2 else x * 3 + 1) n))

main :: IO ()
main = do
  let seqx = map (\x -> (x, chain' x)) [999999,999997..3]
  print . fst .head $ sortBy (flip compare `on` snd) seqx

--对可变（mutable）变量的读写

incRef :: IORef Int -> IO ( )

incRef var = do
    val <- readIORef var
    writeIORef var (val+1)

type MyDataStructure = [Int]
type ConcMyData = IORef MyDataStructure
main = do
    sharedData <- newIORef []
    //...
    atomicModifyIORef sharedData (\xs -> (1:xs,()))

fact n = runST (do
    r < - newSTRef 1
    for (1,n) (\x -> do
        val < - readSTRef r
        writeSTRef r (val * x))
    readSTRef r)

for :: (Int,Int) -> (Int -> ST s ()) -> ST s ()
for (i,j) k = sequence_  (map k [i..j])

--String和ByteString互相转换

toBS :: String -> BS.ByteString 
toBS = BS.pack . map (fromIntegral . fromEnum) 

fromBS :: BS.ByteString -> String 
fromBS = map (toEnum . fromIntegral) . BS.unpack

--Associated Array

import Data.Map

makeMap ks vs = fromList $ zip ks vs
mymap = makeMap ['a','b','c'] [1,2,3]

--文件操作

readUtf8File :: FilePath -> IO String
readUtf8File filePath = do

    h <- openFile filePath ReadMode
    hSetEncoding h utf8
    hSetEncoding stdout utf8
    hGetContents h

   betterStdGen :: IO StdGen
betterStdGen = alloca $ \p -> do
   h <- openBinaryFile "/dev/urandom" ReadMode
   hGetBuf h p $ sizeOf (undefined :: Int)
   hClose h
   mkStdGen <$> peek p

--模拟for循环的函数

nTimes :: Int -> IO () -> IO ()
nTimes 0 do_this = return ()
nTimes n do_this = do {
    do_this;
    nTimes (n-1) do_this;
}

main = nTimes 10 ( hPutStr stdout "Hello")  --重复输出10个"Hello"

-- for(i=0; i<100; i++) {}
  for :: Monad m => a -> (a -> Bool) -> (a -> a) -> (a -> m ()) -> m ()
for start test step body = loop start where
    loop x = if test x
        then body x >> loop (step x)
        else return ()

main = for 0 (< 100) (+ 1) $ \i -> do
    -- do something with i
    print i

--如果值有空格就加上引号

> [k ++ "=" ++ c ++ v ++ c | (k,v) <- [("key1","123"),("key2","abc 456")] ,let c = ['\"' | any isSpace v]]
["key1=123","key2=\"abc 456\""]

--转义

escapeHTML = concatMap f
where
    f '\"' = "&quot;"

    f '\'' = "&#39;"
    f '<' = "&lt;"
    f '>' = "&gt;"
    f '&' = "&amp;"
    f '\n' = "<br/>"
    f x = [x]

escapeCGI = concatMap f
where
    f x

      | isAlphaNum x || x `elem` "-"  =  [x]
      | x == ' '  = "+"
      | otherwise = '%' : ['0' | length s == 1] ++ s
          where s = showHex (ord x) ""

--位操作

let w4 = (w32 ` shiftR ` 24) .&. 0xff
w3 = (w32 ` shiftR ` 16).&. 0xff
w2 = (w32 ` shiftR ` 8).&. 0xff
w1 = w32 .&. 0xff

return $! (w4 ` shiftL ` 24) .|. (w3 `shiftL` 16).|. (w2 `shiftL` 8) .|. (w1)

十六进制

> readHex "41A"
[(1050,"")]

--指数运算

精确结果
(^) :: (Num a, Integral b) => a -> b -> a
(^^) :: (Fractional a, Integral b) => a -> b -> a

近似结果
(**) :: Floating a => a -> a -> a

--数组操作

  import qualified Data.Vector.Generic as G

  import qualified Data.Vector.Unboxed.Mutable as M

replicateM n action = do
  mu <- M.unsafeNew n
  let go !i | i < n = action >>= M.unsafeWrite mu i >> go (i+1)
            | otherwise = G.unsafeFreeze mu
  go 0

import Data.List
import Data.Function

type Key = String
type Score = Int
data Thing = Thing {key :: Key, score :: Score } deriving (Show)

myNub = nubBy ((==) `on` key)
mySort = sortBy (compare `on` (negate .score))

selectFinest = myNub . mySort

在ghci中测试:
Prelude> :load Test.hs
*Main> selectFinest [Thing "a" 7, Thing "b" 5, Thing "a" 10]
[Thing {key = "a", score = 10},Thing {key = "b", score = 5}]

   

--解码 X509 文件

import Data.ByteString (ByteString)
import Data.Certificate.PEM
import Data.Certificate.X509
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L

decode :: ByteString -> Either String X509
decode pem =
    case parsePEMCert pem of
        Nothing       -> Left "certificate not in PEM format"
        Just certdata -> decodeCertificate $ L.fromChunks [certdata]

main :: IO ()
main = print . decode =<< B.readFile "ca-cert.pem"

--使用状态

import Control.Monad. State
import Test.QuickCheck

tThis = take 5 . show . mybreak (>4000000) $ [1..10^7]
tPrel = take 5 . show . prelbreak (>4000000) $ [1..10^7]

prelbreak p xs = ( takeWhile (not . p) xs, dropWhile (not . p) xs)  -- fast, more or less as implemented in prelude

mybreak p xs = evalState (brk p) ([], xs)  -- stateful, slow
brk p = do
      (notsat, remaining) <- get
      case remaining of
        [] -> return (notsat, remaining)
        (r:rs) -> if p r
                    then return (notsat, remaining)
                    else do put (notsat++[r], rs)
                                 brk p

--As an example of using the ST monad with mutable arrays, here is an implementation of the Sieve of Erathostenes:

--runSTUArray is a specialized form of runST which allows you to build an array using mutation on the inside, 
--before freezing it and returning it as an immutable array. newArray, readArray and writeArray do 
what you'd expect.

import Control.Monad.ST
import Data.Array.ST
import Data.Array.Unboxed

primesUpto :: Int -> [Int]
primesUpto n = [p | (p, True) <- assocs $ sieve n] 

sieve :: Int -> UArray Int Bool
sieve n = runSTUArray $ do
     sieve <- newArray (2, n) True
     forM_ [2..n] $ \p -> do
         isPrime <- readArray sieve p
         when isPrime $ do
             forM_ [p*2, p*3 .. n] $ \k -> do
                   writeArray sieve k False
     return sieve


--让用户输入很多行， 以空行结束

.递归实现

import Prelude hiding (readList)
import Control.Applicative
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Trans.Maybe
import Data.Maybe

readList :: IO [String]
readList = do
  l <- getLine
  if null l
    then return []
    else (l :) <$> readList


.非递归实现
通用的many组合子可用于任何applicative函子

many :: Applicative f => f a -> f [a]

IO函子不是Applicative的实例, 但我们可以在其上面加一层MaybeT transformer来解决此问题。MaybeT将是我们区别成功/失败的方法。

readList :: IO [String]
readList = fmap (fromMaybe []) $ runMaybeT $ many $ do
  l <- lift getLine
  guard $ not $ null l
  return l

.lift getLine以MaybeT的角度(总是成功)将getLine从IO String提升(lift)至MaybeT IO String
.guard是MonadZero类的函数，用于检查条件是否有效。它与assert函数相似，但它用于流程控制而不是调试
.如果guard没有放弃计算，将简单返回刚读入的行