content: {-# LANGUAGE MultiWayIf #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE TupleSections #-}
  module Draw
    ( drawWithCurrentTool
    , drawAtPoint
    , drawTextAtPoint
    , truncateText
    , pasteTextAtPoint
    , undo
    , redo
    )
  where
  
  import Brick
  import Brick.Widgets.Border.Style
  import Data.Monoid ((<>))
  import Lens.Micro.Platform
  import Control.Monad.Trans (liftIO)
  import Control.Monad (foldM, void)
  import qualified Data.Text as T
  import qualified Graphics.Vty as V
  import qualified Data.Vector as Vec
  import Data.Maybe (catMaybes)
  
  import Types
  import Tart.Canvas
  import State
  import Draw.Line
  import Draw.Box
  
  undo :: EventM Name AppState ()
  undo = do
      s <- get
      case s^.undoStack of
          [] -> return ()
          (actions:rest) -> do
              let go [] old = return old
                  go (a:as) old = do
                      old' <- applyAction a
                      go as (old' <> old)
  
              undoActs <- go actions []
              undoStack .= rest
              redoStack %= (undoActs:)
  
  redo :: EventM Name AppState ()
  redo = do
      s <- get
      case s^.redoStack of
          [] -> return ()
          (actions:rest) -> do
              let go [] old = return old
                  go (a:as) old = do
                      old' <- applyAction a
                      go as (old' <> old)
  
              undoActs <- go actions []
              redoStack .= rest
              undoStack %= (undoActs:)
  
  applyAction :: Action -> EventM Name AppState [Action]
  applyAction ClearCanvasDirty = do
      canvasDirty .= False
      return []
  applyAction (SetPixels idx ps) = do
      let old' = (\(p, (ch, attr)) -> (p, ch, attr)) <$> ps
      drawMany old' (layerAt idx) (Just idx)
  applyAction (InsertLayer c idx ordIdx name) =
      insertLayer c idx ordIdx name
  applyAction (RemoveLayer idx) =
      deleteLayer idx
  applyAction (ChangeLayerName idx newName) =
      renameLayer idx newName
  applyAction (MoveLayerBy idx up) =
      moveLayer idx up
  applyAction (ToggleLayer idx) =
      toggleLayer idx
  applyAction (SelectLayerIndex idx) =
      selectLayer idx
  
  findFgPaletteEntry :: V.Attr -> AppState -> Int
  findFgPaletteEntry a s =
      let fgc = case V.attrForeColor a of
            V.KeepCurrent -> Nothing
            V.Default -> Nothing
            V.SetTo c -> Just c
      in maybe 0 id $ Vec.findIndex (== fgc) (s^.palette)
  
  findBgPaletteEntry :: V.Attr -> AppState -> Int
  findBgPaletteEntry a s =
      let bgc = case V.attrBackColor a of
            V.KeepCurrent -> Nothing
            V.Default -> Nothing
            V.SetTo c -> Just c
      in maybe 0 id $ Vec.findIndex (== bgc) (s^.palette)
  
  drawWithCurrentTool :: (Int, Int) -> EventM Name AppState ()
  drawWithCurrentTool point = do
      s <- get
      case s^.tool of
          Freehand -> drawAtPoint point
          Eraser   -> eraseAtPoint point (s^.eraserSize)
          Repaint  -> repaintAtPoint point (s^.repaintSize)
          Restyle  -> restyleAtPoint point (s^.restyleSize)
          FloodFill -> floodFillAtPoint point
          TextString -> modify $ beginTextEntry point
          Line ->
              case s^.dragging of
                  Nothing -> return ()
                  Just (n, l0, l1) ->
                      case n of
                          Canvas -> do
                              o <- liftIO $ clearCanvas (s^.drawingOverlay)
                              drawingOverlay .= o
                              void $ drawLine l0 l1 drawingOverlay Nothing
                          _ -> return ()
          Box -> do
              case s^.dragging of
                  Nothing -> return ()
                  Just (n, l0, l1) ->
                      case n of
                          Canvas -> do
                              let bs = snd $ getBoxBorderStyle s
                              o <- liftIO $ clearCanvas (s^.drawingOverlay)
                              drawingOverlay .= o
                              void $ drawBox bs l0 l1 drawingOverlay Nothing
                          _ -> return ()
          Eyedropper -> do
              -- Read the pixel at the canvas location. Set the
              -- application state's current drawing character and colors
              -- from it.
              let (ch, attr) = canvasGetPixel (s^.currentLayer) point
              drawCharacter .= ch
              drawFgPaletteIndex .= findFgPaletteEntry attr s
              drawBgPaletteIndex .= findBgPaletteEntry attr s
              drawStyle .= styleWord (V.attrStyle attr)
  
  styleWord :: V.MaybeDefault V.Style -> V.Style
  styleWord V.KeepCurrent = 0
  styleWord V.Default = 0
  styleWord (V.SetTo s) = s
  
  drawLine :: Location
           -> Location
           -> Lens' AppState Canvas
           -> Maybe Int
           -> EventM Name AppState [Action]
  drawLine (Location p0) (Location p1) which whichIdx = do
      s <- get
      let points = plotLine p0 p1
          pixels = (, s^.drawCharacter, currentPaletteAttribute s) <$> points
      drawMany pixels which whichIdx
  
  truncateText :: (Int, Int) -> [(Char, V.Attr)] -> AppState -> [(Char, V.Attr)]
  truncateText point t s =
      let startCol = point^._1
          maxCol = min ((s^.appCanvasSize)^._1 - 1)
                       (startCol + length t - 1)
          safe = take (maxCol - startCol + 1) t
      in safe
  
  pasteTextAtPoint :: (Int, Int) -> T.Text -> EventM Name AppState ()
  pasteTextAtPoint point t = do
      s <- get
      let ls = T.lines t
          (startCol, startRow) = point
          pasteWidth = maximum $ T.length <$> ls
          pasteHeight = length ls
          (oldWidth, oldHeight) = s^.appCanvasSize
          newSize = ( max oldWidth pasteWidth
                    , max oldHeight pasteHeight
                    )
          pairs = zip [startRow..] ls
          mkLine line = zip (T.unpack line) $ repeat $ currentPaletteAttribute s
  
      resizeCanvas newSize
      mapM_ (\(row, line) -> drawTextAtPoint (startCol, row) (mkLine line)) pairs
  
  drawTextAtPoint :: (Int, Int) -> [(Char, V.Attr)] -> EventM Name AppState ()
  drawTextAtPoint point t = do
      s <- get
      let (startCol, row) = point
          pixs = zip ([startCol..]) (truncateText point t s)
          many = mkEntry <$> pixs
          mkEntry (col, (ch, attr)) = ((col, row), ch, attr)
      withUndoM $ drawMany many currentLayer (Just $ s^.selectedLayerIndex)
  
  floodFillAtPoint :: (Int, Int) -> EventM Name AppState ()
  floodFillAtPoint point = do
      s <- get
  
      let fillAttr = normalizeAttr fillCh $ currentPaletteAttribute s
          fillCh = s^.drawCharacter
          fillPix = (fillCh, fillAttr)
          targetPix = canvasGetPixel (s^.currentLayer) point
          (w, h) = s^.appCanvasSize
          up    = (& _2 %~ (max 0 . pred))
          down  = (& _2 %~ (min (h-1) . succ))
          left  = (& _1 %~ (max 0 . pred))
          right = (& _1 %~ (min (w-1) . succ))
  
          go :: (Int, Int)
             -> [((Int, Int), (Char, V.Attr))]
             -> EventM Name AppState [((Int, Int), (Char, V.Attr))]
          go p uBuf = do
              curL <- use currentLayer
              let rawPix = canvasGetPixel curL p
                  pix = rawPix & _2 %~ normalizeAttr (rawPix^._1)
              if | pix == fillPix -> return uBuf
                 | pix /= targetPix -> return uBuf
                 | otherwise -> do
                     let old = canvasGetPixel curL p
                     d' <- liftIO $ canvasSetPixel curL p fillCh fillAttr
                     currentLayer .= d'
                     canvasDirty .= True
                     go (down p) ((p, old):uBuf) >>=
                         go (up p) >>=
                         go (left p) >>=
                         go (right p)
  
      undoBuf <- go point []
      let prevDirty = s^.canvasDirty
          newDirty = s^.canvasDirty
          d = if prevDirty /= newDirty
              then [ClearCanvasDirty]
              else []
      modify $ pushUndo (d <> [SetPixels (s^.selectedLayerIndex) undoBuf])
  
  drawAtPoint :: (Int, Int) -> EventM Name AppState ()
  drawAtPoint point = do
      s <- get
      drawAtPoint' point (s^.drawCharacter) (currentPaletteAttribute s)
  
  drawAtPoint' :: (Int, Int) -> Char -> V.Attr -> EventM Name AppState ()
  drawAtPoint' point ch attr = do
      s <- get
      withUndoM $ drawMany [(point, ch, attr)] currentLayer (Just $ s^.selectedLayerIndex)
  
  drawMany :: [((Int, Int), Char, V.Attr)]
           -> Lens' AppState Canvas
           -> Maybe Int
           -> EventM Name AppState [Action]
  drawMany pixels which whichIdx = do
      s <- get
      let arr = s^.which
          old = getOld <$> pixels
          getOld (oldLoc, _, _) = (oldLoc, canvasGetPixel (s^.which) oldLoc)
      arr' <- liftIO $ canvasSetMany arr pixels
      let prevDirty = s^.canvasDirty
          newDirty = not $ null pixels
          newSt = s & which .~ arr'
                    & canvasDirty .~ (prevDirty || newDirty)
      put newSt
      return (catMaybes [ do i <- whichIdx
                             return $ SetPixels i old
                        , if prevDirty /= newDirty
                          then Just ClearCanvasDirty
                          else Nothing
                        ])
  
  makeBoxAboutPoint :: (Int, Int) -> Int -> [(Int, Int)]
  makeBoxAboutPoint point sz =
      if sz <= 0
         then []
         else let len = (sz * 2) - 1
                  off = negate $ sz - 1
                  noOffset = [(c, r) | r <- [0..len-1], c <- [0..len-1]]
                  addOffset (c, r) = (c + off + point^._1
                                     ,r + off + point^._2
                                     )
              in addOffset <$> noOffset
  
  eraseAtPoint :: (Int, Int) -> Int -> EventM Name AppState ()
  eraseAtPoint point sz = do
      s <- get
      let points = makeBoxAboutPoint point sz
          pixels = (, ' ', V.defAttr) <$> points
      withUndoM $ drawMany pixels currentLayer (Just $ s^.selectedLayerIndex)
  
  repaintAtPoint :: (Int, Int) -> Int -> EventM Name AppState ()
  repaintAtPoint point sz = do
      s <- get
      let points = makeBoxAboutPoint point sz
          attr = currentPaletteAttribute s
          getPixel p = let old = canvasGetPixel (s^.currentLayer) p
                       in (p, old^._1, attr { V.attrStyle = V.attrStyle $ old^._2 })
          pixels = getPixel <$> points
      withUndoM $ drawMany pixels currentLayer (Just $ s^.selectedLayerIndex)
  
  restyleAtPoint :: (Int, Int) -> Int -> EventM Name AppState ()
  restyleAtPoint point sz = do
      s <- get
      let points = makeBoxAboutPoint point sz
          attr = currentPaletteAttribute s
          getPixel p = let old = canvasGetPixel (s^.currentLayer) p
                       in (p, old^._1, (old^._2) { V.attrStyle = V.attrStyle attr })
          pixels = getPixel <$> points
      withUndoM $ drawMany pixels currentLayer (Just $ s^.selectedLayerIndex)
  
  drawBox :: BorderStyle
          -> Location
          -> Location
          -> Lens' AppState Canvas
          -> Maybe Int
          -> EventM Name AppState [Action]
  drawBox bs (Location a) (Location b) which whichIdx = do
      s <- get
      let attr = currentPaletteAttribute s
          points = plotBox bs a b
          pixels = mkPixel <$> points
          mkPixel (p, ch) = (p, ch, attr)
      drawMany pixels which whichIdx
  