Solution to ACM Finals, 2001, Problem B: Say Cheese.

This program uses the Edison library.  Although it is not entirely
standard Haskell, it is included in GHC and Hugs.

> import EdisonPrelude
> import qualified SplayHeap as Q
> import Array
> import List(tails)

> -- begin canned code: Parser-Output monad

> newtype InOut a = InOut {runInOut :: String -> [(a, String, String -> String)]}

> instance Monad InOut where
>   return x = InOut (\s -> [(x,s,id)])
>   m >>= k =
>     InOut (\s -> [(a',t,w.w') | (a,s',w) <- runInOut m s,
>                                 (a',t,w') <- runInOut (k a) s'])
>   fail _ = InOut (\s -> [])

> do_input :: ReadS a -> InOut a
> do_input r = InOut (\s -> [(a,s',id) | (a,s') <- r s])
> input :: (Read a) => InOut a
> input = do_input reads
> putc :: Char -> InOut ()
> putc c = InOut (\s -> [((), s, (c :))])
> puts, putsln :: String -> InOut ()
> puts cs = InOut (\s -> [((), s, (cs ++))])
> putsln s = puts s >> putc '\n'

> make_interact :: InOut a -> String -> String
> make_interact (InOut m) s = case m s of ((_,_,w):_) -> w ""
>                                         _ -> error "inout parse error"

> -- end canned code: Parser-Output monad

Single source shortest distance.
The input graph is an adjacency matrix.

> sssp :: (Ix v, Real d) => Array (v,v) d -> v -> Array v d
> sssp g src = growcore
>              (listArray (n1,n2) [g!(src,v) | v <- range (n1,n2)])
>              (Q.fromSeq [(g!(src,v),v) | v <- range (n1,n2)])
>   where
>   ((n1,_),(n2,_)) = bounds g
>   growcore d f =
>     case Q.minView f of
>       Nothing2 -> d
>       Just2 (dv,v) f' ->
>         let children = [(w,g!(v,w)) | w <- range (n1,n2), w /= v,
>                                       dv+g!(v,w) < d!w]
>             f'' = Q.deleteSeq [(d!w,w) | (w,_) <- children] f'
>             f''' = Q.insertSeq [(dv+e,w) | (w,e) <- children] f''
>             d' = d // [(w, dv+e) | (w,e) <- children]
>         in growcore d' f'''

> triangle op xs = concatMap (maphead op) (tails xs)
>   where maphead op [] = []
>         maphead op xs@(x:_) = map (op x) xs

E.g.,
triangle op [1,2,3,4] = [1 op 1, 1 op 2, 1 op 3, 1 op 4,
                                 2 op 2, 2 op 3, 2 op 4,
                                         3 op 3, 3 op 4,
                                                 4 op 4]


Amelia is the first hole, the male mite is the second hole.

> solve holes = sd!2 * 10.0
>   where n = length holes
>         sd = sssp m 1
>         -- m is the adjacency matrix
>         m = array ((1,1),(n,n)) ms
>         ms = zip (triangle (,) [1..n]) ds ++
>              [((j,i),m!(i,j)) | i <- [1..n], j <- [i+1..n]]
>         ds = triangle distance holes

> distance (x1,y1,z1,r1) (x2,y2,z2,r2)
>   | d < 0 = 0
>   | otherwise = d
>   where d = sqrt (fromIntegral ((x1-x2)^2 + (y1-y2)^2) + (z1-z2)^2) - fromIntegral (r1 + r2)


Main program.

> main' nth = do n <- input
>                if n == -1 then return () else do
>                  holes <- sequence (replicate n (do x <- input
>                                                     y <- input
>                                                     z <- input
>                                                     r <- input
>                                                     return (x,y,z,r)))
>                  amelia <- (do x <- input
>                                y <- input
>                                z <- input
>                                return (x,y,z,0))
>                  male <- (do x <- input
>                              y <- input
>                              z <- input
>                              return (x,y,z,0))
>                  let answer = solve (amelia : male : holes)
>                  putsln ("Cheese " ++ show nth ++ ": Travel time = " ++
>                          show (round answer) ++ " sec")
>                  main' (nth + 1)

> main = interact (make_interact (main' 1))