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.
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.