diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for tart + +## 0.1 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017, Jonathan Daugherty + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Jonathan Daugherty nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,128 @@ +tart - terminal art program +=========================== + +**NOTE: This is unreleased software and is under heavy development. Use at your own risk.** + +``` + _____ _ ____ _____ _ +(_ _)/ \ | (_ _)| | + | | / ^ \ | O || | |_| + | |/ ___ \| _ < | | _ + |_|_/ \_|_| \_\|_| |_| +``` + +Tart is a program that provides an image-editor-like interface to +creating ASCII art - in the terminal, with your mouse! + +![](screenshots/2.png) + +Building +======== + +`tart` is a Haskell project. You'll need +[GHC](https://www.haskell.org/ghc/) (preferably at least 8.2) and +[cabal-install](http://hackage.haskell.org/package/cabal-install) +(preferably at least 2.0). Then: + +``` +$ cabal update +$ git clone https://github.com/jtdaugherty/tart.git +$ cd tart +$ cabal new-build +$ $(find . -name tart -type f) +``` + +Features +======== + +- Drawing tools: freehand, line, box, flood fill, text string +- Utility tools: repaint, restyle, eyedropper, eraser +- Multiple graphical styles for boxes +- Named image layers with reordering, visibility toggling +- Character selection for freehand and flood fill tools +- Set foreground color, background color, and text style independently +- Full mouse interaction and keyboard shortcuts +- Paste text from clipboard into canvas +- Undo and redo +- Text styles: bold, blink, underline, reverse video +- Load and save ASCII art files (binary) +- Save plain versions of ASCII art for embedding in documents +- Save color versions of ASCII art with terminal escape sequences for + printing to terminals +- Import existing plaintext files as the basis for new ASCII art files +- Set arbitrary canvas size + +Terminal Emulator Support +========================= + +`tart` has been tested extensively with the following terminal emulators +and is known to work well with them: + + * OS X: `iTerm2` + * OS X: `Terminal.app` + +Please let me know if you use `tart` with another emulator and let me +know how well it works! + +Keybindings +=========== + +Tools / styles: +- `0`..`9`: select tool +- `y`: open the attribute style selector +- `!`/`@`/`#`/`$`: select attribute style +- `f`/`b`: open foreground / background palette selectors +- `c`: set tool drawing character (where applicable) +- `<`/`>`: decrease / increase tool size (where applicable) +- `Esc`: cancel tool drag (e.g. box) + +Canvas: +- `w`/`a`/`s`/`d`: move canvas +- `C`: re-center canvas +- `v`: set canvas size +- `-`/`+`: decrease / increase canvas size + +Layers: +- `C-a`: add new layer +- `C-r`: rename current layer +- `C-n`/`C-p`: select next/previous layer +- `C-x`: delete selected layer +- `C-u`/`C-d`: move current layer up / down +- `C-v`: toggle selected layer's visibility +- `C-l`: toggle visibility of layer list + +General: +- `q`: quit +- `u`: undo +- `r`: redo +- OS paste: paste text into canvas + +How It Works +============ + +Tart requires a terminal with mouse support. You use various tools (such +as freehand drawing, boxes, etc.) to draw ASCII pictures. You can set a +current foreground and background color. You can also resize the drawing +canvas to get the desired output size. When you're finished, you can +save to disk, at which point Tart creates three files: + + * A binary file (say `foo.tart`) suitable for reloading with Tart for + further editing later + * A text file `foo.color.txt` containing the ASCII art with terminal + color escape sequences, suitable for emitting to terminals + * A text file `foo.plain.txt` containing the ASCII art without terminal + color escape sequences, suitable for embedding in documentation + +Contributing +============ + +If you decide to contribute, that's great! Here are some guidelines you +should consider to make submitting patches easier for all concerned: + + - If you want to take on big things, talk to me first; let's have a + design/vision discussion before you start coding. Create a GitHub + issue and we can use that as the place to hash things out. + - Please make changes consistent with the conventions I've used in the + codebase. + - Please adjust or provide Haddock and/or user guide documentation + relevant to any changes you make. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/programs/App.hs b/programs/App.hs new file mode 100644 --- /dev/null +++ b/programs/App.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +module App + ( application + , mkInitialState + ) +where + +import qualified Graphics.Vty as V +import qualified Data.Vector as Vec +import qualified Data.Map as M +import Lens.Micro.Platform + +import Brick +import Brick.BChan (BChan) +import Brick.Focus +import Brick.Widgets.Edit (editor) + +import Types +import Events +import UI +import Theme +import Tart.Canvas + +defaultPalette :: Vec.Vector (Maybe V.Color) +defaultPalette = Vec.fromList + [ Nothing -- default attribute + , Just V.white + , Just V.brightWhite + , Just V.black + , Just V.brightBlack + , Just V.blue + , Just V.brightBlue + , Just V.red + , Just V.brightRed + , Just V.magenta + , Just V.brightMagenta + , Just V.green + , Just V.brightGreen + , Just V.cyan + , Just V.brightCyan + , Just V.yellow + , Just V.brightYellow + ] + +initialCanvasSize :: (Int, Int) +initialCanvasSize = (40, 17) + +mkInitialState :: BChan AppEvent + -> Maybe (Maybe FilePath, [Canvas], [Int], [String]) + -> IO AppState +mkInitialState chan mc = do + (cs, order, names, fp) <- case mc of + Nothing -> do + c <- newCanvas initialCanvasSize + return ([c], [0], ["default"], Nothing) + Just (fp, cs, order, names) -> + return (cs, order, names, fp) + + let sz = canvasSize $ cs !! 0 + overlay <- newCanvas sz + + return $ AppState { _layers = M.fromList $ zip [0..] cs + , _layerInfo = M.fromList $ zip [0..] (LayerInfo <$> names <*> pure True) + , _layerOrder = order + , _drawingOverlay = overlay + , _layerListVisible = True + , _selectedLayerIndex = head order + , _modes = [Main] + , _tool = Freehand + , _appCanvasSize = sz + , _drawCharacter = '*' + , _drawFgPaletteIndex = 0 + , _drawBgPaletteIndex = 0 + , _palette = defaultPalette + , _fgPaletteSelectorExtent = Nothing + , _bgPaletteSelectorExtent = Nothing + , _toolSelectorExtent = Nothing + , _boxStyleSelectorExtent = Nothing + , _styleSelectorExtent = Nothing + , _canvasExtent = Nothing + , _dragging = Nothing + , _layerNameEditor = editor LayerNameEditor (Just 1) "" + , _canvasSizeWidthEdit = editor CanvasSizeWidthEdit (Just 1) "" + , _canvasSizeHeightEdit = editor CanvasSizeHeightEdit (Just 1) "" + , _canvasSizeFocus = focusRing [ CanvasSizeWidthEdit + , CanvasSizeHeightEdit + ] + , _canvasOffset = Location $ sz & each %~ (`div` 2) + , _canvasPath = fp + , _canvasDirty = False + , _askToSaveFilenameEdit = editor AskToSaveFilenameEdit (Just 1) "" + , _appEventChannel = chan + , _textEntered = mempty + , _textEntryStart = (0, 0) + , _boxStyleIndex = 0 + , _eraserSize = 1 + , _repaintSize = 1 + , _restyleSize = 1 + , _undoStack = [] + , _redoStack = [] + , _drawStyle = noStyle + } + +application :: App AppState AppEvent Name +application = + App { appDraw = drawUI + , appChooseCursor = \s locs -> + if | CanvasSizePrompt `elem` s^.modes -> do + cur <- focusGetCurrent (s^.canvasSizeFocus) + showCursorNamed cur locs + | AskToSave `elem` s^.modes -> + showCursorNamed AskToSaveFilenameEdit locs + | TextEntry `elem` s^.modes -> + showCursorNamed TextEntryCursor locs + | RenameLayer `elem` s^.modes -> + showCursorNamed LayerNameEditor locs + | otherwise -> Nothing + , appHandleEvent = handleEvent + , appStartEvent = \s -> do + vty <- getVtyHandle + V.setMode (V.outputIface vty) V.Mouse True + V.setMode (V.outputIface vty) V.BracketedPaste True + return s + , appAttrMap = const theme + } diff --git a/programs/Draw.hs b/programs/Draw.hs new file mode 100644 --- /dev/null +++ b/programs/Draw.hs @@ -0,0 +1,297 @@ +{-# 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) +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 :: AppState -> EventM Name AppState +undo s = + case s^.undoStack of + [] -> return s + (actions:rest) -> do + let go st [] old = return (st, old) + go st (a:as) old = do + (st', old') <- applyAction st a + go st' as (old' <> old) + + (finalSt, undoActs) <- go s actions [] + return $ finalSt & undoStack .~ rest + & redoStack %~ (undoActs:) + +redo :: AppState -> EventM Name AppState +redo s = + case s^.redoStack of + [] -> return s + (actions:rest) -> do + let go st [] old = return (st, old) + go st (a:as) old = do + (st', old') <- applyAction st a + go st' as (old' <> old) + + (finalSt, undoActs) <- go s actions [] + return $ finalSt & redoStack .~ rest + & undoStack %~ (undoActs:) + +applyAction :: AppState -> Action -> EventM Name (AppState, [Action]) +applyAction s ClearCanvasDirty = return (s & canvasDirty .~ False, []) +applyAction s (SetPixels idx ps) = do + let old' = (\(p, (ch, attr)) -> (p, ch, attr)) <$> ps + (s', old) <- drawMany old' (layerAt idx) (Just idx) s + return (s', old) +applyAction s (InsertLayer c idx ordIdx name) = + return $ insertLayer c idx ordIdx name s +applyAction s (RemoveLayer idx) = + return $ deleteLayer idx s +applyAction s (ChangeLayerName idx newName) = + return $ renameLayer idx newName s +applyAction s (MoveLayerBy idx up) = + return $ moveLayer idx up s +applyAction s (ToggleLayer idx) = + return $ toggleLayer idx s + +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) -> AppState -> EventM Name AppState +drawWithCurrentTool point s = + case s^.tool of + Freehand -> drawAtPoint point s + Eraser -> eraseAtPoint point (s^.eraserSize) s + Repaint -> repaintAtPoint point (s^.repaintSize) s + Restyle -> restyleAtPoint point (s^.restyleSize) s + FloodFill -> floodFillAtPoint point s + TextString -> return $ beginTextEntry point s + Line -> + case s^.dragging of + Nothing -> return s + Just (n, l0, l1) -> + case n of + Canvas -> do + o <- liftIO $ clearCanvas (s^.drawingOverlay) + (s', _) <- drawLine l0 l1 drawingOverlay Nothing $ + s & drawingOverlay .~ o + return s' + _ -> return s + Box -> do + case s^.dragging of + Nothing -> return s + Just (n, l0, l1) -> + case n of + Canvas -> do + let bs = snd $ getBoxBorderStyle s + o <- liftIO $ clearCanvas (s^.drawingOverlay) + (s', _) <- drawBox bs l0 l1 drawingOverlay Nothing $ + s & drawingOverlay .~ o + return s' + _ -> return s + Eyedropper -> + -- 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 + in return $ s & 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 + -> AppState + -> EventM Name (AppState, [Action]) +drawLine (Location p0) (Location p1) which whichIdx s = + let points = plotLine p0 p1 + pixels = (, s^.drawCharacter, currentPaletteAttribute s) <$> points + in drawMany pixels which whichIdx s + +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) -> AppState -> T.Text -> EventM Name AppState +pasteTextAtPoint point s t = do + 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 + + s' <- resizeCanvas s newSize + foldM (\st (row, line) -> drawTextAtPoint (startCol, row) (mkLine line) st) s' pairs + +drawTextAtPoint :: (Int, Int) -> [(Char, V.Attr)] -> AppState -> EventM Name AppState +drawTextAtPoint point t s = do + let (startCol, row) = point + pixs = zip ([startCol..]) (truncateText point t s) + many = mkEntry <$> pixs + mkEntry (col, (ch, attr)) = ((col, row), ch, attr) + withUndo <$> drawMany many currentLayer (Just $ s^.selectedLayerIndex) s + +floodFillAtPoint :: (Int, Int) -> AppState -> EventM Name AppState +floodFillAtPoint point s = do + 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) + -> (AppState, [((Int, Int), (Char, V.Attr))]) + -> EventM Name (AppState, [((Int, Int), (Char, V.Attr))]) + go p (st, uBuf) = do + let rawPix = canvasGetPixel (st^.currentLayer) p + pix = rawPix & _2 %~ normalizeAttr (rawPix^._1) + if | pix == fillPix -> return (st, uBuf) + | pix /= targetPix -> return (st, uBuf) + | otherwise -> do + let old = canvasGetPixel (st^.currentLayer) p + d' <- liftIO $ canvasSetPixel (st^.currentLayer) p fillCh fillAttr + let newSt = st & currentLayer .~ d' & canvasDirty .~ True + go (down p) (newSt, (p, old):uBuf) >>= + go (up p) >>= + go (left p) >>= + go (right p) + + (finalSt, undoBuf) <- go point (s, []) + let prevDirty = s^.canvasDirty + newDirty = s^.canvasDirty + d = if prevDirty /= newDirty + then [ClearCanvasDirty] + else [] + return $ pushUndo (d <> [SetPixels (s^.selectedLayerIndex) undoBuf]) finalSt + +drawAtPoint :: (Int, Int) -> AppState -> EventM Name AppState +drawAtPoint point s = + drawAtPoint' point (s^.drawCharacter) (currentPaletteAttribute s) s + +drawAtPoint' :: (Int, Int) -> Char -> V.Attr -> AppState -> EventM Name AppState +drawAtPoint' point ch attr s = do + withUndo <$> drawMany [(point, ch, attr)] currentLayer (Just $ s^.selectedLayerIndex) s + +drawMany :: [((Int, Int), Char, V.Attr)] + -> Lens' AppState Canvas + -> Maybe Int + -> AppState + -> EventM Name (AppState, [Action]) +drawMany pixels which whichIdx s = do + 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) + return (newSt, 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 -> AppState -> EventM Name AppState +eraseAtPoint point sz s = do + let points = makeBoxAboutPoint point sz + pixels = (, ' ', V.defAttr) <$> points + withUndo <$> drawMany pixels currentLayer (Just $ s^.selectedLayerIndex) s + +repaintAtPoint :: (Int, Int) -> Int -> AppState -> EventM Name AppState +repaintAtPoint point sz s = do + 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 + withUndo <$> drawMany pixels currentLayer (Just $ s^.selectedLayerIndex) s + +restyleAtPoint :: (Int, Int) -> Int -> AppState -> EventM Name AppState +restyleAtPoint point sz s = do + 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 + withUndo <$> drawMany pixels currentLayer (Just $ s^.selectedLayerIndex) s + +drawBox :: BorderStyle + -> Location + -> Location + -> Lens' AppState Canvas + -> Maybe Int + -> AppState + -> EventM Name (AppState, [Action]) +drawBox bs (Location a) (Location b) which whichIdx s = do + let attr = currentPaletteAttribute s + points = plotBox bs a b + pixels = mkPixel <$> points + mkPixel (p, ch) = (p, ch, attr) + drawMany pixels which whichIdx s diff --git a/programs/Draw/Box.hs b/programs/Draw/Box.hs new file mode 100644 --- /dev/null +++ b/programs/Draw/Box.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE TupleSections #-} +module Draw.Box + ( plotBox + ) +where + +import Data.Monoid ((<>)) +import Lens.Micro.Platform +import Brick.Widgets.Border.Style + +plotBox :: BorderStyle -> (Int, Int) -> (Int, Int) -> [((Int, Int), Char)] +plotBox bs a b = + let (ul, lr) = boxCorners a b + (ll, ur) = ( (ul^._1, lr^._2) + , (lr^._1, ul^._2) + ) + top = (, bsHorizontal bs) <$> (, ul^._2) <$> [ul^._1 + 1..ur^._1 - 1] + bottom = (, bsHorizontal bs) <$> (, ll^._2) <$> [ll^._1 + 1..lr^._1 - 1] + left = (, bsVertical bs) <$> (ul^._1, ) <$> [ul^._2 + 1..ll^._2 - 1] + right = (, bsVertical bs) <$> (ur^._1, ) <$> [ur^._2 + 1..lr^._2 - 1] + + width = lr^._1 - ul^._1 + height = lr^._2 - ul^._2 + corners = if width == 0 + then [ (ul, bsVertical bs) + , (lr, bsVertical bs) + ] + else if height == 0 + then [ (ul, bsHorizontal bs) + , (lr, bsHorizontal bs) + ] + else [ (ul, bsCornerTL bs) + , (lr, bsCornerBR bs) + , (ll, bsCornerBL bs) + , (ur, bsCornerTR bs) + ] + + -- Draw the corners + pixels = corners <> + -- Draw the top and bottom + top <> + bottom <> + -- Draw the sides + left <> + right + in pixels + +boxCorners :: (Int, Int) -> (Int, Int) -> ((Int, Int), (Int, Int)) +boxCorners (a0, a1) (b0, b1) = + let ul = (min a0 b0, min a1 b1) + lr = (max a0 b0, max a1 b1) + in (ul, lr) diff --git a/programs/Draw/Line.hs b/programs/Draw/Line.hs new file mode 100644 --- /dev/null +++ b/programs/Draw/Line.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TemplateHaskell #-} +module Draw.Line + ( plotLine + ) +where + +import Data.Bits (shiftR) +import Control.Monad.State.Lazy +import Lens.Micro.Platform + +data LinePlot = + LinePlot { _lpX :: Int + , _lpY :: Int + , _lpDx1 :: Int + , _lpDy1 :: Int + , _lpDx2 :: Int + , _lpDy2 :: Int + , _lpLongest :: Int + , _lpShortest :: Int + , _lpNumerator :: Int + , _lpPixels :: [(Int, Int)] + } + +makeLenses ''LinePlot + +-- From: +-- http://tech-algorithm.com/articles/drawing-line-using-bresenham-algorithm/ +plotLine :: (Int, Int) -> (Int, Int) -> [(Int, Int)] +plotLine p0 p1 = finalSt^.lpPixels + where + finalSt = execState plot (LinePlot 0 0 0 0 0 0 0 0 0 []) + plot = do + let ((x0, y0), (x1, y1)) = (p0, p1) + w = x1 - x0 + h = y1 - y0 + + lpX .= x0 + lpY .= y0 + lpDx1 .= 0 + lpDy1 .= 0 + lpDx2 .= 0 + lpDy2 .= 0 + + if | w<0 -> lpDx1 .= -1 + | w>0 -> lpDx1 .= 1 + | otherwise -> return () + + if | h<0 -> lpDy1 .= -1 + | h>0 -> lpDy1 .= 1 + | otherwise -> return () + + if | w<0 -> lpDx2 .= -1 + | w>0 -> lpDx2 .= 1 + | otherwise -> return () + + lpLongest .= abs w + lpShortest .= abs h + + longest <- use lpLongest + shortest <- use lpShortest + + when (not $ longest > shortest) $ do + lpLongest .= abs h + lpShortest .= abs w + + if | (h<0) -> lpDy2 .= -1 + | (h>0) -> lpDy2 .= 1 + | otherwise -> return () + + lpDx2 .= 0 + + longest' <- use lpLongest + lpNumerator .= (longest' `shiftR` 1) + + forM_ [0..longest'] $ \_ -> do + x <- use lpX + y <- use lpY + lpPixels %= ((x, y):) + + shortest' <- use lpShortest + lpNumerator += shortest' + numerator <- use lpNumerator + longest'' <- use lpLongest + if not $ numerator < longest'' + then do + lpNumerator -= longest'' + (lpX +=) =<< use lpDx1 + (lpY +=) =<< use lpDy1 + else do + (lpX +=) =<< use lpDx2 + (lpY +=) =<< use lpDy2 diff --git a/programs/Events.hs b/programs/Events.hs new file mode 100644 --- /dev/null +++ b/programs/Events.hs @@ -0,0 +1,81 @@ +module Events + ( handleEvent + ) +where + +import Brick +import Brick.BChan (writeBChan) +import Control.Monad.Trans (liftIO) +import Lens.Micro.Platform +import qualified Graphics.Vty as V + +import Types +import Events.Main +import Events.CharacterSelect +import Events.PaletteEntrySelect +import Events.ToolSelect +import Events.CanvasSizePrompt +import Events.AskToSave +import Events.AskForSaveFilename +import Events.TextEntry +import Events.BoxStyleSelect +import Events.StyleSelect +import Events.RenameLayer + +handleEvent :: AppState -> BrickEvent Name AppEvent -> EventM Name (Next AppState) +handleEvent s (VtyEvent (V.EvResize _ _)) = do + continue =<< updateExtents s +handleEvent s e = do + s' <- updateExtents s + + next <- case e of + MouseDown n _ _ l -> + case s'^.dragging of + Nothing -> + return $ Just (e, s' & dragging .~ Just (n, l, l)) + Just (n', start, _) | n == n' -> + return $ Just (e, s' & dragging .~ Just (n, start, l)) + _ -> + return $ Nothing + MouseUp _ _ _ -> do + case s'^.dragging of + Nothing -> return () + Just (n, l0, l1) -> do + let ev = DragFinished n l0 l1 + liftIO $ writeBChan (s^.appEventChannel) ev + return $ Just (e, s' & dragging .~ Nothing) + _ -> + return $ Just (e, s') + + case next of + Nothing -> continue s' + Just (ev, st) -> + case currentMode st of + Main -> handleMainEvent st ev + FgPaletteEntrySelect -> handlePaletteEntrySelectEvent st ev + BgPaletteEntrySelect -> handlePaletteEntrySelectEvent st ev + ToolSelect -> handleToolSelectEvent st ev + CharacterSelect -> handleCharacterSelectEvent st ev + CanvasSizePrompt -> handleCanvasSizePromptEvent st ev + AskToSave -> handleAskToSaveEvent st ev + AskForSaveFilename -> handleAskForSaveFilenameEvent st ev + TextEntry -> handleTextEntryEvent st ev + BoxStyleSelect -> handleBoxStyleSelectEvent st ev + StyleSelect -> handleStyleSelectEvent st ev + RenameLayer -> handleRenameLayerEvent st ev + +updateExtents :: AppState -> EventM Name AppState +updateExtents s = do + fgExtent <- lookupExtent FgSelector + bgExtent <- lookupExtent BgSelector + tsExtent <- lookupExtent ToolSelector + cExtent <- lookupExtent Canvas + bsExtent <- lookupExtent BoxStyleSelector + ssExtent <- lookupExtent StyleSelector + + return $ s & fgPaletteSelectorExtent .~ fgExtent + & bgPaletteSelectorExtent .~ bgExtent + & toolSelectorExtent .~ tsExtent + & canvasExtent .~ cExtent + & boxStyleSelectorExtent .~ bsExtent + & styleSelectorExtent .~ ssExtent diff --git a/programs/Events/AskForSaveFilename.hs b/programs/Events/AskForSaveFilename.hs new file mode 100644 --- /dev/null +++ b/programs/Events/AskForSaveFilename.hs @@ -0,0 +1,28 @@ +module Events.AskForSaveFilename + ( handleAskForSaveFilenameEvent + ) +where + +import qualified Graphics.Vty as V +import Lens.Micro.Platform +import qualified Data.Text as T + +import Brick +import Brick.Widgets.Edit + +import Types +import State + +handleAskForSaveFilenameEvent :: AppState -> BrickEvent Name e -> EventM Name (Next AppState) +handleAskForSaveFilenameEvent s (VtyEvent (V.EvKey V.KEsc [])) = + halt s +handleAskForSaveFilenameEvent s (VtyEvent (V.EvKey V.KEnter [])) = do + let [fn] = getEditContents (s^.askToSaveFilenameEdit) + if T.null fn + then halt s + else quit False $ s & canvasPath .~ Just (T.unpack fn) +handleAskForSaveFilenameEvent s (VtyEvent e) = + continue =<< handleEventLensed s askToSaveFilenameEdit handleEditorEvent e +handleAskForSaveFilenameEvent s _ = + continue s + diff --git a/programs/Events/AskToSave.hs b/programs/Events/AskToSave.hs new file mode 100644 --- /dev/null +++ b/programs/Events/AskToSave.hs @@ -0,0 +1,21 @@ +module Events.AskToSave + ( handleAskToSaveEvent + ) +where + +import qualified Graphics.Vty as V + +import Brick + +import Types +import State + +handleAskToSaveEvent :: AppState -> BrickEvent Name e -> EventM Name (Next AppState) +handleAskToSaveEvent s (VtyEvent (V.EvKey V.KEsc [])) = + halt s +handleAskToSaveEvent s (VtyEvent (V.EvKey (V.KChar 'n') [])) = + halt s +handleAskToSaveEvent s (VtyEvent (V.EvKey (V.KChar 'y') [])) = + continue $ askForSaveFilename s +handleAskToSaveEvent s _ = + continue s diff --git a/programs/Events/BoxStyleSelect.hs b/programs/Events/BoxStyleSelect.hs new file mode 100644 --- /dev/null +++ b/programs/Events/BoxStyleSelect.hs @@ -0,0 +1,37 @@ +module Events.BoxStyleSelect + ( handleBoxStyleSelectEvent + ) +where + +import Brick +import Data.Char (isDigit) +import qualified Graphics.Vty as V +import Lens.Micro.Platform + +import Types +import State +import Events.Common + +handleBoxStyleSelectEvent :: AppState -> BrickEvent Name e -> EventM Name (Next AppState) +handleBoxStyleSelectEvent s e = do + result <- handleCommonEvent s e + case result of + Just s' -> continue s' + Nothing -> handleEvent s e + +handleEvent :: AppState -> BrickEvent Name e -> EventM Name (Next AppState) +handleEvent s (MouseDown (BoxStyleSelectorEntry i) _ _ _) = do + continue $ popMode $ s & boxStyleIndex .~ i +handleEvent s (VtyEvent (V.EvKey (V.KChar c) [])) | isDigit c = do + let i = read [c] + case i >= 0 && i < length boxStyles of + True -> continue $ popMode $ s & boxStyleIndex .~ i + False -> continue s +handleEvent s (MouseUp _ _ _) = + -- Ignore mouse-up events so we don't go back to Main mode. This + -- includes mouse-up events generated in this mode, in addition to + -- the mouse-up event generated just after we switch into this mode + -- from Main. + continue s +handleEvent s _ = + continue $ popMode s diff --git a/programs/Events/CanvasSizePrompt.hs b/programs/Events/CanvasSizePrompt.hs new file mode 100644 --- /dev/null +++ b/programs/Events/CanvasSizePrompt.hs @@ -0,0 +1,33 @@ +module Events.CanvasSizePrompt + ( handleCanvasSizePromptEvent + ) +where + +import qualified Graphics.Vty as V +import Lens.Micro.Platform + +import Brick +import Brick.Focus +import Brick.Widgets.Edit + +import Types +import State + +handleCanvasSizePromptEvent :: AppState -> BrickEvent Name e -> EventM Name (Next AppState) +handleCanvasSizePromptEvent s (VtyEvent (V.EvKey (V.KChar '\t') [])) = + continue $ s & canvasSizeFocus %~ focusNext +handleCanvasSizePromptEvent s (VtyEvent (V.EvKey V.KBackTab [])) = + continue $ s & canvasSizeFocus %~ focusPrev +handleCanvasSizePromptEvent s (VtyEvent (V.EvKey V.KEsc [])) = + continue $ popMode s +handleCanvasSizePromptEvent s (VtyEvent (V.EvKey V.KEnter [])) = + continue =<< tryResizeCanvas s +handleCanvasSizePromptEvent s (VtyEvent e) = + case focusGetCurrent (s^.canvasSizeFocus) of + Just CanvasSizeWidthEdit -> + continue =<< handleEventLensed s canvasSizeWidthEdit handleEditorEvent e + Just CanvasSizeHeightEdit -> + continue =<< handleEventLensed s canvasSizeHeightEdit handleEditorEvent e + _ -> continue s +handleCanvasSizePromptEvent s _ = + continue s diff --git a/programs/Events/CharacterSelect.hs b/programs/Events/CharacterSelect.hs new file mode 100644 --- /dev/null +++ b/programs/Events/CharacterSelect.hs @@ -0,0 +1,18 @@ +module Events.CharacterSelect + ( handleCharacterSelectEvent + ) +where + +import Brick +import qualified Graphics.Vty as V + +import Types +import State + +handleCharacterSelectEvent :: AppState -> BrickEvent Name e -> EventM Name (Next AppState) +handleCharacterSelectEvent s (VtyEvent (V.EvKey V.KEsc _)) = + continue $ cancelCharacterSelect s +handleCharacterSelectEvent s (VtyEvent (V.EvKey (V.KChar c) [])) = + continue $ selectCharacter c s +handleCharacterSelectEvent s _ = + continue s diff --git a/programs/Events/Common.hs b/programs/Events/Common.hs new file mode 100644 --- /dev/null +++ b/programs/Events/Common.hs @@ -0,0 +1,25 @@ +module Events.Common + ( handleCommonEvent + ) +where + +import Brick +import qualified Graphics.Vty as V + +import Types +import State + +handleCommonEvent :: AppState -> BrickEvent Name e -> EventM Name (Maybe AppState) +handleCommonEvent s (VtyEvent (V.EvKey (V.KChar 't') [])) = do + if currentMode s == ToolSelect + then return $ Just $ popMode s + else return $ Just $ beginToolSelect s +handleCommonEvent s (VtyEvent (V.EvKey (V.KChar 'f') [])) = do + if currentMode s == FgPaletteEntrySelect + then return $ Just $ popMode s + else return $ Just $ beginFgPaletteSelect s +handleCommonEvent s (VtyEvent (V.EvKey (V.KChar 'b') [])) = do + if currentMode s == BgPaletteEntrySelect + then return $ Just $ popMode s + else return $ Just $ beginBgPaletteSelect s +handleCommonEvent _ _ = return Nothing diff --git a/programs/Events/Main.hs b/programs/Events/Main.hs new file mode 100644 --- /dev/null +++ b/programs/Events/Main.hs @@ -0,0 +1,104 @@ +module Events.Main + ( handleMainEvent + , handleAttrEvent + ) +where + +import Brick +import Data.Char (isDigit) +import Data.Maybe (isJust) +import qualified Graphics.Vty as V +import Lens.Micro.Platform +import Data.Text.Encoding (decodeUtf8) + +import Types +import Draw +import State +import Events.Common + +handleMainEvent :: AppState -> BrickEvent Name AppEvent -> EventM Name (Next AppState) +handleMainEvent s e = do + result <- handleCommonEvent s e + case result of + Just s' -> continue s' + Nothing -> do + result2 <- handleAttrEvent s e + case result2 of + Just s'' -> continue s'' + Nothing -> handleEvent s e + +handleAttrEvent :: AppState -> BrickEvent Name AppEvent -> EventM Name (Maybe AppState) +handleAttrEvent s (MouseDown FgSelector _ _ _) = + return $ Just $ beginFgPaletteSelect s +handleAttrEvent s (MouseDown BgSelector _ _ _) = + return $ Just $ beginBgPaletteSelect s +handleAttrEvent s (MouseDown StyleSelector _ _ _) = + return $ Just $ beginStyleSelect s +handleAttrEvent _ _ = return Nothing + +handleEvent :: AppState -> BrickEvent Name AppEvent -> EventM Name (Next AppState) +handleEvent s (VtyEvent (V.EvPaste bytes)) = + continue =<< pasteTextAtPoint (0, 0) s (decodeUtf8 bytes) +handleEvent s (AppEvent (DragFinished n _ _)) = + continue =<< handleDragFinished s n +handleEvent s (VtyEvent (V.EvMouseDown _ _ V.BScrollUp _)) = + continue $ increaseToolSize s +handleEvent s (VtyEvent (V.EvMouseDown _ _ V.BScrollDown _)) = + continue $ decreaseToolSize s +handleEvent s (MouseDown _ V.BScrollUp _ _) = + continue $ increaseToolSize s +handleEvent s (MouseDown _ V.BScrollDown _ _) = + continue $ decreaseToolSize s +handleEvent s (MouseDown Canvas _ _ (Location l)) = + continue =<< drawWithCurrentTool l s +handleEvent s (MouseDown n _ _ _) = + continue =<< case n of + LayerName -> return $ beginLayerRename s + DeleteLayer -> return $ deleteSelectedLayer s + MoveLayerUp -> return $ moveCurrentLayerUp s + MoveLayerDown -> return $ moveCurrentLayerDown s + ResizeCanvas -> return $ beginCanvasSizePrompt s + ToggleLayerVisible -> return $ toggleCurrentLayer s + ToolSelector -> return $ beginToolSelect s + IncreaseToolSize -> return $ increaseToolSize s + DecreaseToolSize -> return $ decreaseToolSize s + BoxStyleSelector -> return $ beginBoxStyleSelect s + SelectLayer idx -> return $ selectLayer idx s + AddLayer -> addLayer s + CharSelector -> return $ whenTool s charTools beginCharacterSelect + _ -> return s +handleEvent s (VtyEvent (V.EvKey (V.KChar 'q') [])) = + quit True s +handleEvent s (VtyEvent e) = + continue =<< case e of + _ | isStyleKey e -> return $ toggleStyleFromKey e s + (V.EvKey (V.KChar 'l') [V.MCtrl]) -> return $ toggleLayerList s + (V.EvKey (V.KChar 'w') []) -> return $ canvasMoveDown s + (V.EvKey (V.KChar 's') []) -> return $ canvasMoveUp s + (V.EvKey (V.KChar 'a') []) -> return $ canvasMoveLeft s + (V.EvKey (V.KChar 'd') []) -> return $ canvasMoveRight s + (V.EvKey (V.KChar 'y') []) -> return $ beginStyleSelect s + (V.EvKey (V.KChar 'v') []) -> return $ beginCanvasSizePrompt s + (V.EvKey (V.KChar 'r') [V.MCtrl]) -> return $ beginLayerRename s + (V.EvKey (V.KChar 'x') [V.MCtrl]) -> return $ deleteSelectedLayer s + (V.EvKey (V.KChar 'n') [V.MCtrl]) -> return $ selectNextLayer s + (V.EvKey (V.KChar 'p') [V.MCtrl]) -> return $ selectPrevLayer s + (V.EvKey (V.KChar 'u') [V.MCtrl]) -> return $ moveCurrentLayerUp s + (V.EvKey (V.KChar 'd') [V.MCtrl]) -> return $ moveCurrentLayerDown s + (V.EvKey (V.KChar 'v') [V.MCtrl]) -> return $ toggleCurrentLayer s + (V.EvKey (V.KChar 'C') []) -> return $ recenterCanvas s + (V.EvKey (V.KChar 'f') []) -> return $ beginFgPaletteSelect s + (V.EvKey (V.KChar 'b') []) -> return $ beginBgPaletteSelect s + (V.EvKey (V.KChar '>') []) -> return $ increaseToolSize s + (V.EvKey (V.KChar '<') []) -> return $ decreaseToolSize s + (V.EvKey V.KEsc []) | isJust (s^.dragging) -> return $ cancelDragging s + (V.EvKey (V.KChar c) []) | isDigit c -> return $ setToolByChar c s + (V.EvKey (V.KChar 'c') []) -> return $ whenTool s charTools + beginCharacterSelect + (V.EvKey (V.KChar '+') []) -> increaseCanvasSize s + (V.EvKey (V.KChar '-') []) -> decreaseCanvasSize s + (V.EvKey (V.KChar 'a') [V.MCtrl]) -> addLayer s + (V.EvKey (V.KChar 'u') []) -> undo s + (V.EvKey (V.KChar 'r') []) -> redo s + _ -> return s +handleEvent s _ = continue s diff --git a/programs/Events/PaletteEntrySelect.hs b/programs/Events/PaletteEntrySelect.hs new file mode 100644 --- /dev/null +++ b/programs/Events/PaletteEntrySelect.hs @@ -0,0 +1,36 @@ +module Events.PaletteEntrySelect + ( handlePaletteEntrySelectEvent + ) +where + +import Brick + +import Types +import State + +import Events.Common + +handlePaletteEntrySelectEvent :: AppState -> BrickEvent Name e -> EventM Name (Next AppState) +handlePaletteEntrySelectEvent s e = do + result <- handleCommonEvent s e + case result of + Just s' -> continue s' + Nothing -> handleEvent s e + +handleEvent :: AppState -> BrickEvent Name e -> EventM Name (Next AppState) +handleEvent s (MouseDown FgSelector _ _ _) = do + continue $ beginFgPaletteSelect s +handleEvent s (MouseDown BgSelector _ _ _) = do + continue $ beginBgPaletteSelect s +handleEvent s (MouseDown (FgPaletteEntry idx) _ _ _) = do + continue $ setFgPaletteIndex s idx +handleEvent s (MouseDown (BgPaletteEntry idx) _ _ _) = do + continue $ setBgPaletteIndex s idx +handleEvent s (MouseUp _ _ _) = + -- Ignore mouse-up events so we don't go back to Main mode. This + -- includes mouse-up events generated in this mode, in addition to + -- the mouse-up event generated just after we switch into this mode + -- from Main. + continue s +handleEvent s _ = + continue $ popMode s diff --git a/programs/Events/RenameLayer.hs b/programs/Events/RenameLayer.hs new file mode 100644 --- /dev/null +++ b/programs/Events/RenameLayer.hs @@ -0,0 +1,25 @@ +module Events.RenameLayer + ( handleRenameLayerEvent + ) +where + +import Brick +import Brick.Widgets.Edit +import qualified Graphics.Vty as V +import qualified Data.Text as T +import Lens.Micro.Platform + +import Types +import State + +handleRenameLayerEvent :: AppState + -> BrickEvent Name AppEvent + -> EventM Name (Next AppState) +handleRenameLayerEvent s (VtyEvent (V.EvKey V.KEsc [])) = + continue $ popMode s +handleRenameLayerEvent s (VtyEvent (V.EvKey V.KEnter [])) = + continue $ renameCurrentLayer (T.concat $ getEditContents $ s^.layerNameEditor) s +handleRenameLayerEvent s (VtyEvent e) = + continue =<< handleEventLensed s layerNameEditor handleEditorEvent e +handleRenameLayerEvent s _ = + continue s diff --git a/programs/Events/StyleSelect.hs b/programs/Events/StyleSelect.hs new file mode 100644 --- /dev/null +++ b/programs/Events/StyleSelect.hs @@ -0,0 +1,32 @@ +module Events.StyleSelect + ( handleStyleSelectEvent + ) +where + +import Brick +import Lens.Micro.Platform + +import Types +import State +import Events.Common + +handleStyleSelectEvent :: AppState -> BrickEvent Name e -> EventM Name (Next AppState) +handleStyleSelectEvent s e = do + result <- handleCommonEvent s e + case result of + Just s' -> continue s' + Nothing -> handleEvent s e + +handleEvent :: AppState -> BrickEvent Name e -> EventM Name (Next AppState) +handleEvent s (VtyEvent e) | isStyleKey e = + continue $ popMode $ toggleStyleFromKey e s +handleEvent s (MouseDown (StyleSelectorEntry sty) _ _ _) = do + continue $ popMode $ s & drawStyle %~ toggleStyle sty +handleEvent s (MouseUp _ _ _) = + -- Ignore mouse-up events so we don't go back to Main mode. This + -- includes mouse-up events generated in this mode, in addition to + -- the mouse-up event generated just after we switch into this mode + -- from Main. + continue s +handleEvent s _ = + continue $ popMode s diff --git a/programs/Events/TextEntry.hs b/programs/Events/TextEntry.hs new file mode 100644 --- /dev/null +++ b/programs/Events/TextEntry.hs @@ -0,0 +1,38 @@ +module Events.TextEntry + ( handleTextEntryEvent + ) +where + +import Brick +import qualified Graphics.Vty as V +import Data.Monoid ((<>)) +import Lens.Micro.Platform + +import Types +import State +import Draw +import Events.Main + +handleTextEntryEvent :: AppState -> BrickEvent Name AppEvent -> EventM Name (Next AppState) +handleTextEntryEvent s e = do + result <- handleAttrEvent s e + case result of + Just s' -> continue s' + Nothing -> handleEvent s e + +handleEvent :: AppState -> BrickEvent Name AppEvent -> EventM Name (Next AppState) +handleEvent s (VtyEvent (V.EvKey V.KEnter [])) = do + -- Commit the text to the drawing and return to main mode + continue =<< drawTextAtPoint (s^.textEntryStart) (s^.textEntered) (popMode s) +handleEvent s (VtyEvent (V.EvKey V.KBS [])) = do + continue $ s & textEntered %~ (\t -> if null t then t else init t) +handleEvent s (VtyEvent (V.EvKey V.KEsc [])) = + -- Cancel + continue $ popMode s +handleEvent s (VtyEvent (V.EvKey (V.KChar c) [])) | c /= '\t' = do + -- Enter character + let s' = s & textEntered %~ (<> [(c, currentPaletteAttribute s)]) + continue $ s' & textEntered .~ truncateText (s'^.textEntryStart) (s'^.textEntered) s' +handleEvent s _ = + -- Ignore everything else + continue s diff --git a/programs/Events/ToolSelect.hs b/programs/Events/ToolSelect.hs new file mode 100644 --- /dev/null +++ b/programs/Events/ToolSelect.hs @@ -0,0 +1,36 @@ +module Events.ToolSelect + ( handleToolSelectEvent + ) +where + +import Brick +import Data.Char (isDigit) +import qualified Graphics.Vty as V + +import Types +import State +import Events.Common + +handleToolSelectEvent :: AppState -> BrickEvent Name e -> EventM Name (Next AppState) +handleToolSelectEvent s e = do + result <- handleCommonEvent s e + case result of + Just s' -> continue s' + Nothing -> handleEvent s e + +handleEvent :: AppState -> BrickEvent Name e -> EventM Name (Next AppState) +handleEvent s (MouseDown (ToolSelectorEntry t) _ _ _) = do + continue $ popMode $ setTool s t +handleEvent s (VtyEvent (V.EvKey (V.KChar c) [])) | isDigit c = do + let idx = read [c] + case filter ((== idx) . snd) tools of + [(t, _)] -> continue $ popMode $ setTool s t + _ -> continue s +handleEvent s (MouseUp _ _ _) = + -- Ignore mouse-up events so we don't go back to Main mode. This + -- includes mouse-up events generated in this mode, in addition to + -- the mouse-up event generated just after we switch into this mode + -- from Main. + continue s +handleEvent s _ = + continue $ popMode s diff --git a/programs/Main.hs b/programs/Main.hs new file mode 100644 --- /dev/null +++ b/programs/Main.hs @@ -0,0 +1,112 @@ +module Main where + +import Control.Monad (void, when) +import Control.Applicative ((<|>)) +import Brick +import Brick.BChan (newBChan) +import qualified Graphics.Vty as V +import System.Environment (getArgs, getProgName) +import System.Exit (exitFailure, exitSuccess) +import System.Console.GetOpt +import Data.Monoid ((<>)) +import System.Directory (doesFileExist) + +import App +import State +import Tart.Canvas +import Tart.Format + +data Option = Import FilePath + | Output FilePath + | ShowHelp + deriving (Eq) + +data Config = + Config { configImport :: Maybe FilePath + , configOutput :: Maybe FilePath + , configShowHelp :: Bool + } + +defaultConfig :: Config +defaultConfig = + Config { configImport = Nothing + , configOutput = Nothing + , configShowHelp = False + } + +opts :: [OptDescr Option] +opts = + [ Option "i" ["import"] (ReqArg Import "FILE") + "Import a plain text file to begin a drawing" + , Option "o" ["output"] (ReqArg Output "FILE") + "Where to write the output file" + , Option "h" ["help"] (NoArg ShowHelp) + "Show this help" + ] + +configFromOpts :: [Option] -> Config -> IO Config +configFromOpts [] c = + return c +configFromOpts (ShowHelp:os) c = + configFromOpts os $ c { configShowHelp = True } +configFromOpts (Output f:os) c = do + configFromOpts os $ c { configOutput = Just f } +configFromOpts (Import f:os) c = do + ex <- doesFileExist f + case ex of + False -> error $ "file not found: " <> f + True -> configFromOpts os $ c { configImport = Just f } + +showHelp :: IO () +showHelp = do + pn <- getProgName + putStrLn $ usageInfo ("Usage: " <> pn <> " [file]") opts + +main :: IO () +main = do + checkForMouseSupport + + args <- getArgs + let (os, rest, errs) = getOpt Permute opts args + + when (not $ null errs) $ + showHelp >> exitFailure + + cfg <- configFromOpts os defaultConfig + + when (configShowHelp cfg) $ + showHelp >> exitFailure + + -- If this is an import operation, read the plain text file and + -- convert to a canvas. If an output filename was specified, write + -- the file and exit. Otherwise look for an input file in canvas + -- format + c <- case configImport cfg of + Just f -> do + s <- readFile f + c <- canvasFromText s + case configOutput cfg of + Nothing -> return $ Just (Nothing, [c], [0], ["default"]) + Just output -> do + writeCanvasFiles output [c] [0] ["default"] + exitSuccess + Nothing -> + case rest of + [f] -> do + r <- readTartFile $ toTartFilepath f + case r of + Left e -> do + putStrLn $ f <> ": could not read file: " <> e + exitFailure + Right tf -> + return $ Just ( configOutput cfg <|> Just f + , tartFileCanvasList tf + , tartFileCanvasOrder tf + , tartFileCanvasNames tf + ) + _ -> return Nothing + + chan <- newBChan 10 + let mkVty = V.mkVty =<< V.standardIOConfig + + (void . customMain mkVty (Just chan) application) =<< mkInitialState chan c diff --git a/programs/State.hs b/programs/State.hs new file mode 100644 --- /dev/null +++ b/programs/State.hs @@ -0,0 +1,568 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +module State + ( checkForMouseSupport + , setTool + , setToolByChar + , whenTool + , setFgPaletteIndex + , setBgPaletteIndex + , beginFgPaletteSelect + , beginBgPaletteSelect + , beginToolSelect + , selectNextLayer + , selectPrevLayer + , selectLayer + , pushMode + , popMode + , toolSize + , askForSaveFilename + , increaseCanvasSize + , decreaseCanvasSize + , increaseToolSize + , decreaseToolSize + , beginCanvasSizePrompt + , toggleCurrentLayer + , toggleLayer + , beginTextEntry + , tryResizeCanvas + , quit + , beginLayerRename + , renameCurrentLayer + , renameLayer + , deleteLayer + , deleteSelectedLayer + , insertLayer + , currentPaletteAttribute + , handleDragFinished + , getBoxBorderStyle + , beginBoxStyleSelect + , beginStyleSelect + , writeCanvasFiles + , resizeCanvas + , increaseEraserSize + , decreaseEraserSize + , increaseRepaintSize + , decreaseRepaintSize + , increaseRestyleSize + , decreaseRestyleSize + , pushUndo + , withUndo + , toggleStyleFromKey + , isStyleKey + , styleBindings + , recenterCanvas + , addLayer + , moveLayer + , moveCurrentLayerDown + , moveCurrentLayerUp + , cancelDragging + , toggleLayerList + + , canvasMoveDown + , canvasMoveUp + , canvasMoveLeft + , canvasMoveRight + + , tools + , charTools + , boxStyles + + , beginCharacterSelect + , cancelCharacterSelect + , selectCharacter + ) +where + +import Control.Monad (when, forM, forM_) +import Control.Monad.Trans (liftIO) +import Data.Monoid ((<>)) +import qualified Graphics.Vty as V +import qualified Data.Vector as Vec +import qualified Data.Text as T +import qualified Data.Map as M +import Data.List (sortOn, elemIndex) +import System.Exit (exitFailure) +import Lens.Micro.Platform +import Data.Text.Zipper (gotoEOL, textZipper) +import Text.Read (readMaybe) +import Data.Maybe (isJust, fromJust, catMaybes) + +import Brick +import Brick.Focus +import Brick.Widgets.Edit (editor, applyEdit, getEditContents, editContentsL) +import Brick.Widgets.Border.Style + +import Types +import Tart.Canvas +import Tart.Format + +tools :: [(Tool, Int)] +tools = + [ (Freehand , 1) + , (Box , 2) + , (Line , 3) + , (FloodFill , 4) + , (TextString, 5) + , (Repaint , 6) + , (Restyle , 7) + , (Eyedropper, 8) + , (Eraser , 0) + ] + +charTools :: [Tool] +charTools = + [ Freehand + , Line + , FloodFill + ] + +styleBindings :: [(Char, V.Style)] +styleBindings = + [ ('!', V.bold) + , ('@', V.underline) + , ('#', V.blink) + , ('$', V.reverseVideo) + ] + +isStyleKey :: V.Event -> Bool +isStyleKey (V.EvKey (V.KChar c) []) = + isJust $ lookup c styleBindings +isStyleKey _ = False + +toggleStyleFromKey :: V.Event -> AppState -> AppState +toggleStyleFromKey e s = + if isStyleKey e + then let V.EvKey (V.KChar c) _ = e + Just sty = lookup c styleBindings + in s & drawStyle %~ toggleStyle sty + else s + +boxStyles :: [(String, BorderStyle)] +boxStyles = + [ ("ASCII", ascii) + , ("Unicode", unicode) + , ("Unicode rounded", unicodeRounded) + ] + +getBoxBorderStyle :: AppState -> (String, BorderStyle) +getBoxBorderStyle s = boxStyles !! (s^.boxStyleIndex) + +increaseToolSize :: AppState -> AppState +increaseToolSize s = + let f = case s^.tool of + Repaint -> increaseRepaintSize + Restyle -> increaseRestyleSize + Eraser -> increaseEraserSize + _ -> id + in f s + +decreaseToolSize :: AppState -> AppState +decreaseToolSize s = + let f = case s^.tool of + Repaint -> decreaseRepaintSize + Restyle -> decreaseRestyleSize + Eraser -> decreaseEraserSize + _ -> id + in f s + +toolSize :: AppState -> Maybe Int +toolSize s = + case s^.tool of + Repaint -> Just $ s^.repaintSize + Restyle -> Just $ s^.restyleSize + Eraser -> Just $ s^.eraserSize + _ -> Nothing + +increaseEraserSize :: AppState -> AppState +increaseEraserSize = (& eraserSize %~ succ) + +decreaseEraserSize :: AppState -> AppState +decreaseEraserSize = (& eraserSize %~ (max 1 . pred)) + +increaseRepaintSize :: AppState -> AppState +increaseRepaintSize = (& repaintSize %~ succ) + +decreaseRepaintSize :: AppState -> AppState +decreaseRepaintSize = (& repaintSize %~ (max 1 . pred)) + +increaseRestyleSize :: AppState -> AppState +increaseRestyleSize = (& restyleSize %~ succ) + +decreaseRestyleSize :: AppState -> AppState +decreaseRestyleSize = (& restyleSize %~ (max 1 . pred)) + +withUndo :: (AppState, [Action]) -> AppState +withUndo (s, as) = pushUndo as s + +pushUndo :: [Action] -> AppState -> AppState +pushUndo [] s = s +pushUndo l s = s & undoStack %~ (l:) + & redoStack .~ [] + +beginLayerRename :: AppState -> AppState +beginLayerRename s = + let z = textZipper [line] (Just 1) + line = T.pack $ s^.layerInfoFor(s^.selectedLayerIndex).layerName + in pushMode RenameLayer $ + s & layerNameEditor.editContentsL .~ gotoEOL z + +toggleCurrentLayer :: AppState -> AppState +toggleCurrentLayer s = + withUndo $ toggleLayer (s^.selectedLayerIndex) s + +toggleLayer :: Int -> AppState -> (AppState, [Action]) +toggleLayer idx s = + ( s & layerInfoFor(idx).layerVisible %~ not + , [ToggleLayer idx] + ) + +renameCurrentLayer :: T.Text -> AppState -> AppState +renameCurrentLayer name s = + withUndo $ renameLayer (s^.selectedLayerIndex) name s + +renameLayer :: Int -> T.Text -> AppState -> (AppState, [Action]) +renameLayer idx name s = + let newName = T.unpack name + oldName = s^.layerInfoFor(idx).layerName + act = ChangeLayerName idx (T.pack oldName) + in if null newName + then (s, []) + else if newName == oldName + then (popMode s, []) + else (popMode $ + s & layerInfoFor(idx).layerName .~ T.unpack name + & canvasDirty .~ True + , [act]) + +moveCurrentLayerDown :: AppState -> AppState +moveCurrentLayerDown s = + withUndo $ moveLayer (s^.selectedLayerIndex) False s + +moveCurrentLayerUp :: AppState -> AppState +moveCurrentLayerUp s = + withUndo $ moveLayer (s^.selectedLayerIndex) True s + +moveLayer :: Int -> Bool -> AppState -> (AppState, [Action]) +moveLayer idx up s = + if up && idx == (head $ s^.layerOrder) + then (s, []) + else if (not up) && idx == (last $ s^.layerOrder) + then (s, []) + else let Just orderIndex = elemIndex idx $ s^.layerOrder + newIndex = if up then orderIndex - 1 + else orderIndex + 1 + dropped = filter (/= idx) $ s^.layerOrder + newOrder = take newIndex dropped <> + [idx] <> + drop newIndex dropped + act = MoveLayerBy idx (not up) + in (s & canvasDirty .~ True & layerOrder .~ newOrder, [act]) + +selectNextLayer :: AppState -> AppState +selectNextLayer s = + -- Find the selected layer in the layer ordering. + let Just selIndex = elemIndex (s^.selectedLayerIndex) (s^.layerOrder) + -- Then select the next layer, if any. + newSel = if selIndex == length (s^.layerOrder) - 1 + then s^.selectedLayerIndex + else (s^.layerOrder) !! (selIndex + 1) + in s & selectedLayerIndex .~ newSel + +selectPrevLayer :: AppState -> AppState +selectPrevLayer s = + -- Find the selected layer in the layer ordering. + let Just selIndex = elemIndex (s^.selectedLayerIndex) (s^.layerOrder) + -- Then select the previous layer, if any. + newSel = if selIndex == 0 + then s^.selectedLayerIndex + else (s^.layerOrder) !! (selIndex - 1) + in s & selectedLayerIndex .~ newSel + +selectLayer :: Int -> AppState -> AppState +selectLayer idx s = + s & selectedLayerIndex .~ idx + +cancelDragging :: AppState -> AppState +cancelDragging s = + s & dragging .~ Nothing + +deleteSelectedLayer :: AppState -> AppState +deleteSelectedLayer s = + withUndo $ deleteLayer (s^.selectedLayerIndex) s + +deleteLayer :: Int -> AppState -> (AppState, [Action]) +deleteLayer idx s + | M.size (s^.layers) == 1 = (s, []) + | otherwise = + let Just orderIndex = elemIndex idx (s^.layerOrder) + Just selOrderIndex = elemIndex (s^.selectedLayerIndex) (s^.layerOrder) + newSelIndex = if selOrderIndex == orderIndex + then newOrder !! (min (length newOrder - 1) selOrderIndex) + else s^.selectedLayerIndex + newOrder = catMaybes $ fixOrder <$> s^.layerOrder + fixOrder i = if idx == i + then Nothing + else Just $ if i > idx + then i - 1 + else i + + fixNameKeys m = M.fromList $ catMaybes $ fixPair <$> M.toList m + fixPair (i, n) = if idx == i + then Nothing + else (, n) <$> fixOrder i + + act = InsertLayer (s^.layerAt idx) + idx + orderIndex + (_layerName $ fromJust $ s^.layerInfo.at idx) + + in (-- Change the selected index + s & selectedLayerIndex .~ newSelIndex + -- Remove the layer from the layer map, fix indices + & layers %~ fixNameKeys + -- Reassign all higher indices in name map, ordering list, + -- layer map + & layerOrder .~ newOrder + -- Remove the layer from the layer visibility map, fix + -- indices + & layerInfo %~ fixNameKeys + , [act]) + +insertLayer :: Canvas -> Int -> Int -> String -> AppState -> (AppState, [Action]) +insertLayer c newIdx orderIndex name s = + let selIdx = s^.selectedLayerIndex + newSelIndex = if selIdx >= newIdx + then selIdx + 1 + else selIdx + newOrderNoInsert = (\i -> if i >= newIdx then i + 1 else i) <$> s^.layerOrder + newOrder = take orderIndex newOrderNoInsert <> + [newIdx] <> + drop orderIndex newOrderNoInsert + + fixNameKeys m = M.fromList $ fixPair <$> M.toList m + fixPair (i, n) = if i >= newIdx + then (i + 1, n) + else (i, n) + + act = RemoveLayer newIdx + + in ( + s & selectedLayerIndex .~ newSelIndex + & layers %~ (M.insert newIdx c . fixNameKeys) + & layerOrder .~ newOrder + & layerInfo %~ (M.insert newIdx (LayerInfo name True) . fixNameKeys) + , [act]) + +quit :: Bool -> AppState -> EventM Name (Next AppState) +quit ask s = do + case (s^.canvasDirty) of + True -> + case s^.canvasPath of + Nothing -> + case ask of + True -> continue $ askToSave s + False -> halt s + Just p -> + if ask + then continue $ askToSave s + else do + let ls = snd <$> (sortOn fst $ M.toList $ s^.layers) + liftIO $ writeCanvasFiles p ls (s^.layerOrder) + (_layerName <$> snd <$> (sortOn fst $ M.toList $ s^.layerInfo)) + halt s + False -> halt s + +writeCanvasFiles :: FilePath -> [Canvas] -> [Int] -> [String] -> IO () +writeCanvasFiles path cs order names = do + let tf = TartFile cs names order + tfp = toTartFilepath path + formats = [FormatBinary, FormatPlain, FormatAnsiColor] + forM_ formats $ \f -> writeTartFile f tf tfp + +askToSave :: AppState -> AppState +askToSave s = + pushMode AskToSave s + +askForSaveFilename :: AppState -> AppState +askForSaveFilename s = + pushMode AskForSaveFilename $ + s & askToSaveFilenameEdit .~ applyEdit gotoEOL (editor AskToSaveFilenameEdit (Just 1) $ + T.pack $ maybe "" id $ s^.canvasPath) + +beginTextEntry :: (Int, Int) -> AppState -> AppState +beginTextEntry start s = + pushMode TextEntry $ s & textEntryStart .~ start + & textEntered .~ mempty + +handleDragFinished :: AppState -> Name -> EventM Name AppState +handleDragFinished s n = + case n of + Canvas -> + case s^.tool `elem` [Box, Line] of + True -> do + (c', old) <- liftIO $ merge (s^.currentLayer) (s^.drawingOverlay) + o' <- liftIO $ clearCanvas (s^.drawingOverlay) + return $ pushUndo [SetPixels (s^.selectedLayerIndex) old] $ + s & currentLayer .~ c' + & drawingOverlay .~ o' + False -> return s + _ -> return s + +increaseCanvasSize :: AppState -> EventM Name AppState +increaseCanvasSize s = + resizeCanvas s $ + (s^.appCanvasSize) & _1 %~ (\w -> if w == 1 then 4 else w + 4) + & _2 %~ (\h -> if h == 1 then 2 else h + 2) + +decreaseCanvasSize :: AppState -> EventM Name AppState +decreaseCanvasSize s = + resizeCanvas s $ + (s^.appCanvasSize) & _1 %~ (max 1 . (subtract 4)) + & _2 %~ (max 1 . (subtract 2)) + +pushMode :: Mode -> AppState -> AppState +pushMode m s = + if isSelectionMode m && isSelectionMode (currentMode s) + then s & modes %~ ((m:) . tail) + & dragging .~ Nothing + else s & modes %~ (m:) + & dragging .~ Nothing + +popMode :: AppState -> AppState +popMode s = s & modes %~ (\m -> if length m == 1 then m else tail m) + & dragging .~ Nothing + +beginCanvasSizePrompt :: AppState -> AppState +beginCanvasSizePrompt s = + pushMode CanvasSizePrompt $ + s & canvasSizeFocus .~ focusRing [ CanvasSizeWidthEdit + , CanvasSizeHeightEdit + ] + & canvasSizeWidthEdit .~ applyEdit gotoEOL (editor CanvasSizeWidthEdit (Just 1) $ + T.pack $ show $ fst $ s^.appCanvasSize) + & canvasSizeHeightEdit .~ applyEdit gotoEOL (editor CanvasSizeHeightEdit (Just 1) $ + T.pack $ show $ snd $ s^.appCanvasSize) + +canvasMoveDown :: AppState -> AppState +canvasMoveDown s = + s & canvasOffset._2 %~ pred + +canvasMoveUp :: AppState -> AppState +canvasMoveUp s = + s & canvasOffset._2 %~ succ + +canvasMoveLeft :: AppState -> AppState +canvasMoveLeft s = + s & canvasOffset._1 %~ pred + +canvasMoveRight :: AppState -> AppState +canvasMoveRight s = + s & canvasOffset._1 %~ succ + +tryResizeCanvas :: AppState -> EventM Name AppState +tryResizeCanvas s = do + -- If the canvas size prompt inputs are valid, resize the canvas and + -- exit prompt mode. Otherwise stay in prompt mode. + let [wStr] = getEditContents $ s^.canvasSizeWidthEdit + [hStr] = getEditContents $ s^.canvasSizeHeightEdit + result = (,) <$> (readMaybe $ T.unpack wStr) + <*> (readMaybe $ T.unpack hStr) + case result of + Just (w, h) | w > 0 && h > 0 -> do + resizeCanvas (popMode s) (w, h) + _ -> return s + +beginToolSelect :: AppState -> AppState +beginToolSelect = pushMode ToolSelect + +beginBoxStyleSelect :: AppState -> AppState +beginBoxStyleSelect = pushMode BoxStyleSelect + +beginStyleSelect :: AppState -> AppState +beginStyleSelect = pushMode StyleSelect + +beginFgPaletteSelect :: AppState -> AppState +beginFgPaletteSelect = pushMode FgPaletteEntrySelect + +beginBgPaletteSelect :: AppState -> AppState +beginBgPaletteSelect = pushMode BgPaletteEntrySelect + +setTool :: AppState -> Tool -> AppState +setTool s t = s & tool .~ t + +setToolByChar :: Char -> AppState -> AppState +setToolByChar c s = + let idx = read [c] + in case filter ((== idx) . snd) tools of + [(t, _)] -> popMode $ setTool s t + _ -> s + +whenTool :: AppState -> [Tool] -> (AppState -> AppState) -> AppState +whenTool s ts f = if s^.tool `elem` ts then f s else s + +setFgPaletteIndex :: AppState -> Int -> AppState +setFgPaletteIndex s i = popMode $ s & drawFgPaletteIndex .~ i + +setBgPaletteIndex :: AppState -> Int -> AppState +setBgPaletteIndex s i = popMode $ s & drawBgPaletteIndex .~ i + +beginCharacterSelect :: AppState -> AppState +beginCharacterSelect = pushMode CharacterSelect + +cancelCharacterSelect :: AppState -> AppState +cancelCharacterSelect = popMode + +selectCharacter :: Char -> AppState -> AppState +selectCharacter c s = popMode $ s & drawCharacter .~ c + +checkForMouseSupport :: IO () +checkForMouseSupport = do + vty <- V.mkVty =<< V.standardIOConfig + + when (not $ V.supportsMode (V.outputIface vty) V.Mouse) $ do + putStrLn "Error: this terminal does not support mouse interaction" + exitFailure + + V.shutdown vty + +resizeCanvas :: AppState -> (Int, Int) -> EventM n AppState +resizeCanvas s newSz = do + ls <- liftIO $ forM (M.toList $ s^.layers) $ \(idx, l) -> + (idx,) <$> resizeFrom l newSz + o <- liftIO $ resizeFrom (s^.drawingOverlay) newSz + return $ + recenterCanvas $ + s & layers .~ (M.fromList ls) + & drawingOverlay .~ o + & appCanvasSize .~ newSz + & canvasDirty .~ (s^.appCanvasSize /= newSz) + +recenterCanvas :: AppState -> AppState +recenterCanvas s = + let sz = s^.appCanvasSize + in s & canvasOffset .~ (Location $ sz & each %~ (`div` 2)) + +toggleLayerList :: AppState -> AppState +toggleLayerList s = + s & layerListVisible %~ not + +addLayer :: AppState -> EventM Name AppState +addLayer s = do + let newLayerName = "layer " <> (show $ idx + 1) + idx = M.size $ s^.layers + orderIndex = length (s^.layerOrder) + + c <- liftIO $ newCanvas (s^.appCanvasSize) + return $ withUndo $ insertLayer c idx orderIndex newLayerName s + +currentPaletteAttribute :: AppState -> V.Attr +currentPaletteAttribute s = + let fgEntry = Vec.unsafeIndex (s^.palette) (s^.drawFgPaletteIndex) + bgEntry = Vec.unsafeIndex (s^.palette) (s^.drawBgPaletteIndex) + applyFg Nothing = id + applyFg (Just c) = (`V.withForeColor` c) + applyBg Nothing = id + applyBg (Just c) = (`V.withBackColor` c) + in (applyFg fgEntry $ applyBg bgEntry V.defAttr) `V.withStyle` (s^.drawStyle) diff --git a/programs/Theme.hs b/programs/Theme.hs new file mode 100644 --- /dev/null +++ b/programs/Theme.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} +module Theme + ( theme + + , keybindingAttr + , selectedLayerAttr + , clickableAttr + ) +where + +import Brick +import Brick.Widgets.Edit +import Graphics.Vty + +keybindingAttr :: AttrName +keybindingAttr = "keybinding" + +selectedLayerAttr :: AttrName +selectedLayerAttr = "selectedLayer" + +clickableAttr :: AttrName +clickableAttr = "clickable" + +theme :: AttrMap +theme = attrMap defAttr + [ (keybindingAttr, fg white `withStyle` underline) + , (editAttr, black `on` yellow) + , (editFocusedAttr, black `on` yellow) + , (selectedLayerAttr, white `on` magenta) + , (clickableAttr, fg white `withStyle` bold) + ] diff --git a/programs/Types.hs b/programs/Types.hs new file mode 100644 --- /dev/null +++ b/programs/Types.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RankNTypes #-} +module Types + ( Mode(..) + , Name(..) + , Tool(..) + , AppEvent(..) + , Action(..) + , toolName + , isSelectionMode + + , LayerInfo(..) + , layerName + , layerVisible + + , noStyle + , setStyle + , clearStyle + , toggleStyle + , hasStyle + + , AppState(..) + , layers + , currentLayer + , layerAt + , layerInfoFor + , layerOrder + , layerInfo + , layerNameEditor + , selectedLayerIndex + , drawingOverlay + , modes + , currentMode + , tool + , drawFgPaletteIndex + , drawBgPaletteIndex + , layerListVisible + , appCanvasSize + , palette + , drawCharacter + , fgPaletteSelectorExtent + , bgPaletteSelectorExtent + , toolSelectorExtent + , boxStyleSelectorExtent + , styleSelectorExtent + , canvasExtent + , dragging + , canvasSizeWidthEdit + , canvasSizeHeightEdit + , canvasSizeFocus + , canvasOffset + , canvasPath + , canvasDirty + , askToSaveFilenameEdit + , appEventChannel + , textEntered + , textEntryStart + , boxStyleIndex + , eraserSize + , repaintSize + , restyleSize + , undoStack + , redoStack + , drawStyle + ) +where + +import Data.Bits ((.&.), (.|.), complement) +import Data.Word (Word8) +import Data.Maybe (fromJust) +import Brick (Extent, Location) +import Brick.BChan (BChan) +import Brick.Focus +import Brick.Widgets.Edit (Editor) +import qualified Data.Text as T +import qualified Data.Map as M +import Lens.Micro.Platform +import qualified Data.Vector as Vec +import qualified Graphics.Vty as V + +import Tart.Canvas + +data AppEvent = + DragFinished Name Location Location + deriving (Eq) + +data Action = + SetPixels Int [((Int, Int), (Char, V.Attr))] + | ClearCanvasDirty + | InsertLayer Canvas Int Int String + | RemoveLayer Int + | ChangeLayerName Int T.Text + | MoveLayerBy Int Bool + | ToggleLayer Int + +data Mode = Main + | CharacterSelect + | FgPaletteEntrySelect + | BgPaletteEntrySelect + | ToolSelect + | StyleSelect + | BoxStyleSelect + | CanvasSizePrompt + | AskToSave + | AskForSaveFilename + | TextEntry + | RenameLayer + deriving (Eq, Show) + +selectionModes :: [Mode] +selectionModes = + [ CharacterSelect + , FgPaletteEntrySelect + , BgPaletteEntrySelect + , ToolSelect + , StyleSelect + , BoxStyleSelect + ] + +isSelectionMode :: Mode -> Bool +isSelectionMode = (`elem` selectionModes) + +data Name = Canvas + | TopHud + | BottomHud + | ToolSelector + | ToolSelectorEntry Tool + | CharSelector + | FgSelector + | BgSelector + | StyleSelector + | StyleSelectorEntry V.Style + | FgPaletteEntry Int + | BgPaletteEntry Int + | BoxStyleSelectorEntry Int + | ResizeCanvas + | CanvasSizeWidthEdit + | CanvasSizeHeightEdit + | AskToSaveFilenameEdit + | TextEntryCursor + | BoxStyleSelector + | IncreaseToolSize + | DecreaseToolSize + | SelectLayer Int + | LayerName + | LayerNameEditor + | AddLayer + | DeleteLayer + | MoveLayerUp + | MoveLayerDown + | ToggleLayerVisible + deriving (Eq, Show, Ord) + +data Tool = Freehand + | Box + | Line + | Repaint + | Restyle + | Eyedropper + | FloodFill + | Eraser + | TextString + deriving (Eq, Show, Ord) + +toolName :: Tool -> String +toolName Freehand = "Freehand" +toolName Box = "Box" +toolName Line = "Line" +toolName Repaint = "Repaint" +toolName Restyle = "Restyle" +toolName Eraser = "Eraser" +toolName Eyedropper = "Eyedropper" +toolName FloodFill = "Flood fill" +toolName TextString = "Text string" + +newtype DrawStyle = + DrawStyle Word8 + deriving (Eq, Show) + +setStyle :: V.Style -> V.Style -> V.Style +setStyle a b = a .|. b + +toggleStyle :: V.Style -> V.Style -> V.Style +toggleStyle a b = + if hasStyle a b + then clearStyle a b + else setStyle a b + +hasStyle :: V.Style -> V.Style -> Bool +hasStyle a b = a .&. b /= 0 + +clearStyle :: V.Style -> V.Style -> V.Style +clearStyle old dest = dest .&. complement old + +noStyle :: V.Style +noStyle = 0 + +data LayerInfo = + LayerInfo { _layerName :: String + , _layerVisible :: Bool + } + +makeLenses ''LayerInfo + +data AppState = + AppState { _layers :: M.Map Int Canvas + , _layerOrder :: [Int] + , _layerInfo :: M.Map Int LayerInfo + , _layerListVisible :: Bool + , _drawingOverlay :: Canvas + , _selectedLayerIndex :: Int + , _appCanvasSize :: (Int, Int) + , _modes :: [Mode] + , _drawFgPaletteIndex :: Int + , _drawBgPaletteIndex :: Int + , _drawStyle :: V.Style + , _drawCharacter :: Char + , _tool :: Tool + , _palette :: Vec.Vector (Maybe V.Color) + , _fgPaletteSelectorExtent :: Maybe (Extent Name) + , _bgPaletteSelectorExtent :: Maybe (Extent Name) + , _toolSelectorExtent :: Maybe (Extent Name) + , _boxStyleSelectorExtent :: Maybe (Extent Name) + , _styleSelectorExtent :: Maybe (Extent Name) + , _canvasExtent :: Maybe (Extent Name) + , _dragging :: Maybe (Name, Location, Location) + , _layerNameEditor :: Editor T.Text Name + , _canvasSizeWidthEdit :: Editor T.Text Name + , _canvasSizeHeightEdit :: Editor T.Text Name + , _canvasSizeFocus :: FocusRing Name + , _canvasOffset :: Location + , _canvasPath :: Maybe FilePath + , _canvasDirty :: Bool + , _askToSaveFilenameEdit :: Editor T.Text Name + , _appEventChannel :: BChan AppEvent + , _textEntered :: [(Char, V.Attr)] + , _textEntryStart :: (Int, Int) + , _boxStyleIndex :: Int + , _eraserSize :: Int + , _repaintSize :: Int + , _restyleSize :: Int + , _undoStack :: [[Action]] + , _redoStack :: [[Action]] + } + +makeLenses ''AppState + +currentLayer :: Lens' AppState Canvas +currentLayer = + lens (\s -> fromJust $ s^.layers.at (s^.selectedLayerIndex)) + (\s c -> s & layers.at (s^.selectedLayerIndex) .~ Just c) + +layerAt :: Int -> Lens' AppState Canvas +layerAt i = + lens (\s -> fromJust $ s^.layers.at i) + (\s c -> s & layers.at i .~ Just c) + +layerInfoFor :: Int -> Lens' AppState LayerInfo +layerInfoFor i = + lens (\s -> fromJust $ s^.layerInfo.at i) + (\s v -> s & layerInfo.at i .~ Just v) + +currentMode :: AppState -> Mode +currentMode s = case _modes s of + (m:_) -> m + _ -> error "BUG: currentMode: no modes!" diff --git a/programs/UI.hs b/programs/UI.hs new file mode 100644 --- /dev/null +++ b/programs/UI.hs @@ -0,0 +1,39 @@ +module UI + ( drawUI + ) +where + +import Brick +import Lens.Micro.Platform + +import Types +import UI.Main +import UI.CharacterSelect +import UI.PaletteEntrySelect +import UI.ToolSelect +import UI.CanvasSizePrompt +import UI.AskToSave +import UI.AskForSaveFilename +import UI.TextEntry +import UI.BoxStyleSelect +import UI.StyleSelect + +drawUI :: AppState -> [Widget Name] +drawUI s = + concat $ drawMode s <$> s^.modes + +drawMode :: AppState -> Mode -> [Widget Name] +drawMode s m = + case m of + Main -> drawMainUI s + RenameLayer -> [] + FgPaletteEntrySelect -> drawPaletteEntrySelectUI s + BgPaletteEntrySelect -> drawPaletteEntrySelectUI s + ToolSelect -> drawToolSelectUI s + CharacterSelect -> drawCharacterSelectUI s + CanvasSizePrompt -> drawCanvasSizePromptUI s + AskToSave -> drawAskToSaveUI s + AskForSaveFilename -> drawAskForSaveFilenameUI s + TextEntry -> drawTextEntryUI s + BoxStyleSelect -> drawBoxStyleSelectUI s + StyleSelect -> drawStyleSelectUI s diff --git a/programs/UI/AskForSaveFilename.hs b/programs/UI/AskForSaveFilename.hs new file mode 100644 --- /dev/null +++ b/programs/UI/AskForSaveFilename.hs @@ -0,0 +1,37 @@ +module UI.AskForSaveFilename + ( drawAskForSaveFilenameUI + ) +where + +import qualified Data.Text as T +import Lens.Micro.Platform + +import Brick +import Brick.Widgets.Border +import Brick.Widgets.Center +import Brick.Widgets.Edit + +import Types +import Theme + +drawAskForSaveFilenameUI :: AppState -> [Widget Name] +drawAskForSaveFilenameUI s = [drawPromptWindow s] + +drawPromptWindow :: AppState -> Widget Name +drawPromptWindow s = + centerLayer $ + borderWithLabel (str "Save") $ + hLimit 60 $ + padLeftRight 2 $ padTopBottom 1 body + where + help = hBox [ str "(" + , withDefAttr keybindingAttr $ str "Enter" + , str " to save and quit, " + , withDefAttr keybindingAttr $ str "Esc" + , str " to quit without saving)" + ] + body = (hCenter $ str "Save changes to:") <=> + (hCenter help) <=> + padTopBottom 1 fn + renderString = txt . T.unlines + fn = str "Path: " <+> renderEditor renderString True (s^.askToSaveFilenameEdit) diff --git a/programs/UI/AskToSave.hs b/programs/UI/AskToSave.hs new file mode 100644 --- /dev/null +++ b/programs/UI/AskToSave.hs @@ -0,0 +1,28 @@ +module UI.AskToSave + ( drawAskToSaveUI + ) +where + +import Brick +import Brick.Widgets.Border +import Brick.Widgets.Center + +import Types +import Theme + +drawAskToSaveUI :: AppState -> [Widget Name] +drawAskToSaveUI _ = [drawPromptWindow] + +drawPromptWindow :: Widget Name +drawPromptWindow = + centerLayer $ + borderWithLabel (str "Save") $ + hLimit 60 $ + padLeftRight 2 $ padTopBottom 1 body + where + help = hBox [ str "(" + , withDefAttr keybindingAttr $ str "Esc" + , str " to quit without saving)" + ] + body = (hCenter $ str "You have unsaved changes. Save them? (y/n)") <=> + (hCenter help) diff --git a/programs/UI/BoxStyleSelect.hs b/programs/UI/BoxStyleSelect.hs new file mode 100644 --- /dev/null +++ b/programs/UI/BoxStyleSelect.hs @@ -0,0 +1,40 @@ +module UI.BoxStyleSelect + ( drawBoxStyleSelectUI + ) +where + +import Brick +import Brick.Widgets.Border +import Brick.Widgets.Border.Style +import Lens.Micro.Platform + +import Types +import UI.Main +import State + +drawBoxStyleSelectUI :: AppState -> [Widget Name] +drawBoxStyleSelectUI s = + let Just ext = s^.boxStyleSelectorExtent + toolSel = drawBoxStyleSelector ext + in toolSel + +drawBoxStyleSelector :: Extent Name -> [Widget Name] +drawBoxStyleSelector ext = + [borderHack, body] + where + borderHack = translateBy l bottomBorder + l = Location ( fst $ loc $ extentUpperLeft ext + , (snd $ extentSize ext) + (snd $ loc $ extentUpperLeft ext) - 1 + ) + bottomBorder = hBox [ borderElem bsIntersectL + , hLimit boxStyleSelectorEntryWidth hBorder + , borderElem bsIntersectR + ] + body = translateBy l $ + border $ vBox entries + entries = mkEntry <$> zip [0..] boxStyles + mkEntry (i, (n, _)) = + clickable (BoxStyleSelectorEntry i) $ + vLimit 1 $ + hLimit boxStyleSelectorEntryWidth $ + (str n) <+> fill ' ' diff --git a/programs/UI/CanvasSizePrompt.hs b/programs/UI/CanvasSizePrompt.hs new file mode 100644 --- /dev/null +++ b/programs/UI/CanvasSizePrompt.hs @@ -0,0 +1,32 @@ +module UI.CanvasSizePrompt + ( drawCanvasSizePromptUI + ) +where + +import qualified Data.Text as T +import Lens.Micro.Platform + +import Brick +import Brick.Focus +import Brick.Widgets.Border +import Brick.Widgets.Center +import Brick.Widgets.Edit + +import Types + +drawCanvasSizePromptUI :: AppState -> [Widget Name] +drawCanvasSizePromptUI s = [drawPromptWindow s] + +drawPromptWindow :: AppState -> Widget Name +drawPromptWindow s = + centerLayer $ + borderWithLabel (str "Resize Canvas") $ + hLimit 40 $ + padLeftRight 2 $ padTopBottom 1 body + where + body = padBottom (Pad 1) width <=> height + renderString = txt . T.unlines + width = str "Width: " <+> withFocusRing (s^.canvasSizeFocus) + (renderEditor renderString) (s^.canvasSizeWidthEdit) + height = str "Height: " <+> withFocusRing (s^.canvasSizeFocus) + (renderEditor renderString) (s^.canvasSizeHeightEdit) diff --git a/programs/UI/CharacterSelect.hs b/programs/UI/CharacterSelect.hs new file mode 100644 --- /dev/null +++ b/programs/UI/CharacterSelect.hs @@ -0,0 +1,21 @@ +module UI.CharacterSelect + ( drawCharacterSelectUI + ) +where + +import Brick +import Brick.Widgets.Center +import Brick.Widgets.Border + +import Types + +drawCharacterSelectUI :: AppState -> [Widget Name] +drawCharacterSelectUI _ = [prompt] + +prompt :: Widget Name +prompt = + centerLayer $ + borderWithLabel (str "Choose a Character") $ + padTopBottom 1 $ + padLeftRight 2 $ + str "Press a character to draw with." diff --git a/programs/UI/Common.hs b/programs/UI/Common.hs new file mode 100644 --- /dev/null +++ b/programs/UI/Common.hs @@ -0,0 +1,49 @@ +module UI.Common + ( drawPaletteEntry + , drawPalette + ) +where + +import Brick +import Brick.Widgets.Border +import Brick.Widgets.Border.Style +import Lens.Micro.Platform +import qualified Graphics.Vty as V +import qualified Data.Vector as Vec + +import Types + +drawPaletteEntry :: AppState -> Int -> Int -> Widget Name +drawPaletteEntry s idx width = + let pal = s^.palette + entry = Vec.unsafeIndex pal idx + attr = case entry of + Nothing -> V.defAttr + Just c -> V.defAttr `V.withBackColor` c + ch = ' ' + in raw $ V.string attr (replicate width ch) + +drawPalette :: AppState -> Bool -> [Widget Name] +drawPalette s isFgPalette = + [borderHack, body] + where + pal = s^.palette + Just ext = if isFgPalette + then s^.fgPaletteSelectorExtent + else s^.bgPaletteSelectorExtent + mkName = if isFgPalette + then FgPaletteEntry + else BgPaletteEntry + borderHack = translateBy l topBorder + topBorder = hBox [ borderElem bsIntersectL + , hLimit 4 hBorder + , borderElem bsIntersectB + ] + body = translateBy l $ border $ vBox entries + l = Location ( fst $ loc $ extentUpperLeft ext + , (snd $ extentSize ext) + (snd $ loc $ extentUpperLeft ext) - 1 + ) + idxs = [0..Vec.length pal-1] + entries = mkEntry <$> idxs + mkEntry i = clickable (mkName i) $ + drawPaletteEntry s i 6 diff --git a/programs/UI/Main.hs b/programs/UI/Main.hs new file mode 100644 --- /dev/null +++ b/programs/UI/Main.hs @@ -0,0 +1,240 @@ +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 -> "" + Just p -> p + modified = if not $ s^.canvasDirty then "" else "*" + in clickable TopHud $ + vBox [ (padLeft (Pad 1) $ hBox $ padRight (Pad 1) <$> toolbarEntries) + , hBox [hBorder, str ("[" <> 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 $ str "Layers") : + (mkEntry <$> entries) <> + [addLayerEntry] + entries = [ ( i + , s^.layerInfoFor(i) + ) + | i <- s^.layerOrder + ] + addLayerEntry = + clickable AddLayer $ hCenter $ + withDefAttr clickableAttr $ str "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 (<+> str "H") + in clickable (if idx == s^.selectedLayerIndex + then LayerName + else SelectLayer idx) $ + applyAttr $ vLimit 1 $ + showHiddenStatus $ + str name <+> fill ' ' + layerOptions = + let i = s^.selectedLayerIndex + entry n label = + clickable n $ vLimit 1 $ withDefAttr clickableAttr $ + str label <+> fill ' ' + in vBox $ catMaybes + [ Just $ hBorderWithLabel (str "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 = 7 + +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 $ str ">>" + dec = clickable DecreaseToolSize $ withDefAttr keybindingAttr $ str "<<" + sz = fromMaybe (error "BUG: current tool has no size") $ toolSize s + in borderWithLabel (str "Size") $ + dec <+> (hLimit 5 $ hCenter $ str $ show sz) <+> inc + +drawBoxStyleSelector :: AppState -> Widget Name +drawBoxStyleSelector s = + let styleName = fst $ getBoxBorderStyle s + in clickable BoxStyleSelector $ + borderWithLabel (str "Box Style") $ + hLimit boxStyleSelectorEntryWidth $ + hCenter $ str styleName + +drawStyleSelector :: AppState -> Widget Name +drawStyleSelector s = + clickable StyleSelector $ + borderWithLabel (str "St" <+> (withDefAttr keybindingAttr $ str "y") <+> str "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 (str "Can" <+> (withDefAttr keybindingAttr (str "v")) <+> str "as") $ + hLimit 8 $ hCenter (str $ show width <> "x" <> show height) + +drawChar :: AppState -> Widget Name +drawChar s = + clickable CharSelector $ + borderWithLabel ((withDefAttr keybindingAttr $ str "C") <+> str "har") $ + padLeftRight 2 $ str [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 $ str "T") <+> str "ool") $ + hLimit toolSelectorEntryWidth $ + hCenter $ + (withDefAttr keybindingAttr (str $ show idx)) <+> + (str $ ":" <> toolName (s^.tool)) + +drawPaletteSelector :: AppState -> Bool -> Widget Name +drawPaletteSelector s isFg = + (clickable selName $ borderWithLabel label curColor) + where + label = if isFg + then (withDefAttr keybindingAttr $ str "F") <+> str "G" + else (withDefAttr keybindingAttr $ str "B") <+> str "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 diff --git a/programs/UI/PaletteEntrySelect.hs b/programs/UI/PaletteEntrySelect.hs new file mode 100644 --- /dev/null +++ b/programs/UI/PaletteEntrySelect.hs @@ -0,0 +1,19 @@ +module UI.PaletteEntrySelect + ( drawPaletteEntrySelectUI + ) +where + +import Data.Monoid ((<>)) +import Brick + +import Types +import UI.Common + +drawPaletteEntrySelectUI :: AppState -> [Widget Name] +drawPaletteEntrySelectUI s = + let isFg = case currentMode s of + FgPaletteEntrySelect -> True + BgPaletteEntrySelect -> False + m -> error $ "BUG: should never get called in mode " <> show m + pal = drawPalette s isFg + in pal diff --git a/programs/UI/StyleSelect.hs b/programs/UI/StyleSelect.hs new file mode 100644 --- /dev/null +++ b/programs/UI/StyleSelect.hs @@ -0,0 +1,48 @@ +module UI.StyleSelect + ( drawStyleSelectUI + ) +where + +import Brick +import Brick.Widgets.Border +import Brick.Widgets.Border.Style +import Lens.Micro.Platform +import qualified Graphics.Vty as V + +import Types +import UI.Main +import State +import Theme + +drawStyleSelectUI :: AppState -> [Widget Name] +drawStyleSelectUI s = + let Just ext = s^.styleSelectorExtent + stySel = drawStyleSelector (s^.drawStyle) ext + in stySel + +drawStyleSelector :: V.Style -> Extent Name -> [Widget Name] +drawStyleSelector curStyle ext = + [borderHack, body] + where + borderHack = translateBy l bottomBorder + l = Location ( fst $ loc $ extentUpperLeft ext + , (snd $ extentSize ext) + (snd $ loc $ extentUpperLeft ext) - 1 + ) + bottomBorder = hBox [ borderElem bsIntersectL + , hLimit styleSelectorEntryWidth hBorder + , borderElem bsIntersectR + ] + body = translateBy l $ + border $ vBox entries + entries = mkEntry <$> styleBindings + maybeActive sty = + if hasStyle sty curStyle + then (<+> str "*") + else id + mkEntry (ch, sty) = + clickable (StyleSelectorEntry sty) $ + vLimit 1 $ + hLimit styleSelectorEntryWidth $ + (withDefAttr keybindingAttr (str [ch])) <+> str ":" <+> + (maybeActive sty $ raw $ V.string (V.defAttr `V.withStyle` sty) "demo") <+> + fill ' ' diff --git a/programs/UI/TextEntry.hs b/programs/UI/TextEntry.hs new file mode 100644 --- /dev/null +++ b/programs/UI/TextEntry.hs @@ -0,0 +1,26 @@ +module UI.TextEntry + ( drawTextEntryUI + ) +where + +import Brick +import qualified Graphics.Vty as V +import Lens.Micro.Platform + +import Types +import Draw + +drawTextEntryUI :: AppState -> [Widget Name] +drawTextEntryUI s = [textOverlay s] + +textOverlay :: AppState -> Widget Name +textOverlay s = + let Just cExt = s^.canvasExtent + p = s^.textEntryStart + t = s^.textEntered + off = extentUpperLeft cExt & _1 %~ (+ (p^._1)) + & _2 %~ (+ (p^._2)) + in translateBy off $ + showCursor TextEntryCursor (Location (length t, 0)) $ + (raw $ V.horizCat $ (\(ch, attr) -> V.char attr ch) <$> + (truncateText (s^.textEntryStart) (s^.textEntered) s)) diff --git a/programs/UI/ToolSelect.hs b/programs/UI/ToolSelect.hs new file mode 100644 --- /dev/null +++ b/programs/UI/ToolSelect.hs @@ -0,0 +1,41 @@ +module UI.ToolSelect + ( drawToolSelectUI + ) +where + +import Data.Monoid ((<>)) +import Brick +import Brick.Widgets.Border +import Brick.Widgets.Border.Style +import Lens.Micro.Platform + +import Types +import UI.Main +import State +import Theme + +drawToolSelectUI :: AppState -> [Widget Name] +drawToolSelectUI s = + let Just ext = s^.toolSelectorExtent + in drawToolSelector ext + +drawToolSelector :: Extent Name -> [Widget Name] +drawToolSelector ext = + [borderHack, body] + where + borderHack = translateBy l topBorder + topBorder = hBox [ borderElem bsIntersectL + , hLimit toolSelectorEntryWidth hBorder + , borderElem bsIntersectR + ] + body = translateBy l $ border $ vBox entries + l = Location ( fst $ loc $ extentUpperLeft ext + , (snd $ extentSize ext) + (snd $ loc $ extentUpperLeft ext) - 1 + ) + entries = mkEntry <$> tools + mkEntry (t, i) = + clickable (ToolSelectorEntry t) $ + vLimit 1 $ + hLimit toolSelectorEntryWidth $ + (withDefAttr keybindingAttr (str $ show i)) <+> + (str $ ":" <> toolName t) <+> fill ' ' diff --git a/src/Tart/Canvas.hs b/src/Tart/Canvas.hs new file mode 100644 --- /dev/null +++ b/src/Tart/Canvas.hs @@ -0,0 +1,397 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE BinaryLiterals #-} +module Tart.Canvas + ( Canvas + , CanvasData + , canvasFromData + , canvasToData + , newCanvas + , canvasSize + , canvasSetPixel + , canvasSetMany + , canvasGetPixel + , resizeFrom + , prettyPrintCanvas + , merge + , clearCanvas + , canvasFromText + , canvasLayersToImage + , normalizeAttr + ) +where + +import Control.Monad (forM_, forM, replicateM, when) +import Control.Monad.State +import Data.Bits +import Data.Word (Word64) +import Data.Monoid ((<>)) +import Data.Maybe (catMaybes) +import Data.List (intercalate) +import qualified Graphics.Vty as V +import qualified Data.Array.IArray as I +import qualified Data.Array.MArray as A +import qualified Data.Binary as B +import Data.Array.IO (IOUArray) +import Data.Array.Unboxed (UArray) +import Lens.Micro.Platform + +data Canvas = + Canvas { mut :: IOUArray (Int, Int) Word64 + , immut :: UArray (Int, Int) Word64 + , size :: (Int, Int) + } + +data CanvasData = + CanvasData { canvasDataSize :: (Int, Int) + , canvasData :: [Word64] + } + +instance B.Binary CanvasData where + put cd = do + B.put $ canvasDataSize cd + mapM_ B.put $ canvasData cd + + get = do + (w, h) <- B.get + CanvasData <$> (pure (w, h)) + <*> replicateM (w * h) B.get + +canvasFromData :: CanvasData -> IO (Either String Canvas) +canvasFromData cd = do + let (w, h) = canvasDataSize cd + if w * h /= length (canvasData cd) + then return $ Left "Canvas data entries do not match dimensions" + else do + c <- newCanvas (w, h) + let idxs = [(w', h') | w' <- [0..w-1], h' <- [0..h-1]] + forM_ (zip idxs (canvasData cd)) $ \(point, word) -> + A.writeArray (mut c) point word + f <- A.freeze $ mut c + return $ Right $ c { immut = f } + +canvasToData :: Canvas -> CanvasData +canvasToData c = + CanvasData sz canvasPixels + where + sz@(w, h) = canvasSize c + canvasPixels = + [ canvasGetPixelRaw c (w', h') + | w' <- [0..w-1], h' <- [0..h-1] + ] + +newCanvas :: (Int, Int) -> IO Canvas +newCanvas sz = do + let arrayBounds = ((0, 0), sz & each %~ pred) + draw <- A.newArray arrayBounds blankPixel + drawFreeze <- A.freeze draw + return $ Canvas draw drawFreeze sz + +canvasFromText :: String -> IO Canvas +canvasFromText s = do + let ls = convertTab <$> lines s + convertTab l = concat $ convertTabChar <$> l + convertTabChar '\t' = replicate 8 ' ' + convertTabChar c = [c] + height = length ls + width = maximum $ length <$> ls + pixs = concat $ mkRowPixels <$> zip [0..] ls + mkRowPixels (rowNum, row) = + mkPixel rowNum <$> zip [0..] row + mkPixel rowNum (colNum, ch) = + ((colNum, rowNum), ch, V.defAttr) + + c <- newCanvas (width, height) + canvasSetMany c pixs + +clearCanvas :: Canvas -> IO Canvas +clearCanvas c = do + let (width, height) = canvasSize c + forM_ [0..width-1] $ \w -> + forM_ [0..height-1] $ \h -> do + A.writeArray (mut c) (w, h) blankPixel + f <- A.freeze (mut c) + return $ c { immut = f } + +type RLE a = State RLEState a + +data RLEState = + RLEState { content :: [(String, V.Attr)] + , currentString :: String + , currentAttr :: V.Attr + } + +runRLE :: RLE () -> [(String, V.Attr)] +runRLE act = + let s = execState (act >> sealFinalToken) (RLEState [] "" V.defAttr) + in content s + +rleNext :: (Char, V.Attr) -> RLE () +rleNext (ch, attr) = do + -- If the attribute matches the current attribute, just append the + -- character. + cur <- gets currentAttr + case cur == attr of + True -> appendCharacter ch + False -> newToken ch attr + +appendCharacter :: Char -> RLE () +appendCharacter c = + modify $ \s -> s { currentString = currentString s <> [c] + } + +sealFinalToken :: RLE () +sealFinalToken = + modify $ \s -> s { content = if null $ currentString s + then content s + else content s <> [(currentString s, currentAttr s)] + } + +newToken :: Char -> V.Attr -> RLE () +newToken c a = + modify $ \s -> s { currentString = [c] + , currentAttr = a + , content = if null $ currentString s + then content s + else content s <> [(currentString s, currentAttr s)] + } + +prettyPrintCanvas :: Bool -> [Canvas] -> String +prettyPrintCanvas emitSequences cs = + let pairs = runRLE (mkRLE cs) + mkOutput (s, attr) = + if emitSequences + then ctrlSequence attr <> s + else s + ctrlSequence a = + "\ESC[0m" <> attrSequence a + in concat $ mkOutput <$> pairs + +mkRLE :: [Canvas] -> RLE () +mkRLE [] = return () +mkRLE cs@(c:_) = do + let (w, h) = canvasSize c + forM_ [0..h-1] $ \row -> do + forM_ [0..w-1] $ \col -> + rleNext $ findPixel cs (col, row) + rleNext ('\n', V.defAttr) + +attrSequence :: V.Attr -> String +attrSequence a = + let fg = colorCode True (V.attrForeColor a) + bg = colorCode False (V.attrBackColor a) + sty = styleCode (V.attrStyle a) + in fg <> bg <> sty + +styleCode :: V.MaybeDefault V.Style -> String +styleCode V.KeepCurrent = "" +styleCode V.Default = "" +styleCode (V.SetTo s) = styleCode' s + +styles :: [V.Style] +styles = + [ V.bold + , V.underline + , V.blink + , V.reverseVideo + ] + +styleCode' :: V.Style -> String +styleCode' s = + let present = filter (V.hasStyle s) styles + in if null present + then "" + else "\ESC[" <> intercalate ";" (styleToCode <$> present) <> "m" + +styleToCode :: V.Style -> String +styleToCode s = + let mapping = [ (V.bold, "1") + , (V.underline, "4") + , (V.blink, "5") + , (V.reverseVideo, "7") + ] + in maybe "" id $ lookup s mapping + +colorCode :: Bool -> V.MaybeDefault V.Color -> String +colorCode _ V.KeepCurrent = "" +colorCode _ V.Default = "" +colorCode f (V.SetTo c) = colorCode' f c + +colorCode' :: Bool -> V.Color -> String +colorCode' f (V.Color240 w) = + "\ESC[" <> if f then "38" else "48" <> ";5;" <> show w <> "m" +colorCode' f (V.ISOColor w) = + let c = if f then "38" else "48" + valid v = v >= 0 && v <= 15 + in if valid w + then "\ESC[" <> c <> ";5;" <> show w <> "m" + else "" + +canvasSize :: Canvas -> (Int, Int) +canvasSize = size + +canvasGetPixel :: Canvas -> (Int, Int) -> (Char, V.Attr) +canvasGetPixel c p = decodePixel $ canvasGetPixelRaw c p + +canvasGetPixelRaw :: Canvas -> (Int, Int) -> Word64 +canvasGetPixelRaw c point = (immut c) I.! point + +canvasSetMany :: Canvas -> [((Int, Int), Char, V.Attr)] -> IO Canvas +canvasSetMany c pixels = do + forM_ pixels $ \(point, ch, attr) -> do + valid <- isValidPoint point (mut c) + when valid $ A.writeArray (mut c) point $ encodePixel ch attr + + f <- A.freeze (mut c) + return $ c { immut = f + } + +isValidPoint :: (Int, Int) -> IOUArray (Int, Int) Word64 -> IO Bool +isValidPoint (c, r) arr = do + ((loC, loR), (hiC, hiR)) <- A.getBounds arr + return $ r >= loR && c >= loC && + r <= hiR && c <= hiC + +canvasSetPixel :: Canvas -> (Int, Int) -> Char -> V.Attr -> IO Canvas +canvasSetPixel c point ch attr = canvasSetMany c [(point, ch, attr)] + +blankPixel :: Word64 +blankPixel = encodePixel ' ' V.defAttr + +resizeFrom :: Canvas -> (Int, Int) -> IO Canvas +resizeFrom old newSz = do + -- If the new bounds are different than the old, create a new array + -- and copy. + case newSz /= canvasSize old of + False -> return old + True -> do + new <- newCanvas newSz + (c, _) <- merge new old + return c + +encodePixel :: Char -> V.Attr -> Word64 +encodePixel c a = + -- Convert char to word32 + -- Convert attr color slots to 10-bit sequences (set bit, type bit, color bits) + let low32Mask = 2 ^ (32::Integer) - 1 + c64 = fromIntegral $ fromEnum c + a' = normalizeAttr c a + in (c64 .&. low32Mask) .|. + (encodeAttribute a' `shiftL` 32) + +decodePixel :: Word64 -> (Char, V.Attr) +decodePixel v = + let chBits = v .&. (2 ^ (32::Integer) - 1) + attrBits = v `shiftR` 32 + attr = decodeAttribute attrBits + ch = toEnum $ fromIntegral chBits + in (ch, normalizeAttr ch attr) + +normalizeAttr :: Char -> V.Attr -> V.Attr +normalizeAttr ch attr = + if ch == ' ' && (not $ hasForegroundStyle $ V.attrStyle attr) + then attr { V.attrForeColor = V.Default + , V.attrStyle = V.Default + } + else attr + +hasForegroundStyle :: V.MaybeDefault V.Style -> Bool +hasForegroundStyle (V.SetTo s) = + or [ V.hasStyle s V.underline + , V.hasStyle s V.reverseVideo + ] +hasForegroundStyle _ = False + +encodeAttribute :: V.Attr -> Word64 +encodeAttribute attr = + (encodeAttrStyle (V.attrStyle attr) `shiftL` 20) .|. + (encodeAttrColor (V.attrForeColor attr) `shiftL` 10) .|. + (encodeAttrColor (V.attrBackColor attr)) + +encodeAttrStyle :: V.MaybeDefault V.Style -> Word64 +encodeAttrStyle V.Default = 0 +encodeAttrStyle V.KeepCurrent = 0 +encodeAttrStyle (V.SetTo s) = fromIntegral s + +decodeAttrStyle :: Word64 -> V.MaybeDefault V.Style +decodeAttrStyle 0 = V.Default +decodeAttrStyle v = V.SetTo $ fromIntegral v + +decodeAttribute :: Word64 -> V.Attr +decodeAttribute v = + let attrColorMask = 2 ^ (10::Integer) - 1 + attrStyleMask = 2 ^ (8::Integer) - 1 + in V.defAttr { V.attrStyle = decodeAttrStyle $ (v `shiftR` 20) .&. attrStyleMask + , V.attrForeColor = decodeAttrColor $ (v `shiftR` 10) .&. attrColorMask + , V.attrBackColor = decodeAttrColor $ v .&. attrColorMask + } + +encodeAttrColor :: V.MaybeDefault V.Color -> Word64 +encodeAttrColor V.Default = 0 +encodeAttrColor V.KeepCurrent = 0 +encodeAttrColor (V.SetTo c) = + let (ty, color) = case c of + V.ISOColor w -> (0, fromIntegral w) + V.Color240 w -> (1, fromIntegral w) + in (1 `shiftL` 9) .|. + (ty `shiftL` 8) .|. + color + +decodeAttrColor :: Word64 -> V.MaybeDefault V.Color +decodeAttrColor 0 = V.Default +decodeAttrColor v = + let ty = (v `shiftR` 8) .&. 0b1 + color = fromIntegral $ v .&. 0b11111111 + in if ty == 1 + then V.SetTo $ V.Color240 color + else V.SetTo $ V.ISOColor color + +merge :: Canvas -> Canvas -> IO (Canvas, [((Int, Int), (Char, V.Attr))]) +merge dest src = do + let (width, height) = (min srcW destW, min srcH destH) + (srcW, srcH) = canvasSize src + (destW, destH) = canvasSize dest + + undoBuf <- forM [0..width-1] $ \w -> + forM [0..height-1] $ \h -> do + let pix = (immut src) I.! (w, h) + case pix /= blankPixel of + True -> do + old <- A.readArray (mut dest) (w, h) + A.writeArray (mut dest) (w, h) pix + return $ Just ((w, h), decodePixel old) + False -> + return Nothing + + f <- A.freeze $ mut dest + return (dest { immut = f }, catMaybes $ concat undoBuf) + +-- | Create a Vty image from a list of canvas layers, with the topmost +-- layer being the first canvas in the list. A pixel in the final image +-- is set by looking for the first non-blank pixel in the canvas list, +-- starting at the beginning. +-- +-- The result will be as high as the least tall input canvas, and as +-- wide as the least wide input canvas. +canvasLayersToImage :: [Canvas] -> V.Image +canvasLayersToImage [] = V.emptyImage +canvasLayersToImage cs = + let sizes = canvasSize <$> cs + smallestSize = ( minimum $ fst <$> sizes + , minimum $ snd <$> sizes + ) + (lastCol, lastRow) = smallestSize & each %~ pred + rows = getRow <$> [0..lastRow] + getRow r = V.horizCat $ (uncurry $ flip V.char) <$> getCol r <$> [0..lastCol] + getCol r c = findPixel cs (c, r) + in V.vertCat rows + +findPixel :: [Canvas] -> (Int, Int) -> (Char, V.Attr) +findPixel [] _ = error "BUG: canvasLayersToImage got no layers" +findPixel [l] point = canvasGetPixel l point +findPixel (l:ls) point = + let pix = canvasGetPixel l point + blank = decodePixel blankPixel + in if pix == blank + then findPixel ls point + else pix diff --git a/src/Tart/Format.hs b/src/Tart/Format.hs new file mode 100644 --- /dev/null +++ b/src/Tart/Format.hs @@ -0,0 +1,99 @@ +module Tart.Format + ( TartFile(..) + , OutputFormat(..) + , TartFilePath + , readTartFile + , writeTartFile + , sortedCanvases + , toTartFilepath + ) +where + +import Data.Monoid ((<>)) +import Data.List (isSuffixOf) +import qualified Data.Binary.Put as B +import qualified Data.Binary.Get as B +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL + +import Tart.Canvas +import Tart.Format.Types +import Tart.Format.V0 +import Tart.Format.V1 +import Tart.Format.V2 + +data OutputFormat = + FormatBinary + | FormatAnsiColor + | FormatPlain + deriving (Eq, Show, Read) + +formats :: [TartFileFormat] +formats = + [ version2Format + , version1Format + , version0Format + ] + +newtype TartFilePath = TartFilePath FilePath + +tartFilenameExtension :: String +tartFilenameExtension = ".tart" + +toTartFilepath :: FilePath -> TartFilePath +toTartFilepath p = + if tartFilenameExtension `isSuffixOf` p + then TartFilePath $ take (length p - length tartFilenameExtension) p + else TartFilePath p + +readTartFile :: TartFilePath -> IO (Either String TartFile) +readTartFile (TartFilePath path) = do + bs <- BS.readFile $ path <> tartFilenameExtension + readTartFile' (BSL.fromStrict bs) path formats + +readTartFile' :: BSL.ByteString -> FilePath -> [TartFileFormat] -> IO (Either String TartFile) +readTartFile' _ path [] = return $ Left $ path <> ": could not load file" +readTartFile' bs path ((BinaryFormatVersion parser converter):fmts) = do + let tryNextFormat = readTartFile' bs path fmts + case B.runGetOrFail parser bs of + Left _ -> tryNextFormat + Right (remaining, _, d) -> + case BSL.null remaining of + False -> tryNextFormat + True -> do + result <- converter d + case result of + Left _ -> tryNextFormat + Right tf -> return $ Right tf + +writeTartFile :: OutputFormat -> TartFile -> TartFilePath -> IO () +writeTartFile format = + case format of + FormatPlain -> writeTartFilePretty False + FormatAnsiColor -> writeTartFilePretty True + FormatBinary -> writeTartFileBinary + +sortedCanvases :: [Int] -> [Canvas] -> [Canvas] +sortedCanvases order cs = + [ cs !! i | i <- order ] + +tartFileCanvasesSorted :: TartFile -> [Canvas] +tartFileCanvasesSorted tf = + sortedCanvases (tartFileCanvasOrder tf) + (tartFileCanvasList tf) + +writeTartFilePretty :: Bool -> TartFile -> TartFilePath -> IO () +writeTartFilePretty color tf (TartFilePath path) = + let ext = if color then ".color.txt" + else ".plain.txt" + fn = path <> ext + in writeFile fn $ + prettyPrintCanvas color $ tartFileCanvasesSorted tf + +writeTartFileBinary :: TartFile -> TartFilePath -> IO () +writeTartFileBinary tf (TartFilePath path) = + let fn = path <> tartFilenameExtension + in BS.writeFile fn $ BSL.toStrict $ B.runPut $ latestVersionEncoder tf + +latestVersionEncoder :: TartFile -> B.Put +latestVersionEncoder = encodeVersion2 diff --git a/src/Tart/Format/Types.hs b/src/Tart/Format/Types.hs new file mode 100644 --- /dev/null +++ b/src/Tart/Format/Types.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE GADTs #-} +module Tart.Format.Types + ( TartFile(..) + , TartFileFormat(..) + ) +where + +import qualified Data.Binary as B + +import Tart.Canvas + +data TartFile = + TartFile { tartFileCanvasList :: [Canvas] + , tartFileCanvasNames :: [String] + , tartFileCanvasOrder :: [Int] + } + +data TartFileFormat where + BinaryFormatVersion :: (B.Get a) + -> (a -> IO (Either String TartFile)) + -> TartFileFormat diff --git a/src/Tart/Format/V0.hs b/src/Tart/Format/V0.hs new file mode 100644 --- /dev/null +++ b/src/Tart/Format/V0.hs @@ -0,0 +1,30 @@ +module Tart.Format.V0 + ( version0Format + ) +where + +import qualified Data.Binary as B + +import Tart.Canvas +import Tart.Format.Types + +data TartFileDataV0 = + TartFileDataV0 { tartFileDataV0CanvasData :: CanvasData + } + +version0Format :: TartFileFormat +version0Format = + BinaryFormatVersion B.get tartFileFromDataV0 + +instance B.Binary TartFileDataV0 where + put d = + B.put $ tartFileDataV0CanvasData d + get = + TartFileDataV0 <$> B.get + +tartFileFromDataV0 :: TartFileDataV0 -> IO (Either String TartFile) +tartFileFromDataV0 d = do + result <- canvasFromData (tartFileDataV0CanvasData d) + case result of + Left s -> return $ Left s + Right c -> return $ Right $ TartFile [c] ["default"] [0] diff --git a/src/Tart/Format/V1.hs b/src/Tart/Format/V1.hs new file mode 100644 --- /dev/null +++ b/src/Tart/Format/V1.hs @@ -0,0 +1,58 @@ +module Tart.Format.V1 + ( version1Format + , encodeVersion1 + ) +where + +import qualified Data.Binary as B + +import Tart.Canvas +import Tart.Format.Types + +data TartFileDataV1 = + TartFileDataV1 { tartFileDataV1CanvasData :: [CanvasData] + , tartFileDataV1CanvasNames :: [String] + , tartFileDataV1CanvasOrder :: [Int] + } + +encodeVersion1 :: TartFile -> B.Put +encodeVersion1 = B.put . tartFileToDataV1 + +version1Format :: TartFileFormat +version1Format = + BinaryFormatVersion B.get tartFileFromDataV1 + +instance B.Binary TartFileDataV1 where + put d = do + B.put $ tartFileDataV1CanvasData d + B.put $ tartFileDataV1CanvasNames d + B.put $ tartFileDataV1CanvasOrder d + get = do + TartFileDataV1 <$> B.get + <*> B.get + <*> B.get + +tartFileToDataV1 :: TartFile -> TartFileDataV1 +tartFileToDataV1 tf = + TartFileDataV1 (canvasToData <$> tartFileCanvasList tf) + (tartFileCanvasNames tf) + (tartFileCanvasOrder tf) + +tartFileFromDataV1 :: TartFileDataV1 -> IO (Either String TartFile) +tartFileFromDataV1 d = do + let loadCanvases [] = return $ Right [] + loadCanvases (cd:cds) = do + result <- canvasFromData cd + case result of + Left e -> return $ Left e + Right c -> do + rest <- loadCanvases cds + case rest of + Left e -> return $ Left e + Right cs -> return $ Right $ c : cs + + result <- loadCanvases (tartFileDataV1CanvasData d) + case result of + Left s -> return $ Left s + Right cs -> return $ Right $ TartFile cs (tartFileDataV1CanvasNames d) + (tartFileDataV1CanvasOrder d) diff --git a/src/Tart/Format/V2.hs b/src/Tart/Format/V2.hs new file mode 100644 --- /dev/null +++ b/src/Tart/Format/V2.hs @@ -0,0 +1,68 @@ +module Tart.Format.V2 + ( version2Format + , encodeVersion2 + ) +where + +import Control.Monad (when) +import Data.Int (Int32) +import qualified Data.Binary as B + +import Tart.Canvas +import Tart.Format.Types + +data TartFileDataV2 = + TartFileDataV2 { tartFileDataV2CanvasData :: [CanvasData] + , tartFileDataV2CanvasNames :: [String] + , tartFileDataV2CanvasOrder :: [Int] + } + +tartFileDataV2Magic :: Int32 +tartFileDataV2Magic = 0xcafe02 + +encodeVersion2 :: TartFile -> B.Put +encodeVersion2 = B.put . tartFileToDataV2 + +version2Format :: TartFileFormat +version2Format = + BinaryFormatVersion B.get tartFileFromDataV2 + +instance B.Binary TartFileDataV2 where + put d = do + B.put tartFileDataV2Magic + B.put $ tartFileDataV2CanvasData d + B.put $ tartFileDataV2CanvasNames d + B.put $ tartFileDataV2CanvasOrder d + get = do + magic <- B.get + when (magic /= tartFileDataV2Magic) $ + fail "not a valid tart file version 1" + + TartFileDataV2 <$> B.get + <*> B.get + <*> B.get + +tartFileToDataV2 :: TartFile -> TartFileDataV2 +tartFileToDataV2 tf = + TartFileDataV2 (canvasToData <$> tartFileCanvasList tf) + (tartFileCanvasNames tf) + (tartFileCanvasOrder tf) + +tartFileFromDataV2 :: TartFileDataV2 -> IO (Either String TartFile) +tartFileFromDataV2 d = do + let loadCanvases [] = return $ Right [] + loadCanvases (cd:cds) = do + result <- canvasFromData cd + case result of + Left e -> return $ Left e + Right c -> do + rest <- loadCanvases cds + case rest of + Left e -> return $ Left e + Right cs -> return $ Right $ c : cs + + result <- loadCanvases (tartFileDataV2CanvasData d) + case result of + Left s -> return $ Left s + Right cs -> return $ Right $ TartFile cs (tartFileDataV2CanvasNames d) + (tartFileDataV2CanvasOrder d) diff --git a/tart.cabal b/tart.cabal new file mode 100644 --- /dev/null +++ b/tart.cabal @@ -0,0 +1,91 @@ +name: tart +version: 0.1 +synopsis: Terminal Art +description: A program to make ASCII art +license: BSD3 +license-file: LICENSE +author: Jonathan Daugherty +maintainer: cygnus@foobox.com +copyright: 2017 Jonathan Daugherty +category: Graphics +build-type: Simple +extra-source-files: CHANGELOG.md + README.md +cabal-version: >=1.10 +Homepage: https://github.com/jtdaugherty/tart/ +Bug-reports: https://github.com/jtdaugherty/tart/issues + +Source-Repository head + type: git + location: git://github.com/jtdaugherty/tart.git + +library + ghc-options: -Wall + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: + Tart.Canvas + Tart.Format + Tart.Format.Types + Tart.Format.V0 + Tart.Format.V1 + Tart.Format.V2 + build-depends: base >=4.9 && < 5, + array, + binary, + vty >= 5.17.1, + microlens-platform, + bytestring, + mtl, + binary + +executable tart + ghc-options: -threaded -Wall + hs-source-dirs: programs + main-is: Main.hs + other-modules: Events + Events.Main + Events.CharacterSelect + Events.PaletteEntrySelect + Events.ToolSelect + Events.Common + Events.CanvasSizePrompt + Events.AskToSave + Events.AskForSaveFilename + Events.TextEntry + Events.BoxStyleSelect + Events.RenameLayer + Events.StyleSelect + UI + UI.Main + UI.Common + UI.CharacterSelect + UI.PaletteEntrySelect + UI.ToolSelect + UI.CanvasSizePrompt + UI.AskToSave + UI.AskForSaveFilename + UI.TextEntry + UI.BoxStyleSelect + UI.StyleSelect + State + Theme + Types + App + Draw + Draw.Line + Draw.Box + default-language: Haskell2010 + build-depends: base >=4.9 && < 5, + brick >= 0.24, + vty >= 5.17, + vector, + microlens-platform, + microlens-th, + mtl, + text, + text-zipper, + directory, + containers, + tart, + text-zipper