Can this Haskell kata solution be made more idiomatic?

Question

I'm relearning Haskell after a 10 year hiatus, partly to see what's changed and partly as an antidote to days spent in C#, SQL and JavaScript and partly as it's cool all of a sudden ;-)

I decided to set myself the Towers of Hanoi as a coding kata, simple enough stuff but I already feel that my code is non-idiomatic and would love to hear what hints and tips any Haskell old hands might have.

To make the kata slightly more interesting I split the problem into two parts, the first part, the function moves, generates the sequence of moves required to solve the puzzle. The remainder of the code is designed to model the towers and execute the moves.

One part I definitely feel unhappy with is the moveDisc function, this would be tedious to extend to 4 towers.

Hanoi.hs

module Hanoi 
where

import Data.Maybe

type Disc = Integer
type Towers = [[Disc]]
data Column = A | B | C deriving (Eq,Show)

getDisc :: Towers -> Column -> Maybe Disc
getDisc t A = listToMaybe $ t !! 0
getDisc t B = listToMaybe $ t !! 1
getDisc t C = listToMaybe $ t !! 2

validMove :: Towers -> Column -> Column -> Bool
validMove tower from to 
    | srcDisc == Nothing = False
    | destDisc == Nothing = True
    | otherwise = srcDisc < destDisc
    where srcDisc = getDisc tower from
          destDisc = getDisc tower to

moveDisc :: Towers -> Column -> Column -> Towers
moveDisc [a:as, b, c] A B = [as, a:b, c]
moveDisc [a:as, b, c] A C = [as, b, a:c]
moveDisc [a, b:bs, c] B A = [b:a, bs, c]
moveDisc [a, b:bs, c] B C = [a, bs, b:c]
moveDisc [a, b, c:cs] C A = [c:a, b, cs]
moveDisc [a, b, c:cs] C B = [a, c:b, cs]

moves :: Integer -> Column -> Column -> Column -> [(Column,Column)]
moves 1 a _ c = [(a,c)]
moves n a b c = moves (n-1) a c b ++ [(a,c)] ++ moves (n-1) b a c

solve :: Towers -> Towers
solve towers = foldl (\t (from,to) -> moveDisc t from to) towers (moves len A B C)
    where len = height towers

height :: Towers -> Integer
height (t:_) = toInteger $ length t

newGame :: Integer -> Towers
newGame n = [[1..n],[],[]]

TestHanoi.hs

module TestHanoi
where

import Test.HUnit
import Hanoi

main = runTestTT $ "Hanoi Tests" ~: TestList [

    getDisc [[1],[2],[2]] A ~?= Just 1 ,
    getDisc [[1],[2],[3]] B ~?= Just 2 ,
    getDisc [[1],[2],[3]] C ~?= Just 3 ,
    getDisc [[],[2],[3]] A ~?= Nothing ,
    getDisc [[1,2,3],[],[]] A ~?= Just 1 ,

    validMove [[1,2,3],[],[]] A B ~?= True ,
    validMove [[2,3],[1],[]] A B ~?= False ,
    validMove [[3],[],[1,2]] A C ~?= False ,
    validMove [[],[],[1,2,3]] A C ~?= False ,

    moveDisc [[1],[],[]] A B ~?= [[],[1],[]] ,
    moveDisc [[],[1],[]] B C ~?= [[],[],[1]] ,
    moveDisc [[1,2],[],[]] A B ~?= [[2],[1],[]] ,
    moveDisc [[],[2],[1]] C B ~?= [[],[1,2],[]] ,
    moveDisc [[1,2],[],[]] A C ~?= [[2],[],[1]] ,
    moveDisc [[3],[2],[1]] B A ~?= [[2,3],[],[1]] ,

    moves 1 A B C ~?= [(A,C)] ,
    moves 2 A B C ~?= [(A,B),(A,C),(B,C)] ,

    "acceptance test" ~: 
        solve [[1,2,3,4,5,6], [], []] ~?= [[],[],[1,2,3,4,5,6]] ,

    "is optimal" ~: 
        length (moves 3 A B C) ~?= 7
    ]

