Haskellで最長増加部分列(LIS)IOArrayやData.Setで試行錯誤

今度もAOJの練習問題から
最長増加部分列の問題に挑む。
最長増加部分列 | 動的計画法 | Aizu Online Judge
 
コードを書く練習と割り切っているので
考え方は素直にググる。

thさんという方のブログに
分かりやすい考え方が載っていたので
これをHaskellで実装する事にした。

;; 最後の要素から順番に、各要素を先頭とするLIS長を求めていく。
;; 計算を具体的に手でやってみると、次のような流れになる(リストに作用させる関数をfとおく)。
(f 15) => 1
(f 7 15) => 2 ;7 < 15 なので (f 15) + 1 => 1 + 1
(f 11 7 15) => 2 ;11 < 15 なので (f 15) + 1 => 1 + 1
(f 3 11 7 15) => 3 ;3より大きい11,7,15で始まるLISはそれぞれ長さが2,2,1。maxの2に1加えて3
(f 13 3 11 7 15) => 2 ;13 < 15 なので (f 15) + 1 => 1 + 1
(f 5 13 3 11 7 15) => 3 ;5より大きい13か11か7で始まるLISが最長で2。それに1加えて3
(f 9 5 13 3 11 7 15) => 3 ;9より大きい13か11で始まるLISが最長で2。それに1加えて3
(f 1 9 5 13 3 11 7 15) => 4 ;1より大きい9や5で始まるLISが最長で3。それに1加えて4
(f 14 1 9 5 13 3 11 7 15) => 2 ;14 < 15 なので (f 15) + 1 => 1 + 1
(f 6 14 1 9 5 13 3 11 7 15) => 4 ;6より大きい数のうち、9で始まるLISが最長で3。それに1加えて4
(f 10 6 14 …略) => 3 ;10より大きい11,13のLISが最長で2。それに1加えて3
(f 2 10 6 …略) => 5 ;2より大きい6のLISが最長で4。それに1加えて5
(f 12 2 10 …略) => 3 ;12より大きい13, 14のLISが最長で4。それに1加えて3
(f 4 12 2 …略) => 5 ;5より大きい数のうち、6で始まるLISが最長で4。それに1加えて5
(f 8 4 12 …略) => 4 ;8より大きい12,10,9のLISが最長で3。それに1加えて4
(f 0 8 4 …略) => 6 ;0より大きい数のうち、2で始まるLISが最長で5。それに1加えて6

Technical Memorandum: 最長増加部分列の長さ in Elisp

Arrayで書いてみる

最初は数字と最長がいくつなのかの2つの数をArrayに収める事を考えてみた。

