-------------------------------------------------------------------------------

newEditorMode :: Resources -> IO Mode
newEditorMode resources = do
  view <- newEditorView resources
  stateRef <- newEditorState resources >>= newIORef
  let

    mode EvQuit = do
      unsaved <- fmap esUnsaved $ readIORef stateRef
      if not unsaved then return DoQuit else
        return DoQuit -- TODO offer to save terrain
    mode (EvKeyDown KeyR [KeyModCmd] _) = do
      es <- readIORef stateRef
      ChangeMode <$> newTextEntryDialogMode
        resources "Enter new map dimensions:"
        (let (w, h) = tmapSize (esTerrain es) in show w ++ "x" ++ show h)
        (const True) (return mode) doResize view es
    mode (EvKeyDown KeyH [KeyModCmd] _) = do
      es <- readIORef stateRef
      ChangeMode <$> newTextEntryDialogMode resources
        "Enter shift delta:" "0,0" (const True) (return mode) doShift view es
    mode event = do
      when (event == EvTick) $ modifyIORef stateRef tickEditorState
      es <- readIORef stateRef
      action <- handleScreen $ viewHandler view es event
      when (event == EvTick) $ paintScreen (viewPaint view es)
      case fromAction action of
        Nothing -> return SameMode
        Just (JumpMapTo pos) -> alterState $
          es { esCameraTopleft =
                 round <$> (positionCenter pos `pSub` cameraCenterOffset) }
        Just (ScrollMap delta) -> alterState $
          es { esCameraTopleft = esCameraTopleft es `pAdd` delta }
        Just (ScrollPalette top) -> alterState $
          es { esPaletteTop = max 0 top }
        Just (PickTile tile) -> alterState es { esBrush = tile }
        Just (AutoPaintAt pos) -> do
          let brush = autoPaintTile (esTileset es) (esTerrain es) pos
          when (ttId (tmapGet (esTerrain es) pos) /= ttId brush) $ do
            let terrain' = tmapSet [pos] brush (esTerrain es)
            updateMinimapFromTerrainMap (esMinimap es) terrain' [pos]
            setTerrain es terrain'
          return SameMode
        Just (PaintAt pos) -> do
          when (ttId (tmapGet (esTerrain es) pos) /= ttId (esBrush es)) $ do
            let terrain' = tmapSet [pos] (esBrush es) (esTerrain es)
            updateMinimapFromTerrainMap (esMinimap es) terrain' [pos]
            setTerrain es terrain'
          return SameMode
        Just (FloodFill pos) -> do
          when (ttId (tmapGet (esTerrain es) pos) /= ttId (esBrush es)) $ do
            let (terrain', filled) = floodFill pos (esBrush es) (esTerrain es)
            updateMinimapFromTerrainMap (esMinimap es) terrain' filled
            setTerrain es terrain'
          return SameMode
        Just (ChangeMarks pos) -> do
          ChangeMode <$> newTextEntryDialogMode
            resources ("Set marks for " ++ show pos ++ ":")
            (intercalate "," $ Set.toList $ tmapGetMarks pos $ esTerrain es)
            (const True) (return mode) (doSetMarks pos) view es
        Just (ChangeRects pos) -> do
          ChangeMode <$> newTextEntryDialogMode
            resources ("Set rect:")
            (maybe ("R:" ++ show (makeRect pos (1, 1)))
                   (\(s, r) -> s ++ ":" ++ show r) $
             find (flip rectContains pos . snd) $ tmapAllRects $ esTerrain es)
            (const True) (return mode) doSetRect view es
        Just DoSave -> do
          let doSave name = do
                eo <- runIOEO $ saveTerrainMap name $ esTerrain es
                case runEO eo of
                  Left errors -> newNarrateMode resources view es
                                   (intercalate "\n\n" errors) (return mode)
                  Right () -> do
                    writeIORef stateRef es { esFilename = name,
                                             esUnsaved = False }
                    return mode
          ChangeMode <$> newTextEntryDialogMode resources
            "Save terrain file as:" (esFilename es) (const True)
            (return mode) doSave view es
        Just DoLoad -> do
          let doLoad name = do
                eoTerrain <- runIOEO (loadTerrainMap resources name)
                case runEO eoTerrain of
                  Left errors -> newNarrateMode resources view es
                                   (intercalate "\n\n" errors) (return mode)
                  Right terrain -> do
                    writeIORef stateRef es { esCameraTopleft = pZero,
                                             esFilename = name,
                                             esRedoStack = [],
                                             esTerrain = terrain,
                                             esUndoStack = [],
                                             esUnsaved = False }
                    recreateMinimap
                    return mode
          ChangeMode <$> newTextEntryDialogMode resources
            "Load terrain file named:" (esFilename es) (const True)
            (return mode) doLoad view es
        Just DoUndo -> do
          case esUndoStack es of
            (undo : undos) -> do
              writeIORef stateRef es
                { esRedoStack = esTerrain es : esRedoStack es,
                  esTerrain = undo,
                  esUndoStack = undos,
                  esUnsaved = True }
              recreateMinimap
            [] -> return ()
          return SameMode
        Just DoRedo -> do
          case esRedoStack es of
            (redo : redos) -> do
              writeIORef stateRef es
                { esRedoStack = redos,
                  esTerrain = redo,
                  esUndoStack = esTerrain es : esUndoStack es,
                  esUnsaved = True }
              recreateMinimap
            [] -> return ()
          return SameMode

    alterState es' = writeIORef stateRef es' >> return SameMode

    setTerrain es terrain' = writeIORef stateRef $
      es { esRedoStack = [],
           esTerrain = terrain',
           esUndoStack = esTerrain es : take 10 (esUndoStack es),
           esUnsaved = True }

    doSetMarks pos string = do
      let mbKeys = fmap fst $ listToMaybe $ flip Read.readP_to_S string $ do
            ks <- Read.sepBy (Read.munch1 isAlphaNum) (Read.char ',')
            Read.eof
            return ks
      maybeM mbKeys $ \keys -> do
        es <- readIORef stateRef
        setTerrain es $ tmapSetMarks pos (Set.fromList keys) (esTerrain es)
      return mode

    doSetRect string = do
      let mbSetting = fmap fst $ listToMaybe $ flip Read.readP_to_S string $ do
            key <- Read.munch1 isAlphaNum
            mbRect <- Read.option Nothing $ do
              Read.char ':' >> fmap Just (readPrec_to_P readPrec 11)
            Read.eof
            return (key, mbRect)
      maybeM mbSetting $ \(key, mbRect) -> do
        es <- readIORef stateRef
        setTerrain es $ tmapSetRect key mbRect (esTerrain es)
      return mode

    doResize string = do
      let mbPair = fmap fst $ listToMaybe $ flip Read.readP_to_S string $ do
            w <- read <$> Read.munch1 isDigit
            _ <- Read.char 'x'
            h <- read <$> Read.munch1 isDigit
            Read.eof
            return (w, h)
      maybeM mbPair $ \size -> do
        es <- readIORef stateRef
        setTerrain es $ tmapResize (esNullTile es) size (esTerrain es)
        recreateMinimap
      return mode

    doShift string = do
      let mbPair = fmap fst $ listToMaybe $ flip Read.readP_to_S string $ do
            let parseInt = do
                  sign <- Read.option "" (Read.string "-")
                  digits <- Read.munch1 isDigit
                  return $ read $ sign ++ digits
            dx <- parseInt
            _ <- Read.char ','
            dy <- parseInt
            Read.eof
            return (Point dx dy)
      maybeM mbPair $ \delta -> do
        es <- readIORef stateRef
        setTerrain es $ tmapShift (esNullTile es) delta (esTerrain es)
        recreateMinimap
      return mode

    recreateMinimap = do
      es <- readIORef stateRef
      let tmap = esTerrain es
      minimap <- newMinimapFromTerrainMap tmap
      writeIORef stateRef es { esMinimap = minimap }

  return mode

-------------------------------------------------------------------------------
newEditorMode :: Resources -> IO Mode
newEditorMode resources = do
  view <- newEditorView resources
  stateRef <- newEditorState resources >>= newIORef
  let

    mode EvQuit = do
      unsaved <- fmap esUnsaved $ readIORef stateRef
      if not unsaved then return DoQuit else
        return DoQuit -- TODO offer to save terrain
    mode (EvKeyDown KeyR [KeyModCmd] _) = do
      es <- readIORef stateRef
      ChangeMode <$> newTextEntryDialogMode
        resources "Enter new map dimensions:"
        (let (w, h) = tmapSize (esTerrain es) in show w ++ "x" ++ show h)
        (const True) (return mode) doResize view es
    mode (EvKeyDown KeyH [KeyModCmd] _) = do
      es <- readIORef stateRef
      ChangeMode <$> newTextEntryDialogMode resources
        "Enter shift delta:" "0,0" (const True) (return mode) doShift view es
    mode event = do
      when (event == EvTick) $ modifyIORef stateRef tickEditorState
      es <- readIORef stateRef
      action <- handleScreen $ viewHandler view es event
      when (event == EvTick) $ paintScreen (viewPaint view es)
      case fromAction action of
        Nothing -> return SameMode
        Just (JumpMapTo pos) -> alterState $
          es { esCameraTopleft =
                 round <$> (positionCenter pos `pSub` cameraCenterOffset) }
        Just (ScrollMap delta) -> alterState $
          es { esCameraTopleft = esCameraTopleft es `pAdd` delta }
        Just (ScrollPalette top) -> alterState $
          es { esPaletteTop = max 0 top }
        Just (PickTile tile) -> alterState es { esBrush = tile }
        Just (AutoPaintAt pos) -> do
          let brush = autoPaintTile (esTileset es) (esTerrain es) pos
          when (ttId (tmapGet (esTerrain es) pos) /= ttId brush) $ do
            let terrain' = tmapSet [pos] brush (esTerrain es)
            updateMinimapFromTerrainMap (esMinimap es) terrain' [pos]
            setTerrain es terrain'
          return SameMode
        Just (PaintAt pos) -> do
          when (ttId (tmapGet (esTerrain es) pos) /= ttId (esBrush es)) $ do
            let terrain' = tmapSet [pos] (esBrush es) (esTerrain es)
            updateMinimapFromTerrainMap (esMinimap es) terrain' [pos]
            setTerrain es terrain'
          return SameMode
        Just (FloodFill pos) -> do
          when (ttId (tmapGet (esTerrain es) pos) /= ttId (esBrush es)) $ do
            let (terrain', filled) = floodFill pos (esBrush es) (esTerrain es)
            updateMinimapFromTerrainMap (esMinimap es) terrain' filled
            setTerrain es terrain'
          return SameMode
        Just (ChangeMarks pos) -> do
          ChangeMode <$> newTextEntryDialogMode
            resources ("Set marks for " ++ show pos ++ ":")
            (intercalate "," $ Set.toList $ tmapGetMarks pos $ esTerrain es)
            (const True) (return mode) (doSetMarks pos) view es
        Just (ChangeRects pos) -> do
          ChangeMode <$> newTextEntryDialogMode
            resources ("Set rect:")
            (maybe ("R:" ++ show (makeRect pos (1, 1)))
                   (\(s, r) -> s ++ ":" ++ show r) $
             find (flip rectContains pos . snd) $ tmapAllRects $ esTerrain es)
            (const True) (return mode) doSetRect view es
        Just DoSave -> do
          let doSave name = do
                eo <- runIOEO $ saveTerrainMap name $ esTerrain es
                case runEO eo of
                  Left errors -> newNarrateMode resources view es
                                   (intercalate "\n\n" errors) (return mode)
                  Right () -> do
                    writeIORef stateRef es { esFilename = name,
                                             esUnsaved = False }
                    return mode
          ChangeMode <$> newTextEntryDialogMode resources
            "Save terrain file as:" (esFilename es) (const True)
            (return mode) doSave view es
        Just DoLoad -> do
          let doLoad name = do
                eoTerrain <- runIOEO (loadTerrainMap resources name)
                case runEO eoTerrain of
                  Left errors -> newNarrateMode resources view es
                                   (intercalate "\n\n" errors) (return mode)
                  Right terrain -> do
                    writeIORef stateRef es { esCameraTopleft = pZero,
                                             esFilename = name,
                                             esRedoStack = [],
                                             esTerrain = terrain,
                                             esUndoStack = [],
                                             esUnsaved = False }
                    recreateMinimap
                    return mode
          ChangeMode <$> newTextEntryDialogMode resources
            "Load terrain file named:" (esFilename es) (const True)
            (return mode) doLoad view es
        Just DoUndo -> do
          case esUndoStack es of
            (undo : undos) -> do
              writeIORef stateRef es
                { esRedoStack = esTerrain es : esRedoStack es,
                  esTerrain = undo,
                  esUndoStack = undos,
                  esUnsaved = True }
              recreateMinimap
            [] -> return ()
          return SameMode
        Just DoRedo -> do
          case esRedoStack es of
            (redo : redos) -> do
              writeIORef stateRef es
                { esRedoStack = redos,
                  esTerrain = redo,
                  esUndoStack = esTerrain es : esUndoStack es,
                  esUnsaved = True }
              recreateMinimap
            [] -> return ()
          return SameMode

    alterState es' = writeIORef stateRef es' >> return SameMode

    setTerrain es terrain' = writeIORef stateRef $
      es { esRedoStack = [],
           esTerrain = terrain',
           esUndoStack = esTerrain es : take 10 (esUndoStack es),
           esUnsaved = True }

    doSetMarks pos string = do
      let mbKeys = fmap fst $ listToMaybe $ flip Read.readP_to_S string $ do
            ks <- Read.sepBy (Read.munch1 isAlphaNum) (Read.char ',')
            Read.eof
            return ks
      maybeM mbKeys $ \keys -> do
        es <- readIORef stateRef
        setTerrain es $ tmapSetMarks pos (Set.fromList keys) (esTerrain es)
      return mode

    doSetRect string = do
      let mbSetting = fmap fst $ listToMaybe $ flip Read.readP_to_S string $ do
            key <- Read.munch1 isAlphaNum
            mbRect <- Read.option Nothing $ do
              Read.char ':' >> fmap Just (readPrec_to_P readPrec 11)
            Read.eof
            return (key, mbRect)
      maybeM mbSetting $ \(key, mbRect) -> do
        es <- readIORef stateRef
        setTerrain es $ tmapSetRect key mbRect (esTerrain es)
      return mode

    doResize string = do
      let mbPair = fmap fst $ listToMaybe $ flip Read.readP_to_S string $ do
            w <- read <$> Read.munch1 isDigit
            _ <- Read.char 'x'
            h <- read <$> Read.munch1 isDigit
            Read.eof
            return (w, h)
      maybeM mbPair $ \size -> do
        es <- readIORef stateRef
        setTerrain es $ tmapResize (esNullTile es) size (esTerrain es)
        recreateMinimap
      return mode

    doShift string = do
      let mbPair = fmap fst $ listToMaybe $ flip Read.readP_to_S string $ do
            let parseInt = do
                  sign <- Read.option "" (Read.string "-")
                  digits <- Read.munch1 isDigit
                  return $ read $ sign ++ digits
            dx <- parseInt
            _ <- Read.char ','
            dy <- parseInt
            Read.eof
            return (Point dx dy)
      maybeM mbPair $ \delta -> do
        es <- readIORef stateRef
        setTerrain es $ tmapShift (esNullTile es) delta (esTerrain es)
        recreateMinimap
      return mode

    recreateMinimap = do
      es <- readIORef stateRef
      let tmap = esTerrain es
      minimap <- newMinimapFromTerrainMap tmap
      writeIORef stateRef es { esMinimap = minimap }

  return mode

-------------------------------------------------------------------------------
newEditorMode resources = do
  view <- newEditorView resources
  stateRef <- newEditorState resources >>= newIORef
  let

    mode EvQuit = do
      unsaved <- fmap esUnsaved $ readIORef stateRef
      if not unsaved then return DoQuit else
        return DoQuit -- TODO offer to save terrain
    mode (EvKeyDown KeyR [KeyModCmd] _) = do
      es <- readIORef stateRef
      ChangeMode <$> newTextEntryDialogMode
        resources "Enter new map dimensions:"
        (let (w, h) = tmapSize (esTerrain es) in show w ++ "x" ++ show h)
        (const True) (return mode) doResize view es
    mode (EvKeyDown KeyH [KeyModCmd] _) = do
      es <- readIORef stateRef
      ChangeMode <$> newTextEntryDialogMode resources
        "Enter shift delta:" "0,0" (const True) (return mode) doShift view es
    mode event = do
      when (event == EvTick) $ modifyIORef stateRef tickEditorState
      es <- readIORef stateRef
      action <- handleScreen $ viewHandler view es event
      when (event == EvTick) $ paintScreen (viewPaint view es)
      case fromAction action of
        Nothing -> return SameMode
        Just (JumpMapTo pos) -> alterState $
          es { esCameraTopleft =
                 round <$> (positionCenter pos `pSub` cameraCenterOffset) }
        Just (ScrollMap delta) -> alterState $
          es { esCameraTopleft = esCameraTopleft es `pAdd` delta }
        Just (ScrollPalette top) -> alterState $
          es { esPaletteTop = max 0 top }
        Just (PickTile tile) -> alterState es { esBrush = tile }
        Just (AutoPaintAt pos) -> do
          let brush = autoPaintTile (esTileset es) (esTerrain es) pos
          when (ttId (tmapGet (esTerrain es) pos) /= ttId brush) $ do
            let terrain' = tmapSet [pos] brush (esTerrain es)
            updateMinimapFromTerrainMap (esMinimap es) terrain' [pos]
            setTerrain es terrain'
          return SameMode
        Just (PaintAt pos) -> do
          when (ttId (tmapGet (esTerrain es) pos) /= ttId (esBrush es)) $ do
            let terrain' = tmapSet [pos] (esBrush es) (esTerrain es)
            updateMinimapFromTerrainMap (esMinimap es) terrain' [pos]
            setTerrain es terrain'
          return SameMode
        Just (FloodFill pos) -> do
          when (ttId (tmapGet (esTerrain es) pos) /= ttId (esBrush es)) $ do
            let (terrain', filled) = floodFill pos (esBrush es) (esTerrain es)
            updateMinimapFromTerrainMap (esMinimap es) terrain' filled
            setTerrain es terrain'
          return SameMode
        Just (ChangeMarks pos) -> do
          ChangeMode <$> newTextEntryDialogMode
            resources ("Set marks for " ++ show pos ++ ":")
            (intercalate "," $ Set.toList $ tmapGetMarks pos $ esTerrain es)
            (const True) (return mode) (doSetMarks pos) view es
        Just (ChangeRects pos) -> do
          ChangeMode <$> newTextEntryDialogMode
            resources ("Set rect:")
            (maybe ("R:" ++ show (makeRect pos (1, 1)))
                   (\(s, r) -> s ++ ":" ++ show r) $
             find (flip rectContains pos . snd) $ tmapAllRects $ esTerrain es)
            (const True) (return mode) doSetRect view es
        Just DoSave -> do
          let doSave name = do
                eo <- runIOEO $ saveTerrainMap name $ esTerrain es
                case runEO eo of
                  Left errors -> newNarrateMode resources view es
                                   (intercalate "\n\n" errors) (return mode)
                  Right () -> do
                    writeIORef stateRef es { esFilename = name,
                                             esUnsaved = False }
                    return mode
          ChangeMode <$> newTextEntryDialogMode resources
            "Save terrain file as:" (esFilename es) (const True)
            (return mode) doSave view es
        Just DoLoad -> do
          let doLoad name = do
                eoTerrain <- runIOEO (loadTerrainMap resources name)
                case runEO eoTerrain of
                  Left errors -> newNarrateMode resources view es
                                   (intercalate "\n\n" errors) (return mode)
                  Right terrain -> do
                    writeIORef stateRef es { esCameraTopleft = pZero,
                                             esFilename = name,
                                             esRedoStack = [],
                                             esTerrain = terrain,
                                             esUndoStack = [],
                                             esUnsaved = False }
                    recreateMinimap
                    return mode
          ChangeMode <$> newTextEntryDialogMode resources
            "Load terrain file named:" (esFilename es) (const True)
            (return mode) doLoad view es
        Just DoUndo -> do
          case esUndoStack es of
            (undo : undos) -> do
              writeIORef stateRef es
                { esRedoStack = esTerrain es : esRedoStack es,
                  esTerrain = undo,
                  esUndoStack = undos,
                  esUnsaved = True }
              recreateMinimap
            [] -> return ()
          return SameMode
        Just DoRedo -> do
          case esRedoStack es of
            (redo : redos) -> do
              writeIORef stateRef es
                { esRedoStack = redos,
                  esTerrain = redo,
                  esUndoStack = esTerrain es : esUndoStack es,
                  esUnsaved = True }
              recreateMinimap
            [] -> return ()
          return SameMode

    alterState es' = writeIORef stateRef es' >> return SameMode

    setTerrain es terrain' = writeIORef stateRef $
      es { esRedoStack = [],
           esTerrain = terrain',
           esUndoStack = esTerrain es : take 10 (esUndoStack es),
           esUnsaved = True }

    doSetMarks pos string = do
      let mbKeys = fmap fst $ listToMaybe $ flip Read.readP_to_S string $ do
            ks <- Read.sepBy (Read.munch1 isAlphaNum) (Read.char ',')
            Read.eof
            return ks
      maybeM mbKeys $ \keys -> do
        es <- readIORef stateRef
        setTerrain es $ tmapSetMarks pos (Set.fromList keys) (esTerrain es)
      return mode

    doSetRect string = do
      let mbSetting = fmap fst $ listToMaybe $ flip Read.readP_to_S string $ do
            key <- Read.munch1 isAlphaNum
            mbRect <- Read.option Nothing $ do
              Read.char ':' >> fmap Just (readPrec_to_P readPrec 11)
            Read.eof
            return (key, mbRect)
      maybeM mbSetting $ \(key, mbRect) -> do
        es <- readIORef stateRef
        setTerrain es $ tmapSetRect key mbRect (esTerrain es)
      return mode

    doResize string = do
      let mbPair = fmap fst $ listToMaybe $ flip Read.readP_to_S string $ do
            w <- read <$> Read.munch1 isDigit
            _ <- Read.char 'x'
            h <- read <$> Read.munch1 isDigit
            Read.eof
            return (w, h)
      maybeM mbPair $ \size -> do
        es <- readIORef stateRef
        setTerrain es $ tmapResize (esNullTile es) size (esTerrain es)
        recreateMinimap
      return mode

    doShift string = do
      let mbPair = fmap fst $ listToMaybe $ flip Read.readP_to_S string $ do
            let parseInt = do
                  sign <- Read.option "" (Read.string "-")
                  digits <- Read.munch1 isDigit
                  return $ read $ sign ++ digits
            dx <- parseInt
            _ <- Read.char ','
            dy <- parseInt
            Read.eof
            return (Point dx dy)
      maybeM mbPair $ \delta -> do
        es <- readIORef stateRef
        setTerrain es $ tmapShift (esNullTile es) delta (esTerrain es)
        recreateMinimap
      return mode

    recreateMinimap = do
      es <- readIORef stateRef
      let tmap = esTerrain es
      minimap <- newMinimapFromTerrainMap tmap
      writeIORef stateRef es { esMinimap = minimap }

  return mode

-------------------------------------------------------------------------------