I look forward to hearing any comments or suggestions for improvement.

Answer 1

Here's an implementation using an alternative representation. Instead of storing three lists of peg sizes, I store a list of columns, where the first element corresponds to the position of the smallest disc, and so on. This has the benefit that it is now impossible to represent illegal states like missing discs, larger disks stacked on top of smaller ones, etc. It also makes many of the functions trivial to implement.

Hanoi.hs

module Hanoi where

import Control.Applicative
import Control.Monad
import Data.List
import Data.Maybe

type Disc = Integer
type Towers = [Column]
data Column = A | B | C deriving (Eq, Show)

getDisc :: Column -> Towers -> Maybe Disc
getDisc c t = (+1) . toInteger <$> elemIndex c t

validMove :: Column -> Column -> Towers -> Bool
validMove from to = isJust . moveDisc from to

moveDisc :: Column -> Column -> Towers -> Maybe Towers
moveDisc from to = foldr check Nothing . tails
  where check (c:cs)
          | c == from   = const . Just $ to : cs
          | c == to     = const Nothing
          | otherwise   = fmap (c:)

moves :: Integer -> Column -> Column -> Column -> [(Column,Column)]
moves 1 a _ c = [(a,c)]
moves n a b c = moves (n-1) a c b ++ [(a,c)] ++ moves (n-1) b a c

solve :: Towers -> Towers
solve towers = fromJust $ foldM (\t (from,to) -> moveDisc from to t) towers (moves len A B C)
    where len = height towers

height :: Towers -> Integer
height = genericLength

newGame :: Integer -> Towers
newGame n = genericReplicate n A

HanoiTest.hs

module HanoiTest where

import Test.HUnit
import Hanoi

main = runTestTT $ "Hanoi Tests" ~: TestList [

    getDisc A [A, B, C] ~?= Just 1 ,
    getDisc B [A, B, C] ~?= Just 2 ,
    getDisc C [A, B, C] ~?= Just 3 ,
    getDisc A [B, B, C] ~?= Nothing ,
    getDisc A [A, A, A] ~?= Just 1 ,

    validMove A B [A, A, A] ~?= True ,
    validMove A B [B, A, A] ~?= False ,
    validMove A C [C, C, A] ~?= False ,
    validMove A C [C, C, C] ~?= False ,

    moveDisc A B [A] ~?= Just [B] ,
    moveDisc B C [B] ~?= Just [C] ,
    moveDisc A B [A, A] ~?= Just [B, A] ,
    moveDisc C B [C, B] ~?= Just [B, B] ,
    moveDisc A C [A, A] ~?= Just [C, A] ,
    moveDisc B A [C, B, A] ~?= Just [C, A, A] ,

    moves 1 A B C ~?= [(A,C)] ,
    moves 2 A B C ~?= [(A,B),(A,C),(B,C)] ,

    "acceptance test" ~: 
        solve [A, A, A, A, A, A] ~?= [C, C, C, C, C, C] ,

    "is optimal" ~: 
        length (moves 3 A B C) ~?= 7
    ]

Apart from the representation change, I also made moveDisc total by having it return Nothing in case of an invalid move. That way I could trivially implement validMove in terms of it. I do feel like there's a more elegant way to implement moveDisc though.

Note that solve only works if the argument is an initial position. This is also the case for your code (it fails due to incomplete patterns in moveDisc). I return Nothing in this case.

Edit: Added rampion's improved moveDisc and changed the argument ordering to have the data structure last.

Answer 2

If you derive Enum in Column then it is easy to rewrite moveDisk to take arbitrary length lists.

Take the case of (toInt a) < (toInt b) your new tower after the switch is the first (toInt a) - 1 of your initial tower then the bottom part of the second then the distance between a and b of the first, the head of the first cons the second, then the remainder.