[Haskell-cafe] combinatorial search with running bound

[Michael Mossey]

I have a combinatorial search problem that requires a
running lower bound to be tracked in order to prune the search. I have enough
Haskell experience to know how to do a combinatorial search, for example with
list compresions or the list monad, but I don't know how to keep a running
lower bound.

The problem is: I have two groups of boxes, and need to figure out how
closely the centers of the groups can be brought left-right.

For example,

                         55
     11111               55
     11111
                       44
  22                   44
  22  +  <- how close? -> +
   33333                 6666
   33333                 6666
   33333

The left group consists of boxes 1, 2, and 3, which have both a size and
a position (the position is relative to the center of the group,
represented with the +). The right group has boxes 4, 5, and 6.

The problem is to determine how closely the groups can be brought together
without any boxes intersection.

The basic algorithm is to consider each pair of boxes and ask if they
have any "vertical overlap"---if so, figure out how closely they can be
brought together without intersecting, otherwise ignore them. Then take
the maximum of those numbers.



-- (Here assume lrSeparation returns minBound for boxes that don't have
--  vertical intersection.)
boxesSep :: [Box] -> [Box] -> Int
boxesSep lefts rights =
    maximum [ lrSeparation l r | l <- lefts, r <- rights ]


However, this algorithm can be improved by pruning.

- Define the 'left extent' of a box by how far its left edge sticks out to
  the left of the group center. Similarly the 'right extent'.

- Sort the list of left boxes in the order of decreasing right extent.
  Sort the list of right boxes in order of decreasing left extent.

- Consider pairs of boxes as a kind of outer loop on the left boxes, and
  inner loop on the right boxes.

- Track the current maximum required separation, which is a lower bound
  on the final answer.

- If at any point in the inner loop, the right extent has gotten so small
  that there's no way you could find a new maximum, skip the rest of the
  inner loop (skip the remainder of the right boxes).

Here's my attempt to write this using a state monad. There's probably a more
idiomatic way to do it.



-- This is state used in the state monad.
data SearchState = SearchState { -- running maximum:
                                 ssMaximum :: Int
                                 -- remember the full list of right boxes
                                 -- so we can initiate a new outer loop
                               , ssRights :: [Box]
                               }

boxesSep2 :: [Box] -> [Box] -> Int
boxesSep2 lefts rights =
    let ls = sortBy ((flip compare) `on` rightExtent) lefts
        rs = sortBy ((flip compare) `on` leftExtent) rights
    in fst $ runState (boxesSep2' ls rs) (SearchState minBound rs)

boxesSep2' :: [BoxBounds] -> [BoxBounds] -> State SearchState Int

-- Termination of algorithm:
boxesSep2' [] _ = gets ssMaximum

-- Initiate a new inner loop:
boxesSep2' (l:ls) [] = do
  rights <- gets ssRights
  boxesSep' ls rights

-- Common case:
boxesSep2' lss@(l:ls) (r:rs) = do
  -- In this way of writing the code, we distinguish between the
  -- left/right separation which is the sum of the extents, and the
  -- question of whether there is vertical overlap.
  let v = isVerticalOverlap l r
      sep = lrSeparation l r
  ss <- get
  let max = ssMaximum ss
  if sep <= max
    then boxesSep' ls (ssRights ss) --Here we "prune" (initiate new inner
loop)
    else do
      -- Update max is needed:
      when v (put ss { ssMaximum = sep })
      boxesSep' lss rs


So if there is a better way to do this, I'm all ears.