Skyline Solver

SkylineSolver.lhs

This is a Literate Haskell file to make it that much easier to store my thoughts
concisely. I didn't know it would have such an effect on me, but at this stage,
I can only thank the language designers for it.

Skyline fields look a bit like this:

\begin{verbatim}
-1	5	4	3	2	1	-1
5	10	20	30	40	50	1
4	20	30	40	50	10	2
3	30	40	50	10	20	2
2	40	50	10	20	30	2
1	50	10	20	30	40	2
-1	1	2	2	2	2	-1
\end{verbatim}

The encoding of choice is a list of lists:

\begin{verbatim}
[
[-1,  5,  4,  3,  2,  1, -1],
[ 5, 10, 20, 30, 40, 50,  1],
[ 4, 20, 30, 40, 50, 10,  2],
[ 3, 30, 40, 50, 10, 20,  2],
[ 2, 40, 50, 10, 20, 30,  2],
[ 1, 50, 10, 20, 30, 40,  2],
[-1,  1,  2,  2,  2,  2, -1]
]
\end{verbatim}

This solver will encode the whole possibility structure as a list of lists of
lists:

\begin{verbatim}
[
	[
		[-1],
		[ 5],
		[ 4],
		[ 3],
		[ 2],
		[ 1],
		[-1]
	],
	[
		[ 5],
		[10, 20, 30, 40, 50],
		[10, 20, 30, 40, 50],
		[10, 20, 30, 40, 50],
		[10, 20, 30, 40, 50],
		[10, 20, 30, 40, 50],
		[ 1]
	],
	[
		[ 4],
		[10, 20, 30, 40, 50],
		[10, 20, 30, 40, 50],
		[10, 20, 30, 40, 50],
		[10, 20, 30, 40, 50],
		[10, 20, 30, 40, 50],
		[ 2]
	],
	[
		[ 3],
		[10, 20, 30, 40, 50],
		[10, 20, 30, 40, 50],
		[10, 20, 30, 40, 50],
		[10, 20, 30, 40, 50],
		[10, 20, 30, 40, 50],
		[ 2]
	],
	[
		[ 2],
		[10, 20, 30, 40, 50],
		[10, 20, 30, 40, 50],
		[10, 20, 30, 40, 50],
		[10, 20, 30, 40, 50],
		[10, 20, 30, 40, 50],
		[ 2]
	],
	[
		[ 1],
		[10, 20, 30, 40, 50],
		[10, 20, 30, 40, 50],
		[10, 20, 30, 40, 50],
		[10, 20, 30, 40, 50],
		[10, 20, 30, 40, 50],
		[ 2]
	],
	[
		[-1],
		[ 1],
		[ 2],
		[ 2],
		[ 2],
		[ 2],
		[-1]
	]
]
\end{verbatim}

The solver will recursively perform the following steps:

\begin{enumerate}

\item\textbf{Elimination:} The solver removes options that are implausible or
impossible. If this leads to an empty list somewhere in the structure, the
path is considered unsolvable and the solver returns \textit{Nothing} for it.

\item\textbf{Choice:} The solver chooses an option from the first lowest-level
list with more than one element and attempts to solve the puzzle (recursively)
using this new structure. If that fails, the next element is chosen, and so on.

\end{enumerate}

In the following paragraphs, a \textit{decided lot} is a third-level list with
only one element, and an \textit{impossible lot} is an empty third-level list.

\section{Elimination}

The elimination step is probably more important than the choice step. The more
implausible options are removed, the more efficient the whole solving algorithm.

The elimination step looks at each visibility line, horizontal and vertical. In
each line, it
\begin{enumerate}

\item Removes the heights of the decided lots from the possibility lists of the
undecided lots.

\item Returns in case of empty lists.

\item Runs through the list, keeping track of two values: the visibility for the
row and the maximum height until now. Each time a decided higher scraper than
the current maximum is encountered, the local visibility counter is decreased by
one and the maximum is updated. When the visibility counter hits zero, the
remaining possibility lists are cleared of all elements greater than the current
maximum.

The algorithm stops eliminating if an undecided lot is met before the counter
hits zero.

\item Returns in case of empty lists.

\end{enumerate}

