Solvo de Turoj de Hanoï en Haskell

Eble.hs

  {-# LANGUAGE PatternSynonyms #-}

module Esperanto.Eble where

import qualified Data.Maybe as Maybe

type Eble      = Maybe.Maybe
pattern Jxus a = Just a
pattern Nenio  = Nothing

--  vim: set sts=2 ts=2 sw=2 tw=120 et :

h-anoi.hs

import Data.List

import Esperanto.Eble

data Bloko = Bloko { index::Int }
  deriving (Eq, Ord)

instance Show Bloko where
  show (Bloko i) = show i

data Etikedo = D | I | A
  deriving (Eq, Show)

type BlokTuro = [Bloko]

data Turo  = Turo Etikedo
  deriving (Eq, Show)

data Movo = Movo {from::Turo, to::Turo}
  deriving Show

data Hanoi = Hanoi BlokTuro BlokTuro BlokTuro
  deriving Show

hanoiKrei :: Int -> Hanoi
hanoiKrei n = Hanoi (map Bloko [1..n]) [] []

hanoiPresi :: Hanoi -> IO ()
hanoiPresi h@(Hanoi t1 t2 t3) = sequence_ $ map (print . reverse) $ [t1, t2, t3]

presiSinsekvoDeHanoiajStatoj :: [Hanoi] -> IO ()
presiSinsekvoDeHanoiajStatoj hs = sequence_ $ interaj_hanoiaj_presoj ++ [hanoiPresi (last hs)]
  where
    interaj_hanoiaj_presoj = map presi_intera_hanoi (init hs)
    presi_intera_hanoi  = (\ h -> hanoiPresi h >> putStrLn  "+++++")

-------------
--  Solvo  --
-------------

solvi :: Int -> [Movo]
solvi n = pasxi n (Turo D) (Turo I) (Turo A)

pasxi :: Int -> Turo -> Turo -> Turo -> [Movo]
pasxi 0 _  _  _  = []
pasxi n t1 t2 t3 = mdksMovoj ++ [Movo {from=t1, to=t3}] ++ dksMovoj
  where
    mdksMovoj  = pasxi (n-1) t1 t3 t2
    dksMovoj = pasxi (n-1) t2 t1 t3

movi :: Hanoi -> [Movo] -> Hanoi
movi h ms = foldl' moveit h ms
  where moveit h m = case (movi1 h m) of
                       Jxus x -> x
                       Nenio -> h

movi1 :: Hanoi -> Movo -> Eble Hanoi

movi1 (Hanoi [] t2 t3)      (Movo (Turo D)        _) = Nenio
movi1 (Hanoi (b:t1) t2 t3)  (Movo (Turo D) (Turo I)) = Jxus $ Hanoi t1 (b:t2) t3
movi1 (Hanoi (b:t1) t2 t3)  (Movo (Turo D) (Turo A)) = Jxus $ Hanoi t1 t2 (b:t3)

movi1 (Hanoi t1 [] t3)      (Movo (Turo I) (Turo D)) = Nenio
movi1 (Hanoi t1 (b:t2) t3)  (Movo (Turo I) (Turo D)) = Jxus $ Hanoi (b:t1) t2 t3
movi1 (Hanoi t1 (b:t2) t3)  (Movo (Turo I) (Turo A)) = Jxus $ Hanoi t1 t2 (b:t3)

movi1 (Hanoi t1 t2 [])      (Movo (Turo A) (Turo D)) = Nenio
movi1 (Hanoi t1 t2 (b:t3))  (Movo (Turo A) (Turo D)) = Jxus $ Hanoi (b:t1) t2 t3
movi1 (Hanoi t1 t2 (b:t3))  (Movo (Turo A) (Turo I)) = Jxus $ Hanoi t1 (b:t2) t3
movi1 h (Movo a b)
  | a == b = Jxus h
  | otherwise = Nenio

--  vim: set sts=2 ts=2 sw=2 tw=120 et :

Jen ekzemplo de rulo de ĉi tiu programo:

*Main> let l = 4
*Main> presiSinsekvoDeHanoiajStatoj $ scanl' (\ _ i -> movi (hanoiKrei l) (take i $ solvi l)) (hanoiKrei l) [1..2^l-1]
[4,3,2,1]
[]
[]
+++++
[4,3,2]
[1]
[]
+++++
[4,3]
[1]
[2]
+++++
[4,3]
[]
[2,1]
+++++
[4]
[3]
[2,1]
+++++
[4,1]
[3]
[2]
+++++
[4,1]
[3,2]
[]
+++++
[4]
[3,2,1]
[]
+++++
[]
[3,2,1]
[4]
+++++
[]
[3,2]
[4,1]
+++++
[2]
[3]
[4,1]
+++++
[2,1]
[3]
[4]
+++++
[2,1]
[]
[4,3]
+++++
[2]
[1]
[4,3]
+++++
[]
[1]
[4,3,2]
+++++
[]
[]
[4,3,2,1]