Create a gist now

Instantly share code, notes, and snippets.

@wchargin /ColorGo.hs
Last active May 16, 2016

What would you like to do?
the game of Go, with colors: gnugo | runhaskell ColorGo
-- | A Unix pipeline operation to color the output of GNU Go
-- so that the Xs and Os stand out more prominently against the board.
-- Run with no arguments: e.g., @gnugo | runhaskell ColorGo.hs@.
module Main where
import Data.Maybe (fromMaybe)
import Data.Char (isSpace, isDigit)
import System.Exit (exitSuccess)
import System.IO
( hSetBuffering
, hSetEcho
, stdin
, stdout
, BufferMode (NoBuffering)
)
import System.IO.Error
( tryIOError
, isEOFError
, ioError
)
-- | Given a dictionary of conversions and an input character,
-- look up the character and return its converted value,
-- or return just the input (as a string)
-- if the character is not present in the dictionary.
translate :: [(Char, String)] -> Char -> String
translate table c = fromMaybe [c] $ lookup c table
-- | An ANSI terminal effect.
-- These can be primitive effects or combined with the @x @':&:'@ y@ constructor.
data Effect = Colored Int -- ^ Color with an ANSI color code.
| Bold -- ^ Use boldface font.
| Effect :&: Effect -- ^ Apply the left effect
-- and then the right effect.
-- | Get the ANSI escape sequence to start the given effect.
effectCode :: Effect -> String
effectCode (Colored n) = "\x1b[3" ++ show n ++ "m" -- tput setaf @n@
effectCode Bold = "\x1b[1m" -- tput bold
effectCode (x :&: y) = effectCode x ++ effectCode y
-- | Apply the given effect to a string.
-- Returns a valid, self-contained ANSI escape sequence.
effect :: Effect -> String -> String
effect e s = effectCode e ++ s ++ "\x1b(B\x1b[m" -- tput sgr0
-- | The substitution table (for use with 'translate') for the Go game.
-- Lowercase letters are used for dead stones in the post-game discussion.
colorTable :: [(Char, String)]
colorTable = [ ('X', colorBlack "X")
, ('x', colorBlack "x")
, ('O', colorWhite "O")
, ('o', colorWhite "o")
]
where
colorBlack = effect $ Colored 1 :&: Bold
colorWhite = effect $ Colored 4
-- | Set up the terminal buffering and echo modes.
setup :: IO ()
setup = do
hSetBuffering stdin NoBuffering
hSetBuffering stdout NoBuffering
hSetEcho stdin False
-- | Wrap an I/O action with a handler
-- that exits successfully ('exitSuccess') on EOF.
handleEOF :: IO a -> IO a
handleEOF a = tryIOError a >>= \x -> case x of
Left e -> if isEOFError e then exitSuccess else ioError e
Right x -> return x
-- | We maintain a little state machine
-- so that we only color lines that are part of the board.
-- Once we determine that a line is either a board line or a non-board line,
-- we remain in that mode for the rest of the line,
-- at which point we return to the 'NewLine' mode.
data Mode = NewLine | Board | NonBoard
-- | Determine the mode for the state machine
-- after reading the given character from the given mode.
nextMode :: Mode -> Char -> Mode
--
-- We use the heuristic that
-- a line is part of the board iff
-- its first non-space character is a digit.
-- This seems pretty accurate, and is certainly good enough.
-- (It false-positives one of the copyright lines, but who cares?)
nextMode NewLine c
| isSpace c = NewLine
| isDigit c = Board
| otherwise = NonBoard
nextMode _ '\n' = NewLine
nextMode m _ = m
-- | Echo characters with the given mode:
-- either formatting them or passing them through verbatim.
-- Then, echo again with the next mode,
-- thus looping forever or until EOF.
echo :: Mode -> IO a
echo mode = do
x <- handleEOF getChar
putStr $ case mode of
Board -> translate colorTable x
_ -> [x]
echo $ nextMode mode x
main :: IO ()
main = setup >> echo NewLine
Owner

wchargin commented May 12, 2016

Sample output (yeah, I'm not very good)

The same image with a dark colorscheme

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment