How to populate a 2D Array in Haskell - arrays

I am currently working on populating a grid in Haskell defined as type Grid = UArray (Int, Int) Bool where the two Ints are the x and y coordinates. I am trying to turn this into a 10 by 10 data structure where the data types are Boolean. I can get the values as such the listArray is part of the Data.Array.Unboxed package
import System.IO
import Control.Monad
import Data.Array.Unboxed
import Data.List (unfoldr)
type Board = UArray (Int, Int) Bool
progress :: Int -> Int -> Board -> Board
progress width height previous =
listArray b (map f (range b))
where b#((y1,x1),(y2,x2)) = bounds previous
-- some basic math functions performed here
total :: [Bool] -> Int
total = length . filter id
board :: [String] -> (Int, Int, Board)
board l = (width, height, a)
where (width, height) = (length $ head l, length l)
a = listArray ((1, 1), (height, width)) $ concatMap f l
f = map g
g 'f' = False
g _ = True
printGrid :: Int -> Board -> IO ()
printGrid width = mapM_ f . split width . elems
where f = putStrLn . map g
g False = 'f'
g _ = 't'
split :: Int -> [a] -> [[a]]
split n = takeWhile (not . null) . unfoldr (Just . splitAt n)
-- used only as a test trying to create same structure programatically
testBoard = board
["ffffffffff",
"ffffffffff",
"ffffffffff",
"ffffffffff",
"ffffffffff",
"ffffffffff",
"ffffffffff",
"ffffffffff",
"ffffffffff",
"ffffffffff"]
printProgress :: Int -> (Int, Int, Board) -> IO ()
printProgress n (width, height, g) = mapM_ f $ take n $ iterate (progress width height) g
where f g = do
putStrLn "------------------------------"
printGrid width g
main :: IO ()
main = do
printProgress times testBoard


You can make a UArray using the array function or the listArray function. The first expects a list of indices and elements while the second expects a tuple indicating the index range and a list of elements that are paired with an index automatically (lexicographic order).
Data.Array.Unboxed> listArray ((0,0), (9,9)) (replicate 100 False) :: UArray (Int,Int) Bool
array ((0,0),(9,9)) [((0,0),False),((0,1),False),((0,2),False),((0,3),False),((0,4),False),((0,5),False),((0,6),False),((0,7),False),((0,8),False),((0,9),False),((1,0),False),((1,1),False),((1,2),False),((1,3),False),((1,4),False),((1,5),False),((1,6),False),((1,7),False),((1,8),False),((1,9),False),((2,0),False),((2,1),False),((2,2),False),((2,3),False),((2,4),False),((2,5),False),((2,6),False),((2,7),False),((2,8),False),((2,9),False),((3,0),False),((3,1),False),((3,2),False),((3,3),False),((3,4),False),((3,5),False),((3,6),False),((3,7),False),((3,8),False),((3,9),False),((4,0),False),((4,1),False),((4,2),False),((4,3),False),((4,4),False),((4,5),False),((4,6),False),((4,7),False),((4,8),False),((4,9),False),((5,0),False),((5,1),False),((5,2),False),((5,3),False),((5,4),False),((5,5),False),((5,6),False),((5,7),False),((5,8),False),((5,9),False),((6,0),False),((6,1),False),((6,2),False),((6,3),False),((6,4),False),((6,5),False),((6,6),False),((6,7),False),((6,8),False),((6,9),False),((7,0),False),((7,1),False),((7,2),False),((7,3),False),((7,4),False),((7,5),False),((7,6),False),((7,7),False),((7,8),False),((7,9),False),((8,0),False),((8,1),False),((8,2),False),((8,3),False),((8,4),False),((8,5),False),((8,6),False),((8,7),False),((8,8),False),((8,9),False),((9,0),False),((9,1),False),((9,2),False),((9,3),False),((9,4),False),((9,5),False),((9,6),False),((9,7),False),((9,8),False),((9,9),False)]
Going one step further, you can parse your input [String] into a board by simply concatenating and mapping a test for == 't':
stringsToGrid :: [String] -> Grid
stringsToGrid = listArray ((0,0), (9,9)) . map (== 't') . concat

Related

Knights tour in haskell getting a loop

