gistfile1.txt

type Coord = (Int, Int)
type Grid = Map.Map Coord Char
data Instr = F Int | L | R deriving (Show, Eq)

type Delta = (Int, Int)
-- When we step onto these squares in this direction, where do we show up?
type JumpMap = Map.Map (Coord, Delta) (Coord, Delta)

constructTorusMap :: Grid -> JumpMap
constructTorusMap g = (do
    (x, y) <- Map.keys g
    (dx, dy) <- orthogonalMoves
    let
      (nx, ny) = (x + dx, y + dy)
    case Map.lookup (nx, ny) g of
      Just _ -> fail "no jump required"
      Nothing -> do return (((nx, ny),(dx, dy)), (wrap (x, y) (-dx, -dy), (dx, dy)))
  ) & Map.fromList
  where
  wrap :: Coord -> Delta -> Coord
  wrap (x, y) (dx, dy) = iterate (\(x, y) -> (x + dx, y + dy)) (x, y)
                       & takeWhile (`Map.member` g)
                       & last

password (x, y) (dx, dy) = 1000 * y + 4 * x + facing (dx, dy)
  where
  facing (1, 0) = 0
  facing (0, 1) = 1
  facing (-1, 0) = 2
  facing (0, -1) = 3

walk :: Grid -> JumpMap -> (Coord, Delta) -> Instr -> (Coord, Delta)
walk g j ((x, y), (dx, dy)) L = ((x, y), (dy, -dx))
walk g j ((x, y), (dx, dy)) R = ((x, y), (-dy, dx))
walk g j ((x, y), (dx, dy)) (F 0) = ((x, y), (dx, dy))
walk g j ((x, y), (dx, dy)) (F n) =
  let
    (x', y') = (x + dx, y + dy)
    ((x1, y1), (dx1, dy1)) =     if Map.member (x', y') g then ((x', y'), (dx, dy))
                                 else j Map.! ((x', y'), (dx, dy))
  in
    if g Map.! (x1, y1) == '.' then walk g j ((x1, y1), (dx1, dy1)) (F (n - 1))
    else ((x, y), (dx, dy))
  

data Corner = Inner | Straight | Outer deriving (Show, Eq)

constructCubeMap :: Grid -> JumpMap
constructCubeMap g =
  Map.unions $ do
  -- First, we locate an internal corner space (ie, adjacent to two members of the grid)
    (cx, cy) <- locateCorners
    
    let ((x1, y1), (x2, y2)) = neighbours (cx, cy)
    
    -- the direction to move the ((x1, y1), (cx, cy)) on-off pair in the circuit
        path1 = traceOutside (x1, y1) (cx, cy) (cx - x2, cy - y2)
        path2 = traceOutside (x2, y2) (cx, cy) (cx - x1, cy - y1)

    -- merge those two paths until we hit an (Outer, Outer) corner pair
    -- we have to stop zipping up sides on the (Outer, Outer) pair because the net edges those lead into
    -- are not congruent
        pairs = zip path1 path2
              & takeWhile (\((_,_,_,c1), (_,_,_,c2)) -> c1 /= Outer || c2 /= Outer)

    -- construct a piece of a Jumpmap from hopping from path1 to path2
        jm1 = makeJumpMap pairs
    -- and in the other direction
        jm2 = makeJumpMap (map swap pairs)
    
    return $ Map.union (Map.fromList jm1) (Map.fromList jm2)

  where

  -- locate inner corners
  locateCorners :: [Coord]
  locateCorners = do
    let ((minX, maxX), (minY, maxY)) = boundMap g
    x <- [minX - 1..maxX + 1]
    y <- [minY - 1..maxY + 1]
    guard $ not $ Map.member (x, y) g
    let ns = [(x + dx, y + dy) | (dx, dy) <- orthogonalMoves]
           & filter (`Map.member` g)
    guard $ length ns == 2
    return (x, y)

  -- work out the two neighbour cells of this empty inner corner.
  neighbours (cx, cy) =
    let
      [(x1, y1), (x2, y2)] = [(cx + dx, cy + dy) | (dx, dy) <- orthogonalMoves] & filter (`Map.member` g)
      (dx1, dy1) = (x1 - cx, y1 - cy)
      (dx2, dy2) = (x2 - cx, y2 - cy)
    in
      if (dx1 * dy2 - dx2 * dy1) > 0 then ((x1, y1), (x2, y2)) else ((x2, y2), (x1, y1))      
  
  -- trace an outside path all the way around
  -- inside, outside, and the direction in which we want to start circling the edge of the grid
  traceOutside :: Coord -> Coord -> Delta -> [(Coord, Coord, Delta, Corner)]
  traceOutside inner outer direction =
    let
      start = (inner, outer, direction, Inner)
      circuit = iterate stepAround start
      oneCircuit = circuit & drop 1 & takeWhile (/= start)
    in
      [start] ++ oneCircuit
  
  -- move around the grid one place. Report whether we've taken an inner or outer corner, or just moved straight
  stepAround :: (Coord, Coord, Delta, Corner) -> (Coord, Coord, Delta, Corner)
  stepAround ((x, y), (cx, cy), (dx, dy), _) =
    let
      -- if we keep going in the same direction, is all okay?
      (x', y') = (x + dx, y + dy)
      onGridXY' = Map.member (x', y') g
      (cx', cy') = (cx + dx, cy + dy)
      onGridCXY' = Map.member (cx', cy') g
    in
      case (onGridXY', onGridCXY') of
        -- a straight edge
        (True, False) -> ((x',y'), (cx', cy'), (dx, dy), Straight)
        -- an outer corner
        (False, False) -> ((x, y), (x', y'), (x - cx, y - cy), Outer)
        -- an inner corner
        (True, True) -> ((cx', cy'), (cx, cy), (cx - x, cy - y), Inner)

  makeJumpMap :: [((Coord, Coord, Delta, Corner), (Coord, Coord, Delta, Corner))] -> [((Coord, Delta), (Coord, Delta))]
  makeJumpMap pairs = do
    (((x1, y1), (cx1, cy1), _, _), ((x2, y2), (cx2, cy2), _, _)) <- pairs
    -- when we step from (x1, y1) onto (cx1, cy1), we jump directly to (x2, y2) as through coming from (cx2, cy2)
    return (((cx1, cy1), (cx1 - x1, cy1 - y1)), ((x2, y2), (x2 - cx2, y2 - cy2)))