“Great description, you wannabe mathematician,” I hear you say, “but I have no
idea what you’re blathering about. How about an example?” Well, since I might
not understand my definition in a few weeks anymore either, sure, no problem,
here’s an example.

The following row is to be processed:

\begin{verbatim}
visibility           = 3
scraperPossibilities = [
	[10],
	[30],
	[20],
	[60],
	[10, 20, 30, 40, 50, 60],
	[10, 20, 30, 40, 50, 60]
]
\end{verbatim}

First, we eliminate the dupes, of course.

\begin{verbatim}
scraperPossibilities' = [
	[10],
	[30],
	[20],
	[60],
	[40, 50],
	[40, 50]
]
\end{verbatim}

So far, so bad -- we haven't been able to abort yet. Time for step 2.

We start with maximum height 0 and visibility counter at 3.

\begin{enumerate}

\item element: \verb+[10]+, maximum height 0, counter 3

The scraper is decided and higher than our maximum. Update maximum, decrease
counter.

\item element: \verb+[30]+, maximum height 10, counter 2

The scraper is decided and higher than our maximum. Update maximum, decrease
counter.

\item element: \verb+[20]+, maximum height 30, counter 1

The scraper is decided but lower than our maximum. Continue.

\item element: \verb+[60]+, maximum height 30, counter 1

The scraper is decided and higher than our maximum. Update maximum, decrease
counter.

\item element: \verb+[40, 50]+, maximum height 60, counter 0

Counter is at zero; eliminate all elements below 60. New element \verb+[]+ is
the empty list, abort.
\end{enumerate}

Ergo, this row is unsolvable.

\subsection{In Haskell}

One cannot survive without these imports.

> import Data.List
> import Data.Maybe

This import contains \verb+zipWithM+, which is especially awesome with the
\verb+Maybe+ monad.

> import Control.Monad

\subsubsection{undupe}

Let’s first define the undupe operation.

> undupe :: (Eq a) => [a] -> [[a]] -> [[a]]

For an empty value list, the solution is obvious.

> undupe _ []		= []

If the head is a decided lot and a dupe, transform it into an empty list. If
it’s decided but not a dupe, add its value to the dupe list and continue.

> undupe ds ([x]:xss)
>	| x `elem` ds	= ([]:(undupe ds xss))
>	| otherwise	= ([x]:(undupe (x:ds) xss))

If it's not a decided lot, remove the dupes and continue.

> undupe ds (xs:xss)	= (newXs:(undupe ds xss))
>	where
>		newXs	= xs \\ ds

This is already a pretty nice function, but there is room for optimization. If
we ever transform one of the elements into an empty list, it doesn’t make much
sense calculating the rest of the values, since the caller will return
\verb+Nothing+ straight away anyway. Instead, our empty list becomes the last
element. Let’s call the function \verb+undupeAbortive+ to make its eagerness to
abort more obvious.

> undupeAbortive :: (Eq a) => [a] -> [[a]] -> [[a]]
> undupeAbortive _ []		= []
> undupeAbortive ds ([x]:xss)
>	| x `elem` ds	= [[]]
>	| otherwise	= ([x]:(undupeAbortive (x:ds) xss))
> undupeAbortive ds (xs:xss)
>	| newXs == []	= [[]]
>	| otherwise	= (newXs:(undupeAbortive ds xss))
>	where
>		newXs	= xs \\ ds

Sweet. Now on to the visibility eliminator.

\subsubsection{doVisEliminate}

> doVisEliminate :: Integer -> Integer -> [[Integer]] -> [[Integer]]

There isn’t much to do with an empty list, of course.

> doVisEliminate _ _ []			= []

If the visibility counter is zero, eliminate all elements greater than the found
maximum value. Use the early-abort technique from \verb+undupeAbortive+.

> doVisEliminate 0 maxV (xs:xss)
>	| newXs == []			= [[]]
>	| otherwise			= (newXs:(doVisEliminate 0 maxV xss))
>	where
>		newXs	= filter (<= maxV) xs

If the current element is decided and larger than the current maximum
visibility, then reduce the counter and adjust the maximum visibility. If it
is decided but not larger than the current maximum visibility, simply continue.