I'm in the process of coding the knight's tour function, and I'm as far as this where I'm getting an infinte loop in my ghci:
type Field = (Int, Int)
nextPositions:: Int -> Field -> [Field]
nextPositions n (x,y) = filter onBoard
[(x+2,y-1),(x+2,y+1),(x-2,y-1),(x-2,y+1),(x+1,y-2),(x+1,y+2),(x-1,y-2),(x-1,y+2)]
where onBoard (x,y) = x `elem` [1..n] && y `elem` [1..n]
type Path = [Field]
knightTour :: Int -> Field -> [Path]
knightTour n start = [posi:path | (posi,path) <- tour (n*n)]
where tour 1 = [(start, [])]
tour k = [(posi', posi:path) | (posi, path) <- tour (k-1), posi' <- (filter (`notElem` path) (nextPositions n posi))]
F.e. knightTour 10 (4,4) does not give an output!
Any advise?

I think one of the main problems is checking if you have visited a square. This takes too much time. You should look for a data structure that makes that more efficient.
For small boards, for example up to 8×8, you can make use of a 64-bit integer for that. A 64-bit can be seen as 64 booleans that each can represent whether the knight already has visited that place.
we thus can implement this with:
{-# LANGUAGE BangPatterns #-}
import Data.Bits(testBit, setBit)
import Data.Word(Word64)
testPosition :: Int -> Word64 -> (Int, Int) -> Bool
testPosition !n !w (!r, !c) = testBit w (n*r + c)
setPosition :: Int -> (Int, Int) -> Word64 -> Word64
setPosition !n (!r, !c) !w = setBit w (n*r + c)
nextPositions :: Int -> Word64 -> (Int, Int) -> [(Int, Int)]
nextPositions !n !w (!x, !y) = [ c
| c#(x', y') <- [(x-1,y-2), (x-1,y+2), (x+1,y-2), (x+1,y+2), (x-2,y-1), (x-2,y+1), (x+2,y-1), (x+2,y+1)]
, x' >= 0
, y' >= 0
, x' < n
, y' < n
, not (testPosition n w c)
]
knightTour :: Int -> (Int, Int) -> [[(Int, Int)]]
knightTour n p0 = go (n*n-1) (setPosition n p0 0) p0
where go 0 _ _ = [[]]
go !k !w !ps = [
(ps':rs)
| ps' <- nextPositions n w ps
, rs <- go (k-1) (setPosition n ps' w) ps'
]
main = print (knightTour 6 (1,1))
If I compile this with the -O2 flag and run this locally for a 5×5 board where the knight starts at (1,1), all the solutions are generated in 0.32 seconds. For a 6×6 board, it takes 2.91 seconds to print the first solution, but it takes forever to find all solutions that start at (1,1). For an 8×8 board, the first solution was found in 185.76 seconds:
[(0,3),(1,5),(0,7),(2,6),(1,4),(0,2),(1,0),(2,2),(3,0),(4,2),(3,4),(4,6),(5,4),(6,2),(5,0),(3,1),(2,3),(3,5),(2,7),(0,6),(2,5),(1,3),(0,1),(2,0),(3,2),(2,4),(0,5),(1,7),(3,6),(4,4),(5,6),(7,7),(6,5),(7,3),(6,1),(4,0),(5,2),(7,1),(6,3),(7,5),(6,7),(5,5),(4,7),(6,6),(7,4),(5,3),(7,2),(6,0),(4,1),(3,3),(2,1),(0,0),(1,2),(0,4),(1,6),(3,7),(4,5),(5,7),(7,6),(6,4),(4,3),(5,1),(7,0)]
It is however not a good idea to solve this with a brute force approach. If we assume an average branching factor of ~6 moves, then for a 6×6 board, we have already 1.031×1028 possible sequences we have to examine for a 6×6 board.
It is better to work with a divide and conquer approach. It is easy to split a board like 8×8 into four 4×4 boards. Then you determine places where you can hop from one board to another, and then you solve the subproblems for a 4×4 board. For small boards, you can easily store the solutions to go from any square to any other square on a 4×4 board, and then reuse these for all quadrants, so you save computational effort, by not calculating this a second time, especially since you do not need to store symmetrical queries multiple times. If you know how to go from (1,0) to (2,3) on a 4×4 board, you can easily use this to go from (3,0) to (2,3) on the same board, just by mirroring this.

Slow array access in haskell?

I'm doing this Car Game problem on Kattis: https://open.kattis.com/problems/cargame
There's a five-second time limit, but on the last instance, my code requires longer to run. I'm fairly sure I'm doing the right thing (from a big-O standpoint) so now I need to optimize it somehow.
I downloaded the test data from:
http://challenge.csc.kth.se/2013/challenge-2013.tar.bz2
From profiling, it seems like most of the running time is spent in containsSub which is nothing more than an array access together with a tail-recursive call. Furthermore, it's only called about 100M times, so why does it take 6.5 seconds to run (6.5 s on my laptop. I've found Kattis is generally about twice as slow, so probably more like 13 seconds). On the statistics page, some of the C++ solutions run in under a second. Even some python solutions just barely make it under the 5-second bar.
module Main where
import Control.Monad
import Data.Array (Array, (!), (//))
import qualified Data.Array as Array
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.Char
import Data.List
import Data.Maybe
main::IO()
main = do
[n, m] <- readIntsLn
dictWords <- replicateM n BS.getLine
let suffixChains = map (\w -> (w, buildChain w)) dictWords
replicateM_ m $ findChain suffixChains
noWordMsg :: ByteString
noWordMsg = BS.pack "No valid word"
findChain :: [(ByteString, WordChain)] -> IO ()
findChain suffixChains = do
chrs <- liftM (BS.map toLower) BS.getLine
BS.putStrLn
(
case find (containsSub chrs . snd) suffixChains of
Nothing -> noWordMsg
Just (w, _) -> w
)
readAsInt :: BS.ByteString -> Int
readAsInt = fst . fromJust . BS.readInt
readIntsLn :: IO [Int]
readIntsLn = liftM (map readAsInt . BS.words) BS.getLine
data WordChain = None | Rest (Array Char WordChain)
emptyChars :: WordChain
emptyChars = Rest . Array.listArray ('a', 'z') $ repeat None
buildChain :: ByteString -> WordChain
buildChain s =
case BS.uncons s of
Nothing -> emptyChars
Just (hd, tl) ->
let wc#(Rest m) = buildChain tl in
Rest $ m // [(hd, wc)]
containsSub :: ByteString -> WordChain -> Bool
containsSub _ None = False
containsSub s (Rest m) =
case BS.uncons s of
Nothing -> True
Just (hd, tl) -> containsSub tl (m ! hd)
EDIT: TAKE 2:
I tried building a lazy trie to avoid searching things I'd already searched. So for instance, if I've already encountered a triplet beginning with 'a', then in the future I can skip anything which doesn't contain an 'a'. If I've already searched a triplet beginning 'ab', I can skip anything which doesn't contain 'ab'. And if I've already searched the exact triplet 'abc', I can just return the same result from last time. In theory, this should contribute a significant speedup. In practice the running time is identical.
Furthermore, without the seq's, profiling takes forever and gives bogus results (I couldn't guess why).
With the seqs, profiling says the bulk of the time is spent in forLetter (which is where the array accesses have been moved to so again it looks like array access is the slow part)
{-# LANGUAGE TupleSections #-}
module Main where
import Control.Monad
import Data.Array (Array, (!), (//))
import qualified Data.Array as Array
import qualified Data.Array.Base as Base
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.Char
import Data.Functor
import Data.Maybe
main::IO()
main = do
[n, m] <- readIntsLn
dictWords <- replicateM n BS.getLine
let suffixChainsL = map (\w -> (w, buildChain w)) dictWords
let suffixChains = foldr seq suffixChainsL suffixChainsL
suffixChains `seq` doProbs m suffixChains
noWordMsg :: ByteString
noWordMsg = BS.pack "No valid word"
doProbs :: Int -> [(ByteString, WordChain)] -> IO ()
doProbs m chains = replicateM_ m doProb
where
cf = findChain chains
doProb =
do
chrs <- liftM (map toLower) getLine
BS.putStrLn . fromMaybe noWordMsg $ cf chrs
findChain :: [(ByteString, WordChain)] -> String -> Maybe ByteString
findChain [] = const Nothing
findChain suffixChains#(shd : _) = doFind
where
letterMap :: Array Char (String -> Maybe ByteString)
letterMap =
Array.listArray ('a','z')
[findChain (mapMaybe (forLetter hd) suffixChains) | hd <- [0..25]]
endRes = Just $ fst shd
doFind :: String -> Maybe ByteString
doFind [] = endRes
doFind (hd : tl) = (letterMap ! hd) tl
forLetter :: Int -> (ByteString, WordChain) -> Maybe (ByteString, WordChain)
forLetter c (s, WC wc) = (s,) <$> wc `Base.unsafeAt` c
readAsInt :: BS.ByteString -> Int
readAsInt = fst . fromJust . BS.readInt
readIntsLn :: IO [Int]
readIntsLn = liftM (map readAsInt . BS.words) BS.getLine
newtype WordChain = WC (Array Char (Maybe WordChain))
emptyChars :: WordChain
emptyChars = WC . Array.listArray ('a', 'z') $ repeat Nothing
buildChain :: ByteString -> WordChain
buildChain = BS.foldr helper emptyChars
where
helper :: Char -> WordChain -> WordChain
helper hd wc#(WC m) = m `seq` WC (m // [(hd, Just wc)])

The uncons call in containsSub creates a new ByteString. Try speeding it up by keeping track of the offset into the string with an index, e.g.:
containsSub' :: ByteString -> WordChain -> Bool
containsSub' str wc = go 0 wc
where len = BS.length str
go _ None = False
go i (Rest m) | i >= len = True
| otherwise = go (i+1) (m ! BS.index str i)

After much discussion on the #haskell and #ghc IRC channels, I found that the problem was related to this ghc bug: https://ghc.haskell.org/trac/ghc/ticket/1168
The solution was simply to change the definition of doProbs
doProbs m chains = cf `seq` replicateM_ m doProb
...
Or just to compile with -fno-state-hack
ghc's state hack optimization was causing it to unnecessarily recompute cf (and the associated letterMap) on every call.
So it has nothing to do with array accesses.

Haskell: Shuffling deck

I'm working on a lab in which we work with randomness and monads.
The parts of the lab are:
write a function randR that generates a random numbers within a given range
write a function rollTwoDice that simulates rolling two dice
write a function removeCard which randomly removes a card from a list of PlayingCards
write a function shuffleDeck which takes the removed card, puts it in front of the deck, then repeats itself until the deck has been completely shuffled.
I have done 1, 2, and 3, but I'm having trouble with 4.
Here's the given code:
RandState.hs
module RandState where
import UCState
import System.Random
-- In order to generate pseudo-random numbers, need to pass around generator
-- state in State monad
type RandState a = State StdGen a
-- runRandom runs a RandState monad, given an initial random number generator
runRandom :: RandState a -> StdGen -> a
runRandom (State f) s = res
where (res, state) = f s
-- rand is a helper function that generates a random instance of any
-- type in the Random class, using the RandState monad.
rand :: Random a => RandState a
rand = do
gen <- get
let (x, gen') = random gen
put gen'
return x
UCState.hs
{-
- Simplified implementation of the State monad. The real implementation
- is in the Control.Monad.State module: using that is recommended for real
- programs.
-}
module UCState where
data State s a = State { runState :: s -> (a, s) }
instance Monad (State s)
where
{-
- return lifts a function x up into the state monad, turning it into
- a state function that just passes through the state it receives
-}
return x = State ( \s -> (x, s) )
{-
- The >>= combinator combines two functions p and f, and
- gives back a new function (Note: p is originally wrapped in the
- State monad)
-
- p: a function that takes the initial state (from right at the start
- of the monad chain), and gives back a new state and value,
- corresponding to the result of the chain up until this >>=
- f: a function representing the rest of the chain of >>='s
-}
(State p) >>= f = State ( \initState ->
let (res, newState) = p initState
(State g) = f res
in g newState )
-- Get the state
get :: State s s
get = State ( \s -> (s, s) )
-- Update the state
put :: s -> State s ()
put s = State ( \_ -> ((), s))
Here's my code, which I just wrote inside RandState.hs since I couldn't figure out how to import it (help with importing would be nice as well, although not what I'm most concerned about at this point):
randR :: Random a => (a, a) -> RandState a
randR (lo, hi) = do
gen <- get
let (x, gen') = randomR (lo, hi) gen
put gen'
return x
testRandR1 :: IO Bool
testRandR1 = do
gen <- newStdGen
let genR = runRandom (randR (1,5)) gen :: Int
return (genR <=5 && genR >=1)
testRandR2 :: IO Bool
testRandR2 = do
gen <- newStdGen
let genR = runRandom (randR (10.0, 11.5)) gen :: Double
return (genR <= 11.5 && genR >= 10.0)
rollTwoDice :: RandState Int
rollTwoDice = do
gen <- get
let (a, gen') = randomR (1, 6) gen :: (Int, StdGen)
put gen'
let (b, gen'') = randomR (1, 6) gen' :: (Int, StdGen)
put gen''
return $ a + b
testRollTwoDice :: IO Bool
testRollTwoDice = do
gen <- newStdGen
let genR = runRandom (rollTwoDice) gen
return (genR <= 12 && genR >= 2)
-- Data types to represent playing cards
data CardValue = King | Queen | Jack | NumberCard Int
deriving (Show, Eq)
data CardSuit = Hearts | Diamonds | Spades | Clubs
deriving (Show, Eq)
data PlayingCard = PlayingCard CardSuit CardValue
deriving (Show, Eq)
{-
- fullCardDeck will be a deck of cards, 52 in total, with a King, a Queen,
- a Jack and NumberCards from 1 to 10 for each suit.
-}
-- fullCardDeck and its definition were given in the lab
fullCardDeck :: [PlayingCard]
fullCardDeck = [ PlayingCard s v | s <- allsuits, v <- allvals ] where
allvals = King : Queen : Jack : [ NumberCard i | i <- [1..10] ]
allsuits = [Hearts, Diamonds, Spades, Clubs]
removeCard :: [a] -> RandState [a]
removeCard deck = do
gen <- get
let n = runRandom (randR(1, length (deck))) gen :: Int
let (xs, ys) = splitAt (n-1) deck
return $ head ys : xs ++ tail ys
shuffleDeck deck = do
gen <- get
let f deck = head $ runRandom (removeCard deck) gen
return $ take (length(deck)) (iterate f deck)
shuffleDeck doesn't work. The error:
RandState.hs:88:31:
Occurs check: cannot construct the infinite type: a0 = [a0]
Expected type: [a0] -> [a0]
Actual type: [a0] -> a0
In the first argument of `iterate', namely `f'
In the second argument of `take', namely `(iterate f deck)'
In the second argument of `($)', namely `take 52 (iterate f deck)'
I guess the issue is that iterate takes a value, applies a function to this value, applies the function to the result, and so on, returning an infinite list of results. I'm handing iterate a function that takes a list, and returns a card, so the result cannot be passed to the next iteration. What would be a better way to approach this problem (4)? I'm also worried that my removeCard function is a little janky since it just puts the "removed" card in front, which I did to make shuffleDeck easier to write. If necessary, what would be a better way to approach this problem (3)?
Thanks,
Jeff

You should stop trying to runRandom inside your functions. You should only use runRandom once you actually want a result (for example - to print the result, since you can't do this inside the monad). Trying to 'escape' from the monad is a futile task and you will only produce confusing and often non-functioning code. The final output of all of your functions will be inside the monad, so you don't need to escape anyways.
Note that
gen <- get
let n = runRandom (randR(1, length (deck))) gen :: Int
is exactly equivalent to
n <- randR (1, length deck)
The <- syntax executes a computation in monad on the right and 'puts' it into the variable name on the left.
Shuffling:
shuffleR [] = return []
shuffleR xs = do
(y:ys) <- removeR xs -- 1
zs <- shuffleR ys -- 2
return (y:zs) -- 3
The function is straightforward recursion:
1) extract a random element, 2) shuffle what is left, 3) combine the results.
edit: extra info requested:
randSum :: (Num b, Random b) => State StdGen b
randSum = do
a <- randR (1,6)
b <- randR (1,6)
return $ a + b
compiles just fine. Judging from your description of the error, you are trying to call this function inside the IO monad. You cannot mix monads (or at least not so simply). If you want to 'execute' something of type RandState inside of IO you will indeed have to use runRandom here.
n <- randR (1, length deck) makes n an Int because length deck has type Int and randR :: Random a => (a, a) -> RandState a, so from the context we can infer a ~ Int and the type unifies to (Int, Int) -> RandState Int.
Just to recap
Wrong:
try = do
a <- randomIO :: IO Int
b <- randR (0,10) :: RandState Int
return $ a + b -- monads don't match!
Right:
try = do
a <- randomIO :: IO Int
let b = runRandom (randR (0,10)) (mkStdGen a) :: Int -- 'execute' the randstate monad
return $ a + b

How to translate this list-based code into using mutable arrays?

EDIT3: I'm writing a code to process very long input list of Ints with only few hundred non-duplicates. I use two auxiliary lists to maintain cumulative partial sums to calculate some accumulator value, the how's and why's are non-important. I want to ditch all lists here and turn it into nice destructive loop, and I don't know how. I don't need the whole code, just a skeleton code would be great, were read/write is done to two auxiliary arrays and some end result is returned. What I have right now would run 0.5 hour for the input. I've coded this now in C++, and it runs in 90 seconds for the same input.
I can't understand how to do this, at all. This is the list-based code that I have right now:(but the Map-based code below is clearer)
ins :: (Num b, Ord a) => a -> b -> [(a, b)] -> ([(a, b)], b)
ins n x [] = ( [(n,x)], 0)
ins n x l#((v, s):t) =
case compare n v of
LT -> ( (n,s+x) : l , s )
EQ -> ( (n,s+x) : t , if null t then 0 else snd (head t))
GT -> let (u,z) = ins n x t
in ((v,s+x):u,z)
This is used in a loop, to process a list of numbers of known length, (changed it to foldl now)
scanl g (0,([],[])) ns -- ns :: [Int]
g ::
(Num t, Ord t, Ord a) =>
(t, ([(a, t)], [(a, t)])) -> a -> (t, ([(a, t)], [(a, t)]))
g (c,( a, b)) n =
let
(a2,x) = ins n 1 a
(b2,y) = if x>0 then ins n x b else (b,0)
c2 = c + y
in
(c2,( a2, b2))
This works, but I need to speed it up. In C, I would keep the lists (a,b) as arrays; use binary search to find the element with the key just above or equal to n (instead of the sequential search used here); and use in-place update to change all the preceding entries.
I'm only really interested in final value. How is this done in Haskell, with mutable arrays?
I tried something, but I really don't know what I'm doing here, and am getting strange and very long error messages (like "can not deduce ... from context ..."):
goarr top = runSTArray $ do
let sz = 10000
a <- newArray (1,sz) (0,0) :: ST s (STArray s Int (Integer,Integer))
b <- newArray (1,sz) (0,0) :: ST s (STArray s Int (Integer,Integer))
let p1 = somefunc 2 -- somefunc :: Integer -> [(Integer, Int)]
go1 p1 2 0 top a b
go1 p1 i c top a b =
if i >= top
then
do
return c
else
go2 p1 i c top a b
go2 p1 i c top a b =
do
let p2 = somefunc (i+1) -- p2 :: [(Integer, Int)]
let n = combine p1 p2 -- n :: Int
-- update arrays and calc new c
-- like the "g" function is doing:
-- (a2,x) = ins n 1 a
-- (b2,y) = if x>0 then ins n x b else (b,0)
-- c2 = c + y
go1 p2 (i+1) c2 top a b -- a2 b2??
This doesn't work at all. I don't even know how to encode loops in do notation. Please help.
UPD: the Map based code that runs 3 times slower:
ins3 :: (Ord k, Num a) => k -> a -> Map.Map k a -> (Map.Map k a, a)
ins3 n x a | Map.null a = (Map.insert n x a , 0)
ins3 n x a = let (p,q,r) = Map.splitLookup n a in
case q of
Nothing -> (Map.union (Map.map (+x) p)
(Map.insert n (x+leftmost r) r) , leftmost r)
Just s -> (Map.union (Map.map (+x) p)
(Map.insert n (x+s) r) , leftmost r)
leftmost r | Map.null r = 0
| otherwise = snd . head $ Map.toList r
UPD2: The error message is " Could not deduce (Num (STArray s1 i e)) from the context () arising from the literal `0' at filename.hs:417:11"
that's where it says return c in go1 function. Perhaps c is expected to be an array, but I want to return the accumulator value that is built while using the two auxiliary arrays.
EDIT3: I've replaced scanl and (!!) with foldl and take as per Chris's advice, and now it runs in constant space with sane empirical complexity and is actually projected to finish in under 0.5 hour - a.o.t. ... 3 days ! I knew about it of course but was so sure GHC optimizes the stuff away for me, surely it wouldn't make that much of a difference, I thought! And so felt only mutable arrays could help... Bummer.
Still, C++ does same in 90 sec, and I would very much appreciate help in learning how to code this with mutable arrays, in Haskell.

Are the input values ever EQ? If they are not EQ then the way scanl g (0,([],[])) ns is used means that the first [(,)] array, call it a always has map snd a == reverse [1..length a] at each stage of g. For example, in a length 10 list the value of snd (a !! 4) is going to be 10-4. Keeping these reversed index values by mutating the second value of each preceding entry in a is quite wasteful. If you need speed then this is one place to make a better algorithm.
None of this applies to the second [(,)] whose purpose is still mysterious to me. It records all insertions that were not done at the end of a, so perhaps it allows one to reconstruct the initial sequence of values.
You said "I'm only really interested in final value." Do you mean you only care about the last value in list output by the scanl .. line? If so then you need a foldl instead of scanl.
Edit: I am adding a non-mutable solution using a custom Finger Tree. It passes my ad hoc testing (at bottom of code):
{-# LANGUAGE MultiParamTypeClasses #-}
import Data.Monoid
import Data.FingerTree
data Entry a v = E !a !v deriving Show
data ME a v = NoF | F !(Entry a v) deriving Show
instance Num v => Monoid (ME a v) where
mempty = NoF
NoF `mappend` k = k
k `mappend` NoF = k
(F (E _a1 v1)) `mappend` (F (E a2 v2)) = F (E a2 (v1 + v2))
instance Num v => Measured (ME a v) (Entry a v) where
measure = F
type M a v = FingerTree (ME a v) (Entry a v)
getV NoF = 0
getV (F (E _a v)) = v
expand :: Num v => M a v -> [(a, v)]
expand m = case viewl m of
EmptyL -> []
(E a _v) :< m' -> (a, getV (measure m)) : expand m'
ins :: (Ord a, Num v) => a -> v -> M a v -> (M a v, v)
ins n x m =
let comp (F (E a _)) = n <= a
comp NoF = False
(lo, hi) = split comp m
in case viewl hi of
EmptyL -> (lo |> E n x, 0)
(E v s) :< higher | n < v ->
(lo >< (E n x <| hi), getV (measure hi))
| otherwise ->
(lo >< (E n (s+x) <| higher), getV (measure higher))
g :: (Num t, Ord t, Ord a) =>
(t, (M a t, M a t)) -> a -> (t, (M a t, M a t))
g (c, (a, b)) n =
let (a2, x) = ins n 1 a
(b2, y) = if x>0 then ins n x b else (b, 0)
in (c+y, (a2, b2))
go :: (Ord a, Num v, Ord v) => [a] -> (v, ([(a, v)], [(a, v)]))
go ns = let (t, (a, b)) = foldl g (0, (mempty, mempty)) ns
in (t, (expand a, expand b))
up = [1..6]
down = [5,4..1]
see'tests = map go [ up, down, up ++ down, down ++ up ]
main = putStrLn . unlines . map show $ see'test

Slightly unorthodox, I am adding a second answer using a mutable technique. Since user1308992 mentioned Fenwick trees, I have used them to implement the algorithm. Two STUArray are allocated and mutated during the run. The basic Fenwick tree keeps totals for all smaller indices and the algorithm here needs totals for all larger indices. This change is handled by the (sz-x) subtraction.
import Control.Monad.ST(runST,ST)
import Data.Array.ST(STUArray,newArray)
import Data.Array.Base(unsafeRead, unsafeWrite)
import Data.Bits((.&.))
import Debug.Trace(trace)
import Data.List(group,sort)
{-# INLINE lsb #-}
lsb :: Int -> Int
lsb i = (negate i) .&. i
go :: [Int] -> Int
go xs = compute (maximum xs) xs
-- Require "top == maximum xs" and "all (>=0) xs"
compute :: Int -> [Int] -> Int
compute top xs = runST mutating where
-- Have (sz - (top+1)) > 0 to keep algorithm simple
sz = top + 2
-- Reversed Fenwick tree (no bounds checking)
insert :: STUArray s Int Int -> Int -> Int -> ST s ()
insert arr x v = loop (sz-x) where
loop i | i > sz = return ()
| i <= 0 = error "wtf"
| otherwise = do
oldVal <- unsafeRead arr i
unsafeWrite arr i (oldVal + v)
loop (i + lsb i)
getSum :: STUArray s Int Int -> Int -> ST s Int
getSum arr x = loop (sz - x) 0 where
loop i acc | i <= 0 = return acc
| otherwise = do
val <- unsafeRead arr i
loop (i - lsb i) $! acc + val
ins n x arr = do
insert arr n x
getSum arr (succ n)
mutating :: ST s Int
mutating = do
-- Start index from 0 to make unsafeRead, unsafeWrite easy
a <- newArray (0,sz) 0 :: ST s (STUArray s Int Int)
b <- newArray (0,sz) 0 :: ST s (STUArray s Int Int)
let loop [] c = return c
loop (n:ns) c = do
x <- ins n 1 a
y <- if x > 0
then
ins n x b
else
return 0
loop ns $! c + y
-- Without debugging use the next line
-- loop xs 0
-- With debugging use the next five lines
c <- loop xs 0
a' <- see a
b' <- see b
trace (show (c,(a',b'))) $ do
return c
-- see is only used in debugging
see arr = do
let zs = map head . group . sort $ xs
vs <- sequence [ getSum arr z | z <- zs ]
let ans = filter (\(a,v) -> v>0) (zip zs vs)
return ans
up = [1..6]
down = [5,4..1]
see'tests = map go [ up, down, up ++ down, down ++ up ]
main = putStrLn . unlines . map show $ see'tests

Is there a function in haskell working like a mixture of accumArray and foldr?

let me call the function accumrArray.
accumrArray ::
(e' -> e -> e) An accumulating function
-> e A default element
-> (i, i) The bounds of the array
-> [(i, e')] List of associations
-> a i e The array
accumrArray (:) [] (1,2) [(1,1),(2,2),(2,3)] === array [(1,[1]), (2,[2,3])]
head $ (accumrArray (:) [] (1,1) [(1,x)|x<-[4..]]) ! 1 === 4

How strange... I wrote this function a few days ago for someone else. The function first appeared in LML (I believe), but never made it into the Haskell array library.
Here you go:
{-# LANGUAGE ScopedTypeVariables #-}
import Data.Array
import System.IO.Unsafe
import Data.IORef
import Data.Array.MArray
import Data.Array.Base
import Control.Monad
import Data.Array.IO
accumArrayR :: forall a e i. Ix i => (a -> e -> e) -> e -> (i,i) -> [(i,a)] -> Array i e
accumArrayR f e bounds#(l,u) assocs = unsafePerformIO $ do
ref <- newIORef assocs
arr <- newArray_ bounds
let _ = arr :: IOArray i e
let n = safeRangeSize (l,u)
let elem x = unsafePerformIO $ do
ass <- readIORef ref
let loop [] = writeIORef ref [] >> return e
loop ((y,a):rest) = do
let ix = safeIndex bounds n y
let r = f a (elem x)
unsafeWrite arr ix r
if (ix == x)
then writeIORef ref rest >> return r
else loop rest
loop ass
forM_ [0..n] $ \ix -> unsafeWrite arr ix (elem ix)
unsafeFreeze arr
A challenge for the reader: use accumArrayR to implement linear-time depth-first-search of a graph.
Edit I should mention that the function isn't thread-safe as written. Turning the IORef into an MVar would fix it, but there might be better ways.

Not the most efficient, but...
accumrArray f x b l = accumArray (flip f) x b (reverse l)

I would argue that
accumrArray f x b l = accumArray (flip f) x b (reverse l)
is indeed the best solution (credits to sclv's answer).
Its supposed "inefficiency" comes from fact that foldr applies the function f from right to left.
However, since accumArray is strict, l can never be infinite, otherwise the program would be incorrect. It would never terminate.
Therefore, foldl (flip f) is just as good as a foldr.

Resources