How would you implement a Grid in a functional language? - data-structures

I am interrested in different ways of implementing a constant grid in a functional language. A perfect solution should provide traversal in pesimistic constant time per step and not use imperative constructs (laziness is ok). Solutions not quite fulfilling those requirements are still welcome.
My proposal is based on four-way linked nodes like so
A fundamental operation would be to construct a grid of given size. It seems that this operation will determine the type, i.e. which directions will be lazy (obviously this data structure cannot be achieved without laziness). So I propose (in OCaml)
type 'a grid =
| GNil
| GNode of 'a * 'a grid Lazy.t * 'a grid Lazy.t * 'a grid * 'a grid
With references ordered: left, up, right, down. Left and up are suspended. I then build the grid diagonal-wise
Here is a make_grid function that constructs a grid of given size with the coordinate tuples as node values. Please note that gl, gu, gr, gd functions allow walking on a grid in all directions and if given GNil, will return GNil.
let make_grid w h =
let lgnil = Lazy.from_val GNil in
let rec build_ur x y ls dls = match ls with
| l :: ((u :: _) as ls') ->
if x = w && y = h then
GNode ((x, y), l, u, GNil, GNil)
else if x < w && 1 < y then
let rec n = lazy (
let ur = build_ur (x + 1) (y - 1) ls' (n :: dls) in
let r = gd ur in
let d = gl (gd r)
in GNode ((x, y), l, u, r, d)
)
in force n
else if x = w then
let rec n = lazy (
let d = build_dl x (y + 1) (n :: dls) [lgnil]
in GNode ((x, y), l, u, GNil, d)
)
in force n
else
let rec n = lazy (
let r = build_dl (x + 1) y (lgnil :: n :: dls) [lgnil] in
let d = gl (gd r)
in GNode ((x, y), l, u, r, d)
)
in force n
| _ -> failwith "make_grid: Internal error"
and build_dl x y us urs = match us with
| u :: ((l :: _) as us') ->
if x = w && y = h then
GNode ((x, y), l, u, GNil, GNil)
else if 1 < x && y < h then
let rec n = lazy (
let dl = build_dl (x - 1) (y + 1) us' (n :: urs) in
let d = gr dl in
let r = gu (gr d)
in GNode ((x, y), l, u, r, d)
)
in force n
else if y = h then
let rec n = lazy (
let r = build_ur (x + 1) y (n :: urs) [lgnil]
in GNode ((x, y), l, u, r, GNil)
)
in force n
else (* x = 1 *)
let rec n = lazy (
let d = build_ur x (y + 1) (lgnil :: n :: urs) [lgnil] in
let r = gu (gr d)
in GNode ((x, y), l, u, r, d)
)
in force n
| _ -> failwith "make_grid: Internal error"
in build_ur 1 1 [lgnil; lgnil] [lgnil]
It looks pretty complicated as it has to separately handle case when we're going up and when we're going down – build_ur and build_dl auxiliary functions respectively. The build_ur function is of type
build_ur :
int -> int ->
(int * int) grid Lazy.t list ->
(int * int) grid Lazy.t list -> (int * int) grid
It construct a node, given the current position x and y, the list of suspended elements of previous diagonal ls, the list of suspended previous elements of current diagonal urs. The name ls comes from the fact that the first element on ls is the left neighbour of current node. The urs list is needed for construction of the next diagonal.
The build_urs function proceeds with building the next node on the up-right diagonal, passing the current node in a suspension. The left and up neighbour are taken from ls and the right and down neighbours can be accessed through the next node on the diagonal.
Note that I put a bunch of GNils on the urs and ls lists. This is made to always ensure that build_ur and build_dl can consume at least two elements from those lists.
The build_dl function works analogously.
This implementation seems overly complicated for such a simple data structure. In fact I'm suprised it works cause I was driven by faith when writing it and am unable to comprehend completely why it works. Therefore I would like to know a simpler solution.
I was considering building the grid row-wise. This approach has less border cases but I can't eliminate the need of building subsequent rows in different directions. It's because when I go to the end with a row and would like to start building another from the beginning, I would have to somehow know the down node of the first node in current row, which I seemingly can't know until I return from the current function call. And if I can't eliminate bi-directionality, I would need two inner node constructiors: one with suspended left and top and the other with suspended right and top.
Also, here is a gist of this implementation along with omitted functions: https://gist.github.com/mkacz91/0e63aaa2a67f8e67e56f

The datastructure you are looking for if you want a functional solution is a zipper. I've written the rest of the code in Haskell because I find it more to my taste but it's easily ported to OCaml. Here's a gist without the interleaved comments.
{-# LANGUAGE RecordWildCards #-}
module Grid where
import Data.Maybe
We can start by understanding the datastructure for just lists: you can think of a zipper as a pointer deep inside a list. You have wathever is on the left of the element you point at, then the element you point at and finally whatever is on the right.
type ListZipper a = ([a], a, [a])
Given a list and an integer n, you can focus on the element which is at position n. Of course, if n is greater than the lenght of the list, then you just fail. One important thing to notice is that the left part of the list is stored backwards: moving the focus to the left will therefore be possible in constant time. As will moving to the right.
focusListAt :: Int -> [a] -> Maybe (ListZipper a)
focusListAt = go []
where
go _ _ [] = Nothing
go acc 0 (hd : tl) = Just (acc, hd, tl)
go acc n (hd : tl) = go (hd : acc) (n - 1) tl
Let's move on to Grids now. A Grid will just be a list of rows (lists).
newtype Grid a = Grid { unGrid :: [[a]] }
A zipper for a Grid is now given by a grid representing everything above the current focus, another representing everything below it, and a list zipper (advanced level: notice that this looks a bit like nested list zippers & could be reformulated in more generic terms).
data GridZipper a =
GridZipper { above :: Grid a
, below :: Grid a
, left :: [a]
, right :: [a]
, focus :: a }
By focusing on the right row first, and then the right element we may focus a Grid at some coordinates x and y.
focusGridAt :: Int -> Int -> Grid a -> Maybe (GridZipper a)
focusGridAt x y g = do
(before, line , after) <- focusListAt x $ unGrid g
(left , focus, right) <- focusListAt y line
let above = Grid before
let below = Grid after
return GridZipper{..}
Once we have a zipper, we can move around easily. The code for going either left or right is not suprisingly rather similar:
goLeft :: GridZipper a -> Maybe (GridZipper a)
goLeft g#GridZipper{..} =
case left of
[] -> Nothing
(hd:tl) -> Just $ g { focus = hd, left = tl, right = focus : right }
goRight :: GridZipper a -> Maybe (GridZipper a)
goRight g#GridZipper{..} =
case right of
[] -> Nothing
(hd:tl) -> Just $ g { focus = hd, left = focus : left, right = tl }
When going up or down, we have to be a bit careful because we need to focus on the spot right above (or below) the one we left in the new row. We also have to reassemble the previous row we were focused onto into a good old list (by appending the reversed left to focus : right).
goUp :: GridZipper a -> Maybe (GridZipper a)
goUp GridZipper{..} = do
let (line : above') = unGrid above
let below' = (reverse left ++ focus : right) : unGrid below
(left', focus', right') <- focusListAt (length left) line
return $ GridZipper { above = Grid above'
, below = Grid below'
, left = left'
, right = right'
, focus = focus' }
goDown :: GridZipper a -> Maybe (GridZipper a)
goDown GridZipper{..} = do
let (line : below') = unGrid below
let above' = (reverse left ++ focus : right) : unGrid above
(left', focus', right') <- focusListAt (length left) line
return $ GridZipper { above = Grid above'
, below = Grid below'
, left = left'
, right = right'
, focus = focus' }
Finally, I've also added a couple of helper functions to generate grids (with every cell containing a pair of its coordinates) and instances to be able to display grids and zippers in a terminal.
mkGrid :: Int -> Int -> Grid (Int, Int)
mkGrid m n = Grid $ [ zip (repeat i) [0..n-1] | i <- [0..m-1] ]
instance Show a => Show (Grid a) where
show = concatMap (('\n' :) . concatMap show) . unGrid
instance Show a => Show (GridZipper a) where
show GridZipper{..} =
concat [ show above, "\n"
, concatMap show (reverse left)
, "\x1B[33m[\x1B[0m", show focus, "\x1B[33m]\x1B[0m"
, concatMap show right
, show below ]
main creates a small grid of size 5*10, focuses on the element at coordinates (2,3) and moves around a bit.
main :: IO ()
main = do
let grid1 = mkGrid 5 10
print grid1
let grid2 = fromJust $ focusGridAt 2 3 grid1
print grid2
print $ goLeft =<< goLeft =<< goDown =<< goDown grid2

A simple solution for implementing infinite grids consists in using a hash table indexed by the coordinate pairs.
The following is a sample implementation that doesn't check for integer overflow:
type 'a cell = {
x: int; (* position on the horizontal axis *)
y: int; (* position on the vertical axis *)
value: 'a;
}
type 'a grid = {
cells: (int * int, 'a cell) Hashtbl.t;
init_cell: int -> int -> 'a;
}
let create_grid init_cell = {
cells = Hashtbl.create 10;
init_cell;
}
let hashtbl_get tbl k =
try Some (Hashtbl.find tbl k)
with Not_found -> None
(* Check if we have a cell at the given relative position *)
let peek grid cell x_offset y_offset =
hashtbl_get grid.cells (cell.x + x_offset, cell.y + y_offset)
(* Get the cell at the given relative position *)
let get grid cell x_offset y_offset =
let x = cell.x + x_offset in
let y = cell.y + y_offset in
let k = (x, y) in
match hashtbl_get grid.cells k with
| Some c -> c
| None ->
let new_cell = {
x; y;
value = grid.init_cell x y
} in
Hashtbl.add grid.cells k new_cell;
new_cell
let left grid cell = get grid cell (-1) 0
let right grid cell = get grid cell 1 0
let down grid cell = get grid cell 0 (-1)
(* etc. *)

Related

How can I optimise my Haskell so I don't run out of memory

For an online algorithms course I am attempting to write a program which calculates the travelling salesman distance of cities using an approxomation algorithm:
Start the tour at the first city.
Repeatedly visit the closest city that the tour hasn't visited yet. In case of a tie, go to the closest city with the lowest
index. For example, if both the third and fifth cities have the
same distance from the first city (and are closer than any other
city), then the tour should begin by going from the first city to
the third city.
Once every city has been visited exactly once, return to the first city to complete the tour.
I am trying to write a solution in Haskell, and I have it working on small data sets, but it runs out of memory on a large input (the course has an input of ~33000 cities)
-- Fold data: cities map, distances map, visited map, list of visited cities and each distance,
-- and current city
data TS = TS (M.Map Int City) (M.Map (Int,Int) Double) (M.Map Int Bool) ([(Int,Double)]) (Int)
run :: String -> String
run input = let cm = parseInput input -- cityMap contains cities (index,xPos,yPos)
n = length $ M.keys cm
dm = buildDistMap cm -- distanceMap :: M.Map (Int,Int) Double
-- which is the distance between cities a and b
ts = TS cm dm (M.fromList [(1,True)]) [(1,0.0)] 1
(TS _ _ _ beforeLast _) = foldl' (\ts _ -> exec ts n) ts [2..n]
completed = end beforeLast dm
in show $ floor $ sum $ map (\(_,d) -> d) $ completed
exec :: TS -> Int -> TS
exec (TS cm dm visited ordered curr) n =
let candidateIndexes = [(i)|i<-[1..n],M.member i visited == False]
candidates = map (\i -> let (Just x) = M.lookup (curr,i) dm in (x,i)) candidateIndexes
(dist,best) = head $ sortBy bestCity candidates
visited' = M.insert best True visited
ordered' = (best,dist) : ordered
in TS cm dm visited' ordered' best
end :: [(Int,Double)] -> M.Map (Int,Int) Double -> [(Int,Double)]
end ordering dm = let (latest,_) = head ordering
(Just dist) = M.lookup (latest,1) dm
in (1,dist) : ordering
bestCity :: (Double,Int) -> (Double,Int) -> Ordering
bestCity (d1,i1) (d2,i2) =
if compare d1 d2 == EQ
then compare i1 i2
else compare d1 d2
At first I wrote the function exec as a recursive function instead of calling it via the foldl'. I thought changing it to use foldl' would solve my issue as foldl' is strict. However it appears to have made no difference in memory usage. I have tried compiling my program using no optimisations and -O2 optimisations.
I know that somehow it must be keeping multiple loops in memory as I can sort 34000 numbers without issue using
> sort $ [34000,33999..1]
What exactly am I doing wrong here?
Just in case it is any use here is the parseInput and buildDistMap functions, but they are not the source of my issue
data City = City Int Double Double deriving (Show, Eq)
-- Init
parseInput :: String -> M.Map Int City
parseInput input =
M.fromList
$ zip [1..]
$ map ((\(i:x:y:_) -> City (read i) (read x) (read y)) . words)
$ tail
$ lines input
buildDistMap :: M.Map Int City -> M.Map (Int,Int) Double
buildDistMap cm =
let n = length $ M.keys cm
bm = M.fromList $ zip [(i,i)|i<-[1..n]] (repeat 0) :: M.Map (Int,Int) Double
perms = [(x,y)|x<-[1..n],y<-[1..n],x/=y]
in foldl' (\dm (x,y) -> M.insert (x,y) (getDist cm dm (x,y)) dm) bm perms
getDist :: M.Map Int City -> M.Map (Int,Int) Double -> (Int,Int) -> Double
getDist cm dm (x,y) =
case M.lookup (y,x) dm
of (Just v) -> v
Nothing -> let (Just (City _ x1 y1)) = M.lookup x cm
(Just (City _ x2 y2)) = M.lookup y cm
in eDist (x1,y1) (x2,y2)
eDist :: (Double,Double) -> (Double,Double) -> Double
eDist (x1,y1) (x2,y2) = sqrt $ p2 (x2 - x1) + p2 (y2 - y1)
where p2 x = x ^ 2
And some test input
tc1 = "6\n\
\1 2 1\n\
\2 4 0\n\
\3 2 0\n\
\4 0 0\n\
\5 4 3\n\
\6 0 3"
data TS = TS (M.Map Int City) (M.Map (Int,Int) Double) (M.Map Int Bool) ([(Int,Double)]) (Int)
(TS _ _ _ beforeLast _) = foldl' (\ts _ -> exec ts n) ts [2..n]
exec :: TS -> Int -> TS
exec (TS cm dm visited ordered curr) n =
let ...
in TS cm dm visited' ordered' best
That foldl' is doing a lot less than you hope. It causes the TS constructor to be evaluated at every step, but nothing in that evaluation process requires visited', ordered', or best to be evaluated. (cm and dm aren't modified in the loop, so they can't stack up unevaluated thunks.)
The best way to solve this is to make the evaluation of the TS constructor returned by exec depend on evaluating visited', ordered', and best sufficiently.
M.Map is always spine-strict, so evaluating a map at all means the whole structure is evaluated. Whether the values are as well depends on how you imported it, but that turns out to not be relevant here. The value you're inserting is a nullary constructor, so it's already fully evaluated. So evaluating visited' to WHNF is sufficient.
Int is not a nested type, so evaluating best to WHNF is sufficient.
[(Int, Double)] (the outer parens are redundant, the list brackets do grouping of their contents) is a bit trickier. Lists aren't spine strict, nor are pairs strict. But looking at the construction pattern, this is a prepend-only structure. As such, you don't need to worry about the tail. If the list was evaluated coming in, the output will be evaluated as long as the new head is. Unfortunately, that means you've got to be a bit careful with the pair. Half of it is the same best value as constructed above, so that's not too bad. If it's evaluated, it's evaluated! (Though this does suggest you don't need to be passing it at every iteration, you could just use the front of ordered.) The other half of the pair is a Double, which is also non-nested, so WHNF is sufficient for it.
In this particular case, due to the fact that different approaches are necessary, I'd probably just approach this with seq.
let ... all the same stuff ...
in visited' `seq` dist `seq` best `seq` TS ... all the same stuff ...
Note that I'm being careful to force the minimal number of values to remove unnecessary nesting of thunks. The (,) and (:) constructors don't need to be evaluated, only their arguments - the place where nested thunks might build up. (What's the difference in memory consumption between <thunk <expression> <expression>> and <constructor <expression> <expression>>?)
Thanks to Carl for his extremely detailed answer. Also to Daniel for pointing out that caching the huge amounts of distances could actually be causing my memory issues. I was assuming because my code had got past that function that I had enough memory for that - forgetting Haskell is lazy and was only building that map in the exec function as I was actually using it.
I solved this problem now in a cleaner way. I am using a Data.Set of all the city indexes I still need to visit, and then because the cities were given in order of X values I know that the nearest cities on the plane will also be the nearest cities by index. Knowing this I set a value to take a slice from the set either side of the index at each iteration and use this slice to check for distances to my current city, and this allows me to calculate the distance to the next city at each iteration without caching that huge amount of data.
-- How many cities in each direction (index) to consider
-- smaller is faster but less accurate
searchWidth = 1000 :: Int
data TS = TS (M.Map Int City) (S.Set Int) [(Double,Int)] Int
run :: String -> String
run input =
let cm = parseInput input
n = length $ M.keys cm
toVisit = S.fromList [1..n]
ts = TS cm toVisit [(0.0,1)] 1
(TS _ _ beforeLast _) = foldl' (\ts i -> trace (concat [show i,"/",show n]) exec ts) ts [2..n]
afterLast = end cm beforeLast
in show $ floor $ sum $ map (\(d,_) -> d) afterLast
exec :: TS -> TS
exec (TS cm toVisit visited curr) =
let (Just (City _ cx cy)) = M.lookup curr cm
index = S.findIndex curr toVisit
toVisit' = S.deleteAt index toVisit
lb = let x = index - searchWidth in if x < 0 then 0 else x
ub = let x = index + searchWidth - lb in if x >= length toVisit' then (length toVisit') else x
candidateIndexes = S.take ub $ S.drop lb toVisit'
candidates = S.map (\i -> let (Just (City _ x y)) = M.lookup i cm in (eDist (x,y) (cx,cy),i)) candidateIndexes
(dist,next) = S.findMin candidates
visited' = (dist,next) : visited
in toVisit' `seq` dist `seq` next `seq` TS cm toVisit' visited' next
end :: M.Map Int City -> [(Double,Int)] -> [(Double,Int)]
end cm visited =
let (_,currI) = head visited
(Just (City _ cx cy)) = M.lookup currI cm
(Just (City _ lx ly)) = M.lookup 1 cm
dist = eDist (cx,cy) (lx,ly)
in (dist,1) : visited
Using a Data.Set also comes with the added bonus that it automatically sorts the values inside, making getting the next travel location trivial.
I realise this isn't the best Haskell code in the world and that I am doing some naughty things like matching Just straight out of map lookups rather than working with the Maybe values. Additionally it has been pointed out to me that I should be using a record rather than a data type to construct my TS

Haskell groupBy depending on accumulator value

I have a list of pairs of views which represents list of content labels and their widths which I want to group in lines (if the next content label doesn't fit in line then put it into another line). So we have: viewList = [(View1, 45), (View2, 223.5), (View3, 14) (View4, 42)].
I want to write a function groupViews :: [a] -> [[a]] to group this list into a list of sublists where each sublist will contain only views with sum of widths less than the maximum specified width (let's say 250).
So for a sorted viewList this function will return : [[(View3, 14), (View4, 42), (View1, 45)],[(View2, 223.5)]]
It looks similar to groupBy. However, groupBy doesn't maintain an accumulator. I tried to use scanl + takeWhile(<250) combination but in this case I was able to receive only first valid sublist. Maybe use iterate + scanl + takeWhile somehow? But this looks very cumbersome and not functional at all. Any help will be much appreciated.
I would start with a recursive definition like this:
groupViews :: Double -> (a -> Double) -> [a] -> [[a]]
groupViews maxWidth width = go (0, [[]])
where
go (current, acc : accs) (view : views)
| current + width view <= maxWidth
= go (current + width view, (view : acc) : accs) views
| otherwise = go (width view, [view] : acc : accs) views
go (_, accs) []
= reverse $ map reverse accs
Invoked like groupViews 250 snd (sortOn snd viewList). The first thing I notice is that it can be represented as a left fold:
groupViews' maxWidth width
= reverse . map reverse . snd . foldl' go (0, [[]])
where
go (current, acc : accs) view
| current + width view <= maxWidth
= (current + width view, (view : acc) : accs)
| otherwise
= (width view, [view] : acc : accs)
I think this is fine, though you could factor it further if you like, into one scan to accumulate the widths modulo the max width, and another pass to group the elements into ascending runs. For example, here’s a version that works on integer widths:
groupViews'' maxWidth width views
= map fst
$ groupBy ((<) `on` snd)
$ zip views
$ drop 1
$ scanl (\ current view -> (current + width view) `mod` maxWidth) 0 views
And of course you can include the sort in these definitions instead of passing the sorted list from outside.
I don't know a clever way to do this just by combining functions from the standard library, but I do think you can do better than just implementing it from scratch.
This problem fits into a class of problems that I've seen before: "batch up items from this list somehow, and combine its items into batches according to some combination rule and some rule for deciding when a batch is too big". Years ago, when I was writing Clojure, I built a function that abstracted out this idea of batched combinations, just asking you to specify the rules for batching, and was able to use it in a surprising number of places.
Here's how I think it might be reimagined in Haskell:
glue :: Monoid a => (a -> Bool) -> [a] -> [a]
glue tooBig = go mempty
where go current [] = [current]
go current (x:xs) | tooBig x' = current : go x xs
| otherwise = go x' xs
where x' = current `mappend` x
If you had such a glue function already, you could build a simple data type with the appropriate Monoid instance (a list of objects and their cumulative sum), and then let glue do the heavy lifting:
import Data.Monoid (Sum(..))
data ViewGroup contents size = ViewGroup {totalSize :: size,
elements :: [(contents, size)]}
instance Monoid b => Monoid (ViewGroup a b) where
mempty = ViewGroup mempty []
mappend (ViewGroup lSize lElts) (ViewGroup rSize rElts) =
ViewGroup (lSize `mappend` rSize)
(lElts ++ rElts)
viewGroups = let views = [("a", 14), ("b", 42), ("c", 45), ("d", 223.5)]
in glue ((> 250) . totalSize) [ViewGroup (Sum width) [(x, Sum width)]
| (x, width) <- views]
main = print (viewGroups :: [ViewGroup String (Sum Double)])
[ViewGroup {totalSize = Sum {getSum = 101.0},
elements = [("a",Sum {getSum = 14.0}),
("b",Sum {getSum = 42.0}),
("c",Sum {getSum = 45.0})]},
ViewGroup {totalSize = Sum {getSum = 223.5},
elements = [("d",Sum {getSum = 223.5})]}]
On the one hand this looks like quite a bit of work for a simple function, but on the other it's rather nice to have a type that describes the cumulative summing you're doing, and Monoid instances are nice to have anyway...and after defining the type and the Monoid instance there's almost no work left to do in the calling of glue itself.
Well, I don't know, maybe it's still too much work, especially if you don't believe you can reuse that type. But I do think it's useful to recognize that this is a specific case of a more general problem, and try to solve the more general problem as well.
Given that groupBy and span themselves are defined by manual recursive functions, our modified functions will use the same mechanism.
Let us first define a general function groupAcc which takes an initial value for the accumulator, and then a function which takes an element in the list, the current accumulator state and potentially produces a new accumulated value (Nothing means the element is not accepted):
{-# LANGUAGE LambdaCase #-}
import Data.List (sortOn)
import Control.Arrow (first, second)
spanAcc :: z -> (a -> z -> Maybe z) -> [a] -> ((z, [a]), [a])
spanAcc z0 p = \case
xs#[] -> ((z0, xs), xs)
xs#(x:xs') -> case p x z0 of
Nothing -> ((z0, []), xs)
Just z1 -> first (\(z2, xt) -> (if null xt then z1 else z2, x : xt)) $
spanAcc z1 p xs'
groupAcc :: z -> (a -> z -> Maybe z) -> [a] -> [(z, [a])]
groupAcc z p = \case
[] -> [] ;
xs -> uncurry (:) $ second (groupAcc z p) $ spanAcc z p xs
For our specific problem, we define:
threshold :: (Num a, Ord a) => a -> a -> a -> Maybe a
threshold max a z0 = let z1 = a + z0 in if z1 < max then Just z1 else Nothing
groupViews :: (Ord z, Num z) => [(lab, z)] -> [[(lab, z)]]
groupViews = fmap snd . groupAcc 0 (threshold 250 . snd)
Which finally gives us:
groupFinal :: (Num a, Ord a) => [(lab, a)] -> [[(lab, a)]]
groupFinal = groupViews . sortOn snd
And ghci gives us:
> groupFinal [("a", 45), ("b", 223.5), ("c", 14), ("d", 42)]
[[("c",14.0),("d",42.0),("a",45.0)],[("b",223.5)]]
If we want to, we can simplify groupAcc by assuming that z is a Monoid wherefore mempty may be used, such that:
groupAcc2 :: Monoid z => (a -> z -> Maybe z) -> [a] -> [(z, [a])]
groupAcc2 p = \case
[] -> [] ;
xs -> let z = mempty in
uncurry (:) $ second (groupAcc z p) $ spanAcc z p xs

Leftist heap two version create implementation

Recently, I am reading the book Purely-functional-data-structures
when I came to “Exercise 3.2 Define insert directly rather than via a call to merge” for Leftist_tree。I implement a my version insert.
let rec insert x t =
try
match t with
| E -> T (1, x, E, E)
| T (_, y, left, right ) ->
match (Elem.compare x y) with
| n when n < 0 -> makeT x left (insert y right)
| 0 -> raise Same_elem
| _ -> makeT y left (insert x right)
with
Same_elem -> t
And for verifying if it works, I test it and the merge function offered by the book.
let rec merge m n = match (m, n) with
| (h, E) -> h
| (E, h) -> h
| (T (_, x, a1, b1) as h1, (T (_, y, a2, b2) as h2)) ->
if (Elem.compare x y) < 0
then makeT x a1 (merge b1 h2)
else makeT y a2 (merge b2 h1)
Then I found an interesting thing.
I used a list ["a";"b";"d";"g";"z";"e";"c"] as input to create this tree. And the two results are different.
For merge method I got a tree like this:
and insert method I implemented give me a tree like this :
I think there's some details between the two methods even though I follow the implementation of 'merge' to design the 'insert' version. But then I tried a list inverse ["c";"e";"z";"g";"d";"b";"a"] which gave me two leftist-tree-by-insert tree. That really confused me so much that I don't know if my insert method is wrong or right. So now I have two questions:
if my insert method is wrong?
are leftist-tree-by-merge and leftist-tree-by-insert the same structure? I mean this result give me an illusion like they are equal in one sense.
the whole code
module type Comparable = sig
type t
val compare : t -> t -> int
end
module LeftistHeap(Elem:Comparable) = struct
exception Empty
exception Same_elem
type heap = E | T of int * Elem.t * heap * heap
let rank = function
| E -> 0
| T (r ,_ ,_ ,_ ) -> r
let makeT x a b =
if rank a >= rank b
then T(rank b + 1, x, a, b)
else T(rank a + 1, x, b, a)
let rec merge m n = match (m, n) with
| (h, E) -> h
| (E, h) -> h
| (T (_, x, a1, b1) as h1, (T (_, y, a2, b2) as h2)) ->
if (Elem.compare x y) < 0
then makeT x a1 (merge b1 h2)
else makeT y a2 (merge b2 h1)
let insert_merge x h = merge (T (1, x, E, E)) h
let rec insert x t =
try
match t with
| E -> T (1, x, E, E)
| T (_, y, left, right ) ->
match (Elem.compare x y) with
| n when n < 0 -> makeT x left (insert y right)
| 0 -> raise Same_elem
| _ -> makeT y left (insert x right)
with
Same_elem -> t
let rec creat_l_heap f = function
| [] -> E
| h::t -> (f h (creat_l_heap f t))
let create_merge l = creat_l_heap insert_merge l
let create_insert l = creat_l_heap insert l
end;;
module IntLeftTree = LeftistHeap(String);;
open IntLeftTree;;
let l = ["a";"b";"d";"g";"z";"e";"c"];;
let lh = create_merge `enter code here`l;;
let li = create_insert l;;
let h = ["c";"e";"z";"g";"d";"b";"a"];;
let hh = create_merge h;;
let hi = create_insert h;;
16. Oct. 2015 update
by observing the two implementation more precisely, it is easy to find that the difference consisted in merge a base tree T (1, x, E, E) or insert an element x I used graph which can express more clearly.
So i found that my insert version will always use more complexity to finish his work and doesn't utilize the leftist tree's advantage or it always works in the worse situation, even though this tree structure is exactly “leftist”.
and if I changed a little part , the two code will obtain the same result.
let rec insert x t =
try
match t with
| E -> T (1, x, E, E)
| T (_, y, left, right ) ->
match (Elem.compare x y) with
| n when n < 0 -> makeT x E t
| 0 -> raise Same_elem
| _ -> makeT y left (insert x right)
with
Same_elem -> t
So for my first question: I think the answer is not exact. it can truly construct a leftist tree but always work in the bad situation.
and the second question is a little meaningless (I'm not sure). But it is still interesting for this condition. for instance, even though the merge version works more efficiently but for construct a tree from a list without the need for insert order like I mentioned (["a";"b";"d";"g";"z";"e";"c"], ["c";"e";"z";"g";"d";"b";"a"] , if the order isn't important, for me I think they are the same set.) The merge function can't choose the better solution. (I think the the tree's structure of ["a";"b";"d";"g";"z";"e";"c"] is better than ["c";"e";"z";"g";"d";"b";"a"]'s )
so now my question is :
is the tree structure that each sub-right spine is Empty is a good structure?
if yes, can we always construct it in any input order?
A tree with each sub-right spine empty is just a list. As such a simple list is a better structure for a list. The runtime properties will be the same as a list, meaning inserting for example will take O(n) time instead of the desired O(log n) time.
For a tree you usually want a balanced tree, one where all children of a node are ideally the same size. In your code each node has a rank and the goal would be to have the same rank for the left and right side of each node. If you don't have exactly 2^n - 1 entries in the tree this isn't possible and you have to allow some imbalance in the tree. Usually a difference in rank of 1 or 2 is allowed. Insertion should insert the element on the side with smaller rank and removal has to rebalance any node that exceeds the allowed rank difference. This keeps the tree reasonably balanced, ensuring the desired runtime properties are preserved.
Check your text book what difference in rank is allowed in your case.

Minimizing chunks in a matrix

Suppose I have the following matrix:
The matrix can be broken down into chunks such that each chunk must, for all rows, have the same number of columns where the value is marked true for that row.
For example, the following chunk is valid:
This means that rows do not have to be contiguous.
Columns do not have to be contiguous either, as the following is a valid chunk:
However, the following is invalid:
That said, what is an algorithm that can be used to select chunks such that the minimal number of chunks will be used when finding all the chunks?
Given the example, above, the proper solution is (items with the same color represent a valid chunk):
In the above example, three is the minimal number of chunks that this can be broken down into.
Note that the following is also a valid solution:
There's not a preference to the solutions, really, just to get the least number of chunks.
I thought of counting using adjacent cells, but that doesn't account for the fact that the column values don't have to be contiguous.
I believe the key lies in finding the chunks with the largest area given the constraints, removing those items, and then repeating.
Taking that approach, the solution is:
But how to traverse the matrix and find the largest area is eluding me.
Also note, that if you want to reshuffle the rows and/or columns during the operations, that's a valid operation (in order to find the largest area), but I'd imagine you can only do it after you remove the largest areas from the matrix (after one area is found and moving onto the next).
You are doing circuit minimization on a truth table. For 4x4 truth tables, you can use a K map. The Quine-McCluskey algorithm is a generalization that can handle larger truth tables.
Keep in mind the problem is NP-Hard, so depending on the size of your truth tables, this problem can quickly grow to a size that is intractable.
This problem is strongly related to Biclustering, for which there are many efficient algorithms (and freely available implementations). Usually you will have to specify the number K of clusters you expect to find; if you don't have a good idea what K should be, you can proceed by binary search on K.
In case the biclusters don't overlap, you are done, otherwise you need to do some geometry to cut them into "blocks".
The solution I propose is fairly straightforward, but very time consuming.
It can be decomposed in 4 major steps:
find all the existing patterns in the matrix,
find all the possible combinations of these patterns,
remove all the incomplete pattern sets,
scan the remaining list to get the set with the minimum number of elements
First of, the algorithm below works on either column or row major matrices. I chose column for the explanations, but you may swap it for rows at your convenience, as long as it remains consistent accross the whole process.
The sample code accompanying the answer is in OCaml, but doesn't use any specific feature of the language, so it should be easy to port to other ML dialects.
Step 1:
Each column can be seen as a bit vector. Observe that a pattern (what you call chunk in your question) can be constructed by intersecting (ie. and ing) all the columns, or all the rows composing it, or even a combinations. So the first step is really about producing all the combinations of rows and columns (the powerset of the matrix' rows and columns if you will), intersecting them at the same time, and filter out the duplicates.
We consider the following interface for a matrix datatype:
module type MATRIX = sig
type t
val w : int (* the width of the matrix *)
val h : int (* the height ........ *)
val get : t -> int -> int -> bool (* cell value getter *)
end
Now let's have a look at this step's code:
let clength = M.h
let rlength = M.w
(* the vector datatype used throughought the algorithm
operator on this type are in the module V *)
type vector = V.t
(* a pattern description and comparison operators *)
module Pattern = struct
type t = {
w : int; (* width of thd pattern *)
h : int; (* height of the pattern *)
rows : vector; (* which rows of the matrix are used *)
cols : vector; (* which columns... *)
}
let compare a b = Pervasives.compare a b
let equal a b = compare a b = 0
end
(* pattern set : let us store patterns without duplicates *)
module PS = Set.Make(Pattern)
(* a simple recursive loop on #f #k times *)
let rec fold f acc k =
if k < 0
then acc
else fold f (f acc k) (pred k)
(* extract a column/row of the given matrix *)
let cr_extract mget len =
fold (fun v j -> if mget j then V.set v j else v) (V.null len) (pred len)
let col_extract m i = cr_extract (fun j -> M.get m i j) clength
let row_extract m i = cr_extract (fun j -> M.get m j i) rlength
(* encode a single column as a pattern *)
let col_encode c i =
{ w = 1; h = count c; rows = V.set (V.null clength) i; cols = c }
let row_encode r i =
{ h = 1; w = count r; cols = V.set (V.null rlength) i; rows = r }
(* try to add a column to a pattern *)
let col_intersect p c i =
let col = V.l_and p.cols c in
let h = V.count col in
if h > 0
then
let row = V.set (V.copy p.rows) i in
Some {w = V.count row; h = h; rows = row; clos = col}
else None
let row_intersect p r i =
let row = V.l_and p.rows r in
let w = V.count row in
if w > 0
then
let col = V.set (V.copy p.cols) i in
Some { w = w; h = V.count col; rows = row; cols = col }
else None
let build_patterns m =
let bp k ps extract encode intersect =
let build (l,k) =
let c = extract m k in
let u = encode c k in
let fld p ps =
match intersect p c k with
None -> l
| Some npc -> PS.add npc ps
in
PS.fold fld (PS.add u q) q, succ k
in
fst (fold (fun res _ -> build res) (ps, 0) k)
in
let ps = bp (pred rlength) PS.empty col_extract col_encode col_intersect in
let ps = bp (pred clength) ps row_extract row_encode row_intersect in
PS.elements ps
The V module must comply with the following signature for the whole algorithm:
module type V = sig
type t
val null : int -> t (* the null vector, ie. with all entries equal to false *)
val copy : t -> t (* copy operator *)
val get : t -> int -> bool (* get the nth element *)
val set : t -> int -> t (* set the nth element to true *)
val l_and : t -> t -> t (* intersection operator, ie. logical and *)
val l_or : t -> t -> t (* logical or *)
val count : t -> int (* number of elements set to true *)
val equal : t -> t -> bool (* equality predicate *)
end
Step 2:
Combining the patterns can also be seen as a powerset construction, with some restrictions: A valid pattern set may only contain patterns which don't overlap. The later can be defined as true for two patterns if both contain at least one common matrix cell.
With the pattern data structure used above, the overlap predicate is quite simple:
let overlap p1 p2 =
let nullc = V.null h
and nullr = V.null w in
let o v1 v2 n = not (V.equal (V.l_and v1 v2) n) in
o p1.rows p2.rows nullr && o p1.cols p2.cols nullc
The cols and rows of the pattern record indicate which coordinates in the matrix are included in the pattern. Thus a logical and on both fields will tell us if the patterns overlap.
For including a pattern in a pattern set, we must ensure that it does not overlap with any pattern of the set.
type pset = {
n : int; (* number of patterns in the set *)
pats : pattern list;
}
let overlap sp p =
List.exists (fun x -> overlap x p) sp.pats
let scombine sp p =
if overlap sp p
then None
else Some {
n = sp.n + 1;
pats = p::sp.pats;
}
let build_pattern_sets l =
let pset l p =
let sp = { n = 1; pats = [p] } in
List.fold_left (fun l spx ->
match scombine spx p with
None -> l
| Some nsp -> nsp::l
) (sp::l) l
in List.fold_left pset [] l
This step produces a lot of sets, and thus is very memory and computation intensive. It's certainly the weak point of this solution, but I don't see yet how to reduce the fold.
Step 3:
A pattern set is incomplete if when rebuilding the matrix with it, we do not obtain the original one. So the process is rather simple.
let build_matrix ps w =
let add m p =
let rec add_col p i = function
| [] -> []
| c::cs ->
let c =
if V.get p.rows i
then V.l_or c p.cols
else c
in c::(add_col p (succ i) cs)
in add_col p 0 m
in
(* null matrix as a list of null vectors *)
let m = fold (fun l _ -> V.null clength::l) [] (pred rlength) in
List.fold_left add m ps.pats
let drop_incomplete_sets m l =
(* convert the matrix to a list of columns *)
let m' = fold (fun l k -> col_extract m k ::l) [] (pred rlength) in
let complete m sp =
let m' = build_matrix sp in
m = m'
in List.filter (fun x -> complete m' x) l
Step 4:
The last step is just selecting the set with the smallest number of elements:
let smallest_set l =
let smallest ps1 ps2 = if ps1.n < ps2.n then ps1 else ps2 in
match l with
| [] -> assert false (* there should be at least 1 solution *)
| h::t -> List.fold_left smallest h t
The whole computation is then just the chaining of each steps:
let compute m =
let (|>) f g = g f in
build_patterns m |> build_pattern_sets |> drop_incomplete_sets m |> smallest_set
Notes
The algorithm above constructs a powerset of a powerset, with some limited filtering. There isn't as far as I know a way to reduce the search (as mentioned in a comment, if this is a NP hard problem, there isn't any).
This algorithm checks all the possible solutions, and correctly returns an optimal one (tested with many matrices, including the one given in the problem description.
One quick remark regarding the heuristic you propose in your question:
it could be easily implemented using the first step, removing the largest pattern found, and recursing. That would yeld a solution much more rapidly than my algorithm. However, the solution found may not be optimal.
For instance, consider the following matrix:
.x...
.xxx
xxx.
...x.
The central 4 cell chunck is the largest which may be found, but the set using it would comprise 5 patterns in total.
.1...
.223
422.
...5.
Yet this solution uses only 4:
.1...
.122
334.
...4.
Update:
Link to the full code I wrote for this answer.

Optimizing a sudoku solver on Haskell

I have written a sudoku solver in Haskell. It goes through a list and when it finds '0' (an empty cell) it will get the numbers that could fit and try them:
import Data.List (group, (\\), sort)
import Data.Maybe (fromMaybe)
row :: Int -> [Int] -> [Int]
row y grid = foldl (\acc x -> (grid !! x):acc) [] [y*9 .. y*9+8]
where y' = y*9
column :: Int -> [Int] -> [Int]
column x grid = foldl (\acc n -> (grid !! n):acc) [] [x,x+9..80]
box :: Int -> Int -> [Int] -> [Int]
box x y grid = foldl (\acc n -> (grid !! n):acc) [] [x+y*9*3+y' | y' <- [0,9,18], x <- [x'..x'+2]]
where x' = x*3
isValid :: [Int] -> Bool
isValid grid = and [isValidRow, isValidCol, isValidBox]
where isValidRow = isValidDiv row
isValidCol = isValidDiv column
isValidBox = and $ foldl (\acc (x,y) -> isValidList (box x y grid):acc) [] [(x,y) | x <- [0..2], y <- [0..2]]
isValidDiv f = and $ foldl (\acc x -> isValidList (f x grid):acc) [] [0..8]
isValidList = all (\x -> length x <= 1) . tail . group . sort -- tail removes entries that are '0'
isComplete :: [Int] -> Bool
isComplete grid = length (filter (== 0) grid) == 0
solve :: Maybe [Int] -> Maybe [Int]
solve grid' = foldl f Nothing [0..80]
where grid = fromMaybe [] grid'
f acc x
| isValid grid = if isComplete grid then grid' else f' acc x
| otherwise = acc
f' acc x
| (grid !! x) == 0 = case guess x grid of
Nothing -> acc
Just x -> Just x
| otherwise = acc
guess :: Int -> [Int] -> Maybe [Int]
guess x grid
| length valid /= 0 = foldl f Nothing valid
| otherwise = Nothing
where valid = [1..9] \\ (row rowN grid ++ column colN grid ++ box (fst boxN) (snd boxN) grid) -- remove numbers already used in row/collumn/box
rowN = x `div` 9 -- e.g. 0/9=0 75/9=8
colN = x - (rowN * 9) -- e.g. 0-0=0 75-72=3
boxN = (colN `div` 3, rowN `div` 3)
before x = take x grid
after x = drop (x+1) grid
f acc y = case solve $ Just $ before x ++ [y] ++ after x of
Nothing -> acc
Just x -> Just x
For some puzzles this works, for example this one:
sudoku :: [Int]
sudoku = [5,3,0,6,7,8,0,1,2,
6,7,0,0,0,0,3,4,8,
0,0,8,0,0,0,5,0,7,
8,0,0,0,0,1,0,0,3,
4,2,6,0,0,3,7,9,0,
7,0,0,9,0,0,0,5,0,
9,0,0,5,0,7,0,0,0,
2,8,7,4,1,9,6,0,5,
3,0,0,2,8,0,1,0,0]
Took under a second, however this one:
sudoku :: [Int]
sudoku = [5,3,0,0,7,0,0,1,2,
6,7,0,0,0,0,3,4,8,
0,0,0,0,0,0,5,0,7,
8,0,0,0,0,1,0,0,3,
4,2,6,0,0,3,7,9,0,
7,0,0,9,0,0,0,5,0,
9,0,0,5,0,7,0,0,0,
2,8,7,4,1,9,6,0,5,
3,0,0,2,8,0,1,0,0]
I have not seen finish. I don't think this is a problem with the method, as it does return correct results.
Profiling showed that most of the time was spent in the "isValid" function. Is there something obviously inefficient/slow about that function?
The implementation is of course improvable, but that's not the problem. The problem is that for the second grid, the simple guess-and-check algorithm needs a lot of backtracking. Even if you speed up each of your functions 1000-fold, there will be grids where it still needs several times the age of the universe to find the (first, if the grid is not unique) solution.
You need a better algorithm to avoid that. A fairly efficient method to avoid such cases is to guess the square with the least number of possibilities first. That doesn't avoid all bad cases, but reduces them much.
One thing that you should also do is replace the length thing == 0 check with null thing. With the relatively short lists occurring here, the effect is limited, but in general it can be dramatic (and in general you should also not use length list <= 1, use null $ drop 1 list instead).
isValidList = all (\x -> length x <= 1) . tail . group . sort -- tail removes entries that are '0'
If the original list does not contain any zeros, tail will remove something else, perhaps a list of two ones. I'd replace tail . group. sort with group . sort . filter (/= 0).
I don't understand why isValidBox and isValidDiv use foldl as map appears to be adequate. Have I missed something / are they doing something terribly clever?

Resources