#Haskell基础
- 语法、语义
- 常用函数实现
- 函数参考
- 语法拾遗
- Codeforces
- 99 Problem
- Euler
- Queue
- Set
- Heap
- qpueue
- Sort
- Splay Tree
- Suffix Array
- BKTree
- Hacker Rank
- Hakell revolution
- Daily Haskell
- 各种
##语法、语义
1. Primitive Datatypes and Operators
2. Lists and Tuples
3. Functions
-- Put the function name between the two arguments with backticks:
1 `add` 2 -- 3
-- You can also define functions that have no letters! This lets you define your own operators!
(//) a b = a `div` b
35 // 4 -- 8
-- Pattern matching on tuples:
foo (x, y) = (x + 1, y + 2)
**4. Type signatures ** **5. Control Flow and If Statements **
-- if statements
haskell = if 1 == 1 then "awesome" else "awful" -- haskell = "awesome"
-- if statements can be on multiple lines too, indentation is important
haskell = if 1 == 1
then "awesome"
else "awful"
-- case statements: Here's how you could parse command line arguments
case args of
"help" -> printHelp
"start" -> startProgram
_ -> putStrLn "bad args"
-- you can make a for function using map and then use it
for array func = map func array
for [0..5] $ \i -> show i
6. Data Types
-- Here's how you make your own data type in Haskell
data Color = Red | Blue | Green
-- Now you can use it in a function:
say :: Color -> String
say Red = "You are Red!"
say Blue = "You are Blue!"
say Green = "You are Green!"
-- Your data types can have parameters too:
data Maybe a = Nothing | Just a
-- These are all of type Maybe
Just "hello" -- of type `Maybe String`
Just 1 -- of type `Maybe Int`
Nothing -- of type `Maybe a` for any `a`
7. Functor
The Functor class is defined like this:
class Functor f where
fmap :: (a -> b) -> f a -> f b
All instances of Functor should obey:
fmap id = id
fmap (p . q) = (fmap p) . (fmap q)
##常用函数实现
**1. fold**
fold :: (a -> b -> b) -> b -> ([a] -> b)
fold f v [] = v
fold f v (x : xs) = f x (fold f v xs)
sum :: [Int] -> Int
sum = fold (+) 0
product :: [Int] -> Int
product = fold (*) 1
and :: [Bool] -> Bool
and = fold (^) True
or :: [Bool] -> Bool
or = fold ()
length :: [a] -> Int
length = fold (/x n -> 1 + n) 0
reverse :: [a] -> [a]
reverse = fold (/x xs -> xs ++ [x]) []
map :: (a -> b) -> ([a] -> [b])
map f = fold (/x xs -> f x : xs) []
filter :: (a -> Bool) -> ([a] -> [a])
filter p = fold (/x xs -> if p x then x:xs else xs) []
**2. curry**
curry :: ((a,b) -> c) -> (a -> b -> c)
curry f x y = f (x,y)
uncurry :: (a -> b -> c) -> ((a,b) -> c)
uncurry f p = f (fst p) (snd p)
**3. map**
map :: (a -> b) -> [a] -> [b]
map _ [] = []
map f (x:xs) = (f x) : (map f xs)
**4. filter**
filter :: (a -> Bool) -> [a] -> [a]
filter _ [] = []
filter valid (x:xs)
| valid x = x : filter valid xs
| otherwise = filter valid xs
##函数参考
列表
-----------
elem
init 除末尾元素的所有元素
cycle [1, 2, 3, 4] 反复出现列表
[1, 2, 3, 4,1, 2, 3, 4, ...]
repeat 反复出现某一值
replicate 3 1 重复出现某一值一定次数
[1, 1, 1]
takeWhile even[2,4,5,6] 取满足条件的前几个（需连续）
dropWhile
span 分割
span even [2,4,5,6]
([2,4],[5,6])
break
生成列表
enumFrom [n..]
enumFromThen [m, n..]
enumFromTo [m..n]
enumFromThenTo [m, n..o]
succ
zipWith3 (\x y z -> x + y + z) [1, 2, 3] [4, 5, 6] [7, 8, 9]
[12,15,18]
字符
------------
lines
words
unlines
unwords
循环
---------
repeat
iterate f x = x : iterate f (f x)
Input: take 10 (iterate (2*) 1)
Output: [1,2,4,8,16,32,64,128,256,512]
interact
until p f x = if p x then x else until p f (f x)
concat
concatMap
concatMap (\(x, y) -> [x*y]) [(1, 2), (3, 4), (5, 6)]
[2,12,30]
concatMap (enumFromTo 1) [1,3,5]
[1,1,2,3,1,2,3,4,5]
concatMap (\x -> [(x,x+2,x/2)]) [1,3,5]
[(1.0,3.0,0.5),(3.0,5.0,1.5),(5.0,7.0,2.5)]
Data.Map
----------------
fromList
fromList([(1,'a'), (2,'c'), (3,'b')])
empty
size
singleton
singleton 1 'a' == fromList [(1, 'a')]
lookup
insert
keys elems
toList
fmap的多种含义。。
class Functor f where
fmap :: (a -> b) -> f a -> f b
instance Functor Maybe where
fmap f Nothing = Nothing
fmap f (Just x) = Just (f x)
instance Functor IO where
fmap f x = x >>= (return . f)
instance Functor [] where
fmap = map
各种fold
--------------
foldl :: (a -> b -> a) -> a -> [b] -> a
it takes the second argument and the first item of the list and applies the function
to them, then feeds the function with this result and the second argument and so on
foldl max 5 [1,2,3,4,5,6,7] = 7
foldl' :: (a -> b -> a) -> a -> [b] -> a
A strict version of foldl
foldl1 :: (a -> a -> a) -> [a] -> a
it takes the first 2 items of the list and applies the function to them, then feeds
the function with this result and the third argument and so on
foldl1 (/) [64, 4, 2, 8] = 1.0
foldM :: Monad m => (a -> b -> m a) -> a -> [b] -> m a
The foldM function is analogous to foldl, except that its result
is encapsulated in a monad.
foldM f a1 [x1, x2, ..., xm]
==
do
a2 <- f a1 x1
a3 <- f a2 x2
...
f am xm
foldM_ :: Monad m => (a -> b -> m a) -> a -> [b] -> m ()
Like foldM, but discards the result
Data.Map
-----------
insert :: Ord k => k a -> a -> Map k a -> Map k a
O(log n). Insert a new key and value in the map. If the key is already present in the map, the associated value is replaced
with the supplied value
insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Insert with a function, combining new value and old value. insertWith f key value mp will insert the pair (key, value) into
mp if key does not exist in the map. If the key does exist, the function will insert the pair
(key, f new_value old_value).
Control.Applicative
----------------
This module describes a structure intermediate between a functor and a monad
##语法拾遗
1. 运算符
-------
**1.1 !**
**1.2 $**
($) :: (a -> b) -> a -> b
f $ x= f x
右结合，优先级最低。f (g (z x))与f $ g $ z x等价。
减少代码中括号数目：
sum (map sqrt[1..130])
sum $ sqrt[1..130] ?????
sum (filter (> 10) (map (*2) [2..10])
sum $ filter (> 10) $ map (*2) [2..10]。
将数据作为函数使用：
例如映射一个函数调用符到一组函数组成的list
ghci> map ($ 3) [(4+), (10*), (^2), sqrt]
**1.3 .**
function composition
**1.4 定义操作符**
infixr 3 &&
(&&) :: Bool -> Bool -> Bool
False && x = False
True && x = x
运算符用括号括起来, 可以当作函数使用, 比如
map (3+) [1,2,3]
2. 函数
-----------
**2.1 curry实现多参数**
add :: Int -> Int -> Int
add x y = x + y
从add类型可看出, 有两个"->", 而"->"的结合次序是从右向左
即add接受一个Int参数, 返回一个( Int -> Int )的函数, 这个函数再接受一个Int返回一个Int.
用元组表示多参数
add :: (Int,Int) -> Int
add (x,y) = x+y
3. 数据结构
-----------
Tuple元素类型可以不同
Pari 就是二元组
[(a,b,c) | a <- [1..10], b <- [1..a], c <- [1..b], b^2 + c^2 == a^2]
4. ..
------------
as-模式
main = print (aaa (True,12,6))
aaa p@(x,y,z) = if x
then show p ++ ": " ++ show(y+z)
else ""
Output: "(True,12,6): 18"
5. 定义新类型
------------------
类型构造器，值构造器，域
data BookInfo = Book Int String [String]
deriving (Show)
类型的名字（类型构造器）和值构造器的名字是相互独立的。类型构造器只能出现在类型的定义，或者类型签名当中。而值构造器只能出现在实际的代码中。因为存在这种差别，给类型构造器和值构造器赋予一个相同的名字实际上并不会产生任何问题。
6. 类型类
-----------
定义通用接口，为各种不同的类型提供一组公共特性集，和其他语言的接口和多态方法有些类似。
类型类是某些基本语言特性的核心，比如相等性测试和数值操作符
7. Let vs. Where
---------
##Codeforces
--35A Shell Game
import IO
yao :: [Int] -> Int
yao [a] = a
yao (a:b:c:d) = yao $ (if a == b then c else if a == c then b else a):d
main = do
hi <- openFile "input.txt" ReadMode
ho <- openFile "output.txt" WriteMode
hGetContents hi >>= hPutStr ho . show . yao . map read . words
hClose ho
--32B
main = do getLine >>= putStr.yao
yao [] = []
yao ('.':x) = '0':yao x
yao ('-':'.':x) = '1':yao x
yao ('-':'.':x) = '2':yao x
--32D
import Control.Arrow
import Control.Monad
import Data.Array
main = do
[n, m, k] <- fmap(map read . words) getLine
a <- replicatedM n getLine
putStr $ head $ (++["-1"]) $ drop (k - 1) $ yao n m $ listArray ((1,1),(n,m))$concat a
yao n m a = [unlines $ map (\(i, j) -> show i ++ " " ++ show j) z |
r <- [1..min n m -1],
s <- [[id *** id, flip (-) r *** id, (+r) *** id, id *** flip(-) r, id ***(+r)]],
x <- [r + 1 .. n - r],
y <- [r + 1 .. m - r],
a!(x,y) == '*'
z <- [map (\k -> k (x, y)) s],
and [a!(i, j)== '*' | (i, j) <- z]]
##99 Problems
---------------------------------------------------------------
--列表
---------------------------------------------------------------
-- 1. Fing the last element of list
myLast :: [a] -> a
myLast [x] = x
myLast (_:xs) = myLast xs
--Point free
myLast = head . reverse
-- 2.The last but one element of a list
myButLast [x,_] = x
myButLast (_:xs) = myButLast xs
--Point free
myButLast = head . tail . reverse
-- 3. Find the K'th element of a list. The first element in the list is number 1.
-- nth操作符!!, 从0开始
(!!) :: [a] -> Int -> a
(x:_) !! 0 = x
(_:xs) !! n = xs !! (n-1)
--从1开始
elementAt :: [a] -> Int -> a
elmentAt list i = list !! (i-1)
--Point free
elementAt xs n = (last .) . take . (+ 1)
-- 4. Find the number of elements of a list
myLength :: [a] -> Int
myLength [] -> 0
myLength (_:xs) -> 1 + myLength xs
-- others
myLength = foldl (\n _ -> n + 1) 0
myLength = foldr (\_ n -> n + 1) 0
myLength''' = fst . last . zip [1..] -- same, but easier
myLength = sum . map (\_->1)
-- 5. reverse
reverse :: [a] -> [a]
reverse [] = []
reverse (x:xs) = reverse xs ++ [x]
-- other
reverse = foldl (flip (:)) []
--6.判断回文
isHui :: (Eq a) => [a] -> Bool
isHui xs = xs == (reverse xs)
--
isHui = Control.Monad.liftM2 (==) id reverse
isHui = (==) Control.Applicative.<*> reverse
isHui xs = (uncurry (==) . (id &&& reverse))
--20 Remove the K'th element from a list
removeAt n xs = (xs !! (n - 1), take(n - 1) xs ++ drop n xs)
-- Pointer-free style
--22
range :: Int -> Int -> [Int]
range n m
| n == m = [n]
| n < m = n:(range (n+1) m)
---------------------------------------------------------------------
--算术
---------------------------------------------------------------------
--31素数
--32
gcd :: Integer -> Integer ->Integer
gcd a b
| b == 0 = abs a
| otherwise = gcd b (a mod b)
-----------------------------------------------------
--逻辑
----------------------------------------------------
--46.
not' :: Bool -> Bool
not' True = False
not' False = True
and', or', nor', nand', xor', impl', equ' :: Bool -> Bool -> Bool
and' True True = True
and' _ _ = True
or' False False = False
or' _ _ = True
nor' a b = not' $ or' a b
nand' a b = not' $ or' a b
xor' True False = True
xor' False True = True
xor' _ _ = False
--49. 格雷码
gray :: Int -> [String]
gray 0 = [""]
gray n = let xs = gray (n-1) in map ('0':) xs ++ map ('1':) (reverse xs)
-- foldr
gray :: Integer a => a -> [String]
gray 0 = [""]
gray n = foldr (\s acc -> ("0" ++ s):("1" ++ s):acc) [] $ gray (n-1)
-- list comrehension
gray :: Int -> [String]
gray 0 = [""]
gray n = ['0' : x | x <- prev] ++ ['1' : x | x <- reverse prev]
where prev = gray (n-1)
-- 50. 哈夫曼
--------------------------------------------------------------------------------------------
--二叉树
data Tree a = Empty | Branch a (Tree a) (Tree a)
deriving (Show, Eq)
leaf x = Branch x Empty Empty
-------------------------------------------------------------------
--综合
--
--90.八皇后
queens :: Int -> [[Int]]
queens n = filter test (generate n)
where generate 0 = [[]]
generate k = [q : qs | q <- [1..n], qs <- generate (k-1)]
test [] = True
test (q:qs) = isSafe q qs && test qs
isSafe try qs = not (try `elem` qs || sameDiag try qs)
sameDiag try qs = any (\(colDist,q) -> abs (try - q) == colDist) $ zip [1..] qs
##Euler
-- Prob1
euler1 :: Int
euler1 = sum[x | x <- [1..999], x 'mod' 3 == 0 || x 'mod' 5 == 0]
main = print euler1
-- Prob2
main :: IO()
main =
print (sum [x | x <- takeWhile (<= 4000000) fibs, even x])
where
fibs = 0 : 1 : zipWith (+) fibs (tail fibs)
-- Prob3
isPrime :: Integer -> Bool
isPrime n = null [x | x <- [2..(floor(sqrt(fromInteger n)))], mod n x == 0]
factors :: Integer -> [Integer]
factors n = [x | x <- [1..n], mod n x == 0]
main :: IO()
main = print $ filter isPrime $ factors 33
-- Prob4
prob4 = maximun [ x | y <- [100..999],
z <- [y..999],
let x = y * z,
let s = show x,
s == reverse s]
-- Or
module Main where
import Data.Char
isPalendrome :: String -> Bool
isPalendrome x | x == reverse x = True
| otherwise = False
multiples = [ show $ fromInteger x*y | x <- [1..999], y <-[1.999]]
main :: ()
main = do
let palindromes = filter (\x -> isPalendrome x) $ reverse multiples
let result = maximun (map (\y -> read y :: Int) palindromes)
print result
##Queue
-- Basic
newtype Queue a = Queue [a]
deriving (Show, Read)
push :: a -> Queue a -> Queue a
push x (Queue xs) = Queue (x:xs)
pop :: Queue a -> (a, Queue a)
pop (Queue xs) = (last xs, Queue (init xs))
peek :: Queue a -> (a, Queue a)
peek (Queue xs) = (last xs, Queue xs)
-- Another
module Queue(Queue, emptyQueue, queueEmpty, enqueue, dequeue, front) where
emptyQueue :: Queue a
queueEmpty :: Queue a -> Bool
enqueue :: a -> Queue a -> Queue a
dequeue :: Queue a -> Queue a
front :: Queue a -> a
newtype Queue a = Q [a]
emptyQueue = Q []
queueEmpty(Q []) = True
queueEmpty(Q _) = False
enqueue x (Q q) = Q (q ++ [x])
dequeue (Q (_:xs)) = Q xs
dequeue (Q []) = error "dequeue: empty queue"
front ( Q (x:_)) = x
front (Q []) = error "front: empty queue".
##Set
module Set (Set, emptySet, setEmpty, inSet, addSet, delSet) where
import List
showSet [] str = showString "{}" str
showSet (x:xs) str = showChar '{' (shows x (showl xs str))
where showl [] str = showCahr '}' str
showl (x:xs) str = showCahr ',' (shows x (showl xs str))
newtype Set a = St [a]
emptySet :: Set a
setEmpty :: Set a -> Bool
instance (Show a) => Show (Set a) where
showPrec _ (St s) str = showSet s str
emptySet = St []
setEmpty (St []) = True
setEmpty _ = False
inSet x (St xs) = elem x xs
##Heap
module Heap(Heap, emptyHeap, heapEmtpy, findHeap, insHeap, delHeap) where
emptyHeap :: (Ord a) => Heap a
heapEmtpy :: (Ord a) => Heap a -> Bool
findHeap :: (Ord a) => Heap a -> a
insHeap :: (Ord a) => a -> Heap a -> Heap a
delHeap :: (Ord a) => Heap a -> Heap a
data (Ord a) => Heap a = EmptyHP | HP a Int (Heap a) (Heap a)
deriving Show
emptyHeap = EmptyH
heapEmtpy EmptyHP = True
heapEmtpy _ = False
findHeap EmptyHP = error "findHeap:empty heap"
findHeap (HP x _ a b) = x
insHeap x h = merge(HP x 1 EmptyHP EmptyHP) h
delHeap EmptyHP = error "delHeap:empty heap"
delHeap (HP x _ a b) = merge a b
rank :: (Ord a) => Heap a -> Int
rank EmptyHP = 0
rank (HP _ r _ _) = r
makeHP :: (Ord a) => a -> Heap a -> Heap a -> Heap a
makeHP x a b | rank a >= rank b = HP x (rank b + 1) a b
| otherwise = HP x (rank a + 1) b a
merge :: (Ord a) => Heap a -> Heap a -> Heap a
merge h EmptyHP = h
merge EmptyHP h = h
merge h1@(HP x _ a1 b1) h2@(HP y _ a2 b2)
| x < = y = makeHP x a1 (merge b1 h2)
| otherwise = makeHP y a2 (merge h1 b2)
{-
-- examples of use of auxiliary functions
fig5_5a = insHeap 6 (insHeap 1(insHeap 4 (insHeap 8 emptyHeap)))
HP 1 2 (HP 4 1 (HP 8 1 EmptyHP EmptyHP) EmptyHP)
(HP 6 1 EmptyHP EmptyHP)
fig5_5b = insHeap 7 (insHeap 5 emptyHeap)
HP 5 1 (HP 7 1 EmptyHP EmptyHP) EmptyHP
examples of calls and results
Heap> merge fig5_5a fig5_5b
HP 1 2 (HP 5 2 (HP 7 1 EmptyHP EmptyHP) (HP 6 1 EmptyHP EmptyHP)) (HP 4 1 (HP 8 1 EmptyHP EmptyHP) EmptyHP)
-}
##pqueue
module PQueue(PQueue, emptyPQ, pqEmpty, enPQ, dePQ, frontPQ) where
import Heap
emptyPQ :: (Ord a) => PQueue a
pqEmpty :: (Ord a) => PQueue a -> Bool
enPQ :: (Ord a) => a -> PQueue a -> PQueue a
dePQ :: (Ord a) => PQueue a -> PQueue a
frontPQ :: (Ord a) => PQueue a -> a
{- List implementation -}
newtype PQueue a = PQ[a]
deriving Show
emptyPQ = PQ []
pqEmpty (PQ []) = True
pqEmpty _ = False
enPQ x (PQ q) = PQ (insert x q)
where insert x [] = []
insert x r@(e:r') | x < e = x:r
| otherwise = e:insert r'
dePQ (PQ []) =error "dePQ:empty priority queue"
dePQ (PQ (x:xs)) = PQ xs
frontPQ (PQ []) = error "frontPQ:empty priority queue"
frontPQ (PQ (x:xs)) = x
{-Heap implementation -}
emptyPQ = PQ emptyHeap
pqEmpty (PQ, h) = heapEmpty h
enPQ v (PQ h) = PQ (insHeap v h)
frontPQ (PQ h) = findHeap h
dePQ (PQ h) = PQ (delHeap h)
~~~~
##Sort
~~~~
module Sort
(
selectionSort,
bubbleSort,
insertionSort,
mergeSort,
quickSort,
heapSort,
radixSort,
coutingSort
)where
countingSort :: [Int] -> [Int]
countingSort xs = let k = maximum xs
ys = makeKList k []
numList = countList xs ys
in countSort' xs (countPreSumList 1 (length numList) numList) (makeKList (length xs) [])
countSort' (x:xs) ys zs = let v = ys !! (x-1)
(b, a) = splitAt (x-1) ys
newYValue = (ys !! (x-1)) - 1
newys = b ++ [newYValue] ++ (tail a)
(before, after) = splitAt (v-1) zs
newzs = before ++ [x] ++ (tail after)
in countSort' xs newys newzs
countSort' [] ys zs = zs
-- index starts from 1
countPreSumList :: Int -> Int -> [Int] -> [Int]
countPreSumList index n xs
| index < n = let v = xs !! (index-1)
(before, after) = splitAt index xs
newValue = (xs !! index) + v
newxs = before ++ [newValue] ++ (tail after)
in countPreSumList (index+1) n newxs
| otherwise = xs
countList :: [Int] -> [Int] -> [Int]
countList (x:xs) ys = let (before, after) = splitAt (x-1) ys
v = (ys !! (x-1)) + 1
newys = before ++ [v] ++ (tail after)
in countList xs newys
countList [] ys = ys
makeKList :: Int -> [Int] -> [Int]
makeKList 0 xs = xs
makeKList k xs = makeKList (k-1) (0:xs)
radixSort :: [Int] -> Int -> [Int]
radixSort xs base = let maxDigit = numDigit (maximum xs) base
in radixSort' xs 0 maxDigit base
radixSort' :: [Int] -> Int -> Int -> Int -> [Int]
radixSort' xs digit maxDigit base
| digit < maxDigit = let bucket = makeBucketList base
newBucket = bucketData xs digit bucket base
in radixSort' (concat newBucket) (digit+1) maxDigit base
| otherwise = xs
bucketData :: [Int] -> Int -> [[Int]] -> Int -> [[Int]]
bucketData (x:xs) digit bucket base = let v = digitValue x digit base
vThBucket = (bucket !! v) ++ [x]
newBucket = newBucketList bucket vThBucket v base
in bucketData xs digit newBucket base
bucketData [] _ bucket _ = bucket
digitValue :: Int -> Int -> Int -> Int
digitValue x digit base = (truncate ((fromIntegral x) / (10 ** (fromIntegral digit)))) `mod` base
numDigit :: Int -> Int -> Int
numDigit digit base = (truncate (logBase (fromIntegral base) (fromIntegral digit))) + 1
newBucketList :: [[Int]] -> [Int] -> Int -> Int -> [[Int]]
newBucketList bucket vthBucket v base = newBucketList' [] bucket vthBucket v 0 base
newBucketList' :: [[Int]] -> [[Int]] -> [Int] -> Int -> Int -> Int -> [[Int]]
newBucketList' newBucket bucket vThBucket v index base
| v == index = let nb = newBucket ++ [vThBucket]
in newBucketList' nb bucket vThBucket v (index+1) base
| index < base = let newData = (bucket !! index)
nb = newBucket ++ [newData]
in newBucketList' nb bucket vThBucket v (index+1) base
| otherwise = newBucket
makeBucketList :: Int -> [[Int]]
makeBucketList base = makeBucketList' base [[]]
makeBucketList' :: Int -> [[Int]] -> [[Int]]
makeBucketList' 1 lt = lt
makeBucketList' size lt = makeBucketList' (size-1) (lt ++ [[]])
heapSort :: (Ord a) => [a] -> [a]
heapSort xs = let i = (length xs) `div` 2
n = length xs
newxs = buildHeap xs i
in reverse (heapSort' newxs n (n-1))
heapSort' :: (Ord a) => [a] -> Int -> Int -> [a]
heapSort' xs n 0 = xs
heapSort' xs n index = heapSort' (heapify (swap 0 index xs) 1 index) index (index-1)
buildHeap :: (Ord a) => [a] -> Int -> [a]
buildHeap xs 0 = xs
buildHeap xs index = buildHeap (heapify xs index (length xs)) (index - 1)
heapify :: (Ord a) => [a] -> Int -> Int -> [a]
heapify xs k n = heapify' xs k n
heapify' :: (Ord a) => [a] -> Int -> Int -> [a]
heapify' xs k n
| (2 * k) + 1 <= n = let left = 2 * k
right = (2 * k) + 1
leftNode = xs !! (left-1)
rightNode = xs !! (right-1)
in if leftNode < rightNode
then heapSwap xs (k-1) (left-1) n
else heapSwap xs (k-1) (right-1) n
| (2 * k) <= n = let smaller = 2 * k
in heapSwap xs (k-1) (smaller-1) n
| otherwise = xs
heapSwap :: (Ord a) => [a] -> Int -> Int -> Int -> [a]
heapSwap xs k smaller n = let smallerNode = xs !! smaller
kNode = xs !! k
in if smallerNode < kNode
then heapify' (swap k smaller xs) (smaller+1) n
else xs
swap :: (Ord a) => Int -> Int -> [a] -> [a]
swap i j xs = let x = xs !! i
y = xs !! j
(before, after) = splitAt i xs
(after1, after2) = splitAt (j-i-1) (tail after)
in before ++ [y] ++ after1 ++ [x] ++ (tail after2)
quickSort :: (Ord a) => [a] -> [a]
quickSort [] = []
quickSort (x:xs) = quickSort (filter (x >) xs) ++ [x] ++ quickSort (filter (x <=) xs)
mergeSort :: (Ord a) => [a] -> [a]
mergeSort xs
| (length xs) == 1 = xs
| otherwise = merge (mergeSort xs1) (mergeSort xs2)
where index = halfIndex (length xs)
(xs1, xs2) = splitAt index xs
merge :: (Ord a) => [a] -> [a] -> [a]
merge xs@(x:xs') ys@(y:ys') = if x > y
then [y] ++ merge xs ys'
else [x] ++ merge xs' ys
merge [] ys = ys
merge xs [] = xs
halfIndex :: Int -> Int
halfIndex n = n `div` 2
insertionSort :: (Ord a) => [a] -> [a]
insertionSort xs = insertionSort' (length xs) xs 1
insertionSort' :: (Ord a) => Int -> [a] -> Int -> [a]
insertionSort' n xs index
| n <= index = xs
| otherwise = insertionSort' n (insertionExchange (index-1) xs index n) (index+1)
insertionExchange :: (Ord a) => Int -> [a] -> Int -> Int -> [a]
insertionExchange index xs vindex n
| index < 0 = let value = xs !! vindex
(before, after) = splitAt vindex xs
in [value] ++ before ++ (drop 1 after)
| otherwise = let x = xs !! index
value = xs !! vindex
(before, after) = splitAt (index+1) xs
(after1, after2) = splitAt (vindex-index-1) after
in if x <= value
then (before ++ [value] ++ after1 ++ (drop 1 after2))
else insertionExchange (index-1) xs vindex n
bubbleSort :: (Ord a) => [a] -> [a]
bubbleSort xs = bubbleSort' (length xs) xs
bubbleSort' :: (Ord a) => Int -> [a] -> [a]
bubbleSort' 1 xs = xs
bubbleSort' n xs = let (swaped, sorted) = bubbleExchange 0 xs n True
in if sorted == True
then swaped
else bubbleSort' (n-1) swaped
bubbleExchange :: (Ord a) => Int -> [a] -> Int -> Bool -> ([a], Bool)
bubbleExchange index xs n sorted
| index >= (n-1) = (xs, sorted)
| otherwise = let x = xs !! index
y = xs !! (index + 1)
(before, after) = splitAt index xs
nextIndex = index + 1
in if x > y
then bubbleExchange nextIndex (before ++ [y,x] ++ (drop 2 after)) n False
else bubbleExchange nextIndex xs n sorted
selectionSort :: (Ord a) => [a] -> [a]
selectionSort xs = selectionSort' (length xs) xs
selectionSort' :: (Ord a) => Int -> [a] -> [a]
selectionSort' 1 lt = lt
selectionSort' n xs@(x:xs') = let unsorted = take n xs
sorted = drop n xs
index = theLargest unsorted
lastValue = last unsorted
largest = xs !! index
(before, after) = splitAt index unsorted
in if lastValue == largest
then selectionSort' (n - 1) (before ++ [lastValue] ++ (tail after) ++ sorted)
else selectionSort' (n - 1) (before ++ [lastValue] ++ (init (tail after)) ++ [largest] ++ sorted)
theLargest :: (Ord a) => [a] -> Int
theLargest xs = theLargest' xs 0 0
theLargest' :: (Ord a) => [a] -> Int -> Int -> Int
theLargest' (x:y:xs) index largestIndex = let nextIndex = index + 1
in if x < y
then theLargest' (y:xs) nextIndex nextIndex
else theLargest' (x:xs) nextIndex largestIndex
theLargest' (x:[]) _ largestIndex = largestIndex
theLargest' [] _ _ = error "error"
~~~~
##Splay Tree
module SplayTree ( SplayTree, splay, insert, delete, empty, ) where
data SplayTree a = Nil | Node a (SplayTree a) (SplayTree a) deriving (Eq, Show)
splay :: (Ord a) => (a -> Ordering) -> SplayTree a -> SplayTree a splay comp t = walk t Nil Nil where walk Nil _ _ = Nil walk t@(Node nx l r) lspine rspine = case comp nx of LT -> case l of Nil -> final t lspine rspine Node nl a b -> if comp nl == LT && a /= Nil then walk a lspine (Node nl rspine (Node nx b r)) else walk l lspine (Node nx rspine r) GT -> case r of Nil -> final t lspine rspine
Node nr c d -> if comp nr == GT && d /= Nil then walk d (Node nr (Node nx l c) lspine) rspine
else walk r (Node nx l lspine) rspine
EQ -> final t lspine rspine
final g@(Node x l r) lspine rspine = Node x (lfinal l lspine) (rfinal r rspine)
lfinal l Nil = l
lfinal l (Node y a b) = lfinal (Node y a l) b
rfinal r Nil = r
rfinal r (Node y a b) = rfinal (Node y r b) a
insert :: (Ord a) => a -> SplayTree a -> SplayTree a insert key Nil = Node key Nil Nil insert key t = let t'@(Node nx l r) = splay (compare key) t in if key < nx then Node key l (Node nx Nil r) else Node key (Node nx l Nil) r
delete :: (Ord a) => a -> SplayTree a -> SplayTree a delete key Nil = Nil delete key t = let t'@(Node nx l r) = splay (compare key) t in case compare key nx of EQ -> if l == Nil then r else ((Node nl a _) -> Node nl a r) $ splay (const GT) l _ -> t'
empty = Nil
-- Test.QuickCheck
prop_insert_delete :: [Int] -> Bool prop_insert_delete xs = foldr delete (foldr insert empty xs) xs == Nil
##Suffix Array
-- Maintainer : Dani?l de Kok [email protected] -- Stability : experimental
-- Construction of suffix arrays (arrays ordered by suffix). Given an -- array /d/ elements, the suffix array is a sorted array of the sub-arrays -- in /d/. For instance, the suffix array of /banana apple pear apple/ is:
-- * pear apple
module Data.SuffixArray (SuffixArray(..), fromList, suffixArray, suffixArrayBy, toList) where
import qualified Data.Vector as V import Data.List (sortBy)
data SuffixArray a = SuffixArray (V.Vector a) (V.Vector Int) deriving Show
-- | -- 'elems' provides a vector of each element in the suffix array. One element -- of the suffix array contains the full data array. elems :: SuffixArray a -> V.Vector (V.Vector a) elems (SuffixArray d i) = V.map vecAt i where vecAt idx = V.drop idx d
-- | -- 'fromList' constructs a suffix array from a list of elements. fromList :: Ord a => [a] -> SuffixArray a fromList = suffixArray . V.fromList
-- | -- 'suffixArray' is a specialization of 'suffixArrayBy' that uses the -- default 'Prelude.compare' function. suffixArray :: Ord a => V.Vector a -> SuffixArray a suffixArray = suffixArrayBy compare
-- | -- 'suffixArrayBy' constructs a suffix array. The sorting order is determined -- by the supplied compare function. suffixArrayBy :: Ord a => (V.Vector a -> V.Vector a -> Ordering) -> V.Vector a -> SuffixArray a suffixArrayBy cmp d = SuffixArray d (V.fromList srtIndex) where uppBound = V.length d - 1 usrtIndex = [0..uppBound] srtIndex = sortBy (saCompare cmp d) usrtIndex
saCompare :: Ord a => (V.Vector a -> V.Vector a -> Ordering) -> V.Vector a -> Int -> Int -> Ordering saCompare cmp d a b = cmp (V.drop a d) (V.drop b d)
-- | -- 'toList' constructs a list from a suffix array. toList :: SuffixArray a -> [[a]] toList (SuffixArray d i) = V.foldr vecAt [] i where vecAt idx l = V.toList (V.drop idx d) : l
-- sample1 = V.fromList [9,8,7,6,5,4,3,2,1] -- sample2 = V.fromList "abaa"
##BKTree
import Data.Array
data BKTree a = BKEmpty | BKNode [a] [BKEdge a] deriving (Show) data BKEdge a = BKEdge Int (BKTree a) deriving (Show)
bkt_add :: Eq a => BKTree a -> [a] -> BKTree a bkt_add BKEmpty xs = BKNode xs [] bkt_add (BKNode ys edges) xs = BKNode ys insert (map insertIntoEdge edges) where dist = editDist xs ys insertIntoEdge edge@(BKEdge d node) = if d == dist then BKEdge d (bkt_add node xs) else edge
editDist :: Eq a => [a] -> [a] -> Int editDist xs ys = let (m,n) = (length xs, length ys) x = array (1,m) (zip [1..] xs) y = array (1,n) (zip [1..] ys)
table :: Array (Int, Int) Int
table = array bnds [(ij, dist ij) | ij <- range bnds]
bnds = ((0,0),(m,n))
dist (i,0) = i
dist (0,j) = j
dist (i,j) = minimum [1 + table ! (i-1,j), 1 + table ! (i,j-1),
if x ! i == y ! j then table ! (i-1,j-1) else 1 + table ! (i-1,j-1)]
in table ! (m,n)
##Hacker Rank
--Missing Number import Data.List (foldl') import Data.Map (differenceWith,empty,keys,insertWith',Map) import qualified Data.ByteString.Char8 as BC
freqs :: Ord a => [a] -> Map a Int freqs = foldl' (flip f) empty where f k = insertWith' (+) k 1
missing :: Ord a => [a] -> [a] -> [a] missing as bs = keys $ differenceWith f (freqs bs) (freqs as) where f b a | a == b = Nothing | otherwise = Just (b - a)
main = do as <- getList bs <- getList putStrLn $ unwords $ map show $ missing as bs where getList :: IO [Int] getList = do n <- readLn s <- BC.getLine return . map readI . take n $ BC.words s readI s = case BC.readInt s of Just (i, _) -> i Nothing -> 0
--Two Arrays
import Control.Monad
qsort :: [Int] -> [Int] qsort [] = [] qsort [x] = [x] qsort (x:xs) = qsort (filter (<= x) xs) ++ [x] ++ qsort (filter (> x) xs)
match :: Int -> [Int] -> [Int] -> String match _ [] [] = "YES" match k (x:xs) (y:ys) | x + y < k = "NO" | otherwise = match k xs ys
main = do t <- readLn replicateM_ $ do s1 <- getLine let (n:k:_) = map read $ words s1 s2 <- getLine let xs = qsort $ map read $ take n $ words s2 s3 <- getLine let ys = qsort $ map read $ take n $ words s3 putStrLn $ match k xs $ reverse ys
##Haskell革命
--1. Freshman fac n = if n == 0 then 1 else n * fac (n-1)
--2. Sophomore(studied scheme) fac = ((n) -> (if ((==) n 0) then 1 else ((*) n (fac ((-) n 1)))))
--3. Junior fac 0 = 1 fac (n+1) = (n+1) * fac n
--4. Senior fac n = foldl (*) 1 [1..n]
fac n = foldr (*) 1 [1..n]
fac n = foldr (\x g n -> g (x*n)) id [1..n] 1
--5. Memoizing facs = scanl (*) [1..] fac n = facs !! n
--6. "Points-free"(studied at Oxford) fac = foldr (*) 1 . enumFromTo 1
--7. Iterative(former Pascal programmer) fac n = result (for init next done) where init = (0, 1) next (i, m) = (i+1, m * (i+1)) done (i, ) = i == n result (, m) = m for i n d = until d n i
--8. Iterative one-liner Haskell programmer --(former APL and C programmer) fac n = snd (until ((>n) . fst) ((i,m) -> (i+1, i*m)) (1,1))
--9. Accumulating Haskell programmer --(building up to a quick climax) facAcc a 0 = a facAcc a n = facAcc (n*a) (n-1)
fac = facAcc 1
--10. Continuation-passing Haskell programmer --(raised RABBITS in early years, then moved to New Jersey) facCps k 0 = k 1 facCps k n = facCps (k . (n *)) (n-1)
fac = facCps id
--11. Boy Scout Haskell programmer -- (likes tying knots; always “reverent,” he --belongs to the Church of the Least Fixed-Point [8]) y f = f (y f)
fac = y (\f n -> if (n==0) then 1 else n * f (n-1))
--12. Combinatory Haskell programmer -- (eschews variables, if not obfuscation; -- all this currying’s just a phase, though it seldom hinders) s f g x = f x (g x)
k x y = x
b f g x = f (g x)
c f g x = f x g
y f = f (y f)
cond p f g x = if p x then f x else g x
fac = y (b (cond ((==) 0) (k 1)) (b (s (*)) (c b pred)))
--13. List-encoding Haskell programmer -- (prefers to count in unary) arb = () -- "undefined" is also a good RHS, as is "arb" :)
listenc n = replicate n arb listprj f = length . f . listenc
listprod xs ys = [ i (x,y) | x<-xs, y<-ys ] where i _ = arb
facl [] = listenc 1 facl n@(_:pred) = listprod n (facl pred)
fac = listprj facl
##Daily Haskell
-- alias method
import Data.Ratio import Data.Array import Data.List (partition) import System.Random
type DiscreteDistribution a = Array Int (Rational, a, a)
discreteDistribution :: [(a,Integer)] -> DiscreteDistribution a discreteDistribution xs = listArray (0,length xs-1) (uncurry buildTable $ partition ((<h).snd) xs') where xs' = map ((x,y)->(x,y%1)) xs s = foldl (\y (_,x)-> x + y) (0%1) xs' n = fromIntegral (length xs)%1 h = s / n buildTable [] ys = map ((b,y)->(1%1,b,b)) ys buildTable ((a,x):xs) ((b,y):ys) = (x / h, a, b):sol where v = y-(h-x) sol | v >= h = buildTable xs ((b,v):ys) | v < h = buildTable ((b,v):xs) ys
randomElement :: (RandomGen g) => DiscreteDistribution a -> g -> (a, g) randomElement a g = (if u <= numerator v then x else y,g'') where (r,g') = randomR (bounds a) g (v,x,y) = a!r (u,g'') = randomR (1, denominator v) g'
--Test if a integer is a perfect power
A integer n is perfect power if n = m^k for some integer m and k > 1.
import Data.Numbers.Primes import Data.List
perfectPower :: Int -> Bool perfectPower n = c > 1 where c = (foldl gcd 0) . (map length) . group . primeFactors $ n
##各种
gcdf x y | x == y = x gcdf x y | x < y = gcdf x (y-x) gcdf x y = gcdf (x-y) y