Skip to content

Instantly share code, notes, and snippets.

@caotic123

caotic123/astar.hs

Last active May 27, 2019 13:43
Show Gist options
  • Save caotic123/9181cf740b3062acb90a4f14c52befba to your computer and use it in GitHub Desktop.
Save caotic123/9181cf740b3062acb90a4f14c52befba to your computer and use it in GitHub Desktop.
Download ZIP
8 puzzle : A* game solver
Raw
astar.hs
import Control.Monad
import Data.Maybe
import qualified Data.Set as Set
import qualified Data.Map.Strict as Map
data Puzzle = Puzzle [Int] Int Int Int deriving Show
heuristic_comp :: [Int] -> Int
heuristic_comp [] = 8
heuristic_comp (x : xs) = do
let k = (heuristic_comp xs)
if (x + (length (x : xs)) == 10) then (k - 1) else k
class A_search k where
goal :: k -> Bool
prof :: k -> Int
fherustic :: k -> Int
nodes :: k -> [Maybe k]
heur :: k -> Int -> Int -> k
instance Ord Puzzle where
compare (Puzzle x y c _) (Puzzle x' y' c' _) = (compare ((heuristic_comp x) + c) ((heuristic_comp x') + c'))
instance Eq Puzzle where
(Puzzle x y _ _) ==( Puzzle x' y' _ _) = (x == x' && y == y')
instance A_search Puzzle where
goal (Puzzle xs _ _ _) = xs == [1, 2, 3, 4, 5, 6, 7, 8, 0]
prof (Puzzle xs _ _ p) = p
fherustic (Puzzle xs _ _ _) = heuristic_comp xs
nodes k = swap k
heur k q i = heuristic k q i
data Swap_Pos a = Swap_Pos [(a -> a)]
split_t :: Int -> Int -> [a] -> [a]
split_t x y t = fst (splitAt y (snd (splitAt x t)))
index_ :: Int -> [a] -> a
index_ i xs = head (split_t (i - 1) i xs)
swap :: Puzzle -> [Maybe Puzzle]
swap (Puzzle xs i j q) = [
if ((i - 4) >= 0) then
Just (Puzzle
((split_t 0 (i - 4) xs) ++ [index_ i xs] ++ (split_t (i - 3) 2 xs) ++ [index_ (i - 3) xs] ++ ((split_t i ((length xs) - i) xs)))
(i - 3) j q)
else Nothing, -- Top Rotate
if ((i + 3) <= (length xs)) then
Just (Puzzle
((split_t 0 (i - 1) xs) ++ [index_ (i + 3) xs] ++ (split_t i 2 xs) ++ [index_ i xs] ++ ((split_t (i + 3) ((length xs) - (i + 3)) xs)))
(i + 3) j q)
else Nothing, -- Down
if ((mod i 3) /= 0 && (i + 1) <= (length xs)) then
Just (Puzzle
((split_t 0 (i -1) xs) ++ [index_ (i + 1) xs] ++ [index_ i xs] ++ (split_t (i + 1) ((length xs) - (i +1)) xs))
(i + 1) j q)
else Nothing, -- Right Rotate
if ((mod (i - 1) 3) /= 0 && (i - 1) >= 0) then
Just (Puzzle
((split_t 0 (i - 2) xs) ++ [index_ i xs] ++ [index_ (i - 1) xs] ++ (split_t i ((length xs) - i) xs))
(i - 1) j q)
else Nothing -- Left Rotate
]
heuristic (Puzzle k i l q) p q' = (Puzzle k i p q')
expand_node m = (Prelude.foldl (\x -> \y -> case y of
Just y' -> ((heuristic y' 0) : x)
Nothing -> x)
[] m)
get_lis_puzzle (Puzzle xs _ _ _) = xs
print_puzzle xs = foldM_ (\x -> \y -> (show_puzzle (get_lis_puzzle y)) >>= (\a -> putStrLn " ----- " >> return a)) [] xs
where
show_puzzle :: (Show a) => [a] -> IO ([a])
show_puzzle [] = return []
show_puzzle xs = do
let puzzle_list = (split_t 3 (length xs) xs)
putStrLn (print_t xs)
v <- show_puzzle puzzle_list
return xs
print_t [] = ""
print_t (x : (y : (z : xs))) = " " ++ (show x) ++ " " ++ (show y) ++ " " ++ (show z)
expand k = expand_node (swap k)
discard_keys [] = []
discard_keys ((x, k) : xs) = k : discard_keys xs
a_star :: Puzzle -> IO ()
a_star k = do
let v' = (heuristic k 0 (heuristic_comp (get_lis_puzzle k)))
print_puzzle (search_a (Set.insert v' Set.empty))
where
search_a :: A_search a => Ord a => (Set.Set a) -> [a]
search_a ls
| (Set.size ls > 0) = do
let current = (Set.findMin ls)
if (goal current)
then [current]
else (current : (search_a (succ (nodes current) (Set.delete current ls) ((prof current) + 1))))
| otherwise = []
where
succ (y : ls) k i = case y of
Just y -> do
(Set.insert (heur y (i + fherustic y) i) (succ ls k i))
Nothing -> succ ls k i
succ [] k i = k
main :: IO ()
main = do
let i = 5 -- pos of 0 in list
let puzzle_i = (Puzzle [1, 2, 3, 4, 0, 5, 7, 8, 6] i 0 0)
a_star puzzle_i
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment