# Puzzle game solver via Backtracking

I'm relatively new to Haskell and I'd like to get feedback on the style of my program. Specifically:

• Coding Style: Can any parts be written in a more concise or more readable way?
• Misuse: Are there any parts that are generally should be avoided, or any typical beginner mistakes? (Basically the do's and don't's)

### The game

The program solves a puzzle that is also known as binoxxo: There is a 2n x 2n square grid that is partially filled with X and O. The goal filling each cell of the grid with an X or O such that the result satisfies three conditions:

1. In each column and each row, the same symbol cannot occur more than twice in a row. (I.e. OXXOXO is ok, however OXXXOO is not.)
2. Each row and each column have exactly n Xs and n Os.
3. No two rows are equal and no two columns are equal.

(An online version can be found here.)

### The program

The following module consists of three parts: First we define the new type to describe the grid, with the type constructors X,O and finally E (for an empty cell). Then we have two functions: isValid checks whether all three rules hold so far, and backtrack which actually solves the puzzle. It does so by placing an X and O in the first E spot of the given puzzle checking the validity of the new grids, and if that succeeds, recursing a step deeper. This function finds all the possible solutions, but due to the lazy evaluation we can use take 1 $backtrack myBoard to get only one and finish a little bit quicker. module Binoxxo (isValid, backtrack, exampleBoard, Cell (..), Board) where import Control.Applicative import Data.List data Cell = E | X | O -- E = empty deriving (Eq,Show) type Board = [[Cell]] exampleBoard = -- for solving: call "backtrack exampleBoard" [[X,X,E,E], [E,E,E,E], [O,E,E,X], [O,O,E,X]] -- backtracking backtrack :: Board -> [Board] backtrack b | isFull b = [b] --board has no more empty cells | otherwise = nub$ concat $map backtrack validBoards where isFull b = not$ E elem concat b
newBoards = generateAllBoards b :: [Board]
validBoards = filter isValid newBoards

generateAllBoards :: Board -> [Board] -- adds one new X/O in the position of a E
generateAllBoards b = concat $map assembleBoards (prefixRowSuffix b) where prefixRowSuffix :: [a] -> [([a],a,[a])]-- [1,2,3,4] -> [([],1,[2,3,4]), (,2,[3,4]), ([1,2],3,), ([1,2,3],4,[])] prefixRowSuffix b = zip3 (inits b) b (drop 1$ tails b)

assembleBoards :: ([[Cell]],[Cell],[[Cell]]) -> [Board]
assembleBoards (front,m,back) = take 2 -- we only need to place X and O in the first occurence of E, because one of them MUST be correct
[front ++[f++[x]++b]++ back |
(f,E,b)<-prefixRowSuffix m,x<-[X,O]]

-- validity check (implement the three rules)
isValid :: Board -> Bool
isValid b = and $[and . map checkNeighbours, checkDupli, and . map checkCount] -- each of these get applied to all normal and transposed board <*> [rows, cols] where rows = b :: Board cols = transpose b :: Board -- we cannot have three consecutive X or O checkNeighbours :: [Cell] -> Bool checkNeighbours (a:b:c:xs) = let this = not$ any ((&& a==b && b==c) . (c==)) [X,O]
rest = checkNeighbours (b:c:xs)
in this && rest
checkNeighbours _  = True

-- we cannot have two equal rows/columns
checkDupli :: Board -> Bool
checkDupli b = check $filter (all (/=E)) b -- only check full rows for duplicates where check (x:xs) = (not$ x elem xs)  && check xs
check [] = True

-- if row is of length n, we can have at most n/2 X and O
checkCount :: [Cell] -> Bool
checkCount xs = notTooMany O && notTooMany X
where
len = length xs
notTooMany xo = len >= 2 * length (filter (==xo) xs)

• If you're a Haskell beginner, you might want to add the beginner tag. – Zeta Jun 29 '17 at 6:55

## 1 Answer

isFull fires when assembleBoards returns an empty list; we'd expect to be able to ask that question only once. newBoards and validBoards do not deserve names - if you want the reader to be able to tell what the value means, comments are more appropriate.

Most of the rest of backtrack is about descending into a nested data structure and changing a small part, which lens specializes in: traverse . traverse . filtered (==E) descends into the board, then each of its elements, then each of their E cells. holesOf gives you, roughly speaking, the positions of the targets in the original board - it separates the board into a Cell and a Cell -> Board for each target. peek lets you forget there was an E.

import Control.Comonad.Representable.Store (peek)
import Control.Lens (holesOf, filtered)

backtrack :: Board -> [Board]
backtrack b = case setFirstE b of
-- board has no more empty cells
Nothing -> [b]
-- we only need to place X and O in the first occurence of E, because one of them MUST be correct
Just setter -> nub $concatMap backtrack$ filter isValid \$ map setter [X,O]

-- Punches the first E out of the board, if any.
setFirstE :: Board -> Maybe (Cell -> Board)
setFirstE = listToMaybe . map (flip peek) . holesOf (traverse . traverse . filtered (==E))