slowly Haskell code for Slide Puzzle of Google DevQuiz

devquizslide.hs

{-
devquizslide

date : 2011 
author : Katsumi ISHIDA (isis331) 

output sample
>runghc ./devquizslide.hs  True 30 3 3 168452=30
[(9,6),(6,3),(3,2),(2,5),(5,6),(6,3),(3,2),(2,1),(1,4),(4,5),(5,6),(6,9),(9,8),(8,5),(5,4),(4,1),(1,2),(2,3),(3,6),(6,9),(9,8),(8,5),(5,2),(2,3),(3,6),(6,9)]


-}

import System
 
--------------------
--
swap_elm  		:: Int -> Int -> [a] -> [a]
swap_elm x y d@(c:cs) = swap_elm' x y swxc swyc d
	where 
		swxc = d!!(x-1)
		swyc = d!!(y-1)
		swap_elm'  		:: Int -> Int -> a -> a -> [a] -> [a]
		swap_elm' x  y    swxc swyc [] = []
		swap_elm' 0  0    swxc swyc d@(c:cs) =    c : swap_elm' 0 0 swxc swyc cs
		swap_elm' 0  1    swxc swyc d@(c:cs) = swxc : swap_elm' 0 0 swxc swyc cs
		swap_elm' 0  y    swxc swyc d@(c:cs) =    c : swap_elm' 0 (y - 1) swxc swyc cs
		swap_elm' 1  y    swxc swyc d@(c:cs) = swyc : swap_elm' 0 (y - 1) swxc swyc cs
		swap_elm' x  y    swxc swyc d@(c:cs) =    c : swap_elm' (x - 1) (y - 1) swxc swyc cs
--
sort	:: (Ord a) => [a] -> [a]
sort (x:xs) = lr ++ x:gr
	where	
		lr = sort [ y | y <- xs, y < x]
		gr = sort [ y | y <- xs, y >= x]		
sort _ = []
--
lesserByLength :: [a] -> [a] -> Bool
lesserByLength [] [] = False
lesserByLength xs [] = False
lesserByLength [] ys = True
lesserByLength (x:xs) (y:ys) = lesserByLength xs ys
--
fsort :: (a -> a -> Bool) -> [a] -> [a]
fsort f (x:xs) = lesser ++ x:greater
	where
		lesser = fsort f [y| y <- xs, (f y x) ]
		greater = fsort f [y| y <- xs, not (f y x) ]
fsort f [] = []

--
findpos	:: Eq a => a -> [a] -> Int
findpos x [] = 0
findpos x (y : ys) 	| x == y = 1
					| otherwise = 1 + findpos x ys
--
get_eqs_pos 	:: [Char] -> [Int]
get_eqs_pos cs = get_eqs_pos_ 0 cs 
	where
		get_eqs_pos_ 	:: Int -> [Char] -> [Int]
		get_eqs_pos_ pos [] = []
		get_eqs_pos_ pos (c : cs)	
				| c == '=' = (pos+1) : get_eqs_pos_ (pos + 1) cs
				| otherwise = get_eqs_pos_ (pos + 1) cs
--							
erase_eqs :: [Char] -> [Char]
erase_eqs [] = []
erase_eqs (c:cs) | c == '=' = erase_eqs cs
				| c == '0' = erase_eqs cs
				| otherwise = c : erase_eqs cs
--				
insert_eqs 	:: [Int] -> [Char] -> [Char]
insert_eqs ps cs = insert_eqs_ 1 ps cs 
	where
		insert_eqs_ :: Int -> [Int] -> [Char] -> [Char]
		insert_eqs_ pos ps [] = [] -- error
		insert_eqs_ pos [] cs = cs ++ ['0']
		insert_eqs_ pos (p:ps) str@(c:cs) 
								| pos == p = '=' : insert_eqs_ (pos+1) ps str 	
								| otherwise = c : insert_eqs_ (pos+1) (p:ps) cs			
--								
getgoal	:: [Char] -> [Char]
getgoal [] = []
getgoal str@(x : xs) 	 = insert_eqs eqspos (sort (erased))
	where 
		eqspos = get_eqs_pos str
		erased = erase_eqs str
--
get_goal_permutation_ :: [Char] -> [Char] -> Int -> [Int]
get_goal_permutation_ [] gs k = []
get_goal_permutation_ (x : xs) gs k  
		| x == '=' = (k+1): (get_goal_permutation_ xs gs (k+1))
		| otherwise = (findpos x gs) : (get_goal_permutation_ xs gs (k+1))
									
get_permutation pattern1 pattern2 = get_goal_permutation_ pattern1 pattern2 0

get_goal_permutation pattern = get_permutation pattern (getgoal pattern)

