Main.hs

{-# LANGUAGE OverloadedStrings #-}
module UI.Main
  ( drawMainUI
  , toolSelectorEntryWidth
  , boxStyleSelectorEntryWidth
  , styleSelectorEntryWidth
  )
where

import Brick
import Brick.Widgets.Edit
import Brick.Widgets.Border
import Brick.Widgets.Border.Style
import Brick.Widgets.Center
import Data.Monoid ((<>))
import qualified Data.Text as T
import Data.Maybe (isJust, catMaybes, fromMaybe)
import qualified Graphics.Vty as V
import Lens.Micro.Platform

import Types
import UI.Common
import Theme
import State
import Tart.Canvas

drawMainUI :: AppState -> [Widget Name]
drawMainUI s =
    catMaybes [ Just $ topHud s
              , if s^.layerListVisible then Just $ layerHud s else Nothing
              , Just $ canvas s
              ]

topHud :: AppState -> Widget Name
topHud s =
    let fgPal = drawPaletteSelector s True
        bgPal = drawPaletteSelector s False
        stySel = drawStyleSelector s
        toolbarEntries = [ drawToolSelector s
                         , toolHud s
                         , vLimit 1 $ fill ' '
                         , fgPal
                         , bgPal
                         , stySel
                         , drawCanvasSize s
                         ]
        filename = case s^.canvasPath of
            Nothing -> "<unsaved>"
            Just p -> T.pack p
        modified = if not $ s^.canvasDirty then "" else "*"
    in clickable TopHud $
       vBox [ (padLeft (Pad 1) $ hBox $ padRight (Pad 1) <$> toolbarEntries)
            , hBox [hBorder, txt ("[" <> filename <> modified <> "]"), borderElem bsHorizontal]
            ]

layerHud :: AppState -> Widget Name
layerHud s = translateBy (Location (0, 4)) $
             padBottom (Pad 4) $
             (hLimit 20 $ layerList <=> fill ' ' <=> layerOptions) <+> vBorder
    where
        layerList = vBox $ (hCenter $ withDefAttr headerAttr $ txt "Layers") :
                           (mkEntry <$> entries) <>
                           [addLayerEntry]
        entries = [ ( i
                    , s^.layerInfoFor(i)
                    )
                  | i <- s^.layerOrder
                  ]
        addLayerEntry =
            clickable AddLayer $ hCenter $
              withDefAttr clickableAttr $ txt "Add Layer (C-a)"
        mkEntry (idx, LayerInfo name vis) =
            if RenameLayer `elem` s^.modes && s^.selectedLayerIndex == idx
               then
                   renderEditor (txt . T.concat) True (s^.layerNameEditor)
               else
                   let applyAttr = if idx == s^.selectedLayerIndex
                                   then withDefAttr selectedLayerAttr
                                   else id
                       showHiddenStatus = if vis then id else (<+> txt "H")
                   in clickable (if idx == s^.selectedLayerIndex
                                 then LayerName
                                 else SelectLayer idx) $
                      applyAttr $ vLimit 1 $
                      showHiddenStatus $
                      txt name <+> fill ' '
        layerOptions =
            let i = s^.selectedLayerIndex
                entry n label =
                    clickable n $ vLimit 1 $ withDefAttr clickableAttr $
                                             txt label <+> fill ' '
            in vBox $ catMaybes
                 [ Just $ hBorderWithLabel (txt "Layer Options")
                 , Just $ entry ToggleLayerVisible
                            (if s^.layerInfoFor(i).layerVisible
                             then "Hide (C-v)"
                             else "Show (C-v)")
                 , if i /= head (s^.layerOrder)
                      then Just $ entry MoveLayerUp "Move up (C-u)"
                      else Nothing
                 , if i /= last (s^.layerOrder)
                      then Just $ entry MoveLayerDown "Move down (C-d)"
                      else Nothing
                 , if length (s^.layerOrder) == 1
                      then Nothing
                      else Just $ entry DeleteLayer "Delete (C-x)"
                 ]

toolHud :: AppState -> Widget Name
toolHud s =
    let toolHuds = [ (Freehand, freehandHud)
                   , (FloodFill, floodfillHud)
                   , (Box, boxHud)
                   , (Line, lineHud)
                   , (Eraser, eraserHud)
                   , (Repaint, repaintHud)
                   , (Restyle, restyleHud)
                   , (Eyedropper, eyedropperHud)
                   ]
    in case lookup (s^.tool) toolHuds of
        Nothing -> emptyWidget
        Just f -> f s

freehandHud :: AppState -> Widget Name
freehandHud s = drawChar s

lineHud :: AppState -> Widget Name
lineHud s = drawChar s

eyedropperHud :: AppState -> Widget Name
eyedropperHud s = drawChar s

floodfillHud :: AppState -> Widget Name
floodfillHud s = drawChar s

boxStyleSelectorEntryWidth :: Int
boxStyleSelectorEntryWidth = 18

styleSelectorEntryWidth :: Int
styleSelectorEntryWidth = 12

boxHud :: AppState -> Widget Name
boxHud = drawBoxStyleSelector

eraserHud :: AppState -> Widget Name
eraserHud = drawToolSize

repaintHud :: AppState -> Widget Name
repaintHud = drawToolSize

restyleHud :: AppState -> Widget Name
restyleHud = drawToolSize

drawToolSize :: AppState -> Widget Name
drawToolSize s =
    let inc = clickable IncreaseToolSize $ withDefAttr keybindingAttr $ txt ">>"
        dec = clickable DecreaseToolSize $ withDefAttr keybindingAttr $ txt "<<"
        sz = fromMaybe (error "BUG: current tool has no size") $ toolSize s
    in borderWithLabel (txt "Size") $
       dec <+> (hLimit 5 $ hCenter $ txt $ T.pack $ show sz) <+> inc

drawBoxStyleSelector :: AppState -> Widget Name
drawBoxStyleSelector s =
    let styleName = fst $ getBoxBorderStyle s
    in clickable BoxStyleSelector $
       borderWithLabel (txt "Box Style") $
       hLimit boxStyleSelectorEntryWidth $
       hCenter $ txt styleName

drawStyleSelector :: AppState -> Widget Name
drawStyleSelector s =
    clickable StyleSelector $
    borderWithLabel (txt "St" <+> (withDefAttr keybindingAttr $ txt "y") <+> txt "le") $
    hLimit styleSelectorEntryWidth $
    hCenter $ raw $ V.string (V.defAttr `V.withStyle` (s^.drawStyle)) "demo"

drawCanvasSize :: AppState -> Widget Name
drawCanvasSize s =
    let (width, height) = s^.appCanvasSize
    in clickable ResizeCanvas $
       borderWithLabel (txt "Can" <+> (withDefAttr keybindingAttr (txt "v")) <+> txt "as") $
       hLimit 8 $ hCenter (txt $ T.pack $ show width <> "x" <> show height)

drawChar :: AppState -> Widget Name
drawChar s =
    clickable CharSelector $
    borderWithLabel ((withDefAttr keybindingAttr $ txt "C") <+> txt "har") $
    padLeftRight 2 $ txt $ T.singleton $ s^.drawCharacter

toolSelectorEntryWidth :: Int
toolSelectorEntryWidth = 20

drawToolSelector :: AppState -> Widget Name
drawToolSelector s =
    let Just idx = lookup (s^.tool) tools
    in clickable ToolSelector $
       borderWithLabel ((withDefAttr keybindingAttr $ txt "T") <+> txt "ool") $
       hLimit toolSelectorEntryWidth $
       hCenter $
       (withDefAttr keybindingAttr (txt $ T.pack $ show idx)) <+>
       (txt $ ":" <> toolName (s^.tool))

drawPaletteSelector :: AppState -> Bool -> Widget Name
drawPaletteSelector s isFg =
    (clickable selName $ borderWithLabel label curColor)
    where
        label = if isFg
                then (withDefAttr keybindingAttr $ txt "F") <+> txt "G"
                else (withDefAttr keybindingAttr $ txt "B") <+> txt "G"
        curIdx = if isFg then s^.drawFgPaletteIndex
                         else s^.drawBgPaletteIndex
        selName = if isFg then FgSelector else BgSelector
        curColor = drawPaletteEntry s curIdx 4

canvas :: AppState -> Widget Name
canvas s =
    let appLayers = concat
            [ if s^.layerInfoFor(idx).layerVisible
              then if shouldUseOverlay s && idx == s^.selectedLayerIndex
                   then [s^.drawingOverlay, s^.layerAt idx]
                   else [s^.layerAt idx]
              else []
            | idx <- s^.layerOrder
            ]
        sz = s^.appCanvasSize
        widthAdjust = if s^.layerListVisible
                      then 10
                      else 0
    in centerAbout (s^.canvasOffset & _2 %~ pred
                                    & _1 %~ (subtract widthAdjust)) $
       updateAttrMap (applyAttrMappings [(borderAttr, fg V.white)]) $
       setAvailableSize (sz & each %~ (+ 2)) $
       border $
       if null appLayers
          then raw $ V.charFill V.defAttr ' ' (sz^._1) (sz^._2)
          else clickable Canvas $
               raw $ canvasLayersToImage appLayers

shouldUseOverlay :: AppState -> Bool
shouldUseOverlay s =
    isJust $ s^.dragging