> doVisEliminate viscount maxV ([x]:xss)
>	| x > maxV			= ([x]:(doVisEliminate (viscount - 1) x xss))
>	| otherwise			= ([x]:(doVisEliminate viscount maxV xss))

Otherwise, return the rest of the list unchanged.

> doVisEliminate _ _ xss		= xss

\subsubsection{visFine}

One more thing: if the row is fully decided, the visibility must be checked.
Since the visibility eliminator stops on an undecided scraper, we need an
explicit check to prevent bogus results from percolating upwards.

> visFine :: Integer -> Integer -> [[Integer]] -> Bool

On empty lists, zero visibility is fine.

> visFine vis _ []		= (vis == 0)

If no more scrapers may be visible, the current decided scraper must be at most
as high as the highest one.

> visFine 0 maxHt ([x]:xss)	= (x <= maxHt) && (visFine 0 maxHt xss)

If this scraper is decided and higher than the highest decided one, decrement
the visibility counter and reset the maximum height. Otherwise, continue.

> visFine vis maxHt ([x]:xss)
>	| x > maxHt		= visFine (vis-1) x xss
>	| otherwise		= visFine vis maxHt xss

Assume that the visibility in rows with undecided lots is fine.

> visFine _ _ (_:_)		= True

\subsubsection{eliminator}

Time to make it all come together.

> eliminator :: Integer -> [[Integer]] -> Maybe [[Integer]]

Empty lists, once again, are both termination condition and annoying:

> eliminator _ []	= Just []

Otherwise, run the two steps and break early.

> eliminator visibility items
>	| [] `elem` undupedItems	= Nothing
>	| [] `elem` viselimedItems	= Nothing
>	| not visibilityOK		= Nothing
>	| otherwise			= Just viselimedItems
>	where
>		undupedItems	= undupeAbortive [] items
>		viselimedItems	= doVisEliminate visibility 0 undupedItems
>		visibilityOK	= visFine visibility 0 viselimedItems

\section{Picking}

The picking algorithm is not exactly the epitome of smart programming. It
traverses the skyscraper field until it finds the first undecided lot. It then
returns the fields with this lot decided, one entry for each value of the
possibility list.

If all fields are decided, it returns \verb+Nothing+.

First, let’s write the function which returns the picks for (the first undecided
lot of) a given row. For simpler identification of the case where nothing was
picked, the return type is packed in \verb+Maybe+.

> pickFromRow :: [[Integer]] -> Maybe [[[Integer]]]

The empty list is exactly that case.

> pickFromRow []	= Nothing

If it’s a decided field, just skip it. Of course, with the whole \verb+Maybe+
monad, \textit{just skipping it} is a rather involved procedure.

> pickFromRow ([x]:xss)
>	| yss == Nothing	= Nothing
>	| otherwise		= Just [ [x]:ys | ys <- justYss ]
>	where
>		yss		= pickFromRow xss
>		justYss		= fromJust yss

If the field is undecided, we can finally do our magic.

> pickFromRow (xs:xss)	= Just [ ([y]:xss) | y <- xs ]

Awesome. Now, let’s do the same one level further up. This will mostly be a
wrapper for \verb+pickFromRow+.

> pickFromField :: [[[Integer]]] -> Maybe [[[[Integer]]]]

> pickFromField []	= Nothing

> pickFromField (xss:xsss)
>	| noYsss && noZssss	= Nothing
>	| noYsss		= Just [ (xss:zsss) | zsss <- (fromJust zssss) ]
>	| otherwise		= Just [ (yss:xsss) | yss <- justYsss ]
>	where
>		ysss		= pickFromRow xss
>		zssss		= pickFromField xsss
>		noYsss		= ysss == Nothing
>		noZssss		= zssss == Nothing
>		justYsss	= fromJust ysss

\section{Solving}

First, let’s break the field apart into its constituent items: the playing field
itself and its visibility parameters.

> breakField :: [[a]] -> ([[a]], [a], [a], [a], [a])
> breakField xss	= (fss, tVis, bVis, lVis, rVis)
>	where
>		thorax	= tail . init
>		fss	= (map (thorax)) (thorax xss)
>		tVis	= thorax . head $ xss
>		bVis	= thorax . last $ xss
>		lVis	= thorax . map (head) $ xss
>		rVis	= thorax . map (last) $ xss

