Motivation

I plan to use recursion schemes to solve dynamic programming (DP) tasks. In this post, I will solve a simple search problem with non-overlapping subproblems. The idea is to get familiar with recursion schemes before we dig deeper.

In my experience when people discuss DP tasks they usually draw state transition graphs. But after whiteboard discussion, they turn those graphs into an explicit recursion with memoization or into several nested loops which iterate through a mutable array.

Recursion schemes (RS) can build and reduce graphs so they can be used to run search through a graph of possible states. With RS we can model a state space as a tree and generate/traverse/reduce it using recursion schemes. Such approach looks quite interesting to me mainly because resulting code will more closely resemble state transition graph (which we draw on a whiteboard).

Here I will play with a quite simple search problem which wants us to cleverly reduce the number of state transitions by noticing that certain states are impossible.

Interesting points in this post:

  • using Monoids to combine results.
  • using hylo recursion scheme to generate and reduce state space.

Getting started

Here is 8 queens puzzle and here is our first code lines:

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TupleSections #-}
import           Data.List
import           Data.Monoid
import           Data.Set    (Set)
import qualified Data.Set    as Set

First of all let’s encode state representation and relevant game rules.

We encode board coordinates as two integers (assuming a range [1 .. 8]).

type Pos = (Int, Int)

allBoardCoords :: [Pos]
allBoardCoords = [(x, y) | x <- [1 .. 8], y <- [1 .. 8]]

Board state is a sorted list of coordinates.

type BoardState = [Pos]

appendToState :: Pos -> BoardState -> BoardState
appendToState x xs = sort (x:xs)

Rules are quite simple: if two queens occupy the same rows, cols or diagonals then that situation is invalid.

underAttack :: Pos -> Pos -> Bool
underAttack (x1, y1) (x2, y2) =
  or [ x1 == x2
     , y1 == y2
     , x1 + y1 == x2 + y2
     , x1 - y1 == x2 - y2 ]

This functions takes given board state and tries to add a new figure to every possible position. Each position which is not under attack yields a new state. (This strategy can be optimized but we will play with it for some time).

nextStates :: BoardState -> [BoardState]
nextStates st = fmap (flip appendToState st) safeCoords
  where conflict x = any (underAttack x) st
        safeCoords = filter (not . conflict) allBoardCoords

It’s time to solve a problem and to find one valid solution:

solveFstRec :: BoardState -> First BoardState
solveFstRec st
  | length st == 8 = (First . Just) st
  | otherwise      = foldMap solveFstRec (nextStates st)

t1 = Test { res = solveFstRec []
          , ans = (First . Just) [(1,1),(2,5),(3,8),(4,6),(5,3),(6,7),(7,2),(8,4)] }

If you are wondering about that Test datatype then our testing framework is defined at the end of that post.

We where using foldMap to combine results. It allows to quite easily change the way we combine result by changing underlying Monoid:

solveRecList :: BoardState -> [BoardState]
solveRecList st
  | length st == 8 = [st]
  | otherwise      = foldMap solveRecList (nextStates st)

t2 = Test { res = length (solveRecList [])
          , ans = 3709440 }

Hm, 3709440 doesn’t check with Wikipedia page which says “The eight queens puzzle has 92 distinct solutions.”. The problem is that our recursion comes to the same states using different routes. Let’s deduplicate results by using a Set:

solveRec :: BoardState -> Set BoardState
solveRec st
  | length st == 8 = Set.singleton st
  | otherwise      = foldMap solveRec (nextStates st)

t3 = Test { res = Set.size (solveRec [])
          , ans = 92 }

All right, time for algorithmic improvement: we know that queens will occupy different rows so let’s improve our state transition function:

nextStatesSmart :: Int -> BoardState -> [BoardState]
nextStatesSmart col st
  | col > 8     = []
  | otherwise = fmap (flip appendToState st) safeCoords
  where conflict x = any (underAttack x) st
        safeCoords = filter (not . conflict) [(col, y) | y <- [1 .. 8]]

solveRecSmartList :: Int -> BoardState -> [BoardState]
solveRecSmartList col st
  | length st == 8 = [st]
  | otherwise      = foldMap (solveRecSmartList (col + 1)) (nextStatesSmart col st)

t4 = Test { res = length (solveRecSmartList 0 [])
          , ans = 92 }

Good. No more overlapping branches in a state transitions tree.

Recursion schemes

Caution: the information below can be harmful without sufficient understanding of RS. My previous post contains some information about RS as well as links to tutorials.

Let’s model our search process explicitly by defining a tree which represents transitions from one state to another:

data SeartchTreeF n = Node BoardState [n] deriving Functor

Then we can define transitions from one state to another in terms of SearchTreeF to generate a tree. And we also can define a function which “collapses” a tree into a list of solutions.

In fact, resulting code is very similar to solveRecSmartList but it was split into two non-recursive functions which operate on nodes of a tree. The beauty of this solution is that genTree and collapseTree are not recursive and hence can be easily extended even with some effects.

In contrast, solveRecSmartList is not extensible. It can be made extensible by using open recursion but even open recursion has some limitations which we will explore later.

genTree :: (Int, BoardState) -> SeartchTreeF (Int, BoardState)
genTree (col, st) = Node st (fmap (col + 1,) (nextStatesSmart (col + 1) st))

collapseTree :: SeartchTreeF [BoardState] -> [BoardState]
collapseTree (Node st childs)
  | length st == 8 = [st]
  | otherwise      = concat childs

And here we “just” use previously discussed hylo to run a search:

hylo :: Functor f => (f a -> a) -> (b -> f b) -> b -> a
hylo a c = h where h = a . fmap h . c

solveHylo :: [BoardState]
solveHylo = hylo collapseTree genTree (0, [])

t5 = Test { res = length solveHylo
          , ans = 92 }

Literate Haskell

Code blocks from this post can be combined and executed.

data Test a = Test { res :: a, ans :: a }

runTest :: Eq a => Test a -> Bool
runTest t = res t == ans t

main = print $ and
               [ runTest t1
               , runTest t2
               , runTest t3
               , runTest t4
               , runTest t5]

Stay tuned

Next time we will solve a problem with overlapping subproblems which will push us to incorporate caching.