FF13_2_DialFacePuzzle.hs

module FF13_2_DialFacePuzzle where

import Control.Monad (MonadPlus, msum)
import Text.Printf (printf)
import System.Environment (getArgs)
import Debug.Trace (trace)

type Graph = ([Int], [(Int, Int)])

--
-- searcing

dialToGraph :: [Int] -> Graph
dialToGraph dial = ([0..size-1], arrows)
  where
    size = length dial
    getArrow (index, number) =
      let a = (index - number) `mod` size
          b = (index + number) `mod` size in
      if a == b then [(index, a)] else [(index, a), (index, b)]
    arrows = concat $ map getArrow $ zip [0..] dial


-- http://www.shido.info/hs/haskell9.html

find_next :: Int -> Graph -> [Int]
find_next k gr = map snd $ filter ((==k) . fst) (snd gr)

dfs :: MonadPlus m => Graph -> m [Int]
dfs graph = msum $ map (\p -> dfs_aux graph p (length ps) []) ps
  where ps = fst graph

dfs_aux :: MonadPlus m => Graph -> Int -> Int -> [Int] -> m [Int]
dfs_aux graph p0 count path
  | count == 1 = return (reverse $ p0:path)
  | otherwise = {- trace (unwords $ [show p0, show count, show path]) $ -}
                msum $
                map (\p -> dfs_aux graph p (count - 1) (p0:path))
                [x | x <- find_next p0 graph, not (x `elem` path)]

--
-- visualize

radius :: Float
radius = 2

genPos :: Int -> Int -> (Float, Float)
genPos n m = (radius * cos angle, radius * sin angle)
  where angle = pi / 2 - 2 * pi * (fromIntegral n / fromIntegral m)

type Node = (Int, Int, (Float, Float)) -- (index, label, pos)
type Arrow = (Int, Int) -- (node, node)

nodes :: [Int] -> [Node]
nodes ls = [(i, l, genPos i $ length ls) | (i, l) <- zip [0..] ls]

showNode :: Node -> String
showNode (i, l ,(x, y)) =
  printf "  %d [label = \"%d\" pos = \"%.2f,%.2f!\"];" i l x y

showArrow :: Arrow -> String
showArrow (from, to) = printf "%d -> %d;" from to

showHead :: Maybe [Int] -> String
showHead (Just (h:_)) = printf "  %d [shape = doublecircle];" h
showHead Nothing = ""

pathToArrows :: Maybe [Int] -> [Arrow]
pathToArrows (Just ns) = zip ns $ tail ns
pathToArrows Nothing = []


--
-- main

main :: IO ()
main = do
  dial <- fmap (map read) getArgs
  let path = dfs $ dialToGraph dial
      arrows = pathToArrows path
  putStrLn "digraph dial {"
  putStrLn "  node [shape = circle];"
  putStrLn $ showHead path
  mapM_ (putStrLn . showNode) $ nodes dial
  mapM_ (putStrLn . showArrow) $ arrows
  putStrLn "}"