packages feed

tart (empty) → 0.1

raw patch · 44 files changed

+3609/−0 lines, 44 filesdep +arraydep +basedep +binarysetup-changed

Dependencies added: array, base, binary, brick, bytestring, containers, directory, microlens-platform, microlens-th, mtl, tart, text, text-zipper, vector, vty

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for tart++## 0.1  -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ programs/App.hs view
@@ -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+        }
+ programs/Draw.hs view
@@ -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
+ programs/Draw/Box.hs view
@@ -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)
+ programs/Draw/Line.hs view
@@ -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
+ programs/Events.hs view
@@ -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
+ programs/Events/AskForSaveFilename.hs view
@@ -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+
+ programs/Events/AskToSave.hs view
@@ -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
+ programs/Events/BoxStyleSelect.hs view
@@ -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
+ programs/Events/CanvasSizePrompt.hs view
@@ -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
+ programs/Events/CharacterSelect.hs view
@@ -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
+ programs/Events/Common.hs view
@@ -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
+ programs/Events/Main.hs view
@@ -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
+ programs/Events/PaletteEntrySelect.hs view
@@ -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
+ programs/Events/RenameLayer.hs view
@@ -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
+ programs/Events/StyleSelect.hs view
@@ -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
+ programs/Events/TextEntry.hs view
@@ -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
+ programs/Events/ToolSelect.hs view
@@ -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
+ programs/Main.hs view
@@ -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 <> " <options> [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
+ programs/State.hs view
@@ -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)
+ programs/Theme.hs view
@@ -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)+  ]
+ programs/Types.hs view
@@ -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!"
+ programs/UI.hs view
@@ -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
+ programs/UI/AskForSaveFilename.hs view
@@ -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)
+ programs/UI/AskToSave.hs view
@@ -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)
+ programs/UI/BoxStyleSelect.hs view
@@ -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 ' '
+ programs/UI/CanvasSizePrompt.hs view
@@ -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)
+ programs/UI/CharacterSelect.hs view
@@ -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."
+ programs/UI/Common.hs view
@@ -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
+ programs/UI/Main.hs view
@@ -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 -> "<unsaved>"+            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
+ programs/UI/PaletteEntrySelect.hs view
@@ -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
+ programs/UI/StyleSelect.hs view
@@ -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 ' '
+ programs/UI/TextEntry.hs view
@@ -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))
+ programs/UI/ToolSelect.hs view
@@ -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 ' '
+ src/Tart/Canvas.hs view
@@ -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
+ src/Tart/Format.hs view
@@ -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
+ src/Tart/Format/Types.hs view
@@ -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
+ src/Tart/Format/V0.hs view
@@ -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]
+ src/Tart/Format/V1.hs view
@@ -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)
+ src/Tart/Format/V2.hs view
@@ -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)
+ tart.cabal view
@@ -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