import Control.Applicative
import Data.Array
import Data,List (foldl')
main = do
len <- (read :: String -> Int) <$> getLine
xs <- map (read :: String -> Int) . lines <$> getContents
let arr = listArray (1,len) (zip xs [0,0..])
print $ ans $syorinaiyou arr len
ans arr = maximum $ map snd $ elems $ arr
syorinaiyou :: Array Int (Int, Int) -> Int -> Array Int (Int, Int)
syorinaiyou arr len = foldl' keisan arr (reverse [1..len])
where
keisan :: Array Int (Int, Int) -> Int -> Array Int (Int, Int)
keisan arr m
| m == len = arr // [(m,(a,1))]
| 1==1     = fst $ foldl' seisa' (arr,1) [m..(len+1)]
where
(a,_) = arr ! len
seisa' (arr,x) t
| t > len  = (koushin,x)
| fstarr m < fstarr t = (arr,hikaku)
| otherwise          = (arr,x)
where
fstarr r = fst $ arr ! r
sndarr r = snd $ arr ! r
hikaku = max x ((sndarr t)+1)
koushin = arr // [(m,(fstarr m,x))]

(叩き台として書いていたので変数名が酷い)

早速提出する
f:id:mikunimaru:20171118082828j:plain
安定のMLE。

        | m == len = arr // [(m,(a,1))]
koushin = arr // [(m,(fstarr m,x))]

原因は多分この辺り。
Haskellの配列は更新のコストが高すぎるので
破壊的代入をしないならMap一択なのかもしれない。

という訳でMapで書き直す。

import Control.Applicative
import qualified Data.Map.Strict as Map
import Data.List (foldl')
main = do
len <- (read :: String -> Int) <$> getLine
xs <- map (read :: String -> Int) . lines <$> getContents
let arr = Map.fromList $ zip [1..len] (zip xs [0,0..])
print $ ans $ syorinaiyou arr len
ans arr = maximum $ map (snd . snd)  $ Map.toList $ arr
syorinaiyou arr len = foldl' keisan arr (reverse [1..len])
where
keisan arr m
| m == len = Map.insert m (a,1) arr
| 1==1     = fst $ foldl' seisa' (arr,1) [m..(len+1)]
where
(a,_) = arr Map.! len
seisa' (arr,x) t
| t > len  = (koushin,x)
| fstarr m < fstarr t = (arr,hikaku)
| otherwise          = (arr,x)
where
fstarr r = fst $ arr Map.! r
sndarr r = snd $ arr Map.! r
hikaku = max x ((sndarr t)+1)
koushin = Map.insert m (fstarr m,x) arr

小さな修正で済んだ。

早速再提出。
f:id:mikunimaru:20171118101032j:plain
うーむ駄目。

IOArrayを試す

テストケースを見てみると
どうも要素数が1万もあるので、更新云々の問題でもなさそうだ。
まあせっかくなのでIOArrayで再実装したパターンも試してみる。

〜コンパイルエラーと格闘する事 2日間〜

import Control.Applicative
import Data.Array.IO
import Control.Monad (mapM_)
import Data.IORef
main = do
len <- (read :: String -> Int) <$> getLine
xs <- map (read :: String -> Int) . lines <$> getContents
arr <- newListArray (1,len) (zip xs [0,0..]) :: IO (IOArray Int (Int,Int))
syorinaiyou arr len
x <- newIORef 0
ans arr x
print =<< readIORef x
ans :: IOArray Int (Int, Int) -> IORef Int -> IO ()
ans arr x = do
xs <- getElems arr
writeIORef x (maximum $ map snd  xs)
syorinaiyou :: IOArray Int (Int, Int) -> Int -> IO ()
syorinaiyou arr len = do mapM_ (keisan arr) (reverse [1..len])
where
keisan :: IOArray Int (Int, Int) -> Int -> IO ()
keisan arr m = do
x <- newIORef 1
mapM_ (seisa' (arr,x)) [m..(len+1)]
where
seisa' :: (IOArray Int (Int, Int), IORef Int) -> Int -> IO ()
seisa' (arr,x) t
| t > len  = koushin
| otherwise = do
m'' <- readArray arr m
let m' = fst m''
t'' <- readArray arr t
let t' = fst t''
if m' < t' then hikaku
else return ()
where
hikaku = do
x' <- readIORef x
t'' <- readArray arr t
let t' = snd t''
writeIORef x (max x' (t'+1))
koushin = do
x' <- readIORef x
m'' <- readArray arr m
let m' = fst m''
writeArray arr m (m',x')

doだらけのコードがようやく完成。
折角なのでArrayで書いたコードをIOArrayで書き直す時に苦労したポイントをメモしておく。

  arr <- newListArray (1,len) (zip xs [0,0..]) :: IO (IOArray Int (Int,Int))

まずここ。
型注釈「:: IO (IOArray Int (Int,Int))」がないとコンパイルエラーになる。
IOArrayなのかIOUArrayなのかコンパイラが判別出来ないからだ。

seisa' (arr,x) t
| t > len  = koushin
| otherwise = do
m'' <- readArray arr m
let m' = fst m''
t'' <- readArray arr t
let t' = fst t''
if m' < t' then hikaku
else return ()

もとのコードと比較して一番汚く冗長になったこの部分。
初めはfstarr m < fstarr tとして
fstarr内でIOArrayから取得した値を返そうとしたのだが
非純粋?な関数から純粋な関数に値を渡す事は出来ないようで
仕方なくdoブロックを作ってブロック内で値を取り出してから
if then else で条件別に振り分けた。

後半の方は「t”」みたいな投げやりな変数名になってしまったが動いたので満足。
・・・はせずに、ブログ執筆用も兼ねて変数名で意味が分かるように修正。
こんな1文字の変数名では自分でも意味不明なので。

import Control.Applicative
import Data.Array.IO
import Control.Monad (mapM_)
import Data.IORef
main = do
len <- (read :: String -> Int) <$> getLine
xs <- map (read :: String -> Int) . lines <$> getContents
arr <- newListArray (1,len) (zip xs [1,1..]) :: IO (IOArray Int (Int,Int))
syorinaiyou arr len
lengthLIS <- newIORef 0
ans arr lengthLIS
print =<< readIORef lengthLIS
ans :: IOArray Int (Int, Int) -> IORef Int -> IO ()
ans arr lengthLIS = do
xs <- getElems arr
writeIORef lengthLIS (maximum $ map snd xs)
syorinaiyou :: IOArray Int (Int, Int) -> Int -> IO ()
syorinaiyou arr len = do mapM_ (keisan arr) (reverse [1..len])
where
keisan :: IOArray Int (Int, Int) -> Int -> IO ()
keisan arr hikaku_moto_Idx = do
mapM_ (seisa' arr) [hikaku_moto_Idx..(len)]
where
seisa' :: IOArray Int (Int, Int) -> Int -> IO ()
seisa' arr hikaku_saki_Idx = do
(hikaku_moto,_) <- readArray arr hikaku_moto_Idx
(hikaku_saki,_) <- readArray arr hikaku_saki_Idx
if hikaku_moto < hikaku_saki then hikaku
else return ()
where
hikaku = do
(_,hikaku_saki_LIS)                  <- readArray arr hikaku_saki_Idx
(hikaku_moto,hikaku_moto_LIS_zantei) <- readArray arr hikaku_moto_Idx
if hikaku_saki_LIS + 1 > hikaku_moto_LIS_zantei
then do
writeArray arr hikaku_moto_Idx (hikaku_moto, (hikaku_saki_LIS + 1))
else return ()

だいぶ読みやすくなった。
格好つけても仕方ないので変数名はローマ字にした。
処理の流れが分かりやすくなった事で無断な部分を省く事にも成功。

早速これで提出。
f:id:mikunimaru:20171119174350j:plain
メモリの削減という目的は達成されるも
残念ながらTLE

O2ビルドで強行突破をはかるも少し進んでTLE
f:id:mikunimaru:20171119180105j:plain

秘密兵器Data.Set

そこでData.Setに一度
各要素を先頭とするLIS長を保存し
そこから探索をする事にした。
Data.Set

takeWhileAntitone :: (a -> Bool) -> Set a -> Set a
O(log n). Take while a predicate on the elements holds .

findMax :: Set a -> a
O(log n). The maximal element of a set.

Data.Setはリストに扱い方が似ているが
takeWhileやmaximumをO(log n)で実行できるというスグレモノだ。
早速活用してみる。

修正するべき箇所はここ

      keisan :: IOArray Int (Int, Int) -> Int -> IO ()
keisan arr hikaku_moto_Idx = do
mapM_ (seisa' arr) [hikaku_moto_Idx..(len)]
where
seisa' :: IOArray Int (Int, Int) -> Int -> IO ()
seisa' arr hikaku_saki_Idx = do
(hikaku_moto,_) <- readArray arr hikaku_moto_Idx
(hikaku_saki,_) <- readArray arr hikaku_saki_Idx
if hikaku_moto < hikaku_saki then hikaku
else return ()
where
hikaku = do
(_,hikaku_saki_LIS) <- readArray arr hikaku_saki_Idx
(hikaku_moto,hikaku_moto_LIS_zantei) <- readArray arr hikaku_moto_Idx
if hikaku_saki_LIS + 1 > hikaku_moto_LIS_zantei
then do
writeArray arr hikaku_moto_Idx (hikaku_moto, (hikaku_saki_LIS + 1))
else return ()

この処理というのは
比較元よりも手前かつ大きな数の中で
その要素を先頭にするLIS長が一番長いものを探し出すというもの。

lookupMax $ takeWhileAntitone (>hikaku_moto) (これまでのLIS長のData.Set)

こんな完成イメージをもちつつソースを修正していく。

いきなり問題発生

lis.hs:6:57: error:
Module ‘Data.Set’ does not export ‘dropWhileAntitone’  

なんと古いバージョンのData.SetにはtakeWhileやdropWhileにあたる関数がなかったのだ。
仕方ないのでSet.splitを使う。

> b = Set.fromList $ zip [1..10] [1..10]
> b
fromList [(1,1),(2,2),(3,3),(4,4),(5,5),(6,6),(7,7),(8,8),(9,9),(10,10)]
> Set.split (5,0) b
(fromList [(1,1),(2,2),(3,3),(4,4)],fromList [(5,5),(6,6),(7,7),(8,8),(9,9),(10,10)])
> snd $ Set.split (5,0) b
fromList [(5,5),(6,6),(7,7),(8,8),(9,9),(10,10)]

これでtakeWhileAntitoneとほぼ同じような動作になる。

IOArrayは必要なくなったので
大幅に書き直したのが下のコード

{-# OPTIONS_GHC -O2 #-}
import Control.Applicative
import Data.Array.Unboxed
import Data.List (foldl')
import Data.Foldable (maximumBy)
import Data.Ord (comparing)
import qualified Data.Set as Set
main = do
len <- (read :: String -> Int) <$> getLine
xs <- map (read :: String -> Int) . lines <$> getContents
let arr = listArray (1,len) xs :: UArray Int Int
print $ snd $ maximumBy (comparing snd) $ syorinaiyou arr len
syorinaiyou arr len =
foldl' (keisan arr) Set.empty (reverse [1..len])
where
keisan arr set n
| Set.null set =  Set.insert ((arr ! n),1) set
| otherwise    = seisa arr set n
where
seisa arr set n
| Set.null set' = Set.insert (hikaku_moto,1) set
| otherwise     = Set.insert (hikaku_moto, oldLIS + 1) set
where
hikaku_moto = arr ! n
set'   = snd $ Set.split (hikaku_moto + 1 , 0) set
oldLIS = snd $ maximumBy (comparing snd) set'
maximumBy (comparing snd)

この部分はData.Setに収納されたタプルのsndが最大の要素を抽出する処理。
Data.Foldableはfoldableなら何でも適用できる便利な関数が入ったライブラリ。
Data.Foldable

lookupMaxは癖があったので今回は叩き台という事もあって採用しなかった。

早速再提出してみる。
f:id:mikunimaru:20171127041309j:plain
IOArrayの頃よりは進んだが、まだ突破は出来ず・・・

原因を探る

探らなくても薄々わかっている

snd $ maximumBy (comparing snd) set’

この処理がボトルネックになっていると見た。

そこでsetが長くならないように修正

seisa arr set n
| Set.null set' = Set.insert (hikaku_moto,1) set
| otherwise     = Set.insert (hikaku_moto, oldLIS + 1) set2
where
hikaku_moto = arr ! n
(set1, set') = Set.split (hikaku_moto + 1 , 0) set
(old,oldLIS) = maximumBy (comparing snd) set'
set2         = Set.union set1 (snd (Set.split (old,oldLIS-1) set'))

再提出
f:id:mikunimaru:20171127054601j:plain
うーん、あと一息。

もう一度修正

 (old,oldLIS) = Set.elemAt 0 set'

この部分は先頭=最長なので
maximumByを使う必要はなかった。

再提出
f:id:mikunimaru:20171127065518j:plain
色々と間違えていたらしい。
とりあえず継ぎ接ぎで修正して再提出。
f:id:mikunimaru:20171127065748j:plain
通った!!

最後の方にはヤケクソ感が漂うコードになってしまった。

{-# OPTIONS_GHC -O2 #-}
import Control.Applicative
import Data.Array.Unboxed
import Data.List (foldl')
import Data.Foldable (maximumBy)
import Data.Ord (comparing)
import qualified Data.Set as Set
main = do
len <- (read :: String -> Int) <$> getLine
xs <- map (read :: String -> Int) . lines <$> getContents
let arr = listArray (1,len) xs :: UArray Int Int
print $ snd $ maximumBy (comparing snd) $ syorinaiyou arr len
syorinaiyou arr len =
foldl' (keisan arr) Set.empty (reverse [1..len])
where
keisan arr set n
| Set.null set = Set.insert ((arr ! n),1) set
| otherwise    = seisa arr set n
where
seisa arr set n
| Set.null set'      = Set.insert (hikaku_moto,1) set
| Set.size set1 <= 1 =  Set.insert (hikaku_moto, oldLIS + 1) set'
| otherwise = Set.insert (hikaku_moto, oldLIS + 1) set2
where
hikaku_moto = arr ! n
(set1, set') = Set.split (hikaku_moto + 1 , 0) set
(old,oldLIS) = Set.elemAt 0 set'
set2         = Set.union (Set.delete (Set.elemAt ((Set.size set1)-1) set1) set1) (snd (Set.split (old,oldLIS-1) set'))

一応解決。
最終的には破壊的代入とか要らなかった。
IOArrayの為に格闘していた時間は一体・・・