1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
| {-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances, ViewPatterns #-}
import Control.Monad
import Data.List
import Data.Maybe
import Data.Function
import qualified Data.Sequence as Seq
import qualified Data.Map as M
import qualified Data.MultiSet as SS
import System.Environment
import System.IO
type State = [Int]
target = [1..8]++[0] :: State
target' = fromEnum target
factorials = 1 : scanl1 (*) [1..]
instance Enum State where
fromEnum a = (\(_,_,acc) -> acc) $ foldr (\x (i,l,acc) ->
(i+1,x:l,acc+(factorials!!i)*length (filter (<x) l))) (0,[],0) a
toEnum acc = unfoldr (\(i,l,acc) ->
if i < 0 then Nothing
else let (q,r) = acc `divMod` (factorials !! i)
x = l !! q
in Just (x, (i-1,delete x l,r))
) (8,[0..8],acc)
moves :: State -> [State]
moves s = [ map (\x -> if x == 0 then s!!pos' else if x == s!!pos' then 0 else x) s
| d <- [-1,3,1,-3]
, not $ pos `mod` 3 == 0 && d == (-1)
, not $ pos `mod` 3 == 2 && d == 1
, let pos' = pos + d
, not $ pos' < 0 || pos' >= 9
]
where
pos = fromJust $ findIndex (==0) s
solve :: (State -> M.Map Int Int) -> State -> IO ()
solve strategy src = do
let ss = if fromEnum src == target' then M.singleton 0 (-1) else strategy src
if odd (inverse (delete 0 src) - inverse (delete 0 target))
then hPutStrLn stderr "no solution"
else getArgs >>= \args -> if (elem "-g" args)
then do
putStrLn "digraph {"
forM_ (nub $ M.keys ss) $ \s ->
putStrLn $ show s ++ " [shape=record" ++
(if s == fromEnum src
then ",style=filled,color=orange"
else if s == fromEnum target
then ",style=filled,color=orchid"
else "") ++ ",label=\""++label s++"\"];"
forM_ (filter ((/=fromEnum src) . fst) $ M.toList ss) $ \(s,p) ->
putStrLn $ show p ++ "->" ++ show s ++ ";"
putStrLn "}"
else
hPutStrLn stderr $ "minimum steps: " ++ show (pathLen (fromEnum target) ss)
where
label = intercalate "|" . map (('{':).(++"}") . intersperse '|' . concatMap show . map snd) . transpose . groupBy ((/=) `on` fst) . zip (cycle [1..3]) . (toEnum :: Int -> State)
pathLen s m | s == fromEnum src = 0
| otherwise = 1 + pathLen (fromJust $ M.lookup s m) m
inverse = snd . foldr (\x (l,acc) -> (x:l,acc+length(filter(<x)l))) ([],0)
search :: (t -> (s, t)) -> (s -> State) -> ((s, t) -> [State] -> t) -> t -> M.Map Int Int -> M.Map Int Int
search extract transform merge open closed
| isJust $ find (==target') suc' = closed'
| otherwise = search extract transform merge (merge (h,open') suc) closed'
where
(h,open') = extract open
suc = filter (not . flip M.member closed . fromEnum) . moves $ transform h
suc' = map fromEnum suc
closed' = M.union closed . M.fromList . zip suc' . repeat . fromEnum $ transform h
bfs :: State -> M.Map Int Int
bfs src = search extract id merge (Seq.singleton src) $ M.singleton (fromEnum src) (-1)
where
extract = (\(h Seq.:< t) -> (h, t)) . Seq.viewl
merge (h,open') suc = open' Seq.>< Seq.fromList suc
astar :: State -> M.Map Int Int
astar src = search extract snd merge (SS.singleton (heuristic src, src)) $ M.singleton (fromEnum src) (-1)
where
extract = fromJust . SS.minView
merge ((c,p),open') suc = SS.union open' $ SS.fromList $ map (\q -> (c - heuristic p + 1 + heuristic q, q)) suc
heuristic = sum . map (\(x,y) -> distance x (y-1)) . filter ((/=0) . snd) . zip [0..]
where
distance p q = abs (x1-x2) + abs (y1-y2)
where
(x1,y1) = p `divMod` 3
(x2,y2) = q `divMod` 3
main = do
line <- getLine
##ifdef BFS
solve bfs $ map (read . return) line
##else
solve astar $ map (read . return) line
##endif
|