├── .gitignore ├── Setup.hs ├── logo ├── logo.tart ├── logo.plain.txt └── logo.color.txt ├── screenshots ├── 0.png ├── 1.png └── 2.png ├── programs ├── UI │ ├── CharacterSelect.hs │ ├── PaletteEntrySelect.hs │ ├── AskToSave.hs │ ├── TextEntry.hs │ ├── CanvasSizePrompt.hs │ ├── BoxStyleSelect.hs │ ├── ToolSelect.hs │ ├── Common.hs │ ├── StyleSelect.hs │ ├── AskForSaveFilename.hs │ └── Main.hs ├── Events │ ├── CharacterSelect.hs │ ├── AskToSave.hs │ ├── RenameLayer.hs │ ├── Common.hs │ ├── StyleSelect.hs │ ├── AskForSaveFilename.hs │ ├── PaletteEntrySelect.hs │ ├── ToolSelect.hs │ ├── BoxStyleSelect.hs │ ├── TextEntry.hs │ ├── CanvasSizePrompt.hs │ └── Main.hs ├── Theme.hs ├── UI.hs ├── Draw │ ├── Box.hs │ └── Line.hs ├── Events.hs ├── Main.hs ├── App.hs ├── Types.hs ├── Draw.hs └── State.hs ├── src └── Tart │ ├── Format │ ├── Types.hs │ ├── V0.hs │ ├── V1.hs │ └── V2.hs │ ├── Format.hs │ └── Canvas.hs ├── TODO.md ├── CHANGELOG.md ├── LICENSE ├── tart.cabal └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | .*.swp 2 | .DS_Store 3 | dist 4 | dist-newstyle 5 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /logo/logo.tart: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jtdaugherty/tart/HEAD/logo/logo.tart -------------------------------------------------------------------------------- /screenshots/0.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jtdaugherty/tart/HEAD/screenshots/0.png -------------------------------------------------------------------------------- /screenshots/1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jtdaugherty/tart/HEAD/screenshots/1.png -------------------------------------------------------------------------------- /screenshots/2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jtdaugherty/tart/HEAD/screenshots/2.png -------------------------------------------------------------------------------- /logo/logo.plain.txt: -------------------------------------------------------------------------------- 1 | _____ _ ____ _____ _ 2 | (_ _)/ \ | (_ _)| | 3 | | | / ^ \ | O || | |_| 4 | | |/ ___ \| _ < | | _ 5 | |_|_/ \_|_| \_\|_| |_| 6 | -------------------------------------------------------------------------------- /programs/UI/CharacterSelect.hs: -------------------------------------------------------------------------------- 1 | module UI.CharacterSelect 2 | ( drawCharacterSelectUI 3 | ) 4 | where 5 | 6 | import Brick 7 | import Brick.Widgets.Center 8 | import Brick.Widgets.Border 9 | 10 | import Types 11 | 12 | drawCharacterSelectUI :: AppState -> [Widget Name] 13 | drawCharacterSelectUI _ = [prompt] 14 | 15 | prompt :: Widget Name 16 | prompt = 17 | centerLayer $ 18 | borderWithLabel (str "Choose a Character") $ 19 | padTopBottom 1 $ 20 | padLeftRight 2 $ 21 | str "Press a character to draw with." 22 | -------------------------------------------------------------------------------- /programs/Events/CharacterSelect.hs: -------------------------------------------------------------------------------- 1 | module Events.CharacterSelect 2 | ( handleCharacterSelectEvent 3 | ) 4 | where 5 | 6 | import Brick 7 | import qualified Graphics.Vty as V 8 | 9 | import Types 10 | import State 11 | 12 | handleCharacterSelectEvent :: BrickEvent Name e -> EventM Name AppState () 13 | handleCharacterSelectEvent (VtyEvent (V.EvKey V.KEsc _)) = 14 | cancelCharacterSelect 15 | handleCharacterSelectEvent (VtyEvent (V.EvKey (V.KChar c) [])) = 16 | selectCharacter c 17 | handleCharacterSelectEvent _ = 18 | return () 19 | -------------------------------------------------------------------------------- /programs/UI/PaletteEntrySelect.hs: -------------------------------------------------------------------------------- 1 | module UI.PaletteEntrySelect 2 | ( drawPaletteEntrySelectUI 3 | ) 4 | where 5 | 6 | import Data.Monoid ((<>)) 7 | import Brick 8 | 9 | import Types 10 | import UI.Common 11 | 12 | drawPaletteEntrySelectUI :: AppState -> [Widget Name] 13 | drawPaletteEntrySelectUI s = 14 | let isFg = case currentMode s of 15 | FgPaletteEntrySelect -> True 16 | BgPaletteEntrySelect -> False 17 | m -> error $ "BUG: should never get called in mode " <> show m 18 | pal = drawPalette s isFg 19 | in pal 20 | -------------------------------------------------------------------------------- /programs/Events/AskToSave.hs: -------------------------------------------------------------------------------- 1 | module Events.AskToSave 2 | ( handleAskToSaveEvent 3 | ) 4 | where 5 | 6 | import qualified Graphics.Vty as V 7 | 8 | import Brick 9 | 10 | import Types 11 | import State 12 | 13 | handleAskToSaveEvent :: BrickEvent Name e -> EventM Name AppState () 14 | handleAskToSaveEvent (VtyEvent (V.EvKey V.KEsc [])) = 15 | halt 16 | handleAskToSaveEvent (VtyEvent (V.EvKey (V.KChar 'n') [])) = 17 | halt 18 | handleAskToSaveEvent (VtyEvent (V.EvKey (V.KChar 'y') [])) = 19 | askForSaveFilename True 20 | handleAskToSaveEvent _ = 21 | return () 22 | -------------------------------------------------------------------------------- /src/Tart/Format/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | module Tart.Format.Types 3 | ( TartFile(..) 4 | , TartFileFormat(..) 5 | ) 6 | where 7 | 8 | import qualified Data.Binary as B 9 | import qualified Data.Text as T 10 | 11 | import Tart.Canvas 12 | 13 | data TartFile = 14 | TartFile { tartFileCanvasList :: [Canvas] 15 | , tartFileCanvasNames :: [T.Text] 16 | , tartFileCanvasOrder :: [Int] 17 | } 18 | 19 | data TartFileFormat where 20 | BinaryFormatVersion :: (B.Get a) 21 | -> (a -> IO (Either String TartFile)) 22 | -> TartFileFormat 23 | -------------------------------------------------------------------------------- /programs/Events/RenameLayer.hs: -------------------------------------------------------------------------------- 1 | module Events.RenameLayer 2 | ( handleRenameLayerEvent 3 | ) 4 | where 5 | 6 | import Brick 7 | import Brick.Widgets.Edit 8 | import qualified Graphics.Vty as V 9 | import qualified Data.Text as T 10 | import Lens.Micro.Platform 11 | 12 | import Types 13 | import State 14 | 15 | handleRenameLayerEvent :: BrickEvent Name AppEvent 16 | -> EventM Name AppState () 17 | handleRenameLayerEvent (VtyEvent (V.EvKey V.KEsc [])) = 18 | modify popMode 19 | handleRenameLayerEvent (VtyEvent (V.EvKey V.KEnter [])) = do 20 | ed <- use layerNameEditor 21 | renameCurrentLayer (T.concat $ getEditContents ed) 22 | handleRenameLayerEvent e = 23 | zoom layerNameEditor $ handleEditorEvent e 24 | handleRenameLayerEvent _ = 25 | return () 26 | -------------------------------------------------------------------------------- /programs/UI/AskToSave.hs: -------------------------------------------------------------------------------- 1 | module UI.AskToSave 2 | ( drawAskToSaveUI 3 | ) 4 | where 5 | 6 | import Brick 7 | import Brick.Widgets.Border 8 | import Brick.Widgets.Center 9 | 10 | import Types 11 | import Theme 12 | 13 | drawAskToSaveUI :: AppState -> [Widget Name] 14 | drawAskToSaveUI _ = [drawPromptWindow] 15 | 16 | drawPromptWindow :: Widget Name 17 | drawPromptWindow = 18 | centerLayer $ 19 | borderWithLabel (str "Save") $ 20 | hLimit 60 $ 21 | padLeftRight 2 $ padTopBottom 1 body 22 | where 23 | help = hBox [ str "(" 24 | , withDefAttr keybindingAttr $ str "Esc" 25 | , str " to quit without saving)" 26 | ] 27 | body = (hCenter $ str "You have unsaved changes. Save them? (y/n)") <=> 28 | (hCenter help) 29 | -------------------------------------------------------------------------------- /programs/UI/TextEntry.hs: -------------------------------------------------------------------------------- 1 | module UI.TextEntry 2 | ( drawTextEntryUI 3 | ) 4 | where 5 | 6 | import Brick 7 | import qualified Graphics.Vty as V 8 | import Lens.Micro.Platform 9 | 10 | import Types 11 | import Draw 12 | 13 | drawTextEntryUI :: AppState -> [Widget Name] 14 | drawTextEntryUI s = [textOverlay s] 15 | 16 | textOverlay :: AppState -> Widget Name 17 | textOverlay s = 18 | let Just cExt = s^.canvasExtent 19 | p = s^.textEntryStart 20 | t = s^.textEntered 21 | off = extentUpperLeft cExt & _1 %~ (+ (p^._1)) 22 | & _2 %~ (+ (p^._2)) 23 | in translateBy off $ 24 | showCursor TextEntryCursor (Location (length t, 0)) $ 25 | (raw $ V.horizCat $ (\(ch, attr) -> V.char attr ch) <$> 26 | (truncateText (s^.textEntryStart) (s^.textEntered) s)) 27 | -------------------------------------------------------------------------------- /logo/logo.color.txt: -------------------------------------------------------------------------------- 1 |  _____ _ ____ _____ _ 2 | (_ _)/ \ | (_ _)| | 3 | | | / ^ \ | O || | |_| 4 | | |/ ___ \| _ < | | _ 5 | |_|_/ \_|_| \_\|_| |_| 6 | -------------------------------------------------------------------------------- /src/Tart/Format/V0.hs: -------------------------------------------------------------------------------- 1 | module Tart.Format.V0 2 | ( version0Format 3 | ) 4 | where 5 | 6 | import qualified Data.Binary as B 7 | import qualified Data.Text as T 8 | 9 | import Tart.Canvas 10 | import Tart.Format.Types 11 | 12 | data TartFileDataV0 = 13 | TartFileDataV0 { tartFileDataV0CanvasData :: CanvasData 14 | } 15 | 16 | version0Format :: TartFileFormat 17 | version0Format = 18 | BinaryFormatVersion B.get tartFileFromDataV0 19 | 20 | instance B.Binary TartFileDataV0 where 21 | put d = 22 | B.put $ tartFileDataV0CanvasData d 23 | get = 24 | TartFileDataV0 <$> B.get 25 | 26 | tartFileFromDataV0 :: TartFileDataV0 -> IO (Either String TartFile) 27 | tartFileFromDataV0 d = do 28 | result <- canvasFromData (tartFileDataV0CanvasData d) 29 | case result of 30 | Left s -> return $ Left s 31 | Right c -> return $ Right $ TartFile [c] [T.pack "default"] [0] 32 | -------------------------------------------------------------------------------- /programs/Events/Common.hs: -------------------------------------------------------------------------------- 1 | module Events.Common 2 | ( handleCommonEvent 3 | ) 4 | where 5 | 6 | import Brick 7 | import qualified Graphics.Vty as V 8 | 9 | import Types 10 | import State 11 | 12 | handleCommonEvent :: BrickEvent Name e -> EventM Name AppState Bool 13 | handleCommonEvent (VtyEvent (V.EvKey (V.KChar 't') [])) = do 14 | s <- get 15 | if currentMode s == ToolSelect 16 | then modify popMode 17 | else beginToolSelect 18 | return True 19 | handleCommonEvent (VtyEvent (V.EvKey (V.KChar 'f') [])) = do 20 | s <- get 21 | if currentMode s == FgPaletteEntrySelect 22 | then modify popMode 23 | else beginFgPaletteSelect 24 | return True 25 | handleCommonEvent (VtyEvent (V.EvKey (V.KChar 'b') [])) = do 26 | s <- get 27 | if currentMode s == BgPaletteEntrySelect 28 | then modify popMode 29 | else beginBgPaletteSelect 30 | return True 31 | handleCommonEvent _ = return False 32 | -------------------------------------------------------------------------------- /TODO.md: -------------------------------------------------------------------------------- 1 | 2 | - Let user pick RGB colors 3 | 4 | - Extra drawing primitives: 5 | - circles 6 | 7 | - HTML output mode? 8 | 9 | - Better encapsulation of layers and their metadata within app state 10 | 11 | ----------------------------------------------------------------- 12 | Dealing with the larger color space: 13 | 14 | - UI shows "favorite" colors, list can be grown by the user 15 | - Favorites get stored in the file along with canvas data, reloaded on 16 | startup 17 | - Need UI for picking from 256 color spectrum to choose favorites to add 18 | to palette selector 19 | - Attributes still get encoded directly in the output data and canvas 20 | - Eye dropper then just has to find out whether the color is in the 21 | favorites list, and if not, add it. 22 | - Need to have two palettes: Fg and Bg, rather than the same palette 23 | that gets used for both. The latter is a good startup default, but 24 | ultimately the palettes need to be able to vary independently. 25 | - The palette needs to become part of the canvas data structure so it 26 | can be de/serialized with the canvas data 27 | -------------------------------------------------------------------------------- /programs/Events/StyleSelect.hs: -------------------------------------------------------------------------------- 1 | module Events.StyleSelect 2 | ( handleStyleSelectEvent 3 | ) 4 | where 5 | 6 | import Brick 7 | import Lens.Micro.Platform 8 | 9 | import Types 10 | import State 11 | import Events.Common 12 | 13 | handleStyleSelectEvent :: BrickEvent Name e -> EventM Name AppState () 14 | handleStyleSelectEvent e = do 15 | result <- handleCommonEvent e 16 | case result of 17 | True -> return () 18 | False -> handleEvent e 19 | 20 | handleEvent :: BrickEvent Name e -> EventM Name AppState () 21 | handleEvent (VtyEvent e) | isStyleKey e = do 22 | toggleStyleFromKey e 23 | modify popMode 24 | handleEvent (MouseDown (StyleSelectorEntry sty) _ _ _) = do 25 | drawStyle %= toggleStyle sty 26 | modify popMode 27 | handleEvent (MouseUp _ _ _) = 28 | -- Ignore mouse-up events so we don't go back to Main mode. This 29 | -- includes mouse-up events generated in this mode, in addition to 30 | -- the mouse-up event generated just after we switch into this mode 31 | -- from Main. 32 | return () 33 | handleEvent _ = 34 | modify popMode 35 | -------------------------------------------------------------------------------- /programs/Theme.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Theme 3 | ( theme 4 | 5 | , keybindingAttr 6 | , selectedLayerAttr 7 | , clickableAttr 8 | , errorAttr 9 | , headerAttr 10 | ) 11 | where 12 | 13 | import Brick 14 | import Brick.Widgets.Edit 15 | import Graphics.Vty 16 | 17 | keybindingAttr :: AttrName 18 | keybindingAttr = attrName "keybinding" 19 | 20 | selectedLayerAttr :: AttrName 21 | selectedLayerAttr = attrName "selectedLayer" 22 | 23 | clickableAttr :: AttrName 24 | clickableAttr = attrName "clickable" 25 | 26 | headerAttr :: AttrName 27 | headerAttr = attrName "header" 28 | 29 | errorAttr :: AttrName 30 | errorAttr = attrName "error" 31 | 32 | theme :: AttrMap 33 | theme = attrMap defAttr 34 | [ (keybindingAttr, fg white `withStyle` underline) 35 | , (editAttr, black `on` yellow) 36 | , (editFocusedAttr, black `on` yellow) 37 | , (selectedLayerAttr, white `on` magenta) 38 | , (clickableAttr, fg white `withStyle` bold) 39 | , (headerAttr, fg white `withStyle` underline) 40 | , (errorAttr, fg red) 41 | ] 42 | -------------------------------------------------------------------------------- /programs/Events/AskForSaveFilename.hs: -------------------------------------------------------------------------------- 1 | module Events.AskForSaveFilename 2 | ( handleAskForSaveFilenameEvent 3 | ) 4 | where 5 | 6 | import qualified Graphics.Vty as V 7 | import Lens.Micro.Platform 8 | import qualified Data.Text as T 9 | 10 | import Brick 11 | import Brick.Widgets.Edit 12 | 13 | import Types 14 | import State 15 | 16 | handleAskForSaveFilenameEvent :: Bool -> BrickEvent Name e -> EventM Name AppState () 17 | handleAskForSaveFilenameEvent isQuitting (VtyEvent (V.EvKey V.KEsc [])) = 18 | if isQuitting then halt else modify popMode 19 | handleAskForSaveFilenameEvent isQuitting (VtyEvent (V.EvKey V.KEnter [])) = do 20 | editor <- use askToSaveFilenameEdit 21 | let [fn] = getEditContents editor 22 | if T.null fn 23 | then if isQuitting then halt else modify popMode 24 | else do 25 | canvasPath .= Just (T.unpack fn) 26 | if isQuitting 27 | then modify popMode >> quit False 28 | else modify popMode >> saveAndContinue 29 | handleAskForSaveFilenameEvent _ e = do 30 | zoom askToSaveFilenameEdit $ handleEditorEvent e 31 | handleAskForSaveFilenameEvent _ _ = 32 | return () 33 | 34 | -------------------------------------------------------------------------------- /programs/UI/CanvasSizePrompt.hs: -------------------------------------------------------------------------------- 1 | module UI.CanvasSizePrompt 2 | ( drawCanvasSizePromptUI 3 | ) 4 | where 5 | 6 | import qualified Data.Text as T 7 | import Lens.Micro.Platform 8 | 9 | import Brick 10 | import Brick.Focus 11 | import Brick.Widgets.Border 12 | import Brick.Widgets.Center 13 | import Brick.Widgets.Edit 14 | 15 | import Types 16 | 17 | drawCanvasSizePromptUI :: AppState -> [Widget Name] 18 | drawCanvasSizePromptUI s = [drawPromptWindow s] 19 | 20 | drawPromptWindow :: AppState -> Widget Name 21 | drawPromptWindow s = 22 | centerLayer $ 23 | borderWithLabel (str "Resize Canvas") $ 24 | hLimit 40 $ 25 | padLeftRight 2 $ padTopBottom 1 body 26 | where 27 | body = padBottom (Pad 1) width <=> height 28 | renderString = txt . T.unlines 29 | width = str "Width: " <+> 30 | (clickable CanvasSizeWidthEdit $ 31 | withFocusRing (s^.canvasSizeFocus) (renderEditor renderString) (s^.canvasSizeWidthEdit)) 32 | height = str "Height: " <+> 33 | (clickable CanvasSizeHeightEdit $ 34 | withFocusRing (s^.canvasSizeFocus) (renderEditor renderString) (s^.canvasSizeHeightEdit)) 35 | -------------------------------------------------------------------------------- /programs/Events/PaletteEntrySelect.hs: -------------------------------------------------------------------------------- 1 | module Events.PaletteEntrySelect 2 | ( handlePaletteEntrySelectEvent 3 | ) 4 | where 5 | 6 | import Brick 7 | 8 | import Types 9 | import State 10 | 11 | import Events.Common 12 | 13 | handlePaletteEntrySelectEvent :: BrickEvent Name e -> EventM Name AppState () 14 | handlePaletteEntrySelectEvent e = do 15 | result <- handleCommonEvent e 16 | case result of 17 | True -> return () 18 | False -> handleEvent e 19 | 20 | handleEvent :: BrickEvent Name e -> EventM Name AppState () 21 | handleEvent (MouseDown FgSelector _ _ _) = do 22 | beginFgPaletteSelect 23 | handleEvent (MouseDown BgSelector _ _ _) = do 24 | beginBgPaletteSelect 25 | handleEvent (MouseDown (FgPaletteEntry idx) _ _ _) = do 26 | setFgPaletteIndex idx 27 | handleEvent (MouseDown (BgPaletteEntry idx) _ _ _) = do 28 | setBgPaletteIndex idx 29 | handleEvent (MouseUp _ _ _) = 30 | -- Ignore mouse-up events so we don't go back to Main mode. This 31 | -- includes mouse-up events generated in this mode, in addition to 32 | -- the mouse-up event generated just after we switch into this mode 33 | -- from Main. 34 | return () 35 | handleEvent _ = 36 | modify popMode 37 | -------------------------------------------------------------------------------- /programs/Events/ToolSelect.hs: -------------------------------------------------------------------------------- 1 | module Events.ToolSelect 2 | ( handleToolSelectEvent 3 | ) 4 | where 5 | 6 | import Brick 7 | import Data.Char (isDigit) 8 | import qualified Graphics.Vty as V 9 | 10 | import Types 11 | import State 12 | import Events.Common 13 | 14 | handleToolSelectEvent :: BrickEvent Name e -> EventM Name AppState () 15 | handleToolSelectEvent e = do 16 | result <- handleCommonEvent e 17 | case result of 18 | True -> return () 19 | False -> handleEvent e 20 | 21 | handleEvent :: BrickEvent Name e -> EventM Name AppState () 22 | handleEvent (MouseDown (ToolSelectorEntry t) _ _ _) = do 23 | setTool t 24 | modify popMode 25 | handleEvent (VtyEvent (V.EvKey (V.KChar c) [])) | isDigit c = do 26 | let idx = read [c] 27 | case filter ((== idx) . snd) tools of 28 | [(t, _)] -> do 29 | setTool t 30 | modify popMode 31 | _ -> return () 32 | handleEvent (MouseUp _ _ _) = 33 | -- Ignore mouse-up events so we don't go back to Main mode. This 34 | -- includes mouse-up events generated in this mode, in addition to 35 | -- the mouse-up event generated just after we switch into this mode 36 | -- from Main. 37 | return () 38 | handleEvent _ = 39 | modify popMode 40 | -------------------------------------------------------------------------------- /programs/UI.hs: -------------------------------------------------------------------------------- 1 | module UI 2 | ( drawUI 3 | ) 4 | where 5 | 6 | import Brick 7 | import Lens.Micro.Platform 8 | 9 | import Types 10 | import UI.Main 11 | import UI.CharacterSelect 12 | import UI.PaletteEntrySelect 13 | import UI.ToolSelect 14 | import UI.CanvasSizePrompt 15 | import UI.AskToSave 16 | import UI.AskForSaveFilename 17 | import UI.TextEntry 18 | import UI.BoxStyleSelect 19 | import UI.StyleSelect 20 | 21 | drawUI :: AppState -> [Widget Name] 22 | drawUI s = 23 | concat $ drawMode s <$> s^.modes 24 | 25 | drawMode :: AppState -> Mode -> [Widget Name] 26 | drawMode s m = 27 | case m of 28 | Main -> drawMainUI s 29 | RenameLayer -> [] 30 | FgPaletteEntrySelect -> drawPaletteEntrySelectUI s 31 | BgPaletteEntrySelect -> drawPaletteEntrySelectUI s 32 | ToolSelect -> drawToolSelectUI s 33 | CharacterSelect -> drawCharacterSelectUI s 34 | CanvasSizePrompt -> drawCanvasSizePromptUI s 35 | AskToSave -> drawAskToSaveUI s 36 | AskForSaveFilename q -> drawAskForSaveFilenameUI q s 37 | TextEntry -> drawTextEntryUI s 38 | BoxStyleSelect -> drawBoxStyleSelectUI s 39 | StyleSelect -> drawStyleSelectUI s 40 | -------------------------------------------------------------------------------- /programs/Events/BoxStyleSelect.hs: -------------------------------------------------------------------------------- 1 | module Events.BoxStyleSelect 2 | ( handleBoxStyleSelectEvent 3 | ) 4 | where 5 | 6 | import Brick 7 | import Data.Char (isDigit) 8 | import qualified Graphics.Vty as V 9 | import Lens.Micro.Platform 10 | 11 | import Types 12 | import State 13 | import Events.Common 14 | 15 | handleBoxStyleSelectEvent :: BrickEvent Name e -> EventM Name AppState () 16 | handleBoxStyleSelectEvent e = do 17 | result <- handleCommonEvent e 18 | case result of 19 | True -> return () 20 | False -> handleEvent e 21 | 22 | handleEvent :: BrickEvent Name e -> EventM Name AppState () 23 | handleEvent (MouseDown (BoxStyleSelectorEntry i) _ _ _) = do 24 | boxStyleIndex .= i 25 | modify popMode 26 | handleEvent (VtyEvent (V.EvKey (V.KChar c) [])) | isDigit c = do 27 | let i = read [c] 28 | case i >= 0 && i < length boxStyles of 29 | True -> do 30 | modify popMode 31 | boxStyleIndex .= i 32 | False -> return () 33 | handleEvent (MouseUp _ _ _) = 34 | -- Ignore mouse-up events so we don't go back to Main mode. This 35 | -- includes mouse-up events generated in this mode, in addition to 36 | -- the mouse-up event generated just after we switch into this mode 37 | -- from Main. 38 | return () 39 | handleEvent _ = 40 | modify popMode 41 | -------------------------------------------------------------------------------- /programs/Events/TextEntry.hs: -------------------------------------------------------------------------------- 1 | module Events.TextEntry 2 | ( handleTextEntryEvent 3 | ) 4 | where 5 | 6 | import Brick 7 | import qualified Graphics.Vty as V 8 | import Data.Monoid ((<>)) 9 | import Lens.Micro.Platform 10 | 11 | import Types 12 | import State 13 | import Draw 14 | import Events.Main 15 | 16 | handleTextEntryEvent :: BrickEvent Name AppEvent -> EventM Name AppState () 17 | handleTextEntryEvent e = do 18 | result <- handleAttrEvent e 19 | case result of 20 | True -> return () 21 | False -> handleEvent e 22 | 23 | handleEvent :: BrickEvent Name AppEvent -> EventM Name AppState () 24 | handleEvent (VtyEvent (V.EvKey V.KEnter [])) = do 25 | -- Commit the text to the drawing and return to main mode 26 | s <- get 27 | modify popMode 28 | drawTextAtPoint (s^.textEntryStart) (s^.textEntered) 29 | handleEvent (VtyEvent (V.EvKey V.KBS [])) = do 30 | textEntered %= (\t -> if null t then t else init t) 31 | handleEvent (VtyEvent (V.EvKey V.KEsc [])) = 32 | -- Cancel 33 | modify popMode 34 | handleEvent (VtyEvent (V.EvKey (V.KChar c) [])) | c /= '\t' = do 35 | -- Enter character 36 | s <- get 37 | textEntered %= (<> [(c, currentPaletteAttribute s)]) 38 | start <- use textEntryStart 39 | ent <- use textEntered 40 | textEntered .= truncateText start ent s 41 | handleEvent _ = 42 | -- Ignore everything else 43 | return () 44 | -------------------------------------------------------------------------------- /programs/UI/BoxStyleSelect.hs: -------------------------------------------------------------------------------- 1 | module UI.BoxStyleSelect 2 | ( drawBoxStyleSelectUI 3 | ) 4 | where 5 | 6 | import Brick 7 | import Brick.Widgets.Border 8 | import Brick.Widgets.Border.Style 9 | import Lens.Micro.Platform 10 | 11 | import Types 12 | import UI.Main 13 | import State 14 | 15 | drawBoxStyleSelectUI :: AppState -> [Widget Name] 16 | drawBoxStyleSelectUI s = 17 | let Just ext = s^.boxStyleSelectorExtent 18 | toolSel = drawBoxStyleSelector ext 19 | in toolSel 20 | 21 | drawBoxStyleSelector :: Extent Name -> [Widget Name] 22 | drawBoxStyleSelector ext = 23 | [borderHack, body] 24 | where 25 | borderHack = translateBy l bottomBorder 26 | l = Location ( fst $ loc $ extentUpperLeft ext 27 | , (snd $ extentSize ext) + (snd $ loc $ extentUpperLeft ext) - 1 28 | ) 29 | bottomBorder = hBox [ borderElem bsIntersectL 30 | , hLimit boxStyleSelectorEntryWidth hBorder 31 | , borderElem bsIntersectR 32 | ] 33 | body = translateBy l $ 34 | border $ vBox entries 35 | entries = mkEntry <$> zip [0..] boxStyles 36 | mkEntry (i, (n, _)) = 37 | clickable (BoxStyleSelectorEntry i) $ 38 | vLimit 1 $ 39 | hLimit boxStyleSelectorEntryWidth $ 40 | (txt n) <+> fill ' ' 41 | -------------------------------------------------------------------------------- /programs/Events/CanvasSizePrompt.hs: -------------------------------------------------------------------------------- 1 | module Events.CanvasSizePrompt 2 | ( handleCanvasSizePromptEvent 3 | ) 4 | where 5 | 6 | import qualified Graphics.Vty as V 7 | import Lens.Micro.Platform 8 | 9 | import Brick 10 | import Brick.Focus 11 | import Brick.Widgets.Edit 12 | 13 | import Types 14 | import State 15 | 16 | handleCanvasSizePromptEvent :: BrickEvent Name e -> EventM Name AppState () 17 | handleCanvasSizePromptEvent (MouseDown CanvasSizeWidthEdit _ _ _) = 18 | canvasSizeFocus %= focusSetCurrent CanvasSizeWidthEdit 19 | handleCanvasSizePromptEvent (MouseDown CanvasSizeHeightEdit _ _ _) = 20 | canvasSizeFocus %= focusSetCurrent CanvasSizeHeightEdit 21 | handleCanvasSizePromptEvent (MouseDown _ _ _ _) = 22 | modify popMode 23 | handleCanvasSizePromptEvent (VtyEvent (V.EvKey (V.KChar '\t') [])) = 24 | canvasSizeFocus %= focusNext 25 | handleCanvasSizePromptEvent (VtyEvent (V.EvKey V.KBackTab [])) = 26 | canvasSizeFocus %= focusPrev 27 | handleCanvasSizePromptEvent (VtyEvent (V.EvKey V.KEsc [])) = 28 | modify popMode 29 | handleCanvasSizePromptEvent (VtyEvent (V.EvKey V.KEnter [])) = 30 | tryResizeCanvas 31 | handleCanvasSizePromptEvent e = do 32 | foc <- use canvasSizeFocus 33 | case focusGetCurrent foc of 34 | Just CanvasSizeWidthEdit -> 35 | zoom canvasSizeWidthEdit $ handleEditorEvent e 36 | Just CanvasSizeHeightEdit -> 37 | zoom canvasSizeHeightEdit $ handleEditorEvent e 38 | _ -> return () 39 | -------------------------------------------------------------------------------- /programs/UI/ToolSelect.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module UI.ToolSelect 3 | ( drawToolSelectUI 4 | ) 5 | where 6 | 7 | import Data.Monoid ((<>)) 8 | import Brick 9 | import Brick.Widgets.Border 10 | import Brick.Widgets.Border.Style 11 | import Lens.Micro.Platform 12 | import qualified Data.Text as T 13 | 14 | import Types 15 | import UI.Main 16 | import State 17 | import Theme 18 | 19 | drawToolSelectUI :: AppState -> [Widget Name] 20 | drawToolSelectUI s = 21 | let Just ext = s^.toolSelectorExtent 22 | in drawToolSelector ext 23 | 24 | drawToolSelector :: Extent Name -> [Widget Name] 25 | drawToolSelector ext = 26 | [borderHack, body] 27 | where 28 | borderHack = translateBy l topBorder 29 | topBorder = hBox [ borderElem bsIntersectL 30 | , hLimit toolSelectorEntryWidth hBorder 31 | , borderElem bsIntersectR 32 | ] 33 | body = translateBy l $ border $ vBox entries 34 | l = Location ( fst $ loc $ extentUpperLeft ext 35 | , (snd $ extentSize ext) + (snd $ loc $ extentUpperLeft ext) - 1 36 | ) 37 | entries = mkEntry <$> tools 38 | mkEntry (t, i) = 39 | clickable (ToolSelectorEntry t) $ 40 | vLimit 1 $ 41 | hLimit toolSelectorEntryWidth $ 42 | (withDefAttr keybindingAttr (txt $ T.pack $ show i)) <+> 43 | (txt $ ":" <> toolName t) <+> fill ' ' 44 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 2 | 0.4 3 | --- 4 | 5 | * Update for brick 2.7. 6 | * Get rid of `libonly` build flag 7 | 8 | 0.3 9 | --- 10 | 11 | Package changes: 12 | * Added `libonly` flag (defaults to `False`) to control whether to 13 | build the `tart` executable. 14 | * Raised the `brick` upper bound. 15 | * Raised the `vty` upper bound. 16 | 17 | 0.2 18 | --- 19 | 20 | `tart` tool changes: 21 | * When inserting a new layer, also select it and make that selection 22 | part of the undo action. 23 | * Attribute style selector now uses more descriptive labels for style 24 | options. 25 | 26 | Tart library changes: 27 | * Added a dependency on the `text` package. 28 | * The type of some fields was changed from `String` to 29 | `Text` (`TartFile` / `tartFileCanvasNames`, `TartFileDataV1` 30 | / `tartFileDataV1CanvasNames`, `TartFileDataV2` / 31 | `tartFileDataV2CanvasNames`) 32 | * Added `Tart.Canvas.canvasFromString` and changed `canvasFromText` to 33 | take a `Text` input rather than a `String`. 34 | * Relaxed bounds on `vty`. 35 | 36 | 0.1.2 37 | ----- 38 | 39 | Bug fixes: 40 | * Exceptions triggered during an attempt to save to an invalid path no 41 | longer cause a crash and are now reported to the user (#4) 42 | * Canvas size dialog fields are now clickable (#5) 43 | 44 | 0.1.1 45 | ----- 46 | 47 | * Added a new saving UI and keybinding to trigger it (C-s). Previously 48 | the only opportunity to save was on quitting. 49 | 50 | 0.1 51 | --- 52 | 53 | * First version. 54 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017-2025, Jonathan Daugherty 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Jonathan Daugherty nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /programs/UI/Common.hs: -------------------------------------------------------------------------------- 1 | module UI.Common 2 | ( drawPaletteEntry 3 | , drawPalette 4 | ) 5 | where 6 | 7 | import Brick 8 | import Brick.Widgets.Border 9 | import Brick.Widgets.Border.Style 10 | import Lens.Micro.Platform 11 | import qualified Graphics.Vty as V 12 | import qualified Data.Vector as Vec 13 | 14 | import Types 15 | 16 | drawPaletteEntry :: AppState -> Int -> Int -> Widget Name 17 | drawPaletteEntry s idx width = 18 | let pal = s^.palette 19 | entry = Vec.unsafeIndex pal idx 20 | attr = case entry of 21 | Nothing -> V.defAttr 22 | Just c -> V.defAttr `V.withBackColor` c 23 | ch = ' ' 24 | in raw $ V.string attr (replicate width ch) 25 | 26 | drawPalette :: AppState -> Bool -> [Widget Name] 27 | drawPalette s isFgPalette = 28 | [borderHack, body] 29 | where 30 | pal = s^.palette 31 | Just ext = if isFgPalette 32 | then s^.fgPaletteSelectorExtent 33 | else s^.bgPaletteSelectorExtent 34 | mkName = if isFgPalette 35 | then FgPaletteEntry 36 | else BgPaletteEntry 37 | borderHack = translateBy l topBorder 38 | topBorder = hBox [ borderElem bsIntersectL 39 | , hLimit 4 hBorder 40 | , borderElem bsIntersectB 41 | ] 42 | body = translateBy l $ border $ vBox entries 43 | l = Location ( fst $ loc $ extentUpperLeft ext 44 | , (snd $ extentSize ext) + (snd $ loc $ extentUpperLeft ext) - 1 45 | ) 46 | idxs = [0..Vec.length pal-1] 47 | entries = mkEntry <$> idxs 48 | mkEntry i = clickable (mkName i) $ 49 | drawPaletteEntry s i 6 50 | -------------------------------------------------------------------------------- /programs/UI/StyleSelect.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module UI.StyleSelect 3 | ( drawStyleSelectUI 4 | ) 5 | where 6 | 7 | import Brick 8 | import Brick.Widgets.Border 9 | import Brick.Widgets.Border.Style 10 | import Lens.Micro.Platform 11 | import qualified Graphics.Vty as V 12 | import qualified Data.Text as T 13 | 14 | import Types 15 | import UI.Main 16 | import State 17 | import Theme 18 | 19 | drawStyleSelectUI :: AppState -> [Widget Name] 20 | drawStyleSelectUI s = 21 | let Just ext = s^.styleSelectorExtent 22 | stySel = drawStyleSelector (s^.drawStyle) ext 23 | in stySel 24 | 25 | drawStyleSelector :: V.Style -> Extent Name -> [Widget Name] 26 | drawStyleSelector curStyle ext = 27 | [borderHack, body] 28 | where 29 | borderHack = translateBy l bottomBorder 30 | l = Location ( fst $ loc $ extentUpperLeft ext 31 | , (snd $ extentSize ext) + (snd $ loc $ extentUpperLeft ext) - 1 32 | ) 33 | bottomBorder = hBox [ borderElem bsIntersectL 34 | , hLimit styleSelectorEntryWidth hBorder 35 | , borderElem bsIntersectR 36 | ] 37 | body = translateBy l $ 38 | border $ vBox entries 39 | entries = mkEntry <$> styleBindings 40 | maybeActive sty = 41 | if hasStyle sty curStyle 42 | then (<+> txt "*") 43 | else id 44 | mkEntry (ch, (sty, label)) = 45 | clickable (StyleSelectorEntry sty) $ 46 | vLimit 1 $ 47 | hLimit styleSelectorEntryWidth $ 48 | (withDefAttr keybindingAttr (txt $ T.singleton ch)) <+> txt ":" <+> 49 | (maybeActive sty $ raw $ V.text' (V.defAttr `V.withStyle` sty) label) <+> 50 | fill ' ' 51 | -------------------------------------------------------------------------------- /programs/Draw/Box.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | module Draw.Box 3 | ( plotBox 4 | ) 5 | where 6 | 7 | import Data.Monoid ((<>)) 8 | import Lens.Micro.Platform 9 | import Brick.Widgets.Border.Style 10 | 11 | plotBox :: BorderStyle -> (Int, Int) -> (Int, Int) -> [((Int, Int), Char)] 12 | plotBox bs a b = 13 | let (ul, lr) = boxCorners a b 14 | (ll, ur) = ( (ul^._1, lr^._2) 15 | , (lr^._1, ul^._2) 16 | ) 17 | top = (, bsHorizontal bs) <$> (, ul^._2) <$> [ul^._1 + 1..ur^._1 - 1] 18 | bottom = (, bsHorizontal bs) <$> (, ll^._2) <$> [ll^._1 + 1..lr^._1 - 1] 19 | left = (, bsVertical bs) <$> (ul^._1, ) <$> [ul^._2 + 1..ll^._2 - 1] 20 | right = (, bsVertical bs) <$> (ur^._1, ) <$> [ur^._2 + 1..lr^._2 - 1] 21 | 22 | width = lr^._1 - ul^._1 23 | height = lr^._2 - ul^._2 24 | corners = if width == 0 25 | then [ (ul, bsVertical bs) 26 | , (lr, bsVertical bs) 27 | ] 28 | else if height == 0 29 | then [ (ul, bsHorizontal bs) 30 | , (lr, bsHorizontal bs) 31 | ] 32 | else [ (ul, bsCornerTL bs) 33 | , (lr, bsCornerBR bs) 34 | , (ll, bsCornerBL bs) 35 | , (ur, bsCornerTR bs) 36 | ] 37 | 38 | -- Draw the corners 39 | pixels = corners <> 40 | -- Draw the top and bottom 41 | top <> 42 | bottom <> 43 | -- Draw the sides 44 | left <> 45 | right 46 | in pixels 47 | 48 | boxCorners :: (Int, Int) -> (Int, Int) -> ((Int, Int), (Int, Int)) 49 | boxCorners (a0, a1) (b0, b1) = 50 | let ul = (min a0 b0, min a1 b1) 51 | lr = (max a0 b0, max a1 b1) 52 | in (ul, lr) 53 | -------------------------------------------------------------------------------- /programs/UI/AskForSaveFilename.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module UI.AskForSaveFilename 3 | ( drawAskForSaveFilenameUI 4 | ) 5 | where 6 | 7 | import qualified Data.Text as T 8 | import Lens.Micro.Platform 9 | 10 | import Brick 11 | import Brick.Widgets.Border 12 | import Brick.Widgets.Center 13 | import Brick.Widgets.Edit 14 | 15 | import Types 16 | import Theme 17 | 18 | drawAskForSaveFilenameUI :: Bool -> AppState -> [Widget Name] 19 | drawAskForSaveFilenameUI isQuitting s = [drawPromptWindow isQuitting s] 20 | 21 | drawPromptWindow :: Bool -> AppState -> Widget Name 22 | drawPromptWindow isQuitting s = 23 | centerLayer $ 24 | borderWithLabel (str "Save") $ 25 | hLimit 60 $ 26 | padLeftRight 2 $ padTopBottom 1 body 27 | where 28 | help = if isQuitting 29 | then hBox [ str "(" 30 | , withDefAttr keybindingAttr $ str "Enter" 31 | , str " to save and quit, " 32 | , withDefAttr keybindingAttr $ str "Esc" 33 | , str " to quit without saving)" 34 | ] 35 | else hBox [ str "(" 36 | , withDefAttr keybindingAttr $ str "Enter" 37 | , str " to save, " 38 | , withDefAttr keybindingAttr $ str "Esc" 39 | , str " to cancel)" 40 | ] 41 | body = maybeError <=> 42 | (hCenter $ str "Save changes to:") <=> 43 | (hCenter help) <=> 44 | padTopBottom 1 fn 45 | maybeError = maybe emptyWidget mkSaveError (s^.saveError) 46 | mkSaveError msg = withDefAttr errorAttr $ 47 | (hCenter $ txt "Error saving:") <=> 48 | (padBottom (Pad 1) $ txtWrap msg) 49 | renderString = txt . T.unlines 50 | fn = str "Path: " <+> renderEditor renderString True (s^.askToSaveFilenameEdit) 51 | -------------------------------------------------------------------------------- /src/Tart/Format/V1.hs: -------------------------------------------------------------------------------- 1 | module Tart.Format.V1 2 | ( version1Format 3 | , encodeVersion1 4 | ) 5 | where 6 | 7 | import qualified Data.Binary as B 8 | import qualified Data.Text as T 9 | 10 | import Tart.Canvas 11 | import Tart.Format.Types 12 | 13 | data TartFileDataV1 = 14 | TartFileDataV1 { tartFileDataV1CanvasData :: [CanvasData] 15 | , tartFileDataV1CanvasNames :: [T.Text] 16 | , tartFileDataV1CanvasOrder :: [Int] 17 | } 18 | 19 | encodeVersion1 :: TartFile -> B.Put 20 | encodeVersion1 = B.put . tartFileToDataV1 21 | 22 | version1Format :: TartFileFormat 23 | version1Format = 24 | BinaryFormatVersion B.get tartFileFromDataV1 25 | 26 | instance B.Binary TartFileDataV1 where 27 | put d = do 28 | B.put $ tartFileDataV1CanvasData d 29 | B.put $ T.unpack <$> tartFileDataV1CanvasNames d 30 | B.put $ tartFileDataV1CanvasOrder d 31 | get = do 32 | TartFileDataV1 <$> B.get 33 | <*> (fmap T.pack <$> B.get) 34 | <*> B.get 35 | 36 | tartFileToDataV1 :: TartFile -> TartFileDataV1 37 | tartFileToDataV1 tf = 38 | TartFileDataV1 (canvasToData <$> tartFileCanvasList tf) 39 | (tartFileCanvasNames tf) 40 | (tartFileCanvasOrder tf) 41 | 42 | tartFileFromDataV1 :: TartFileDataV1 -> IO (Either String TartFile) 43 | tartFileFromDataV1 d = do 44 | let loadCanvases [] = return $ Right [] 45 | loadCanvases (cd:cds) = do 46 | result <- canvasFromData cd 47 | case result of 48 | Left e -> return $ Left e 49 | Right c -> do 50 | rest <- loadCanvases cds 51 | case rest of 52 | Left e -> return $ Left e 53 | Right cs -> return $ Right $ c : cs 54 | 55 | result <- loadCanvases (tartFileDataV1CanvasData d) 56 | case result of 57 | Left s -> return $ Left s 58 | Right cs -> return $ Right $ TartFile cs (tartFileDataV1CanvasNames d) 59 | (tartFileDataV1CanvasOrder d) 60 | -------------------------------------------------------------------------------- /src/Tart/Format/V2.hs: -------------------------------------------------------------------------------- 1 | module Tart.Format.V2 2 | ( version2Format 3 | , encodeVersion2 4 | ) 5 | where 6 | 7 | import Control.Monad (when) 8 | import Data.Int (Int32) 9 | import qualified Data.Binary as B 10 | import qualified Data.Text as T 11 | 12 | import Tart.Canvas 13 | import Tart.Format.Types 14 | 15 | data TartFileDataV2 = 16 | TartFileDataV2 { tartFileDataV2CanvasData :: [CanvasData] 17 | , tartFileDataV2CanvasNames :: [T.Text] 18 | , tartFileDataV2CanvasOrder :: [Int] 19 | } 20 | 21 | tartFileDataV2Magic :: Int32 22 | tartFileDataV2Magic = 0xcafe02 23 | 24 | encodeVersion2 :: TartFile -> B.Put 25 | encodeVersion2 = B.put . tartFileToDataV2 26 | 27 | version2Format :: TartFileFormat 28 | version2Format = 29 | BinaryFormatVersion B.get tartFileFromDataV2 30 | 31 | instance B.Binary TartFileDataV2 where 32 | put d = do 33 | B.put tartFileDataV2Magic 34 | B.put $ tartFileDataV2CanvasData d 35 | B.put $ T.unpack <$> tartFileDataV2CanvasNames d 36 | B.put $ tartFileDataV2CanvasOrder d 37 | get = do 38 | magic <- B.get 39 | when (magic /= tartFileDataV2Magic) $ 40 | fail "not a valid tart file version 1" 41 | 42 | TartFileDataV2 <$> B.get 43 | <*> (fmap T.pack <$> B.get) 44 | <*> B.get 45 | 46 | tartFileToDataV2 :: TartFile -> TartFileDataV2 47 | tartFileToDataV2 tf = 48 | TartFileDataV2 (canvasToData <$> tartFileCanvasList tf) 49 | (tartFileCanvasNames tf) 50 | (tartFileCanvasOrder tf) 51 | 52 | tartFileFromDataV2 :: TartFileDataV2 -> IO (Either String TartFile) 53 | tartFileFromDataV2 d = do 54 | let loadCanvases [] = return $ Right [] 55 | loadCanvases (cd:cds) = do 56 | result <- canvasFromData cd 57 | case result of 58 | Left e -> return $ Left e 59 | Right c -> do 60 | rest <- loadCanvases cds 61 | case rest of 62 | Left e -> return $ Left e 63 | Right cs -> return $ Right $ c : cs 64 | 65 | result <- loadCanvases (tartFileDataV2CanvasData d) 66 | case result of 67 | Left s -> return $ Left s 68 | Right cs -> return $ Right $ TartFile cs (tartFileDataV2CanvasNames d) 69 | (tartFileDataV2CanvasOrder d) 70 | -------------------------------------------------------------------------------- /programs/Draw/Line.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiWayIf #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | module Draw.Line 4 | ( plotLine 5 | ) 6 | where 7 | 8 | import Data.Bits (shiftR) 9 | import Control.Monad (when, forM_) 10 | import Control.Monad.State.Lazy 11 | import Lens.Micro.Platform 12 | 13 | data LinePlot = 14 | LinePlot { _lpX :: Int 15 | , _lpY :: Int 16 | , _lpDx1 :: Int 17 | , _lpDy1 :: Int 18 | , _lpDx2 :: Int 19 | , _lpDy2 :: Int 20 | , _lpLongest :: Int 21 | , _lpShortest :: Int 22 | , _lpNumerator :: Int 23 | , _lpPixels :: [(Int, Int)] 24 | } 25 | 26 | makeLenses ''LinePlot 27 | 28 | -- From: 29 | -- http://tech-algorithm.com/articles/drawing-line-using-bresenham-algorithm/ 30 | plotLine :: (Int, Int) -> (Int, Int) -> [(Int, Int)] 31 | plotLine p0 p1 = finalSt^.lpPixels 32 | where 33 | finalSt = execState plot (LinePlot 0 0 0 0 0 0 0 0 0 []) 34 | plot = do 35 | let ((x0, y0), (x1, y1)) = (p0, p1) 36 | w = x1 - x0 37 | h = y1 - y0 38 | 39 | lpX .= x0 40 | lpY .= y0 41 | lpDx1 .= 0 42 | lpDy1 .= 0 43 | lpDx2 .= 0 44 | lpDy2 .= 0 45 | 46 | if | w<0 -> lpDx1 .= -1 47 | | w>0 -> lpDx1 .= 1 48 | | otherwise -> return () 49 | 50 | if | h<0 -> lpDy1 .= -1 51 | | h>0 -> lpDy1 .= 1 52 | | otherwise -> return () 53 | 54 | if | w<0 -> lpDx2 .= -1 55 | | w>0 -> lpDx2 .= 1 56 | | otherwise -> return () 57 | 58 | lpLongest .= abs w 59 | lpShortest .= abs h 60 | 61 | longest <- use lpLongest 62 | shortest <- use lpShortest 63 | 64 | when (not $ longest > shortest) $ do 65 | lpLongest .= abs h 66 | lpShortest .= abs w 67 | 68 | if | (h<0) -> lpDy2 .= -1 69 | | (h>0) -> lpDy2 .= 1 70 | | otherwise -> return () 71 | 72 | lpDx2 .= 0 73 | 74 | longest' <- use lpLongest 75 | lpNumerator .= (longest' `shiftR` 1) 76 | 77 | forM_ [0..longest'] $ \_ -> do 78 | x <- use lpX 79 | y <- use lpY 80 | lpPixels %= ((x, y):) 81 | 82 | shortest' <- use lpShortest 83 | lpNumerator += shortest' 84 | numerator <- use lpNumerator 85 | longest'' <- use lpLongest 86 | if not $ numerator < longest'' 87 | then do 88 | lpNumerator -= longest'' 89 | (lpX +=) =<< use lpDx1 90 | (lpY +=) =<< use lpDy1 91 | else do 92 | (lpX +=) =<< use lpDx2 93 | (lpY +=) =<< use lpDy2 94 | -------------------------------------------------------------------------------- /programs/Events.hs: -------------------------------------------------------------------------------- 1 | module Events 2 | ( handleEvent 3 | ) 4 | where 5 | 6 | import Brick 7 | import Brick.BChan (writeBChan) 8 | import Control.Monad.Trans (liftIO) 9 | import Lens.Micro.Platform 10 | import qualified Graphics.Vty as V 11 | 12 | import Types 13 | import Events.Main 14 | import Events.CharacterSelect 15 | import Events.PaletteEntrySelect 16 | import Events.ToolSelect 17 | import Events.CanvasSizePrompt 18 | import Events.AskToSave 19 | import Events.AskForSaveFilename 20 | import Events.TextEntry 21 | import Events.BoxStyleSelect 22 | import Events.StyleSelect 23 | import Events.RenameLayer 24 | 25 | handleEvent :: BrickEvent Name AppEvent -> EventM Name AppState () 26 | handleEvent (VtyEvent (V.EvResize _ _)) = do 27 | updateExtents 28 | handleEvent e = do 29 | updateExtents 30 | drg <- use dragging 31 | chan <- use appEventChannel 32 | 33 | next <- case e of 34 | MouseDown n _ _ l -> 35 | case drg of 36 | Nothing -> 37 | return $ Just (e, dragging .= Just (n, l, l)) 38 | Just (n', start, _) | n == n' -> 39 | return $ Just (e, dragging .= Just (n, start, l)) 40 | _ -> 41 | return Nothing 42 | MouseUp _ _ _ -> do 43 | case drg of 44 | Nothing -> return () 45 | Just (n, l0, l1) -> do 46 | let ev = DragFinished n l0 l1 47 | liftIO $ writeBChan chan ev 48 | return $ Just (e, dragging .= Nothing) 49 | _ -> 50 | return $ Just (e, return ()) 51 | 52 | case next of 53 | Nothing -> return () 54 | Just (ev, act) -> do 55 | act 56 | m <- gets currentMode 57 | case m of 58 | Main -> handleMainEvent ev 59 | FgPaletteEntrySelect -> handlePaletteEntrySelectEvent ev 60 | BgPaletteEntrySelect -> handlePaletteEntrySelectEvent ev 61 | ToolSelect -> handleToolSelectEvent ev 62 | CharacterSelect -> handleCharacterSelectEvent ev 63 | CanvasSizePrompt -> handleCanvasSizePromptEvent ev 64 | AskToSave -> handleAskToSaveEvent ev 65 | AskForSaveFilename q -> handleAskForSaveFilenameEvent q ev 66 | TextEntry -> handleTextEntryEvent ev 67 | BoxStyleSelect -> handleBoxStyleSelectEvent ev 68 | StyleSelect -> handleStyleSelectEvent ev 69 | RenameLayer -> handleRenameLayerEvent ev 70 | 71 | updateExtents :: EventM Name AppState () 72 | updateExtents = do 73 | fgExtent <- lookupExtent FgSelector 74 | bgExtent <- lookupExtent BgSelector 75 | tsExtent <- lookupExtent ToolSelector 76 | cExtent <- lookupExtent Canvas 77 | bsExtent <- lookupExtent BoxStyleSelector 78 | ssExtent <- lookupExtent StyleSelector 79 | 80 | fgPaletteSelectorExtent .= fgExtent 81 | bgPaletteSelectorExtent .= bgExtent 82 | toolSelectorExtent .= tsExtent 83 | canvasExtent .= cExtent 84 | boxStyleSelectorExtent .= bsExtent 85 | styleSelectorExtent .= ssExtent 86 | -------------------------------------------------------------------------------- /tart.cabal: -------------------------------------------------------------------------------- 1 | name: tart 2 | version: 0.4 3 | synopsis: Terminal Art 4 | description: A program to make ASCII art 5 | license: BSD3 6 | license-file: LICENSE 7 | author: Jonathan Daugherty 8 | maintainer: cygnus@foobox.com 9 | copyright: 2025 Jonathan Daugherty 10 | category: Graphics 11 | build-type: Simple 12 | extra-source-files: CHANGELOG.md 13 | README.md 14 | cabal-version: >=1.10 15 | Homepage: https://github.com/jtdaugherty/tart/ 16 | Bug-reports: https://github.com/jtdaugherty/tart/issues 17 | 18 | Source-Repository head 19 | type: git 20 | location: git://github.com/jtdaugherty/tart.git 21 | 22 | library 23 | ghc-options: -Wall 24 | hs-source-dirs: src 25 | default-language: Haskell2010 26 | exposed-modules: 27 | Tart.Canvas 28 | Tart.Format 29 | Tart.Format.Types 30 | Tart.Format.V0 31 | Tart.Format.V1 32 | Tart.Format.V2 33 | build-depends: base >=4.9 && < 5, 34 | array, 35 | binary, 36 | vty, 37 | microlens-platform, 38 | bytestring, 39 | mtl, 40 | binary, 41 | text 42 | 43 | executable tart 44 | ghc-options: -threaded -Wall 45 | hs-source-dirs: programs 46 | main-is: Main.hs 47 | other-modules: Events 48 | Events.Main 49 | Events.CharacterSelect 50 | Events.PaletteEntrySelect 51 | Events.ToolSelect 52 | Events.Common 53 | Events.CanvasSizePrompt 54 | Events.AskToSave 55 | Events.AskForSaveFilename 56 | Events.TextEntry 57 | Events.BoxStyleSelect 58 | Events.RenameLayer 59 | Events.StyleSelect 60 | UI 61 | UI.Main 62 | UI.Common 63 | UI.CharacterSelect 64 | UI.PaletteEntrySelect 65 | UI.ToolSelect 66 | UI.CanvasSizePrompt 67 | UI.AskToSave 68 | UI.AskForSaveFilename 69 | UI.TextEntry 70 | UI.BoxStyleSelect 71 | UI.StyleSelect 72 | State 73 | Theme 74 | Types 75 | App 76 | Draw 77 | Draw.Line 78 | Draw.Box 79 | default-language: Haskell2010 80 | build-depends: base >=4.9 && < 5, 81 | brick >= 2.7 && < 2.8, 82 | vty, 83 | vty-crossplatform, 84 | vector, 85 | microlens-platform, 86 | microlens-th, 87 | mtl, 88 | text, 89 | text-zipper, 90 | directory, 91 | containers, 92 | tart 93 | -------------------------------------------------------------------------------- /src/Tart/Format.hs: -------------------------------------------------------------------------------- 1 | module Tart.Format 2 | ( TartFile(..) 3 | , OutputFormat(..) 4 | , TartFilePath 5 | , readTartFile 6 | , writeTartFile 7 | , sortedCanvases 8 | , toTartFilepath 9 | ) 10 | where 11 | 12 | import Data.Monoid ((<>)) 13 | import Data.List (isSuffixOf) 14 | import qualified Data.Binary.Put as B 15 | import qualified Data.Binary.Get as B 16 | import qualified Data.ByteString as BS 17 | import qualified Data.ByteString.Lazy as BSL 18 | import qualified Data.Text.IO as T 19 | 20 | import Tart.Canvas 21 | import Tart.Format.Types 22 | import Tart.Format.V0 23 | import Tart.Format.V1 24 | import Tart.Format.V2 25 | 26 | data OutputFormat = 27 | FormatBinary 28 | | FormatAnsiColor 29 | | FormatPlain 30 | deriving (Eq, Show, Read) 31 | 32 | formats :: [TartFileFormat] 33 | formats = 34 | [ version2Format 35 | , version1Format 36 | , version0Format 37 | ] 38 | 39 | newtype TartFilePath = TartFilePath FilePath 40 | 41 | tartFilenameExtension :: String 42 | tartFilenameExtension = ".tart" 43 | 44 | toTartFilepath :: FilePath -> TartFilePath 45 | toTartFilepath p = 46 | if tartFilenameExtension `isSuffixOf` p 47 | then TartFilePath $ take (length p - length tartFilenameExtension) p 48 | else TartFilePath p 49 | 50 | readTartFile :: TartFilePath -> IO (Either String TartFile) 51 | readTartFile (TartFilePath path) = do 52 | bs <- BS.readFile $ path <> tartFilenameExtension 53 | readTartFile' (BSL.fromStrict bs) path formats 54 | 55 | readTartFile' :: BSL.ByteString -> FilePath -> [TartFileFormat] -> IO (Either String TartFile) 56 | readTartFile' _ path [] = return $ Left $ path <> ": could not load file" 57 | readTartFile' bs path ((BinaryFormatVersion parser converter):fmts) = do 58 | let tryNextFormat = readTartFile' bs path fmts 59 | case B.runGetOrFail parser bs of 60 | Left _ -> tryNextFormat 61 | Right (remaining, _, d) -> 62 | case BSL.null remaining of 63 | False -> tryNextFormat 64 | True -> do 65 | result <- converter d 66 | case result of 67 | Left _ -> tryNextFormat 68 | Right tf -> return $ Right tf 69 | 70 | writeTartFile :: OutputFormat -> TartFile -> TartFilePath -> IO () 71 | writeTartFile format = 72 | case format of 73 | FormatPlain -> writeTartFilePretty False 74 | FormatAnsiColor -> writeTartFilePretty True 75 | FormatBinary -> writeTartFileBinary 76 | 77 | sortedCanvases :: [Int] -> [Canvas] -> [Canvas] 78 | sortedCanvases order cs = 79 | [ cs !! i | i <- order ] 80 | 81 | tartFileCanvasesSorted :: TartFile -> [Canvas] 82 | tartFileCanvasesSorted tf = 83 | sortedCanvases (tartFileCanvasOrder tf) 84 | (tartFileCanvasList tf) 85 | 86 | writeTartFilePretty :: Bool -> TartFile -> TartFilePath -> IO () 87 | writeTartFilePretty color tf (TartFilePath path) = 88 | let ext = if color then ".color.txt" 89 | else ".plain.txt" 90 | fn = path <> ext 91 | in T.writeFile fn $ 92 | prettyPrintCanvas color $ tartFileCanvasesSorted tf 93 | 94 | writeTartFileBinary :: TartFile -> TartFilePath -> IO () 95 | writeTartFileBinary tf (TartFilePath path) = 96 | let fn = path <> tartFilenameExtension 97 | in BS.writeFile fn $ BSL.toStrict $ B.runPut $ latestVersionEncoder tf 98 | 99 | latestVersionEncoder :: TartFile -> B.Put 100 | latestVersionEncoder = encodeVersion2 101 | -------------------------------------------------------------------------------- /programs/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad (void, when) 4 | import Control.Applicative ((<|>)) 5 | import Brick 6 | import Brick.BChan (newBChan) 7 | import qualified Graphics.Vty as V 8 | import qualified Graphics.Vty.CrossPlatform as V 9 | import System.Environment (getArgs, getProgName) 10 | import System.Exit (exitFailure, exitSuccess) 11 | import System.Console.GetOpt 12 | import Data.Monoid ((<>)) 13 | import System.Directory (doesFileExist) 14 | import qualified Data.Text as T 15 | import qualified Data.Text.IO as T 16 | 17 | import App 18 | import State 19 | import Tart.Canvas 20 | import Tart.Format 21 | 22 | data Option = Import FilePath 23 | | Output FilePath 24 | | ShowHelp 25 | deriving (Eq) 26 | 27 | data Config = 28 | Config { configImport :: Maybe FilePath 29 | , configOutput :: Maybe FilePath 30 | , configShowHelp :: Bool 31 | } 32 | 33 | defaultConfig :: Config 34 | defaultConfig = 35 | Config { configImport = Nothing 36 | , configOutput = Nothing 37 | , configShowHelp = False 38 | } 39 | 40 | opts :: [OptDescr Option] 41 | opts = 42 | [ Option "i" ["import"] (ReqArg Import "FILE") 43 | "Import a plain text file to begin a drawing" 44 | , Option "o" ["output"] (ReqArg Output "FILE") 45 | "Where to write the output file" 46 | , Option "h" ["help"] (NoArg ShowHelp) 47 | "Show this help" 48 | ] 49 | 50 | configFromOpts :: [Option] -> Config -> IO Config 51 | configFromOpts [] c = 52 | return c 53 | configFromOpts (ShowHelp:os) c = 54 | configFromOpts os $ c { configShowHelp = True } 55 | configFromOpts (Output f:os) c = do 56 | configFromOpts os $ c { configOutput = Just f } 57 | configFromOpts (Import f:os) c = do 58 | ex <- doesFileExist f 59 | case ex of 60 | False -> do 61 | putStrLn $ "Error: file not found: " <> f 62 | exitFailure 63 | True -> configFromOpts os $ c { configImport = Just f } 64 | 65 | showHelp :: IO () 66 | showHelp = do 67 | pn <- getProgName 68 | putStrLn $ usageInfo ("Usage: " <> pn <> " [file]") opts 69 | 70 | main :: IO () 71 | main = do 72 | checkForMouseSupport 73 | 74 | args <- getArgs 75 | let (os, rest, errs) = getOpt Permute opts args 76 | 77 | when (not $ null errs) $ 78 | showHelp >> exitFailure 79 | 80 | cfg <- configFromOpts os defaultConfig 81 | 82 | when (configShowHelp cfg) $ 83 | showHelp >> exitFailure 84 | 85 | -- If this is an import operation, read the plain text file and 86 | -- convert to a canvas. If an output filename was specified, write 87 | -- the file and exit. Otherwise look for an input file in canvas 88 | -- format 89 | c <- case configImport cfg of 90 | Just f -> do 91 | t <- T.readFile f 92 | c <- canvasFromText t 93 | case configOutput cfg of 94 | Nothing -> return $ Just (Nothing, [c], [0], [T.pack "default"]) 95 | Just output -> do 96 | writeCanvasFiles output [c] [0] [T.pack "default"] 97 | exitSuccess 98 | Nothing -> 99 | case rest of 100 | [f] -> do 101 | r <- readTartFile $ toTartFilepath f 102 | case r of 103 | Left e -> do 104 | putStrLn $ f <> ": could not read file: " <> e 105 | exitFailure 106 | Right tf -> 107 | return $ Just ( configOutput cfg <|> Just f 108 | , tartFileCanvasList tf 109 | , tartFileCanvasOrder tf 110 | , tartFileCanvasNames tf 111 | ) 112 | _ -> return Nothing 113 | 114 | chan <- newBChan 10 115 | let mkVty = V.mkVty V.defaultConfig 116 | 117 | initialVty <- mkVty 118 | (void . customMain initialVty mkVty (Just chan) application) =<< mkInitialState chan c 119 | -------------------------------------------------------------------------------- /programs/Events/Main.hs: -------------------------------------------------------------------------------- 1 | module Events.Main 2 | ( handleMainEvent 3 | , handleAttrEvent 4 | ) 5 | where 6 | 7 | import Brick 8 | import Control.Monad (when, void) 9 | import Data.Char (isDigit) 10 | import Data.Maybe (isJust) 11 | import qualified Graphics.Vty as V 12 | import Graphics.Vty (Event(..), Key(..), Modifier(..)) 13 | import Lens.Micro.Platform 14 | import Data.Text.Encoding (decodeUtf8) 15 | 16 | import Types 17 | import Draw 18 | import State 19 | import Events.Common 20 | 21 | handleMainEvent :: BrickEvent Name AppEvent -> EventM Name AppState () 22 | handleMainEvent e = do 23 | result <- handleCommonEvent e 24 | case result of 25 | True -> return () 26 | False -> do 27 | result2 <- handleAttrEvent e 28 | case result2 of 29 | True -> return () 30 | False -> handleEvent e 31 | 32 | handleAttrEvent :: BrickEvent Name AppEvent -> EventM Name AppState Bool 33 | handleAttrEvent (MouseDown FgSelector _ _ _) = do 34 | beginFgPaletteSelect 35 | return True 36 | handleAttrEvent (MouseDown BgSelector _ _ _) = do 37 | beginBgPaletteSelect 38 | return True 39 | handleAttrEvent (MouseDown StyleSelector _ _ _) = do 40 | beginStyleSelect 41 | return True 42 | handleAttrEvent _ = 43 | return False 44 | 45 | handleEvent :: BrickEvent Name AppEvent -> EventM Name AppState () 46 | handleEvent (VtyEvent (V.EvPaste bytes)) = 47 | pasteTextAtPoint (0, 0) (decodeUtf8 bytes) 48 | handleEvent (AppEvent (DragFinished n _ _)) = 49 | handleDragFinished n 50 | handleEvent (VtyEvent (V.EvMouseDown _ _ V.BScrollUp _)) = 51 | increaseToolSize 52 | handleEvent (VtyEvent (V.EvMouseDown _ _ V.BScrollDown _)) = 53 | decreaseToolSize 54 | handleEvent (MouseDown _ V.BScrollUp _ _) = 55 | increaseToolSize 56 | handleEvent (MouseDown _ V.BScrollDown _ _) = 57 | decreaseToolSize 58 | handleEvent (MouseDown Canvas _ _ (Location l)) = 59 | drawWithCurrentTool l 60 | handleEvent (MouseDown n _ _ _) = 61 | case n of 62 | LayerName -> beginLayerRename 63 | DeleteLayer -> deleteSelectedLayer 64 | MoveLayerUp -> moveCurrentLayerUp 65 | MoveLayerDown -> moveCurrentLayerDown 66 | ResizeCanvas -> beginCanvasSizePrompt 67 | ToggleLayerVisible -> toggleCurrentLayer 68 | ToolSelector -> beginToolSelect 69 | IncreaseToolSize -> increaseToolSize 70 | DecreaseToolSize -> decreaseToolSize 71 | BoxStyleSelector -> beginBoxStyleSelect 72 | SelectLayer idx -> void $ selectLayer idx 73 | AddLayer -> addLayer 74 | CharSelector -> whenTool charTools beginCharacterSelect 75 | _ -> return () 76 | handleEvent (VtyEvent (V.EvKey (V.KChar 'q') [])) = 77 | quit True 78 | handleEvent (VtyEvent e) = 79 | case e of 80 | _ | isStyleKey e -> toggleStyleFromKey e 81 | (EvKey (KChar 'l') [MCtrl]) -> toggleLayerList 82 | (EvKey (KChar 'w') []) -> canvasMoveDown 83 | (EvKey (KChar 's') []) -> canvasMoveUp 84 | (EvKey (KChar 'a') []) -> canvasMoveLeft 85 | (EvKey (KChar 'd') []) -> canvasMoveRight 86 | (EvKey (KChar 'y') []) -> beginStyleSelect 87 | (EvKey (KChar 'v') []) -> beginCanvasSizePrompt 88 | (EvKey (KChar 's') [MCtrl]) -> askForSaveFilename False 89 | (EvKey (KChar 'r') [MCtrl]) -> beginLayerRename 90 | (EvKey (KChar 'x') [MCtrl]) -> deleteSelectedLayer 91 | (EvKey (KChar 'n') [MCtrl]) -> selectNextLayer 92 | (EvKey (KChar 'p') [MCtrl]) -> selectPrevLayer 93 | (EvKey (KChar 'u') [MCtrl]) -> moveCurrentLayerUp 94 | (EvKey (KChar 'd') [MCtrl]) -> moveCurrentLayerDown 95 | (EvKey (KChar 'v') [MCtrl]) -> toggleCurrentLayer 96 | (EvKey (KChar 'C') []) -> recenterCanvas 97 | (EvKey (KChar '>') []) -> increaseToolSize 98 | (EvKey (KChar '<') []) -> decreaseToolSize 99 | (EvKey KEsc []) -> do 100 | drg <- use dragging 101 | when (isJust drg) cancelDragging 102 | (EvKey (KChar c) []) | isDigit c -> setToolByChar c 103 | (EvKey (KChar 'c') []) -> whenTool charTools beginCharacterSelect 104 | (EvKey (KChar '+') []) -> increaseCanvasSize 105 | (EvKey (KChar '-') []) -> decreaseCanvasSize 106 | (EvKey (KChar 'a') [MCtrl]) -> addLayer 107 | (EvKey (KChar 'u') []) -> undo 108 | (EvKey (KChar 'r') []) -> redo 109 | _ -> return () 110 | handleEvent _ = return () 111 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | tart - terminal art program 2 | =========================== 3 | 4 | ``` 5 | _____ _ ____ _____ _ 6 | (_ _)/ \ | (_ _)| | 7 | | | / ^ \ | O || | |_| 8 | | |/ ___ \| _ < | | _ 9 | |_|_/ \_|_| \_\|_| |_| 10 | ``` 11 | 12 | Tart is a program that provides an image-editor-like interface to 13 | creating ASCII art - in the terminal, with your mouse! This program is 14 | written using my purely-functional terminal user interface toolkit, 15 | [Brick](https://github.com/jtdaugherty/brick). 16 | 17 | ![](screenshots/2.png) 18 | 19 | Status 20 | ====== 21 | 22 | Expectation management: This is a fun hobby project that I spent time 23 | on when I first created it many years ago. Since then, I have only 24 | done a little bit to keep it working. Since it was (and still is) 25 | mostly intended as a proof of concept, and since I do not use the tool 26 | actively, I have not been putting much energy into maintaining it beyond 27 | keeping it building. While that isn't likely to change, I am happy to 28 | support people who want to contribute to the tool and I may have energy 29 | to fix small things as they are reported. Use at your own risk. If other 30 | tools are more mature or perform better, you are probably better off 31 | using them! 32 | 33 | Building 34 | ======== 35 | 36 | `tart` is a Haskell project. You'll need 37 | [GHC](https://www.haskell.org/ghc/) (preferably at least 8.2) and 38 | [cabal-install](http://hackage.haskell.org/package/cabal-install) 39 | (preferably at least 2.0). Then: 40 | 41 | ``` 42 | $ git clone https://github.com/jtdaugherty/tart.git 43 | $ cd tart 44 | $ cabal new-build 45 | $ $(find . -name tart -type f) 46 | ``` 47 | 48 | Features 49 | ======== 50 | 51 | - Drawing tools: freehand, line, box, flood fill, text string 52 | - Utility tools: repaint, restyle, eyedropper, eraser 53 | - Multiple graphical styles for boxes 54 | - Named image layers with reordering, visibility toggling 55 | - Character selection for freehand and flood fill tools 56 | - Set foreground color, background color, and text style independently 57 | - Full mouse interaction and keyboard shortcuts 58 | - Paste text from clipboard into canvas 59 | - Undo and redo 60 | - Text styles: bold, blink, underline, reverse video 61 | - Load and save ASCII art files (binary) 62 | - Save plain versions of ASCII art for embedding in documents 63 | - Save color versions of ASCII art with terminal escape sequences for 64 | printing to terminals 65 | - Import existing plaintext files as the basis for new ASCII art files 66 | - Set arbitrary canvas size 67 | 68 | Terminal Emulator Support 69 | ========================= 70 | 71 | `tart` has been tested extensively with the following terminal emulators 72 | and is known to work well with them: 73 | 74 | * OS X: `iTerm2` 75 | * OS X: `Terminal.app` 76 | 77 | Please let me know if you use `tart` with another emulator and let me 78 | know how well it works! 79 | 80 | Keybindings 81 | =========== 82 | 83 | Tools / styles: 84 | - `0`..`9`: select tool 85 | - `y`: open the attribute style selector 86 | - `!`/`@`/`#`/`$`: select attribute style 87 | - `f`/`b`: open foreground / background palette selectors 88 | - `c`: set tool drawing character (where applicable) 89 | - `<`/`>`: decrease / increase tool size (where applicable) 90 | - `Esc`: cancel tool drag (e.g. box) 91 | 92 | Canvas: 93 | - `w`/`a`/`s`/`d`: move canvas 94 | - `C`: re-center canvas 95 | - `v`: set canvas size 96 | - `-`/`+`: decrease / increase canvas size 97 | 98 | Layers: 99 | - `C-a`: add new layer 100 | - `C-r`: rename current layer 101 | - `C-n`/`C-p`: select next/previous layer 102 | - `C-x`: delete selected layer 103 | - `C-u`/`C-d`: move current layer up / down 104 | - `C-v`: toggle selected layer's visibility 105 | - `C-l`: toggle visibility of layer list 106 | 107 | General: 108 | - `q`: quit (and optionally save) 109 | - `C-s`: save 110 | - `u`: undo 111 | - `r`: redo 112 | - OS paste: paste text into canvas 113 | 114 | How It Works 115 | ============ 116 | 117 | Tart requires a terminal with mouse support. You use various tools (such 118 | as freehand drawing, boxes, etc.) to draw ASCII pictures. You can set a 119 | current foreground and background color. You can also resize the drawing 120 | canvas to get the desired output size. When you're finished, you can 121 | save to disk, at which point Tart creates three files: 122 | 123 | * A binary file (say `foo.tart`) suitable for reloading with Tart for 124 | further editing later 125 | * A text file `foo.color.txt` containing the ASCII art with terminal 126 | color escape sequences, suitable for emitting to terminals 127 | * A text file `foo.plain.txt` containing the ASCII art without terminal 128 | color escape sequences, suitable for embedding in documentation 129 | 130 | Contributing 131 | ============ 132 | 133 | If you decide to contribute, that's great! Here are some guidelines you 134 | should consider to make submitting patches easier for all concerned: 135 | 136 | - If you want to take on big things, talk to me first; let's have a 137 | design/vision discussion before you start coding. Create a GitHub 138 | issue and we can use that as the place to hash things out. 139 | - Please make changes consistent with the conventions I've used in the 140 | codebase. 141 | - Please adjust or provide Haddock and/or user guide documentation 142 | relevant to any changes you make. 143 | -------------------------------------------------------------------------------- /programs/App.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiWayIf #-} 2 | {-# LANGUAGE TupleSections #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | module App 5 | ( application 6 | , mkInitialState 7 | ) 8 | where 9 | 10 | import Control.Monad.Trans (liftIO) 11 | import qualified Graphics.Vty as V 12 | import qualified Data.Vector as Vec 13 | import qualified Data.Map as M 14 | import Lens.Micro.Platform 15 | import qualified Data.Text as T 16 | 17 | import Brick 18 | import Brick.BChan (BChan) 19 | import Brick.Focus 20 | import Brick.Widgets.Edit (editor) 21 | 22 | import Types 23 | import Events 24 | import UI 25 | import Theme 26 | import Tart.Canvas 27 | 28 | defaultPalette :: Vec.Vector (Maybe V.Color) 29 | defaultPalette = Vec.fromList 30 | [ Nothing -- default attribute 31 | , Just V.white 32 | , Just V.brightWhite 33 | , Just V.black 34 | , Just V.brightBlack 35 | , Just V.blue 36 | , Just V.brightBlue 37 | , Just V.red 38 | , Just V.brightRed 39 | , Just V.magenta 40 | , Just V.brightMagenta 41 | , Just V.green 42 | , Just V.brightGreen 43 | , Just V.cyan 44 | , Just V.brightCyan 45 | , Just V.yellow 46 | , Just V.brightYellow 47 | ] 48 | 49 | initialCanvasSize :: (Int, Int) 50 | initialCanvasSize = (40, 17) 51 | 52 | mkInitialState :: BChan AppEvent 53 | -> Maybe (Maybe FilePath, [Canvas], [Int], [T.Text]) 54 | -> IO AppState 55 | mkInitialState chan mc = do 56 | (cs, order, names, fp) <- case mc of 57 | Nothing -> do 58 | c <- newCanvas initialCanvasSize 59 | return ([c], [0], [T.pack "default"], Nothing) 60 | Just (fp, cs, order, names) -> 61 | return (cs, order, names, fp) 62 | 63 | let sz = canvasSize $ cs !! 0 64 | overlay <- newCanvas sz 65 | 66 | return $ AppState { _layers = M.fromList $ zip [0..] cs 67 | , _layerInfo = M.fromList $ zip [0..] (LayerInfo <$> names <*> pure True) 68 | , _layerOrder = order 69 | , _drawingOverlay = overlay 70 | , _layerListVisible = True 71 | , _selectedLayerIndex = head order 72 | , _modes = [Main] 73 | , _tool = Freehand 74 | , _appCanvasSize = sz 75 | , _drawCharacter = '*' 76 | , _drawFgPaletteIndex = 0 77 | , _drawBgPaletteIndex = 0 78 | , _palette = defaultPalette 79 | , _fgPaletteSelectorExtent = Nothing 80 | , _bgPaletteSelectorExtent = Nothing 81 | , _toolSelectorExtent = Nothing 82 | , _boxStyleSelectorExtent = Nothing 83 | , _styleSelectorExtent = Nothing 84 | , _canvasExtent = Nothing 85 | , _dragging = Nothing 86 | , _layerNameEditor = editor LayerNameEditor (Just 1) "" 87 | , _canvasSizeWidthEdit = editor CanvasSizeWidthEdit (Just 1) "" 88 | , _canvasSizeHeightEdit = editor CanvasSizeHeightEdit (Just 1) "" 89 | , _canvasSizeFocus = focusRing [ CanvasSizeWidthEdit 90 | , CanvasSizeHeightEdit 91 | ] 92 | , _canvasOffset = Location $ sz & each %~ (`div` 2) 93 | , _canvasPath = fp 94 | , _canvasDirty = False 95 | , _askToSaveFilenameEdit = editor AskToSaveFilenameEdit (Just 1) "" 96 | , _saveError = Nothing 97 | , _appEventChannel = chan 98 | , _textEntered = mempty 99 | , _textEntryStart = (0, 0) 100 | , _boxStyleIndex = 0 101 | , _eraserSize = 1 102 | , _repaintSize = 1 103 | , _restyleSize = 1 104 | , _undoStack = [] 105 | , _redoStack = [] 106 | , _drawStyle = noStyle 107 | } 108 | 109 | application :: App AppState AppEvent Name 110 | application = 111 | App { appDraw = drawUI 112 | , appChooseCursor = \s locs -> 113 | let isSaving = any isSavingMode 114 | isSavingMode (AskForSaveFilename _) = True 115 | isSavingMode _ = False 116 | in if | CanvasSizePrompt `elem` s^.modes -> do 117 | cur <- focusGetCurrent (s^.canvasSizeFocus) 118 | showCursorNamed cur locs 119 | | isSaving (s^.modes) -> 120 | showCursorNamed AskToSaveFilenameEdit locs 121 | | TextEntry `elem` s^.modes -> 122 | showCursorNamed TextEntryCursor locs 123 | | RenameLayer `elem` s^.modes -> 124 | showCursorNamed LayerNameEditor locs 125 | | otherwise -> Nothing 126 | , appHandleEvent = handleEvent 127 | , appStartEvent = do 128 | vty <- getVtyHandle 129 | liftIO $ V.setMode (V.outputIface vty) V.Mouse True 130 | liftIO $ V.setMode (V.outputIface vty) V.BracketedPaste True 131 | , appAttrMap = const theme 132 | } 133 | -------------------------------------------------------------------------------- /programs/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BinaryLiterals #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | module Types 6 | ( Mode(..) 7 | , Name(..) 8 | , Tool(..) 9 | , AppEvent(..) 10 | , Action(..) 11 | , toolName 12 | , isSelectionMode 13 | 14 | , LayerInfo(..) 15 | , layerName 16 | , layerVisible 17 | 18 | , noStyle 19 | , setStyle 20 | , clearStyle 21 | , toggleStyle 22 | , hasStyle 23 | 24 | , AppState(..) 25 | , layers 26 | , currentLayer 27 | , layerAt 28 | , layerInfoFor 29 | , layerOrder 30 | , layerInfo 31 | , layerNameEditor 32 | , selectedLayerIndex 33 | , drawingOverlay 34 | , modes 35 | , currentMode 36 | , tool 37 | , drawFgPaletteIndex 38 | , drawBgPaletteIndex 39 | , layerListVisible 40 | , appCanvasSize 41 | , palette 42 | , drawCharacter 43 | , fgPaletteSelectorExtent 44 | , bgPaletteSelectorExtent 45 | , toolSelectorExtent 46 | , boxStyleSelectorExtent 47 | , styleSelectorExtent 48 | , canvasExtent 49 | , dragging 50 | , canvasSizeWidthEdit 51 | , canvasSizeHeightEdit 52 | , canvasSizeFocus 53 | , canvasOffset 54 | , canvasPath 55 | , canvasDirty 56 | , askToSaveFilenameEdit 57 | , appEventChannel 58 | , textEntered 59 | , textEntryStart 60 | , boxStyleIndex 61 | , eraserSize 62 | , repaintSize 63 | , restyleSize 64 | , undoStack 65 | , redoStack 66 | , drawStyle 67 | , saveError 68 | ) 69 | where 70 | 71 | import Data.Bits ((.&.), (.|.), complement) 72 | import Data.Word (Word8) 73 | import Data.Maybe (fromJust) 74 | import Brick (Extent, Location) 75 | import Brick.BChan (BChan) 76 | import Brick.Focus 77 | import Brick.Widgets.Edit (Editor) 78 | import qualified Data.Text as T 79 | import qualified Data.Map as M 80 | import Lens.Micro.Platform 81 | import qualified Data.Vector as Vec 82 | import qualified Graphics.Vty as V 83 | 84 | import Tart.Canvas 85 | 86 | data AppEvent = 87 | DragFinished Name Location Location 88 | deriving (Eq) 89 | 90 | data Action = 91 | SetPixels Int [((Int, Int), (Char, V.Attr))] 92 | | ClearCanvasDirty 93 | | InsertLayer Canvas Int Int T.Text 94 | | RemoveLayer Int 95 | | SelectLayerIndex Int 96 | | ChangeLayerName Int T.Text 97 | | MoveLayerBy Int Bool 98 | | ToggleLayer Int 99 | 100 | data Mode = Main 101 | | CharacterSelect 102 | | FgPaletteEntrySelect 103 | | BgPaletteEntrySelect 104 | | ToolSelect 105 | | StyleSelect 106 | | BoxStyleSelect 107 | | CanvasSizePrompt 108 | | AskToSave 109 | | AskForSaveFilename Bool 110 | | TextEntry 111 | | RenameLayer 112 | deriving (Eq, Show) 113 | 114 | selectionModes :: [Mode] 115 | selectionModes = 116 | [ CharacterSelect 117 | , FgPaletteEntrySelect 118 | , BgPaletteEntrySelect 119 | , ToolSelect 120 | , StyleSelect 121 | , BoxStyleSelect 122 | ] 123 | 124 | isSelectionMode :: Mode -> Bool 125 | isSelectionMode = (`elem` selectionModes) 126 | 127 | data Name = Canvas 128 | | TopHud 129 | | BottomHud 130 | | ToolSelector 131 | | ToolSelectorEntry Tool 132 | | CharSelector 133 | | FgSelector 134 | | BgSelector 135 | | StyleSelector 136 | | StyleSelectorEntry V.Style 137 | | FgPaletteEntry Int 138 | | BgPaletteEntry Int 139 | | BoxStyleSelectorEntry Int 140 | | ResizeCanvas 141 | | CanvasSizeWidthEdit 142 | | CanvasSizeHeightEdit 143 | | AskToSaveFilenameEdit 144 | | TextEntryCursor 145 | | BoxStyleSelector 146 | | IncreaseToolSize 147 | | DecreaseToolSize 148 | | SelectLayer Int 149 | | LayerName 150 | | LayerNameEditor 151 | | AddLayer 152 | | DeleteLayer 153 | | MoveLayerUp 154 | | MoveLayerDown 155 | | ToggleLayerVisible 156 | deriving (Eq, Show, Ord) 157 | 158 | data Tool = Freehand 159 | | Box 160 | | Line 161 | | Repaint 162 | | Restyle 163 | | Eyedropper 164 | | FloodFill 165 | | Eraser 166 | | TextString 167 | deriving (Eq, Show, Ord) 168 | 169 | toolName :: Tool -> T.Text 170 | toolName Freehand = "Freehand" 171 | toolName Box = "Box" 172 | toolName Line = "Line" 173 | toolName Repaint = "Repaint" 174 | toolName Restyle = "Restyle" 175 | toolName Eraser = "Eraser" 176 | toolName Eyedropper = "Eyedropper" 177 | toolName FloodFill = "Flood fill" 178 | toolName TextString = "Text string" 179 | 180 | newtype DrawStyle = 181 | DrawStyle Word8 182 | deriving (Eq, Show) 183 | 184 | setStyle :: V.Style -> V.Style -> V.Style 185 | setStyle a b = a .|. b 186 | 187 | toggleStyle :: V.Style -> V.Style -> V.Style 188 | toggleStyle a b = 189 | if hasStyle a b 190 | then clearStyle a b 191 | else setStyle a b 192 | 193 | hasStyle :: V.Style -> V.Style -> Bool 194 | hasStyle a b = a .&. b /= 0 195 | 196 | clearStyle :: V.Style -> V.Style -> V.Style 197 | clearStyle old dest = dest .&. complement old 198 | 199 | noStyle :: V.Style 200 | noStyle = 0 201 | 202 | data LayerInfo = 203 | LayerInfo { _layerName :: T.Text 204 | , _layerVisible :: Bool 205 | } 206 | 207 | makeLenses ''LayerInfo 208 | 209 | data AppState = 210 | AppState { _layers :: M.Map Int Canvas 211 | , _layerOrder :: [Int] 212 | , _layerInfo :: M.Map Int LayerInfo 213 | , _layerListVisible :: Bool 214 | , _drawingOverlay :: Canvas 215 | , _selectedLayerIndex :: Int 216 | , _appCanvasSize :: (Int, Int) 217 | , _modes :: [Mode] 218 | , _drawFgPaletteIndex :: Int 219 | , _drawBgPaletteIndex :: Int 220 | , _drawStyle :: V.Style 221 | , _drawCharacter :: Char 222 | , _tool :: Tool 223 | , _palette :: Vec.Vector (Maybe V.Color) 224 | , _fgPaletteSelectorExtent :: Maybe (Extent Name) 225 | , _bgPaletteSelectorExtent :: Maybe (Extent Name) 226 | , _toolSelectorExtent :: Maybe (Extent Name) 227 | , _boxStyleSelectorExtent :: Maybe (Extent Name) 228 | , _styleSelectorExtent :: Maybe (Extent Name) 229 | , _canvasExtent :: Maybe (Extent Name) 230 | , _dragging :: Maybe (Name, Location, Location) 231 | , _layerNameEditor :: Editor T.Text Name 232 | , _canvasSizeWidthEdit :: Editor T.Text Name 233 | , _canvasSizeHeightEdit :: Editor T.Text Name 234 | , _canvasSizeFocus :: FocusRing Name 235 | , _canvasOffset :: Location 236 | , _canvasPath :: Maybe FilePath 237 | , _canvasDirty :: Bool 238 | , _askToSaveFilenameEdit :: Editor T.Text Name 239 | , _saveError :: Maybe T.Text 240 | , _appEventChannel :: BChan AppEvent 241 | , _textEntered :: [(Char, V.Attr)] 242 | , _textEntryStart :: (Int, Int) 243 | , _boxStyleIndex :: Int 244 | , _eraserSize :: Int 245 | , _repaintSize :: Int 246 | , _restyleSize :: Int 247 | , _undoStack :: [[Action]] 248 | , _redoStack :: [[Action]] 249 | } 250 | 251 | makeLenses ''AppState 252 | 253 | currentLayer :: Lens' AppState Canvas 254 | currentLayer = 255 | lens (\s -> fromJust $ s^.layers.at (s^.selectedLayerIndex)) 256 | (\s c -> s & layers.at (s^.selectedLayerIndex) .~ Just c) 257 | 258 | layerAt :: Int -> Lens' AppState Canvas 259 | layerAt i = 260 | lens (\s -> fromJust $ s^.layers.at i) 261 | (\s c -> s & layers.at i .~ Just c) 262 | 263 | layerInfoFor :: Int -> Lens' AppState LayerInfo 264 | layerInfoFor i = 265 | lens (\s -> fromJust $ s^.layerInfo.at i) 266 | (\s v -> s & layerInfo.at i .~ Just v) 267 | 268 | currentMode :: AppState -> Mode 269 | currentMode s = case _modes s of 270 | (m:_) -> m 271 | _ -> error "BUG: currentMode: no modes!" 272 | -------------------------------------------------------------------------------- /programs/UI/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module UI.Main 3 | ( drawMainUI 4 | , toolSelectorEntryWidth 5 | , boxStyleSelectorEntryWidth 6 | , styleSelectorEntryWidth 7 | ) 8 | where 9 | 10 | import Brick 11 | import Brick.Widgets.Edit 12 | import Brick.Widgets.Border 13 | import Brick.Widgets.Border.Style 14 | import Brick.Widgets.Center 15 | import Data.Monoid ((<>)) 16 | import qualified Data.Text as T 17 | import Data.Maybe (isJust, catMaybes, fromMaybe) 18 | import qualified Graphics.Vty as V 19 | import Lens.Micro.Platform 20 | 21 | import Types 22 | import UI.Common 23 | import Theme 24 | import State 25 | import Tart.Canvas 26 | 27 | drawMainUI :: AppState -> [Widget Name] 28 | drawMainUI s = 29 | catMaybes [ Just $ topHud s 30 | , if s^.layerListVisible then Just $ layerHud s else Nothing 31 | , Just $ canvas s 32 | ] 33 | 34 | topHud :: AppState -> Widget Name 35 | topHud s = 36 | let fgPal = drawPaletteSelector s True 37 | bgPal = drawPaletteSelector s False 38 | stySel = drawStyleSelector s 39 | toolbarEntries = [ drawToolSelector s 40 | , toolHud s 41 | , vLimit 1 $ fill ' ' 42 | , fgPal 43 | , bgPal 44 | , stySel 45 | , drawCanvasSize s 46 | ] 47 | filename = case s^.canvasPath of 48 | Nothing -> "" 49 | Just p -> T.pack p 50 | modified = if not $ s^.canvasDirty then "" else "*" 51 | in clickable TopHud $ 52 | vBox [ (padLeft (Pad 1) $ hBox $ padRight (Pad 1) <$> toolbarEntries) 53 | , hBox [hBorder, txt ("[" <> filename <> modified <> "]"), borderElem bsHorizontal] 54 | ] 55 | 56 | layerHud :: AppState -> Widget Name 57 | layerHud s = translateBy (Location (0, 4)) $ 58 | padBottom (Pad 4) $ 59 | (hLimit 20 $ layerList <=> fill ' ' <=> layerOptions) <+> vBorder 60 | where 61 | layerList = vBox $ (hCenter $ withDefAttr headerAttr $ txt "Layers") : 62 | (mkEntry <$> entries) <> 63 | [addLayerEntry] 64 | entries = [ ( i 65 | , s^.layerInfoFor(i) 66 | ) 67 | | i <- s^.layerOrder 68 | ] 69 | addLayerEntry = 70 | clickable AddLayer $ hCenter $ 71 | withDefAttr clickableAttr $ txt "Add Layer (C-a)" 72 | mkEntry (idx, LayerInfo name vis) = 73 | if RenameLayer `elem` s^.modes && s^.selectedLayerIndex == idx 74 | then 75 | renderEditor (txt . T.concat) True (s^.layerNameEditor) 76 | else 77 | let applyAttr = if idx == s^.selectedLayerIndex 78 | then withDefAttr selectedLayerAttr 79 | else id 80 | showHiddenStatus = if vis then id else (<+> txt "H") 81 | in clickable (if idx == s^.selectedLayerIndex 82 | then LayerName 83 | else SelectLayer idx) $ 84 | applyAttr $ vLimit 1 $ 85 | showHiddenStatus $ 86 | txt name <+> fill ' ' 87 | layerOptions = 88 | let i = s^.selectedLayerIndex 89 | entry n label = 90 | clickable n $ vLimit 1 $ withDefAttr clickableAttr $ 91 | txt label <+> fill ' ' 92 | in vBox $ catMaybes 93 | [ Just $ hBorderWithLabel (txt "Layer Options") 94 | , Just $ entry ToggleLayerVisible 95 | (if s^.layerInfoFor(i).layerVisible 96 | then "Hide (C-v)" 97 | else "Show (C-v)") 98 | , if i /= head (s^.layerOrder) 99 | then Just $ entry MoveLayerUp "Move up (C-u)" 100 | else Nothing 101 | , if i /= last (s^.layerOrder) 102 | then Just $ entry MoveLayerDown "Move down (C-d)" 103 | else Nothing 104 | , if length (s^.layerOrder) == 1 105 | then Nothing 106 | else Just $ entry DeleteLayer "Delete (C-x)" 107 | ] 108 | 109 | toolHud :: AppState -> Widget Name 110 | toolHud s = 111 | let toolHuds = [ (Freehand, freehandHud) 112 | , (FloodFill, floodfillHud) 113 | , (Box, boxHud) 114 | , (Line, lineHud) 115 | , (Eraser, eraserHud) 116 | , (Repaint, repaintHud) 117 | , (Restyle, restyleHud) 118 | , (Eyedropper, eyedropperHud) 119 | ] 120 | in case lookup (s^.tool) toolHuds of 121 | Nothing -> emptyWidget 122 | Just f -> f s 123 | 124 | freehandHud :: AppState -> Widget Name 125 | freehandHud s = drawChar s 126 | 127 | lineHud :: AppState -> Widget Name 128 | lineHud s = drawChar s 129 | 130 | eyedropperHud :: AppState -> Widget Name 131 | eyedropperHud s = drawChar s 132 | 133 | floodfillHud :: AppState -> Widget Name 134 | floodfillHud s = drawChar s 135 | 136 | boxStyleSelectorEntryWidth :: Int 137 | boxStyleSelectorEntryWidth = 18 138 | 139 | styleSelectorEntryWidth :: Int 140 | styleSelectorEntryWidth = 12 141 | 142 | boxHud :: AppState -> Widget Name 143 | boxHud = drawBoxStyleSelector 144 | 145 | eraserHud :: AppState -> Widget Name 146 | eraserHud = drawToolSize 147 | 148 | repaintHud :: AppState -> Widget Name 149 | repaintHud = drawToolSize 150 | 151 | restyleHud :: AppState -> Widget Name 152 | restyleHud = drawToolSize 153 | 154 | drawToolSize :: AppState -> Widget Name 155 | drawToolSize s = 156 | let inc = clickable IncreaseToolSize $ withDefAttr keybindingAttr $ txt ">>" 157 | dec = clickable DecreaseToolSize $ withDefAttr keybindingAttr $ txt "<<" 158 | sz = fromMaybe (error "BUG: current tool has no size") $ toolSize s 159 | in borderWithLabel (txt "Size") $ 160 | dec <+> (hLimit 5 $ hCenter $ txt $ T.pack $ show sz) <+> inc 161 | 162 | drawBoxStyleSelector :: AppState -> Widget Name 163 | drawBoxStyleSelector s = 164 | let styleName = fst $ getBoxBorderStyle s 165 | in clickable BoxStyleSelector $ 166 | borderWithLabel (txt "Box Style") $ 167 | hLimit boxStyleSelectorEntryWidth $ 168 | hCenter $ txt styleName 169 | 170 | drawStyleSelector :: AppState -> Widget Name 171 | drawStyleSelector s = 172 | clickable StyleSelector $ 173 | borderWithLabel (txt "St" <+> (withDefAttr keybindingAttr $ txt "y") <+> txt "le") $ 174 | hLimit styleSelectorEntryWidth $ 175 | hCenter $ raw $ V.string (V.defAttr `V.withStyle` (s^.drawStyle)) "demo" 176 | 177 | drawCanvasSize :: AppState -> Widget Name 178 | drawCanvasSize s = 179 | let (width, height) = s^.appCanvasSize 180 | in clickable ResizeCanvas $ 181 | borderWithLabel (txt "Can" <+> (withDefAttr keybindingAttr (txt "v")) <+> txt "as") $ 182 | hLimit 8 $ hCenter (txt $ T.pack $ show width <> "x" <> show height) 183 | 184 | drawChar :: AppState -> Widget Name 185 | drawChar s = 186 | clickable CharSelector $ 187 | borderWithLabel ((withDefAttr keybindingAttr $ txt "C") <+> txt "har") $ 188 | padLeftRight 2 $ txt $ T.singleton $ s^.drawCharacter 189 | 190 | toolSelectorEntryWidth :: Int 191 | toolSelectorEntryWidth = 20 192 | 193 | drawToolSelector :: AppState -> Widget Name 194 | drawToolSelector s = 195 | let Just idx = lookup (s^.tool) tools 196 | in clickable ToolSelector $ 197 | borderWithLabel ((withDefAttr keybindingAttr $ txt "T") <+> txt "ool") $ 198 | hLimit toolSelectorEntryWidth $ 199 | hCenter $ 200 | (withDefAttr keybindingAttr (txt $ T.pack $ show idx)) <+> 201 | (txt $ ":" <> toolName (s^.tool)) 202 | 203 | drawPaletteSelector :: AppState -> Bool -> Widget Name 204 | drawPaletteSelector s isFg = 205 | (clickable selName $ borderWithLabel label curColor) 206 | where 207 | label = if isFg 208 | then (withDefAttr keybindingAttr $ txt "F") <+> txt "G" 209 | else (withDefAttr keybindingAttr $ txt "B") <+> txt "G" 210 | curIdx = if isFg then s^.drawFgPaletteIndex 211 | else s^.drawBgPaletteIndex 212 | selName = if isFg then FgSelector else BgSelector 213 | curColor = drawPaletteEntry s curIdx 4 214 | 215 | canvas :: AppState -> Widget Name 216 | canvas s = 217 | let appLayers = concat 218 | [ if s^.layerInfoFor(idx).layerVisible 219 | then if shouldUseOverlay s && idx == s^.selectedLayerIndex 220 | then [s^.drawingOverlay, s^.layerAt idx] 221 | else [s^.layerAt idx] 222 | else [] 223 | | idx <- s^.layerOrder 224 | ] 225 | sz = s^.appCanvasSize 226 | widthAdjust = if s^.layerListVisible 227 | then 10 228 | else 0 229 | in centerAbout (s^.canvasOffset & _2 %~ pred 230 | & _1 %~ (subtract widthAdjust)) $ 231 | updateAttrMap (applyAttrMappings [(borderAttr, fg V.white)]) $ 232 | setAvailableSize (sz & each %~ (+ 2)) $ 233 | border $ 234 | if null appLayers 235 | then raw $ V.charFill V.defAttr ' ' (sz^._1) (sz^._2) 236 | else clickable Canvas $ 237 | raw $ canvasLayersToImage appLayers 238 | 239 | shouldUseOverlay :: AppState -> Bool 240 | shouldUseOverlay s = 241 | isJust $ s^.dragging 242 | -------------------------------------------------------------------------------- /programs/Draw.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiWayIf #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE TupleSections #-} 4 | module Draw 5 | ( drawWithCurrentTool 6 | , drawAtPoint 7 | , drawTextAtPoint 8 | , truncateText 9 | , pasteTextAtPoint 10 | , undo 11 | , redo 12 | ) 13 | where 14 | 15 | import Brick 16 | import Brick.Widgets.Border.Style 17 | import Data.Monoid ((<>)) 18 | import Lens.Micro.Platform 19 | import Control.Monad.Trans (liftIO) 20 | import Control.Monad (foldM, void) 21 | import qualified Data.Text as T 22 | import qualified Graphics.Vty as V 23 | import qualified Data.Vector as Vec 24 | import Data.Maybe (catMaybes) 25 | 26 | import Types 27 | import Tart.Canvas 28 | import State 29 | import Draw.Line 30 | import Draw.Box 31 | 32 | undo :: EventM Name AppState () 33 | undo = do 34 | s <- get 35 | case s^.undoStack of 36 | [] -> return () 37 | (actions:rest) -> do 38 | let go [] old = return old 39 | go (a:as) old = do 40 | old' <- applyAction a 41 | go as (old' <> old) 42 | 43 | undoActs <- go actions [] 44 | undoStack .= rest 45 | redoStack %= (undoActs:) 46 | 47 | redo :: EventM Name AppState () 48 | redo = do 49 | s <- get 50 | case s^.redoStack of 51 | [] -> return () 52 | (actions:rest) -> do 53 | let go [] old = return old 54 | go (a:as) old = do 55 | old' <- applyAction a 56 | go as (old' <> old) 57 | 58 | undoActs <- go actions [] 59 | redoStack .= rest 60 | undoStack %= (undoActs:) 61 | 62 | applyAction :: Action -> EventM Name AppState [Action] 63 | applyAction ClearCanvasDirty = do 64 | canvasDirty .= False 65 | return [] 66 | applyAction (SetPixels idx ps) = do 67 | let old' = (\(p, (ch, attr)) -> (p, ch, attr)) <$> ps 68 | drawMany old' (layerAt idx) (Just idx) 69 | applyAction (InsertLayer c idx ordIdx name) = 70 | insertLayer c idx ordIdx name 71 | applyAction (RemoveLayer idx) = 72 | deleteLayer idx 73 | applyAction (ChangeLayerName idx newName) = 74 | renameLayer idx newName 75 | applyAction (MoveLayerBy idx up) = 76 | moveLayer idx up 77 | applyAction (ToggleLayer idx) = 78 | toggleLayer idx 79 | applyAction (SelectLayerIndex idx) = 80 | selectLayer idx 81 | 82 | findFgPaletteEntry :: V.Attr -> AppState -> Int 83 | findFgPaletteEntry a s = 84 | let fgc = case V.attrForeColor a of 85 | V.KeepCurrent -> Nothing 86 | V.Default -> Nothing 87 | V.SetTo c -> Just c 88 | in maybe 0 id $ Vec.findIndex (== fgc) (s^.palette) 89 | 90 | findBgPaletteEntry :: V.Attr -> AppState -> Int 91 | findBgPaletteEntry a s = 92 | let bgc = case V.attrBackColor a of 93 | V.KeepCurrent -> Nothing 94 | V.Default -> Nothing 95 | V.SetTo c -> Just c 96 | in maybe 0 id $ Vec.findIndex (== bgc) (s^.palette) 97 | 98 | drawWithCurrentTool :: (Int, Int) -> EventM Name AppState () 99 | drawWithCurrentTool point = do 100 | s <- get 101 | case s^.tool of 102 | Freehand -> drawAtPoint point 103 | Eraser -> eraseAtPoint point (s^.eraserSize) 104 | Repaint -> repaintAtPoint point (s^.repaintSize) 105 | Restyle -> restyleAtPoint point (s^.restyleSize) 106 | FloodFill -> floodFillAtPoint point 107 | TextString -> modify $ beginTextEntry point 108 | Line -> 109 | case s^.dragging of 110 | Nothing -> return () 111 | Just (n, l0, l1) -> 112 | case n of 113 | Canvas -> do 114 | o <- liftIO $ clearCanvas (s^.drawingOverlay) 115 | drawingOverlay .= o 116 | void $ drawLine l0 l1 drawingOverlay Nothing 117 | _ -> return () 118 | Box -> do 119 | case s^.dragging of 120 | Nothing -> return () 121 | Just (n, l0, l1) -> 122 | case n of 123 | Canvas -> do 124 | let bs = snd $ getBoxBorderStyle s 125 | o <- liftIO $ clearCanvas (s^.drawingOverlay) 126 | drawingOverlay .= o 127 | void $ drawBox bs l0 l1 drawingOverlay Nothing 128 | _ -> return () 129 | Eyedropper -> do 130 | -- Read the pixel at the canvas location. Set the 131 | -- application state's current drawing character and colors 132 | -- from it. 133 | let (ch, attr) = canvasGetPixel (s^.currentLayer) point 134 | drawCharacter .= ch 135 | drawFgPaletteIndex .= findFgPaletteEntry attr s 136 | drawBgPaletteIndex .= findBgPaletteEntry attr s 137 | drawStyle .= styleWord (V.attrStyle attr) 138 | 139 | styleWord :: V.MaybeDefault V.Style -> V.Style 140 | styleWord V.KeepCurrent = 0 141 | styleWord V.Default = 0 142 | styleWord (V.SetTo s) = s 143 | 144 | drawLine :: Location 145 | -> Location 146 | -> Lens' AppState Canvas 147 | -> Maybe Int 148 | -> EventM Name AppState [Action] 149 | drawLine (Location p0) (Location p1) which whichIdx = do 150 | s <- get 151 | let points = plotLine p0 p1 152 | pixels = (, s^.drawCharacter, currentPaletteAttribute s) <$> points 153 | drawMany pixels which whichIdx 154 | 155 | truncateText :: (Int, Int) -> [(Char, V.Attr)] -> AppState -> [(Char, V.Attr)] 156 | truncateText point t s = 157 | let startCol = point^._1 158 | maxCol = min ((s^.appCanvasSize)^._1 - 1) 159 | (startCol + length t - 1) 160 | safe = take (maxCol - startCol + 1) t 161 | in safe 162 | 163 | pasteTextAtPoint :: (Int, Int) -> T.Text -> EventM Name AppState () 164 | pasteTextAtPoint point t = do 165 | s <- get 166 | let ls = T.lines t 167 | (startCol, startRow) = point 168 | pasteWidth = maximum $ T.length <$> ls 169 | pasteHeight = length ls 170 | (oldWidth, oldHeight) = s^.appCanvasSize 171 | newSize = ( max oldWidth pasteWidth 172 | , max oldHeight pasteHeight 173 | ) 174 | pairs = zip [startRow..] ls 175 | mkLine line = zip (T.unpack line) $ repeat $ currentPaletteAttribute s 176 | 177 | resizeCanvas newSize 178 | mapM_ (\(row, line) -> drawTextAtPoint (startCol, row) (mkLine line)) pairs 179 | 180 | drawTextAtPoint :: (Int, Int) -> [(Char, V.Attr)] -> EventM Name AppState () 181 | drawTextAtPoint point t = do 182 | s <- get 183 | let (startCol, row) = point 184 | pixs = zip ([startCol..]) (truncateText point t s) 185 | many = mkEntry <$> pixs 186 | mkEntry (col, (ch, attr)) = ((col, row), ch, attr) 187 | withUndoM $ drawMany many currentLayer (Just $ s^.selectedLayerIndex) 188 | 189 | floodFillAtPoint :: (Int, Int) -> EventM Name AppState () 190 | floodFillAtPoint point = do 191 | s <- get 192 | 193 | let fillAttr = normalizeAttr fillCh $ currentPaletteAttribute s 194 | fillCh = s^.drawCharacter 195 | fillPix = (fillCh, fillAttr) 196 | targetPix = canvasGetPixel (s^.currentLayer) point 197 | (w, h) = s^.appCanvasSize 198 | up = (& _2 %~ (max 0 . pred)) 199 | down = (& _2 %~ (min (h-1) . succ)) 200 | left = (& _1 %~ (max 0 . pred)) 201 | right = (& _1 %~ (min (w-1) . succ)) 202 | 203 | go :: (Int, Int) 204 | -> [((Int, Int), (Char, V.Attr))] 205 | -> EventM Name AppState [((Int, Int), (Char, V.Attr))] 206 | go p uBuf = do 207 | curL <- use currentLayer 208 | let rawPix = canvasGetPixel curL p 209 | pix = rawPix & _2 %~ normalizeAttr (rawPix^._1) 210 | if | pix == fillPix -> return uBuf 211 | | pix /= targetPix -> return uBuf 212 | | otherwise -> do 213 | let old = canvasGetPixel curL p 214 | d' <- liftIO $ canvasSetPixel curL p fillCh fillAttr 215 | currentLayer .= d' 216 | canvasDirty .= True 217 | go (down p) ((p, old):uBuf) >>= 218 | go (up p) >>= 219 | go (left p) >>= 220 | go (right p) 221 | 222 | undoBuf <- go point [] 223 | let prevDirty = s^.canvasDirty 224 | newDirty = s^.canvasDirty 225 | d = if prevDirty /= newDirty 226 | then [ClearCanvasDirty] 227 | else [] 228 | modify $ pushUndo (d <> [SetPixels (s^.selectedLayerIndex) undoBuf]) 229 | 230 | drawAtPoint :: (Int, Int) -> EventM Name AppState () 231 | drawAtPoint point = do 232 | s <- get 233 | drawAtPoint' point (s^.drawCharacter) (currentPaletteAttribute s) 234 | 235 | drawAtPoint' :: (Int, Int) -> Char -> V.Attr -> EventM Name AppState () 236 | drawAtPoint' point ch attr = do 237 | s <- get 238 | withUndoM $ drawMany [(point, ch, attr)] currentLayer (Just $ s^.selectedLayerIndex) 239 | 240 | drawMany :: [((Int, Int), Char, V.Attr)] 241 | -> Lens' AppState Canvas 242 | -> Maybe Int 243 | -> EventM Name AppState [Action] 244 | drawMany pixels which whichIdx = do 245 | s <- get 246 | let arr = s^.which 247 | old = getOld <$> pixels 248 | getOld (oldLoc, _, _) = (oldLoc, canvasGetPixel (s^.which) oldLoc) 249 | arr' <- liftIO $ canvasSetMany arr pixels 250 | let prevDirty = s^.canvasDirty 251 | newDirty = not $ null pixels 252 | newSt = s & which .~ arr' 253 | & canvasDirty .~ (prevDirty || newDirty) 254 | put newSt 255 | return (catMaybes [ do i <- whichIdx 256 | return $ SetPixels i old 257 | , if prevDirty /= newDirty 258 | then Just ClearCanvasDirty 259 | else Nothing 260 | ]) 261 | 262 | makeBoxAboutPoint :: (Int, Int) -> Int -> [(Int, Int)] 263 | makeBoxAboutPoint point sz = 264 | if sz <= 0 265 | then [] 266 | else let len = (sz * 2) - 1 267 | off = negate $ sz - 1 268 | noOffset = [(c, r) | r <- [0..len-1], c <- [0..len-1]] 269 | addOffset (c, r) = (c + off + point^._1 270 | ,r + off + point^._2 271 | ) 272 | in addOffset <$> noOffset 273 | 274 | eraseAtPoint :: (Int, Int) -> Int -> EventM Name AppState () 275 | eraseAtPoint point sz = do 276 | s <- get 277 | let points = makeBoxAboutPoint point sz 278 | pixels = (, ' ', V.defAttr) <$> points 279 | withUndoM $ drawMany pixels currentLayer (Just $ s^.selectedLayerIndex) 280 | 281 | repaintAtPoint :: (Int, Int) -> Int -> EventM Name AppState () 282 | repaintAtPoint point sz = do 283 | s <- get 284 | let points = makeBoxAboutPoint point sz 285 | attr = currentPaletteAttribute s 286 | getPixel p = let old = canvasGetPixel (s^.currentLayer) p 287 | in (p, old^._1, attr { V.attrStyle = V.attrStyle $ old^._2 }) 288 | pixels = getPixel <$> points 289 | withUndoM $ drawMany pixels currentLayer (Just $ s^.selectedLayerIndex) 290 | 291 | restyleAtPoint :: (Int, Int) -> Int -> EventM Name AppState () 292 | restyleAtPoint point sz = do 293 | s <- get 294 | let points = makeBoxAboutPoint point sz 295 | attr = currentPaletteAttribute s 296 | getPixel p = let old = canvasGetPixel (s^.currentLayer) p 297 | in (p, old^._1, (old^._2) { V.attrStyle = V.attrStyle attr }) 298 | pixels = getPixel <$> points 299 | withUndoM $ drawMany pixels currentLayer (Just $ s^.selectedLayerIndex) 300 | 301 | drawBox :: BorderStyle 302 | -> Location 303 | -> Location 304 | -> Lens' AppState Canvas 305 | -> Maybe Int 306 | -> EventM Name AppState [Action] 307 | drawBox bs (Location a) (Location b) which whichIdx = do 308 | s <- get 309 | let attr = currentPaletteAttribute s 310 | points = plotBox bs a b 311 | pixels = mkPixel <$> points 312 | mkPixel (p, ch) = (p, ch, attr) 313 | drawMany pixels which whichIdx 314 | -------------------------------------------------------------------------------- /src/Tart/Canvas.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiWayIf #-} 2 | {-# LANGUAGE TupleSections #-} 3 | {-# LANGUAGE BinaryLiterals #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | module Tart.Canvas 6 | ( Canvas 7 | , CanvasData 8 | , canvasFromData 9 | , canvasToData 10 | , newCanvas 11 | , canvasSize 12 | , canvasSetPixel 13 | , canvasSetMany 14 | , canvasGetPixel 15 | , resizeFrom 16 | , prettyPrintCanvas 17 | , merge 18 | , clearCanvas 19 | , canvasFromString 20 | , canvasFromText 21 | , canvasLayersToImage 22 | , normalizeAttr 23 | ) 24 | where 25 | 26 | import Control.Monad (forM_, forM, replicateM, when) 27 | import Control.Monad.State 28 | import Data.Bits 29 | import Data.Word (Word64) 30 | import Data.Monoid ((<>)) 31 | import Data.Maybe (catMaybes) 32 | import qualified Graphics.Vty as V 33 | import qualified Data.Array.IArray as I 34 | import qualified Data.Array.MArray as A 35 | import qualified Data.Binary as B 36 | import Data.Array.IO (IOUArray) 37 | import Data.Array.Unboxed (UArray) 38 | import Lens.Micro.Platform 39 | import qualified Data.Text as T 40 | 41 | data Canvas = 42 | Canvas { mut :: IOUArray (Int, Int) Word64 43 | , immut :: UArray (Int, Int) Word64 44 | , size :: (Int, Int) 45 | } 46 | 47 | data CanvasData = 48 | CanvasData { canvasDataSize :: (Int, Int) 49 | , canvasData :: [Word64] 50 | } 51 | 52 | instance B.Binary CanvasData where 53 | put cd = do 54 | B.put $ canvasDataSize cd 55 | mapM_ B.put $ canvasData cd 56 | 57 | get = do 58 | (w, h) <- B.get 59 | CanvasData <$> (pure (w, h)) 60 | <*> replicateM (w * h) B.get 61 | 62 | canvasFromData :: CanvasData -> IO (Either String Canvas) 63 | canvasFromData cd = do 64 | let (w, h) = canvasDataSize cd 65 | if w * h /= length (canvasData cd) 66 | then return $ Left "Canvas data entries do not match dimensions" 67 | else do 68 | c <- newCanvas (w, h) 69 | let idxs = [(w', h') | w' <- [0..w-1], h' <- [0..h-1]] 70 | forM_ (zip idxs (canvasData cd)) $ \(point, word) -> 71 | A.writeArray (mut c) point word 72 | f <- A.freeze $ mut c 73 | return $ Right $ c { immut = f } 74 | 75 | canvasToData :: Canvas -> CanvasData 76 | canvasToData c = 77 | CanvasData sz canvasPixels 78 | where 79 | sz@(w, h) = canvasSize c 80 | canvasPixels = 81 | [ canvasGetPixelRaw c (w', h') 82 | | w' <- [0..w-1], h' <- [0..h-1] 83 | ] 84 | 85 | newCanvas :: (Int, Int) -> IO Canvas 86 | newCanvas sz = do 87 | let arrayBounds = ((0, 0), sz & each %~ pred) 88 | draw <- A.newArray arrayBounds blankPixel 89 | drawFreeze <- A.freeze draw 90 | return $ Canvas draw drawFreeze sz 91 | 92 | canvasFromString :: String -> IO Canvas 93 | canvasFromString = canvasFromText . T.pack 94 | 95 | canvasFromText :: T.Text -> IO Canvas 96 | canvasFromText t = do 97 | let ls = convertTab <$> T.lines t 98 | convertTab = T.concatMap convertTabChar 99 | convertTabChar '\t' = T.replicate 8 " " 100 | convertTabChar c = T.singleton c 101 | height = length ls 102 | width = maximum $ T.length <$> ls 103 | pixs = concat $ mkRowPixels <$> zip [0..] ls 104 | mkRowPixels (rowNum, row) = 105 | mkPixel rowNum <$> zip [0..] (T.unpack row) 106 | mkPixel rowNum (colNum, ch) = 107 | ((colNum, rowNum), ch, V.defAttr) 108 | 109 | c <- newCanvas (width, height) 110 | canvasSetMany c pixs 111 | 112 | clearCanvas :: Canvas -> IO Canvas 113 | clearCanvas c = do 114 | let (width, height) = canvasSize c 115 | forM_ [0..width-1] $ \w -> 116 | forM_ [0..height-1] $ \h -> do 117 | A.writeArray (mut c) (w, h) blankPixel 118 | f <- A.freeze (mut c) 119 | return $ c { immut = f } 120 | 121 | type RLE a = State RLEState a 122 | 123 | data RLEState = 124 | RLEState { content :: [(T.Text, V.Attr)] 125 | , currentString :: T.Text 126 | , currentAttr :: V.Attr 127 | } 128 | 129 | runRLE :: RLE () -> [(T.Text, V.Attr)] 130 | runRLE act = 131 | let s = execState (act >> sealFinalToken) (RLEState [] "" V.defAttr) 132 | in content s 133 | 134 | rleNext :: (Char, V.Attr) -> RLE () 135 | rleNext (ch, attr) = do 136 | -- If the attribute matches the current attribute, just append the 137 | -- character. 138 | cur <- gets currentAttr 139 | case cur == attr of 140 | True -> appendCharacter ch 141 | False -> newToken ch attr 142 | 143 | appendCharacter :: Char -> RLE () 144 | appendCharacter c = 145 | modify $ \s -> s { currentString = currentString s <> T.singleton c 146 | } 147 | 148 | sealFinalToken :: RLE () 149 | sealFinalToken = 150 | modify $ \s -> s { content = if T.null $ currentString s 151 | then content s 152 | else content s <> [(currentString s, currentAttr s)] 153 | } 154 | 155 | newToken :: Char -> V.Attr -> RLE () 156 | newToken c a = 157 | modify $ \s -> s { currentString = T.singleton c 158 | , currentAttr = a 159 | , content = if T.null $ currentString s 160 | then content s 161 | else content s <> [(currentString s, currentAttr s)] 162 | } 163 | 164 | prettyPrintCanvas :: Bool -> [Canvas] -> T.Text 165 | prettyPrintCanvas emitSequences cs = 166 | let pairs = runRLE (mkRLE cs) 167 | mkOutput (s, attr) = 168 | if emitSequences 169 | then ctrlSequence attr <> s 170 | else s 171 | ctrlSequence a = 172 | "\ESC[0m" <> attrSequence a 173 | in T.concat $ mkOutput <$> pairs 174 | 175 | mkRLE :: [Canvas] -> RLE () 176 | mkRLE [] = return () 177 | mkRLE cs@(c:_) = do 178 | let (w, h) = canvasSize c 179 | forM_ [0..h-1] $ \row -> do 180 | forM_ [0..w-1] $ \col -> 181 | rleNext $ findPixel cs (col, row) 182 | rleNext ('\n', V.defAttr) 183 | 184 | attrSequence :: V.Attr -> T.Text 185 | attrSequence a = 186 | let fg = colorCode True (V.attrForeColor a) 187 | bg = colorCode False (V.attrBackColor a) 188 | sty = styleCode (V.attrStyle a) 189 | in fg <> bg <> sty 190 | 191 | styleCode :: V.MaybeDefault V.Style -> T.Text 192 | styleCode V.KeepCurrent = "" 193 | styleCode V.Default = "" 194 | styleCode (V.SetTo s) = styleCode' s 195 | 196 | styles :: [V.Style] 197 | styles = 198 | [ V.bold 199 | , V.underline 200 | , V.blink 201 | , V.reverseVideo 202 | ] 203 | 204 | styleCode' :: V.Style -> T.Text 205 | styleCode' s = 206 | let present = filter (V.hasStyle s) styles 207 | in if null present 208 | then "" 209 | else "\ESC[" <> T.intercalate ";" (styleToCode <$> present) <> "m" 210 | 211 | styleToCode :: V.Style -> T.Text 212 | styleToCode s = 213 | let mapping = [ (V.bold, "1") 214 | , (V.underline, "4") 215 | , (V.blink, "5") 216 | , (V.reverseVideo, "7") 217 | ] 218 | in maybe "" id $ lookup s mapping 219 | 220 | colorCode :: Bool -> V.MaybeDefault V.Color -> T.Text 221 | colorCode _ V.KeepCurrent = "" 222 | colorCode _ V.Default = "" 223 | colorCode f (V.SetTo c) = colorCode' f c 224 | 225 | colorCode' :: Bool -> V.Color -> T.Text 226 | colorCode' f (V.Color240 w) = 227 | "\ESC[" <> if f then "38" else "48" <> ";5;" <> T.pack (show w) <> "m" 228 | colorCode' f (V.ISOColor w) = 229 | let c = if f then "38" else "48" 230 | valid v = v >= 0 && v <= 15 231 | in if valid w 232 | then "\ESC[" <> c <> ";5;" <> T.pack (show w) <> "m" 233 | else "" 234 | 235 | canvasSize :: Canvas -> (Int, Int) 236 | canvasSize = size 237 | 238 | canvasGetPixel :: Canvas -> (Int, Int) -> (Char, V.Attr) 239 | canvasGetPixel c p = decodePixel $ canvasGetPixelRaw c p 240 | 241 | canvasGetPixelRaw :: Canvas -> (Int, Int) -> Word64 242 | canvasGetPixelRaw c point = (immut c) I.! point 243 | 244 | canvasSetMany :: Canvas -> [((Int, Int), Char, V.Attr)] -> IO Canvas 245 | canvasSetMany c pixels = do 246 | forM_ pixels $ \(point, ch, attr) -> do 247 | valid <- isValidPoint point (mut c) 248 | when valid $ A.writeArray (mut c) point $ encodePixel ch attr 249 | 250 | f <- A.freeze (mut c) 251 | return $ c { immut = f 252 | } 253 | 254 | isValidPoint :: (Int, Int) -> IOUArray (Int, Int) Word64 -> IO Bool 255 | isValidPoint (c, r) arr = do 256 | ((loC, loR), (hiC, hiR)) <- A.getBounds arr 257 | return $ r >= loR && c >= loC && 258 | r <= hiR && c <= hiC 259 | 260 | canvasSetPixel :: Canvas -> (Int, Int) -> Char -> V.Attr -> IO Canvas 261 | canvasSetPixel c point ch attr = canvasSetMany c [(point, ch, attr)] 262 | 263 | blankPixel :: Word64 264 | blankPixel = encodePixel ' ' V.defAttr 265 | 266 | resizeFrom :: Canvas -> (Int, Int) -> IO Canvas 267 | resizeFrom old newSz = do 268 | -- If the new bounds are different than the old, create a new array 269 | -- and copy. 270 | case newSz /= canvasSize old of 271 | False -> return old 272 | True -> do 273 | new <- newCanvas newSz 274 | (c, _) <- merge new old 275 | return c 276 | 277 | encodePixel :: Char -> V.Attr -> Word64 278 | encodePixel c a = 279 | -- Convert char to word32 280 | -- Convert attr color slots to 10-bit sequences (set bit, type bit, color bits) 281 | let low32Mask = 2 ^ (32::Integer) - 1 282 | c64 = fromIntegral $ fromEnum c 283 | a' = normalizeAttr c a 284 | in (c64 .&. low32Mask) .|. 285 | (encodeAttribute a' `shiftL` 32) 286 | 287 | decodePixel :: Word64 -> (Char, V.Attr) 288 | decodePixel v = 289 | let chBits = v .&. (2 ^ (32::Integer) - 1) 290 | attrBits = v `shiftR` 32 291 | attr = decodeAttribute attrBits 292 | ch = toEnum $ fromIntegral chBits 293 | in (ch, normalizeAttr ch attr) 294 | 295 | normalizeAttr :: Char -> V.Attr -> V.Attr 296 | normalizeAttr ch attr = 297 | if ch == ' ' && (not $ hasForegroundStyle $ V.attrStyle attr) 298 | then attr { V.attrForeColor = V.Default 299 | , V.attrStyle = V.Default 300 | } 301 | else attr 302 | 303 | hasForegroundStyle :: V.MaybeDefault V.Style -> Bool 304 | hasForegroundStyle (V.SetTo s) = 305 | or [ V.hasStyle s V.underline 306 | , V.hasStyle s V.reverseVideo 307 | ] 308 | hasForegroundStyle _ = False 309 | 310 | encodeAttribute :: V.Attr -> Word64 311 | encodeAttribute attr = 312 | (encodeAttrStyle (V.attrStyle attr) `shiftL` 20) .|. 313 | (encodeAttrColor (V.attrForeColor attr) `shiftL` 10) .|. 314 | (encodeAttrColor (V.attrBackColor attr)) 315 | 316 | encodeAttrStyle :: V.MaybeDefault V.Style -> Word64 317 | encodeAttrStyle V.Default = 0 318 | encodeAttrStyle V.KeepCurrent = 0 319 | encodeAttrStyle (V.SetTo s) = fromIntegral s 320 | 321 | decodeAttrStyle :: Word64 -> V.MaybeDefault V.Style 322 | decodeAttrStyle 0 = V.Default 323 | decodeAttrStyle v = V.SetTo $ fromIntegral v 324 | 325 | decodeAttribute :: Word64 -> V.Attr 326 | decodeAttribute v = 327 | let attrColorMask = 2 ^ (10::Integer) - 1 328 | attrStyleMask = 2 ^ (8::Integer) - 1 329 | in V.defAttr { V.attrStyle = decodeAttrStyle $ (v `shiftR` 20) .&. attrStyleMask 330 | , V.attrForeColor = decodeAttrColor $ (v `shiftR` 10) .&. attrColorMask 331 | , V.attrBackColor = decodeAttrColor $ v .&. attrColorMask 332 | } 333 | 334 | encodeAttrColor :: V.MaybeDefault V.Color -> Word64 335 | encodeAttrColor V.Default = 0 336 | encodeAttrColor V.KeepCurrent = 0 337 | encodeAttrColor (V.SetTo c) = 338 | let (ty, color) = case c of 339 | V.ISOColor w -> (0, fromIntegral w) 340 | V.Color240 w -> (1, fromIntegral w) 341 | in (1 `shiftL` 9) .|. 342 | (ty `shiftL` 8) .|. 343 | color 344 | 345 | decodeAttrColor :: Word64 -> V.MaybeDefault V.Color 346 | decodeAttrColor 0 = V.Default 347 | decodeAttrColor v = 348 | let ty = (v `shiftR` 8) .&. 0b1 349 | color = fromIntegral $ v .&. 0b11111111 350 | in if ty == 1 351 | then V.SetTo $ V.Color240 color 352 | else V.SetTo $ V.ISOColor color 353 | 354 | merge :: Canvas -> Canvas -> IO (Canvas, [((Int, Int), (Char, V.Attr))]) 355 | merge dest src = do 356 | let (width, height) = (min srcW destW, min srcH destH) 357 | (srcW, srcH) = canvasSize src 358 | (destW, destH) = canvasSize dest 359 | 360 | undoBuf <- forM [0..width-1] $ \w -> 361 | forM [0..height-1] $ \h -> do 362 | let pix = (immut src) I.! (w, h) 363 | case pix /= blankPixel of 364 | True -> do 365 | old <- A.readArray (mut dest) (w, h) 366 | A.writeArray (mut dest) (w, h) pix 367 | return $ Just ((w, h), decodePixel old) 368 | False -> 369 | return Nothing 370 | 371 | f <- A.freeze $ mut dest 372 | return (dest { immut = f }, catMaybes $ concat undoBuf) 373 | 374 | -- | Create a Vty image from a list of canvas layers, with the topmost 375 | -- layer being the first canvas in the list. A pixel in the final image 376 | -- is set by looking for the first non-blank pixel in the canvas list, 377 | -- starting at the beginning. 378 | -- 379 | -- The result will be as high as the least tall input canvas, and as 380 | -- wide as the least wide input canvas. 381 | canvasLayersToImage :: [Canvas] -> V.Image 382 | canvasLayersToImage [] = V.emptyImage 383 | canvasLayersToImage cs = 384 | let sizes = canvasSize <$> cs 385 | smallestSize = ( minimum $ fst <$> sizes 386 | , minimum $ snd <$> sizes 387 | ) 388 | (lastCol, lastRow) = smallestSize & each %~ pred 389 | rows = getRow <$> [0..lastRow] 390 | getRow r = V.horizCat $ (uncurry $ flip V.char) <$> getCol r <$> [0..lastCol] 391 | getCol r c = findPixel cs (c, r) 392 | in V.vertCat rows 393 | 394 | findPixel :: [Canvas] -> (Int, Int) -> (Char, V.Attr) 395 | findPixel [] _ = error "BUG: canvasLayersToImage got no layers" 396 | findPixel [l] point = canvasGetPixel l point 397 | findPixel (l:ls) point = 398 | let pix = canvasGetPixel l point 399 | blank = decodePixel blankPixel 400 | in if pix == blank 401 | then findPixel ls point 402 | else pix 403 | -------------------------------------------------------------------------------- /programs/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | module State 6 | ( checkForMouseSupport 7 | , setTool 8 | , setToolByChar 9 | , whenTool 10 | , setFgPaletteIndex 11 | , setBgPaletteIndex 12 | , beginFgPaletteSelect 13 | , beginBgPaletteSelect 14 | , beginToolSelect 15 | , selectNextLayer 16 | , selectPrevLayer 17 | , selectLayer 18 | , pushMode 19 | , popMode 20 | , toolSize 21 | , askForSaveFilename 22 | , increaseCanvasSize 23 | , decreaseCanvasSize 24 | , increaseToolSize 25 | , decreaseToolSize 26 | , beginCanvasSizePrompt 27 | , toggleCurrentLayer 28 | , toggleLayer 29 | , beginTextEntry 30 | , tryResizeCanvas 31 | , quit 32 | , beginLayerRename 33 | , renameCurrentLayer 34 | , renameLayer 35 | , deleteLayer 36 | , deleteSelectedLayer 37 | , insertLayer 38 | , currentPaletteAttribute 39 | , handleDragFinished 40 | , getBoxBorderStyle 41 | , beginBoxStyleSelect 42 | , beginStyleSelect 43 | , writeCanvasFiles 44 | , resizeCanvas 45 | , increaseEraserSize 46 | , decreaseEraserSize 47 | , increaseRepaintSize 48 | , decreaseRepaintSize 49 | , increaseRestyleSize 50 | , decreaseRestyleSize 51 | , pushUndo 52 | , withUndoM 53 | , toggleStyleFromKey 54 | , isStyleKey 55 | , styleBindings 56 | , recenterCanvas 57 | , addLayer 58 | , moveLayer 59 | , moveCurrentLayerDown 60 | , moveCurrentLayerUp 61 | , cancelDragging 62 | , toggleLayerList 63 | , saveAndContinue 64 | 65 | , canvasMoveDown 66 | , canvasMoveUp 67 | , canvasMoveLeft 68 | , canvasMoveRight 69 | 70 | , tools 71 | , charTools 72 | , boxStyles 73 | 74 | , beginCharacterSelect 75 | , cancelCharacterSelect 76 | , selectCharacter 77 | ) 78 | where 79 | 80 | import Control.Monad (when, forM, forM_) 81 | import Control.Monad.Trans (liftIO) 82 | import qualified Control.Exception as E 83 | import Data.Monoid ((<>)) 84 | import qualified Graphics.Vty as V 85 | import qualified Graphics.Vty.CrossPlatform as V 86 | import qualified Data.Vector as Vec 87 | import qualified Data.Text as T 88 | import qualified Data.Map as M 89 | import Data.List (sortOn, elemIndex) 90 | import System.Exit (exitFailure) 91 | import Lens.Micro.Platform 92 | import Data.Text.Zipper (gotoEOL, textZipper) 93 | import Text.Read (readMaybe) 94 | import Data.Maybe (isJust, fromJust, catMaybes) 95 | 96 | import Brick 97 | import Brick.Focus 98 | import Brick.Widgets.Edit (editor, applyEdit, getEditContents, editContentsL) 99 | import Brick.Widgets.Border.Style 100 | 101 | import Types 102 | import Tart.Canvas 103 | import Tart.Format 104 | 105 | tools :: [(Tool, Int)] 106 | tools = 107 | [ (Freehand , 1) 108 | , (Box , 2) 109 | , (Line , 3) 110 | , (FloodFill , 4) 111 | , (TextString, 5) 112 | , (Repaint , 6) 113 | , (Restyle , 7) 114 | , (Eyedropper, 8) 115 | , (Eraser , 0) 116 | ] 117 | 118 | charTools :: [Tool] 119 | charTools = 120 | [ Freehand 121 | , Line 122 | , FloodFill 123 | ] 124 | 125 | styleBindings :: [(Char, (V.Style, T.Text))] 126 | styleBindings = 127 | [ ('!', (V.bold, "Bold")) 128 | , ('@', (V.underline, "Underline")) 129 | , ('#', (V.blink, "Blink")) 130 | , ('$', (V.reverseVideo, "Reverse")) 131 | ] 132 | 133 | isStyleKey :: V.Event -> Bool 134 | isStyleKey (V.EvKey (V.KChar c) []) = 135 | isJust $ lookup c styleBindings 136 | isStyleKey _ = False 137 | 138 | toggleStyleFromKey :: V.Event -> EventM Name AppState () 139 | toggleStyleFromKey e = 140 | when (isStyleKey e) $ do 141 | let V.EvKey (V.KChar c) _ = e 142 | Just (sty, _) = lookup c styleBindings 143 | drawStyle %= toggleStyle sty 144 | 145 | boxStyles :: [(T.Text, BorderStyle)] 146 | boxStyles = 147 | [ ("ASCII", ascii) 148 | , ("Unicode", unicode) 149 | , ("Unicode rounded", unicodeRounded) 150 | ] 151 | 152 | getBoxBorderStyle :: AppState -> (T.Text, BorderStyle) 153 | getBoxBorderStyle s = boxStyles !! (s^.boxStyleIndex) 154 | 155 | increaseToolSize :: EventM Name AppState () 156 | increaseToolSize = do 157 | s <- get 158 | let f = case s^.tool of 159 | Repaint -> increaseRepaintSize 160 | Restyle -> increaseRestyleSize 161 | Eraser -> increaseEraserSize 162 | _ -> id 163 | modify f 164 | 165 | decreaseToolSize :: EventM Name AppState () 166 | decreaseToolSize = do 167 | s <- get 168 | let f = case s^.tool of 169 | Repaint -> decreaseRepaintSize 170 | Restyle -> decreaseRestyleSize 171 | Eraser -> decreaseEraserSize 172 | _ -> id 173 | modify f 174 | 175 | toolSize :: AppState -> Maybe Int 176 | toolSize s = 177 | case s^.tool of 178 | Repaint -> Just $ s^.repaintSize 179 | Restyle -> Just $ s^.restyleSize 180 | Eraser -> Just $ s^.eraserSize 181 | _ -> Nothing 182 | 183 | increaseEraserSize :: AppState -> AppState 184 | increaseEraserSize = (& eraserSize %~ succ) 185 | 186 | decreaseEraserSize :: AppState -> AppState 187 | decreaseEraserSize = (& eraserSize %~ (max 1 . pred)) 188 | 189 | increaseRepaintSize :: AppState -> AppState 190 | increaseRepaintSize = (& repaintSize %~ succ) 191 | 192 | decreaseRepaintSize :: AppState -> AppState 193 | decreaseRepaintSize = (& repaintSize %~ (max 1 . pred)) 194 | 195 | increaseRestyleSize :: AppState -> AppState 196 | increaseRestyleSize = (& restyleSize %~ succ) 197 | 198 | decreaseRestyleSize :: AppState -> AppState 199 | decreaseRestyleSize = (& restyleSize %~ (max 1 . pred)) 200 | 201 | withUndoM :: EventM Name AppState [Action] -> EventM Name AppState () 202 | withUndoM act = do 203 | as <- act 204 | modify $ pushUndo as 205 | 206 | withUndo :: (AppState, [Action]) -> AppState 207 | withUndo (s, as) = pushUndo as s 208 | 209 | pushUndo :: [Action] -> AppState -> AppState 210 | pushUndo [] s = s 211 | pushUndo l s = s & undoStack %~ (l:) 212 | & redoStack .~ [] 213 | 214 | beginLayerRename :: EventM Name AppState () 215 | beginLayerRename = do 216 | s <- get 217 | let z = textZipper [line] (Just 1) 218 | line = s^.layerInfoFor(s^.selectedLayerIndex).layerName 219 | layerNameEditor.editContentsL .= gotoEOL z 220 | modify $ pushMode RenameLayer 221 | 222 | toggleCurrentLayer :: EventM Name AppState () 223 | toggleCurrentLayer = do 224 | idx <- use selectedLayerIndex 225 | withUndoM $ toggleLayer idx 226 | 227 | toggleLayer :: Int -> EventM Name AppState [Action] 228 | toggleLayer idx = do 229 | layerInfoFor(idx).layerVisible %= not 230 | return [ToggleLayer idx] 231 | 232 | renameCurrentLayer :: T.Text -> EventM Name AppState () 233 | renameCurrentLayer name = do 234 | idx <- use selectedLayerIndex 235 | withUndoM $ renameLayer idx name 236 | 237 | renameLayer :: Int -> T.Text -> EventM Name AppState [Action] 238 | renameLayer idx newName = do 239 | s <- get 240 | let oldName = s^.layerInfoFor(idx).layerName 241 | act = ChangeLayerName idx oldName 242 | if T.null newName 243 | then return [] 244 | else if newName == oldName 245 | then do 246 | modify popMode >> return [] 247 | else do 248 | modify popMode 249 | layerInfoFor(idx).layerName .= newName 250 | canvasDirty .= True 251 | return [act] 252 | 253 | moveCurrentLayerDown :: EventM Name AppState () 254 | moveCurrentLayerDown = do 255 | idx <- use selectedLayerIndex 256 | withUndoM $ moveLayer idx False 257 | 258 | moveCurrentLayerUp :: EventM Name AppState () 259 | moveCurrentLayerUp = do 260 | idx <- use selectedLayerIndex 261 | withUndoM $ moveLayer idx True 262 | 263 | moveLayer :: Int -> Bool -> EventM Name AppState [Action] 264 | moveLayer idx up = do 265 | s <- get 266 | if up && idx == (head $ s^.layerOrder) 267 | then return [] 268 | else if (not up) && idx == (last $ s^.layerOrder) 269 | then return [] 270 | else let Just orderIndex = elemIndex idx $ s^.layerOrder 271 | newIndex = if up then orderIndex - 1 272 | else orderIndex + 1 273 | dropped = filter (/= idx) $ s^.layerOrder 274 | newOrder = take newIndex dropped <> 275 | [idx] <> 276 | drop newIndex dropped 277 | act = MoveLayerBy idx (not up) 278 | in do 279 | canvasDirty .= True 280 | layerOrder .= newOrder 281 | return [act] 282 | 283 | selectNextLayer :: EventM Name AppState () 284 | selectNextLayer = do 285 | s <- get 286 | -- Find the selected layer in the layer ordering. 287 | let Just selIndex = elemIndex (s^.selectedLayerIndex) (s^.layerOrder) 288 | -- Then select the next layer, if any. 289 | newSel = if selIndex == length (s^.layerOrder) - 1 290 | then s^.selectedLayerIndex 291 | else (s^.layerOrder) !! (selIndex + 1) 292 | selectedLayerIndex .= newSel 293 | 294 | selectPrevLayer :: EventM Name AppState () 295 | selectPrevLayer = do 296 | s <- get 297 | -- Find the selected layer in the layer ordering. 298 | let Just selIndex = elemIndex (s^.selectedLayerIndex) (s^.layerOrder) 299 | -- Then select the previous layer, if any. 300 | newSel = if selIndex == 0 301 | then s^.selectedLayerIndex 302 | else (s^.layerOrder) !! (selIndex - 1) 303 | selectedLayerIndex .= newSel 304 | 305 | selectLayer :: Int -> EventM Name AppState [Action] 306 | selectLayer idx = do 307 | oldIdx <- use selectedLayerIndex 308 | selectedLayerIndex .= idx 309 | return [SelectLayerIndex oldIdx] 310 | 311 | cancelDragging :: EventM Name AppState () 312 | cancelDragging = 313 | dragging .= Nothing 314 | 315 | deleteSelectedLayer :: EventM Name AppState () 316 | deleteSelectedLayer = do 317 | idx <- use selectedLayerIndex 318 | withUndoM $ deleteLayer idx 319 | 320 | deleteLayer :: Int -> EventM Name AppState [Action] 321 | deleteLayer idx = do 322 | s <- get 323 | if M.size (s^.layers) == 1 324 | then return [] 325 | else do 326 | let Just orderIndex = elemIndex idx (s^.layerOrder) 327 | Just selOrderIndex = elemIndex (s^.selectedLayerIndex) (s^.layerOrder) 328 | newSelIndex = if selOrderIndex == orderIndex 329 | then newOrder !! (min (length newOrder - 1) selOrderIndex) 330 | else s^.selectedLayerIndex 331 | newOrder = catMaybes $ fixOrder <$> s^.layerOrder 332 | fixOrder i = if idx == i 333 | then Nothing 334 | else Just $ if i > idx 335 | then i - 1 336 | else i 337 | 338 | fixNameKeys m = M.fromList $ catMaybes $ fixPair <$> M.toList m 339 | fixPair (i, n) = if idx == i 340 | then Nothing 341 | else (, n) <$> fixOrder i 342 | 343 | act = InsertLayer (s^.layerAt idx) 344 | idx 345 | orderIndex 346 | (_layerName $ fromJust $ s^.layerInfo.at idx) 347 | 348 | -- Change the selected index 349 | selectedLayerIndex .= newSelIndex 350 | -- Remove the layer from the layer map, fix indices 351 | layers %= fixNameKeys 352 | -- Reassign all higher indices in name map, ordering list, 353 | -- layer map 354 | layerOrder .= newOrder 355 | -- Remove the layer from the layer visibility map, fix 356 | -- indices 357 | layerInfo %= fixNameKeys 358 | return [act] 359 | 360 | insertLayer :: Canvas -> Int -> Int -> T.Text -> EventM Name AppState [Action] 361 | insertLayer c newIdx orderIndex name = do 362 | s <- get 363 | let newOrderNoInsert = (\i -> if i >= newIdx then i + 1 else i) <$> s^.layerOrder 364 | newOrder = take orderIndex newOrderNoInsert <> 365 | [newIdx] <> 366 | drop orderIndex newOrderNoInsert 367 | 368 | fixNameKeys m = M.fromList $ fixPair <$> M.toList m 369 | fixPair (i, n) = if i >= newIdx 370 | then (i + 1, n) 371 | else (i, n) 372 | 373 | removeAct = RemoveLayer newIdx 374 | selAct = SelectLayerIndex (s^.selectedLayerIndex) 375 | 376 | selectedLayerIndex .= (length (s^.layerOrder)) 377 | layers %= (M.insert newIdx c . fixNameKeys) 378 | layerOrder .= newOrder 379 | layerInfo %= (M.insert newIdx (LayerInfo name True) . fixNameKeys) 380 | return [removeAct, selAct] 381 | 382 | quit :: Bool -> EventM Name AppState () 383 | quit ask = do 384 | s <- get 385 | case (s^.canvasDirty) of 386 | True -> 387 | case s^.canvasPath of 388 | Nothing -> 389 | case ask of 390 | True -> modify askToSave 391 | False -> halt 392 | Just p -> 393 | if ask 394 | then modify askToSave 395 | else do 396 | result <- liftIO $ E.try $ saveToDisk s p 397 | case result of 398 | Left (e::E.SomeException) -> do 399 | saveError .= (Just $ T.pack $ show e) 400 | askForSaveFilename True 401 | Right () -> halt 402 | False -> halt 403 | 404 | saveToDisk :: AppState -> FilePath -> IO () 405 | saveToDisk s p = do 406 | let ls = snd <$> (sortOn fst $ M.toList $ s^.layers) 407 | writeCanvasFiles p ls (s^.layerOrder) 408 | (_layerName <$> snd <$> (sortOn fst $ M.toList $ s^.layerInfo)) 409 | 410 | saveAndContinue :: EventM Name AppState () 411 | saveAndContinue = do 412 | s <- get 413 | case s^.canvasPath of 414 | Nothing -> return () 415 | Just p -> do 416 | liftIO $ saveToDisk s p 417 | put $ s & canvasDirty .~ False 418 | 419 | writeCanvasFiles :: FilePath -> [Canvas] -> [Int] -> [T.Text] -> IO () 420 | writeCanvasFiles path cs order names = do 421 | let tf = TartFile cs names order 422 | tfp = toTartFilepath path 423 | formats = [FormatBinary, FormatPlain, FormatAnsiColor] 424 | forM_ formats $ \f -> writeTartFile f tf tfp 425 | 426 | askToSave :: AppState -> AppState 427 | askToSave s = 428 | pushMode AskToSave s 429 | 430 | askForSaveFilename :: Bool -> EventM Name AppState () 431 | askForSaveFilename shouldQuit = do 432 | s <- get 433 | askToSaveFilenameEdit .= applyEdit gotoEOL (editor AskToSaveFilenameEdit (Just 1) $ 434 | T.pack $ maybe "" id $ s^.canvasPath) 435 | modify $ pushMode (AskForSaveFilename shouldQuit) 436 | 437 | beginTextEntry :: (Int, Int) -> AppState -> AppState 438 | beginTextEntry start s = 439 | pushMode TextEntry $ s & textEntryStart .~ start 440 | & textEntered .~ mempty 441 | 442 | handleDragFinished :: Name -> EventM Name AppState () 443 | handleDragFinished n = do 444 | s <- get 445 | case n of 446 | Canvas -> 447 | case s^.tool `elem` [Box, Line] of 448 | True -> do 449 | (c', old) <- liftIO $ merge (s^.currentLayer) (s^.drawingOverlay) 450 | o' <- liftIO $ clearCanvas (s^.drawingOverlay) 451 | put $ pushUndo [SetPixels (s^.selectedLayerIndex) old] $ 452 | s & currentLayer .~ c' 453 | & drawingOverlay .~ o' 454 | False -> return () 455 | _ -> return () 456 | 457 | increaseCanvasSize :: EventM Name AppState () 458 | increaseCanvasSize = do 459 | sz <- use appCanvasSize 460 | resizeCanvas $ 461 | sz & _1 %~ (\w -> if w == 1 then 4 else w + 4) 462 | & _2 %~ (\h -> if h == 1 then 2 else h + 2) 463 | 464 | decreaseCanvasSize :: EventM Name AppState () 465 | decreaseCanvasSize = do 466 | sz <- use appCanvasSize 467 | resizeCanvas $ 468 | sz & _1 %~ (max 1 . (subtract 4)) 469 | & _2 %~ (max 1 . (subtract 2)) 470 | 471 | pushMode :: Mode -> AppState -> AppState 472 | pushMode m s = 473 | if isSelectionMode m && isSelectionMode (currentMode s) 474 | then s & modes %~ ((m:) . tail) 475 | & dragging .~ Nothing 476 | else s & modes %~ (m:) 477 | & dragging .~ Nothing 478 | 479 | popMode :: AppState -> AppState 480 | popMode s = s & modes %~ (\m -> if length m == 1 then m else tail m) 481 | & dragging .~ Nothing 482 | 483 | beginCanvasSizePrompt :: EventM Name AppState () 484 | beginCanvasSizePrompt = do 485 | s <- get 486 | canvasSizeFocus .= focusRing [ CanvasSizeWidthEdit 487 | , CanvasSizeHeightEdit 488 | ] 489 | canvasSizeWidthEdit .= applyEdit gotoEOL (editor CanvasSizeWidthEdit (Just 1) $ 490 | T.pack $ show $ fst $ s^.appCanvasSize) 491 | canvasSizeHeightEdit .= applyEdit gotoEOL (editor CanvasSizeHeightEdit (Just 1) $ 492 | T.pack $ show $ snd $ s^.appCanvasSize) 493 | modify $ pushMode CanvasSizePrompt 494 | 495 | canvasMoveDown :: EventM Name AppState () 496 | canvasMoveDown = 497 | canvasOffset._2 %= pred 498 | 499 | canvasMoveUp :: EventM Name AppState () 500 | canvasMoveUp = 501 | canvasOffset._2 %= succ 502 | 503 | canvasMoveLeft :: EventM Name AppState () 504 | canvasMoveLeft = 505 | canvasOffset._1 %= pred 506 | 507 | canvasMoveRight :: EventM Name AppState () 508 | canvasMoveRight = 509 | canvasOffset._1 %= succ 510 | 511 | tryResizeCanvas :: EventM Name AppState () 512 | tryResizeCanvas = do 513 | s <- get 514 | -- If the canvas size prompt inputs are valid, resize the canvas and 515 | -- exit prompt mode. Otherwise stay in prompt mode. 516 | let [wStr] = getEditContents $ s^.canvasSizeWidthEdit 517 | [hStr] = getEditContents $ s^.canvasSizeHeightEdit 518 | result = (,) <$> (readMaybe $ T.unpack wStr) 519 | <*> (readMaybe $ T.unpack hStr) 520 | case result of 521 | Just (w, h) | w > 0 && h > 0 -> do 522 | modify popMode 523 | resizeCanvas (w, h) 524 | _ -> return () 525 | 526 | beginToolSelect :: EventM Name AppState () 527 | beginToolSelect = modify $ pushMode ToolSelect 528 | 529 | beginBoxStyleSelect :: EventM Name AppState () 530 | beginBoxStyleSelect = modify $ pushMode BoxStyleSelect 531 | 532 | beginStyleSelect :: EventM Name AppState () 533 | beginStyleSelect = modify $ pushMode StyleSelect 534 | 535 | beginFgPaletteSelect :: EventM Name AppState () 536 | beginFgPaletteSelect = modify $ pushMode FgPaletteEntrySelect 537 | 538 | beginBgPaletteSelect :: EventM Name AppState () 539 | beginBgPaletteSelect = modify $ pushMode BgPaletteEntrySelect 540 | 541 | setTool :: Tool -> EventM Name AppState () 542 | setTool t = tool .= t 543 | 544 | setToolByChar :: Char -> EventM Name AppState () 545 | setToolByChar c = 546 | let idx = read [c] 547 | in case filter ((== idx) . snd) tools of 548 | [(t, _)] -> do 549 | setTool t 550 | modify popMode 551 | _ -> return () 552 | 553 | whenTool :: [Tool] -> EventM Name AppState () -> EventM Name AppState () 554 | whenTool ts act = do 555 | t <- use tool 556 | when (t `elem` ts) act 557 | 558 | setFgPaletteIndex :: Int -> EventM Name AppState () 559 | setFgPaletteIndex i = do 560 | drawFgPaletteIndex .= i 561 | modify popMode 562 | 563 | setBgPaletteIndex :: Int -> EventM Name AppState () 564 | setBgPaletteIndex i = do 565 | drawBgPaletteIndex .= i 566 | modify popMode 567 | 568 | beginCharacterSelect :: EventM Name AppState () 569 | beginCharacterSelect = modify $ pushMode CharacterSelect 570 | 571 | cancelCharacterSelect :: EventM Name AppState () 572 | cancelCharacterSelect = modify popMode 573 | 574 | selectCharacter :: Char -> EventM Name AppState () 575 | selectCharacter c = do 576 | drawCharacter .= c 577 | modify popMode 578 | 579 | checkForMouseSupport :: IO () 580 | checkForMouseSupport = do 581 | vty <- V.mkVty V.defaultConfig 582 | 583 | when (not $ V.supportsMode (V.outputIface vty) V.Mouse) $ do 584 | putStrLn "Error: this terminal does not support mouse interaction" 585 | exitFailure 586 | 587 | V.shutdown vty 588 | 589 | resizeCanvas :: (Int, Int) -> EventM n AppState () 590 | resizeCanvas newSz = do 591 | s <- get 592 | ls <- liftIO $ forM (M.toList $ s^.layers) $ \(idx, l) -> 593 | (idx,) <$> resizeFrom l newSz 594 | o <- liftIO $ resizeFrom (s^.drawingOverlay) newSz 595 | layers .= (M.fromList ls) 596 | drawingOverlay .= o 597 | appCanvasSize .= newSz 598 | canvasDirty .= (s^.appCanvasSize /= newSz) 599 | recenterCanvas 600 | 601 | recenterCanvas :: EventM n AppState () 602 | recenterCanvas = do 603 | sz <- use appCanvasSize 604 | canvasOffset .= (Location $ sz & each %~ (`div` 2)) 605 | 606 | toggleLayerList :: EventM Name AppState () 607 | toggleLayerList = 608 | layerListVisible %= not 609 | 610 | addLayer :: EventM Name AppState () 611 | addLayer = do 612 | s <- get 613 | let newLayerName = T.pack $ "layer " <> (show $ idx + 1) 614 | idx = M.size $ s^.layers 615 | 616 | c <- liftIO $ newCanvas (s^.appCanvasSize) 617 | withUndoM $ insertLayer c idx 0 newLayerName 618 | 619 | currentPaletteAttribute :: AppState -> V.Attr 620 | currentPaletteAttribute s = 621 | let fgEntry = Vec.unsafeIndex (s^.palette) (s^.drawFgPaletteIndex) 622 | bgEntry = Vec.unsafeIndex (s^.palette) (s^.drawBgPaletteIndex) 623 | applyFg Nothing = id 624 | applyFg (Just c) = (`V.withForeColor` c) 625 | applyBg Nothing = id 626 | applyBg (Just c) = (`V.withBackColor` c) 627 | in (applyFg fgEntry $ applyBg bgEntry V.defAttr) `V.withStyle` (s^.drawStyle) 628 | --------------------------------------------------------------------------------