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
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
import Control.Monad as M (foldM)
import Control.Monad.ST
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Data.HashMap.Strict as HM
import Data.HashSet as HS
import Data.List as L
import Data.Tuple as T
import Prelude
import Prelude as P (filter, foldl, map, read, take)
import Data.Vector.Mutable as V
type Node = (Int,Int)
type Blocked = HS.HashSet Node
type Visited = HM.HashMap Node Int
type Frontier s = BucketQueue s Node
data BucketQueue s a = BQ Int (V.MVector s [a])
data PathingResult s = Success Int | Fail | Working (Frontier s, Visited)
insert :: BucketQueue s a -> (Int,a) -> ST s (BucketQueue s a)
insert (BQ top buckets) (prio,x) =
V.modify buckets (x:) prio >> return (BQ (min top prio) buckets)
view :: BucketQueue s a -> MaybeT (ST s) (a, BucketQueue s a)
view (BQ top buckets) = do
(x, xs) <- V.read buckets top >>= hoistMaybe . L.uncons
lift $ V.write buckets top xs
top' <- lift $ findTop top buckets
return (x, BQ top' buckets)
findTop :: Int -> V.MVector s [a] -> ST s Int
findTop n v = do
top <- V.read v n
case top of
[] -> if n < V.length v - 1 then findTop (n+1) v else return n
_ -> return n
newBQ :: Int -> ST s (BucketQueue s a)
newBQ n = BQ n <$> V.replicate n []
neighbours :: Node -> [Node]
neighbours (x,y) = [ (x+1,y)
, (x-1,y)
, (x,y+1)
, (x,y-1)
]
expand :: Int -> Blocked -> Node -> [Node]
expand coordMax blocked = P.filter p . neighbours
where
p :: Node -> Bool
p n@(x,y) = not (HS.member n blocked)
&& min x y >= 0 && max x y <= coordMax
crowDistance :: Node -> Node -> Int
crowDistance (x0,y0) (x1,y1) =
let a = fromIntegral $ x0 - x1 :: Double
b = fromIntegral $ y0 - y1 :: Double
in floor $ sqrt (a**2 + b**2)
cost :: Visited -> Node -> Int
cost = (HM.!)
betterPath :: Visited -> Node -> Node -> Int
betterPath visited through node
| HM.member node visited =
min (cost visited node) (cost visited through + 1)
| otherwise = cost visited through + 1
heuristic :: Node -> (Node,Int) -> (Node,Int)
heuristic goal (p,c) = (p, c + crowDistance p goal)
pathingStep :: Int
-> Node
-> Blocked
-> Visited
-> Frontier s
-> ST s (PathingResult s)
pathingStep coordMax goal blocked visited frontier =
runMaybeT (view frontier) >>= maybe (return Fail) continue
where
continue (current, rest)
| current == goal = return . Success $ cost visited current
| otherwise = do
let nexts = expand coordMax blocked current
let nextsCosts = P.map (betterPath visited current) nexts
let visited' = P.foldl (flip $ uncurry HM.insert) visited
$ zip nexts nextsCosts
frontier' <- M.foldM Main.insert rest
. P.map (T.swap . heuristic goal)
. P.filter (not . (`HM.member` visited) . fst)
$ zip nexts nextsCosts
return $ Working (frontier', visited')
findDistance :: Int -> Blocked -> ST s Int
findDistance coordMax blocked = do
let start = (0,0)
let goal = (coordMax, coordMax)
let visited = HM.insert start 0 HM.empty
frontier <- newBQ (coordMax ^ (2 :: Int)) >>= flip Main.insert (0, start)
loop goal visited frontier
where
loop :: Node -> Visited -> Frontier s -> ST s Int
loop g v f = do
once <- pathingStep coordMax g blocked v f
case once of
Success x -> return x
Fail -> error "no path"
Working (f',v') -> loop g v' f'
parsePoint :: String -> Node
parsePoint s = P.read $ '(' : s ++ ")"
parse :: String -> [Node]
parse = P.map parsePoint . lines
main :: IO ()
main = do
input <- getContents
let blocked = HS.fromList . P.take 1024 $ parse input
print $ runST $ findDistance 70 blocked
|
