Optimization 优化Haskell程序
我昨天开始研究Haskell，目的是真正学习它。我在编程语言课程中用它编写了一些琐碎的程序，但没有一个真正关心效率。我试图了解如何提高以下程序的运行时间 我的程序解决了以下玩具问题（我知道，如果你知道阶乘是什么，手工计算答案很简单，但我用一个后继函数以蛮力的方式进行计算）： 对于给定有限长列表的词典排序的后继函数，我的算法如下：Optimization 优化Haskell程序,optimization,haskell,Optimization,Haskell,我昨天开始研究Haskell，目的是真正学习它。我在编程语言课程中用它编写了一些琐碎的程序，但没有一个真正关心效率。我试图了解如何提高以下程序的运行时间 我的程序解决了以下玩具问题（我知道，如果你知道阶乘是什么，手工计算答案很简单，但我用一个后继函数以蛮力的方式进行计算）： 对于给定有限长列表的词典排序的后继函数，我的算法如下： 如果列表已经是降序的，那么我们在字典序中有最大元素，所以没有后继元素 给定一个列表h:t，t在字典序中要么是最大的，要么不是。在后一种情况下，计算t的后继项。在前一种
max\u list:：（Ord a）=>a]>a
max_list[]=错误“空列表没有最大值！”
最大列表（h:[]）=h
最大列表（h:t）=最大h（最大列表t）
最小列表：：（Ord a）=>[a]->a
min_list[]=错误“空列表没有最小值！”
最小列表（h:[]）=h
最小列表（h:t）=最小h（最小列表t）
--将列表中第一个出现的x替换为y
替换：：（等式a）=>a->a->[a]->[a]
替换u[]=[]
更换x y（h:t）
|h==x=y:t
|否则=h：（替换x y t）
--按递增顺序排序
排序列表：：（Ord a）=>[a]->[a]
排序列表[]=[]
排序列表（h:t）=（排序列表（过滤器（\x->x>h）t））
--检查列表是否按降序排列
降序：：（Ord a）=>[a]->Bool
递减[]=True
递减（h:[]）=真
下降（h:t）
|h>（最大列表t）=递减t
|否则=假
成功列表：：（Ord a）=>[a]->[a]
成功列表[]=[]
成功列表（h:[]）=[h]
成功列表（h:t）
|下降（h:t）=（h:t）
|不（递减t）=h：成功列表t
|否则=下一个：排序列表（替换下一个）
其中next_h=min_列表（过滤器（\x->x>h）t）
--应用函数n次
应用次数：：（整数n）=>n->（a->a）-->a->a
应用\u次n\ua
|n
这些函数中的很多可能都在标准库中
的确如此。如果导入数据.列表
，这使得排序
可用，最大值
和最小值
可从序言
中获得。来自Data.List
的排序
总的来说比准快速排序更有效，特别是因为这里的列表中有很多已排序的块
descending :: (Ord a) => [a] -> Bool
descending [] = True
descending (h:[]) = True
descending (h:t)
| h > (max_list t) = descending t
| otherwise = False
是低效的-O（n²）
-因为它在每一步中都会遍历整个左尾部，尽管如果列表是递减的，尾部的最大值必须是它的头部但是这有一个很好的结果。由于成功列表
的第三个等式的第一个保护强制对列表进行完全评估，因此它可以防止thunks的累积。但是，如果显式强制列表一次，则可以更有效地执行此操作
将使其线性化。那
在注意到我的程序运行了一段时间后，我编写了一个等效的C程序进行比较
那将是不寻常的。到目前为止，很少有人会在C语言中使用链表，在此基础上实现惰性评估将是一项艰巨的任务
用C语言编写一个等价的程序将是非常不明智的。在C语言中，实现算法的自然方式是使用数组和就地变异。这在这里会自动地更有效率
我的猜测是，Haskell的延迟计算导致apply_times函数在实际开始计算结果之前在内存中构建一个巨大的列表
不完全是，它建造的是一个巨大的撞击
apply_times 999999 succ_list [0,1,2,3,4,5,6,7,8,9]
~> apply_times 999998 succ_list (succ_list [0 .. 9])
~> apply_times 999997 succ_list (succ_list (succ_list [0 .. 9]))
~> apply_times 999996 succ_list (succ_list (succ_list (succ_list [0 .. 9])))
...
succ_list (succ_list (succ_list ... (succ_list [0 .. 9])...))
而且，在thunk建成之后，必须对其进行评估。要计算最外层调用，必须对下一个调用进行足够的计算，以找出与最外层调用中的模式匹配的模式。因此，将最外层的调用推送到堆栈上，并开始计算下一个调用。为此，必须确定哪种模式匹配，因此需要第三次调用的部分结果。因此，第二个调用被推送到堆栈上。最后，堆栈上有99998个调用，并开始计算最里面的调用。然后在每次调用和下一个外部调用之间打乒乓球（至少，依赖关系可能会传播得更远），同时从堆栈中弹出调用
有什么好的技巧可以用来最小化内存消耗吗
是，强制中间列表在成为apply\u times
的参数之前进行计算。这里需要完整的评估，所以普通的seq
不够好
import Control.DeepSeq
apply_times' :: (NFData a, Integral n) => n -> (a -> a) -> a -> a
apply_times' 0 _ x = x
apply_times' k f x = apply_times' (k-1) f $!! f x
这可以防止Thunk的累积，因此您不需要比在succ\u list
中构建的几个短列表和计数器更多的内存
如何减少复制和垃圾收集，因为列表不断被创建，而C实现可以完成所有工作
对，这仍然会分配（和垃圾收集）很多。现在，GHC在分配和垃圾收集短期数据方面非常出色（在我的机器上，它可以轻松地以每秒2GB的速度分配数据，而不会太慢），但是，不分配所有这些列表会更快
所以，如果你想推动它，使用原位突变。工作
STUArray s Int Int
或者是一个非固定可变向量（我更喜欢数组
包提供的接口，但大多数人更喜欢向量
I）
import Control.DeepSeq
apply_times' :: (NFData a, Integral n) => n -> (a -> a) -> a -> a
apply_times' 0 _ x = x
apply_times' k f x = apply_times' (k-1) f $!! f x
STUArray s Int Int
{-# LANGUAGE BangPatterns #-}
module Main (main) where
import Data.Array.ST
import Data.Array.Base
import Control.Monad.ST
import Control.Monad (when, replicateM_)
sortPart :: STUArray s Int Int -> Int -> Int -> ST s ()
sortPart a lo hi
| lo < hi = do
let lscan !p h i
| i < h = do
v <- unsafeRead a i
if p < v then return i else lscan p h (i+1)
| otherwise = return i
rscan !p l i
| l < i = do
v <- unsafeRead a i
if v < p then return i else rscan p l (i-1)
| otherwise = return i
swap i j = do
v <- unsafeRead a i
unsafeRead a j >>= unsafeWrite a i
unsafeWrite a j v
sloop !p l h
| l < h = do
l1 <- lscan p h l
h1 <- rscan p l1 h
if (l1 < h1) then (swap l1 h1 >> sloop p l1 h1) else return l1
| otherwise = return l
piv <- unsafeRead a hi
i <- sloop piv lo hi
swap i hi
sortPart a lo (i-1)
sortPart a (i+1) hi
| otherwise = return ()
descending :: STUArray s Int Int -> Int -> Int -> ST s Bool
descending arr lo hi
| lo < hi = do
let check i !v
| hi < i = return True
| otherwise = do
w <- unsafeRead arr i
if w < v
then check (i+1) w
else return False
x <- unsafeRead arr lo
check (lo+1) x
| otherwise = return True
findAndReplace :: STUArray s Int Int -> Int -> Int -> ST s ()
findAndReplace arr lo hi
| lo < hi = do
x <- unsafeRead arr lo
let go !mi !mv i
| hi < i = when (lo < mi) $ unsafeWrite arr mi x >> unsafeWrite arr lo mv
| otherwise = do
w <- unsafeRead arr i
if x < w && w < mv
then go i w (i+1)
else go mi mv (i+1)
look i
| hi < i = return ()
| otherwise = do
w <- unsafeRead arr i
if x < w
then go i w (i+1)
else look (i+1)
look (lo+1)
| otherwise = return ()
succArr :: STUArray s Int Int -> Int -> Int -> ST s ()
succArr arr lo hi
| lo < hi = do
end <- descending arr lo hi
if end
then return ()
else do
needSwap <- descending arr (lo+1) hi
if needSwap
then do
findAndReplace arr lo hi
sortPart arr (lo+1) hi
else succArr arr (lo+1) hi
| otherwise = return ()
solution :: [Int]
solution = runST $ do
arr <- newListArray (0,9) [0 .. 9]
replicateM_ 999999 $ succArr arr 0 9
getElems arr
main :: IO ()
main = print solution
module Main (main) where
import Data.Array.ST
import Data.Array.Base
import Data.Array.Unboxed
import Control.Monad.ST
import Control.Monad (when)
import Data.Bits
lexPerm :: Int -> Int -> [Int]
lexPerm idx num = elems (runSTUArray $ do
arr <- unsafeNewArray_ (0,num)
let fill i
| num < i = return ()
| otherwise = unsafeWrite arr i i >> fill (i+1)
swap i j = do
x <- unsafeRead arr i
y <- unsafeRead arr j
unsafeWrite arr j x
unsafeWrite arr i y
flop i j
| i < j = do
swap i j
flop (i+1) (j-1)
| otherwise = return ()
binsearch v a b = go a b
where
go i j
| i < j = do
let m = (i+j+1) `unsafeShiftR` 1
w <- unsafeRead arr m
if w < v
then go i (m-1)
else go m j
| otherwise = swap a i
upstep k j
| k < 1 = return ()
| j == num-1 = unsafeRead arr num >>= flip (back k) (num-1)
| otherwise = nextP k (num-1)
back k v i
| i < 0 = return ()
| otherwise = do
w <- unsafeRead arr i
if w < v
then nextP k i
else back k w (i-1)
nextP k up
| k < 1 || up < 0 = return ()
| otherwise = do
v <- unsafeRead arr up
binsearch v up num
flop (up+1) num
upstep (k-1) up
fill 0
nextP (idx-1) (num-1)
return arr)
main :: IO ()
main = print $ lexPerm 1000000 9