6
\$\begingroup\$

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]), ([1],2,[3,4]), ([1,2],3,[4]), ([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)
\$\endgroup\$
  • \$\begingroup\$ If you're a Haskell beginner, you might want to add the beginner tag. \$\endgroup\$ – Zeta Jun 29 '17 at 6:55
2
\$\begingroup\$

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))
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.