Now, we transform the playing field into a possibility field. If the value in
the given field is the gap value, it is filled with the specified filler list.
Otherwise, the existing element is packed into a list.

> possibilify :: (Eq a) => a -> [a] -> [[a]] -> [[[a]]]
> possibilify _ _ []			= []
> possibilify gapVal fillers fss	= map (possibRow) fss
>	where
>		possibRow []		= []
>		possibRow (v:vs)
>			| (v == gapVal)		= fillers:(possibRow vs)
>			| otherwise		= [v]:(possibRow vs)

Now, it’s time to get all these functions together into a solver. Let’s split
out the recursive part for easier unit testing.

> recSolver :: [Integer] -> [Integer] -> [Integer] -> [Integer] -> [[[Integer]]] -> Maybe [[Integer]]
> recSolver tVis bVis lVis rVis psss
>	-- elimination hit a wall
>	| isNothing elsss1	= Nothing
>	| isNothing elsss2	= Nothing
>	| isNothing elsss3	= Nothing
>	| isNothing elsss4	= Nothing
>	-- nothing more to pick :-)
>	| isNothing pickssss	= Just (map (map (head)) donesss)
>	-- first valid pick
>	| otherwise		= listToMaybe subPicks
>	where
>		elsss1	= zipWithM (eliminator) lVis psss
>		jelsss1	= fromJust elsss1
>		elsss2	= zipWithM (eliminator) rVis (map (reverse) jelsss1)
>		jelsss2	= fromJust elsss2
>		elsss3	= zipWithM (eliminator) tVis (transpose . map (reverse) $ jelsss2)
>		jelsss3	= fromJust elsss3
>		elsss4	= zipWithM (eliminator) bVis (map (reverse) jelsss3)
>		jelsss4	= fromJust elsss4
>		donesss	= transpose . map (reverse) $ jelsss4
>		pickssss	= pickFromField donesss
>		jpickssss	= fromJust pickssss
>		subPicks	= catMaybes . map (recSolver tVis bVis lVis rVis) $ jpickssss

And, finally, the user-facing version.

> solver :: [[Integer]] -> Maybe [[Integer]]
> solver xss	= recSolver tVis bVis lVis rVis psss
>	where
>		(fss, tVis, bVis, lVis, rVis)	= breakField xss
>		vals	= [10, 20 .. 10*(genericLength fss)]
>		psss	= possibilify 0 vals fss

For testing, let’s first include the skyline from the problem description.

> tc_desc :: [[Integer]]
> tc_desc = [
>	[-1, 5, 4, 3, 2, 1, -1],
>	[5, 10, 20, 30, 40, 50, 1],
>	[4, 20, 30, 40, 50, 10, 2],
>	[3, 30, 40, 50, 10, 20, 2],
>	[2, 40, 50, 10, 20, 30, 2],
>	[1, 50, 10, 20, 30, 40, 2],
>	[-1, 1, 2, 2, 2, 2, -1]
>	]
>
> (tc_desc_fss, tc_desc_tVis, tc_desc_bVis, tc_desc_lVis, tc_desc_rVis) = breakField tc_desc
> tc_desc_psss = possibilify 0 [10, 20 .. 50] tc_desc_fss

Now, let's carve out a truckload of values.

> tc_desc_1 :: [[Integer]]
> tc_desc_1 = [
>	[-1, 5, 4, 3, 1, 2, -1],
>	[5, 0, 0, 0, 0, 0, 1],
>	[4, 0, 0, 0, 0, 0, 2],
>	[3, 0, 0, 0, 0, 0, 2],
>	[1, 0, 0, 0, 0, 0, 2],
>	[2, 0, 0, 0, 0, 0, 2],
>	[-1, 1, 2, 2, 2, 2, -1]
>	]
>
> (tc_desc_1_fss, tc_desc_1_tVis, tc_desc_1_bVis, tc_desc_1_lVis, tc_desc_1_rVis) = breakField tc_desc_1
> tc_desc_1_psss = possibilify 0 [10, 20 .. 50] tc_desc_1_fss