--
find_positions :: Ord a => [(a,a)] -> a -> [Int]
find_positions [] x = []
find_positions path x = reverse (find_positions' path x 1 [])
	where 
		find_positions' [] x pos acc = acc
		find_positions' path@(p@(f,s):ps) x pos acc 	
			| x == s 	= find_positions' ps x (pos+1) (pos : acc)
			| otherwise = find_positions' ps x (pos+1) acc

--						
check_skippath :: [[Int]] -> [Int] -> Bool
check_skippath [] ps = False
check_skippath ctss@(ts:tss) ps = or (map (check) ctss) 
	where
		-- matchhead_ :: [Int] -> [Int] -> Bool
		matchhead_ [] [] = True
		matchhead_ ps [] = True
		matchhead_ [] ts = False
		matchhead_ (p:ps) (t:ts) 
				| p == t 	= matchhead_ ps ts 
				| otherwise = False
		check ts = (matchhead_ ps ts)
--
transpositions_tpl	:: Int -> Int -> [Char] -> [(Int,Int)]
transpositions_tpl x y xs = 
	[ (p,q) | 
	p <- [1 .. (x * y)], (xs!!(p-1)) /= '=', 
	q <- [1 .. (x * y)], (xs!!(q-1)) /= '=', 
	(  ((p == q + 1) && (q `mod` x) /= 0)
	|| ((p == q - 1) && (p `mod` x) /= 0)
	|| (p == q-x) 
	|| (p == q+x)) 
	]

-- 
make_transpositions_tpl_seq :: Int -> [(Int,Int)] -> Int -> [[(Int,Int)]]
make_transpositions_tpl_seq d transs start 
	= (map_ (make_transpositions_tpl_seq' d transs) (make_start_transpositions start))
	where 
		-- make_skippathpattern_sub :: Int -> [Int]
		make_skippathpattern_sub t = map ((*)(t)) [1..2]
		
		-- make_skippathpattern :: Int -> Int -> [[Int]]
		make_skippathpattern {- x y -} = map make_skippathpattern_sub [4..80]
		
		cts = make_skippathpattern {- x y -}
		
		--make_next :: (a,a) -> [(a,a)]
		make_next previous@(p@(prev,start):ps)  
			= [ (p,q) | (p,q) <- transs, p == start && q /= prev, not (check_skippath cts (find_positions previous q)) ]
		
		-- make_next_lst :: [(a,a)] -> [[(a,a)]]
		make_next_lst prev@(p:ps) = map (:prev) (make_next prev)
		
		make_next_lst_first prev@(p:ps) = map (:[]) (make_next prev)
				
		make_start_transpositions start =  map_ (\x->[x])  (make_next_lst_first [(0,start)])

		-- map_ :: ([a] -> [[a]]) -> [[a]] -> [[a]]
		map_ f [] = []
		map_ f (x:xs) = (f x) ++ (map_ f xs) 
		
		-- make_transpositions_tpl_seq' :: Int -> [(a,a)] -> [(a,a)] -> [[(a,a)]]
		make_transpositions_tpl_seq' 0 transs prev = [] 
		make_transpositions_tpl_seq' d transs prev 
			= (map reverse (make_next_lst prev)) ++ (map_ (make_transpositions_tpl_seq' (d-1) transs) (make_next_lst prev))
--				
make_transpositions_tpl_seq_from_pattern :: Int -> Int -> Int -> [Char] -> [[(Int,Int)]]
make_transpositions_tpl_seq_from_pattern d x y pattern =
	make_transpositions_tpl_seq d (transpositions_tpl x y pattern) st
	where 
		st = findpos '0' pattern
	
--
solve_by_transpositions_tpl_seq :: Bool -> Int -> Int -> Int -> [Char] -> [(Int,Int)]
solve_by_transpositions_tpl_seq bydepth d x y pattern
	| bydepth = map_ (check_ start) pathlist
	| otherwise = map_ (check_ start) (fsort lesserByLength pathlist)
	where 
		st = findpos '0' pattern

		start = get_goal_permutation pattern
		goal = [1..(x*y)]
		
		moves :: [a] -> [(Int,Int)] -> [a]
		moves per path@(p0@(fst0,snd0):[]) = (swap_elm (min fst0 snd0) (max fst0 snd0) per)
		moves per path@(p0@(fst0,snd0):p1@(fst1,snd1):ps) 
					| fst0 /= fst1 = moves (swap_elm (min fst0 fst1) (max fst0 fst1) per) (p1:ps)
					| otherwise = moves per (p1:ps)
		
		check_ start path 
					| goal == (moves start path) = path
					| otherwise = []
				
		map_ f [] = []
		map_ f (x:xs) 
					| r == [] =  map_ f xs 
					| otherwise = r
			where r = f x
		pathlist = (make_transpositions_tpl_seq_from_pattern d x y pattern)
				



--------------------
main :: IO ()
main = do 
	args <- getArgs
	if ((length args) < 5) 
		then 
			print "runghc ./devquizslide.hs bydepth depth w h pattern"
		else
			print (solve_by_transpositions_tpl_seq (read (args!!0)::Bool) (read (args!!1)::Int) (read (args!!2)::Int)  (read (args!!3)::Int) (args!!4))