cheat-sheet.hs

{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -pgmF marxup -F #-}
{-# LANGUAGE TupleSections, RecordWildCards, RecursiveDo, OverloadedStrings #-}
module Main (main) where

import Data.Char (toUpper,chr)
import Prelude hiding (mapM,sequence,Num(..),(/))
import MarXup
import MarXup.Latex
import MarXup.Tex hiding (label)
import Graphics.Diagrams
import MarXup.Diagram
import Control.Lens (set)
import Data.Traversable
import Data.List (isSuffixOf,isPrefixOf)
import Algebra.Classes
import System.Environment
import Mqwerty
import Mqwertz
import Mcolemak
import Mworkman

preamble body = do
  documentClass "article" ["10pt"]
  usepackage "fontspec" []
  cmd "setsansfont" (tex "DejaVu Sans")
  -- cmd "setmainfont" (tex "DejaVu Serif")
  usepackage "tikz" []
  usepackage "graphicx" []
  usepackage "amssymb" []
  usepackage "varwidth" []
  usepackage "geometry" ["margin=1cm","paper=a4paper","landscape"]
  env "document" body

data CheatSheet = CS
  { leftHandK, rightHandK :: [[String]] -- keycap glyphs
  , commandsInfo, selectorsInfo :: [(String, (TeX,Argument,TeX))]
  }

commandArgument :: String -> Argument
commandArgument x | "region" `isSuffixOf` x = TextRegion
                  | "character" `isSuffixOf` x = Char
                  | "map" `isSuffixOf` x = Prefix
                  | "avy" `isPrefixOf` x = Char
commandArgument "boon-enclose" = Bin Enclosure TextRegion
commandArgument "selectContent" = TextRegion
commandArgument "" = Reserved
commandArgument _  = None



upKey :: Char -> Char
upKey c = case [c] of
  "'" -> head "\""
  ";" -> ':'
  "," -> '<'
  "." -> '>'
  "/" -> '?'
  _ -> toUpper c


data Argument = Bin Argument Argument | None | Char | SearchObject | TextRegion | Prefix | Enclosure | Reserved

argColor :: Argument -> String
argColor a = case a of
  None -> "gray"
  Char -> "red"
  SearchObject -> "orange"
  Prefix -> "yellow"
  TextRegion -> "cyan"
  Bin _ _ -> "purple"
  _ -> "white"

varwidth :: forall a. String -> Tex a -> Tex a
varwidth x body = env "varwidth" ((braces $ tex x) >> cmd0 "centering" >> body)

keySize :: Constant
keySize = 65

massageInfo :: (Integer, (String,String)) -> (String, (TeX,Argument,TeX))
massageInfo (c,(mnemonic,command)) = ([chr (fromIntegral c)],(cmdTex,arg,textual mnemonic))
  where (cmdTex,arg) | command == "nil" = (italic "reserved",Reserved)
                     | otherwise = (textual (shortenCommand command),commandArgument command)

shortenCommand :: String -> String
shortenCommand c | "boon-" `isPrefixOf` c = shortenCommand (drop 5 c)
shortenCommand c | "-map" `isSuffixOf` c = shortenCommand (dropR 4 c)
shortenCommand c = c

dropR :: forall a. Int -> [a] -> [a]
dropR n = reverse . drop n . reverse

keyHalf :: [(String, (TeX, Argument, TeX))]
           -> String -> TexDiagram Object
keyHalf kmInfo k = do
  let (act,arg,mnem) = case lookup k kmInfo of
                         Nothing -> (mempty,Reserved,mempty)
                         Just (act,arg,mnem) -> (act,arg,mnem)
  up <- using (fill (argColor arg)) $ draw $ box "keyHalf"
  upK <- label "k" $  textSize Huge $ sans $ textual $ k
  upT <- label "scr" $ varwidth "45pt" $ sans $ textSize ScriptSize $ act
  m <- (label "mnem" $ sans $ textSize Tiny $ mnem)
  m # SW .=. up # SW
  up # E .=. upT # E
  up # W .=. upK # W
  width up === constant keySize
  height up === constant (keySize / 2)
  return up


keyDiagram :: [(String, (TeX, Argument, TeX))] -> String -> Diagram TeX Tex Object
keyDiagram kmInfo k = do
  b <- using (set lineWidth thick) $ draw $ box "keyB"
  up <- keyHalf kmInfo (map upKey k)
  down <- keyHalf kmInfo k
  up # S .=. down # N
  b # NW .=. up # NW
  b # NE .=. up # NE
  b # SE .=. down # SE
  return b

keyFull :: Constant -> String -> TeX -> Argument -> TexDiagram Object
keyFull w k act arg = do
  b <- using (set lineWidth thick . fill (argColor arg)) $ draw $ box "kf"
  width b === constant w
  height b === constant keySize
  k' <- label "huge" $ textSize Huge $ textual $ k
  act' <- label "scr2" $ varwidth "55pt" $ sans $ textSize ScriptSize $ act
  k' # NW .=. b # NW
  act' # S .=. b # S
  return b

keyDist :: Constant
keyDist = 5

argDescs :: [(Argument, TeX)]
argDescs =
  [(Bin Enclosure TextRegion, "First an enclosure, then a region")
  ,(None,"No Argument")
  ,(Char,"A character")
  ,(SearchObject,"A search space")
  ,(TextRegion,"A region")
  ,(Prefix,"(Prefix map)")
  -- ,(Enclosure,"An enclosure")
  ,(Reserved,"(Reserved key)")]

legend :: TexDiagram ()
legend = do
  txt <- label "legleg" (textSize Tiny $ "Color corresponds to the type of expected argument:")
  ds <- forM argDescs $
    \ (arg,desc) -> do
        b <- using (set lineWidth thick . fill (argColor arg)) $ draw $ box "legend"
        width b === constant 15
        height b === constant 15
        l <- label "desc" desc
        b # E .=. l # W
        return b
  let ds' = ds++[txt]
  align xpart (map (# W) ds')
  spread vdist (constant 5) ds'

matrixDiag :: [[TexDiagram Object]] -> TexDiagram [[Object]]
matrixDiag matrix = do
  keys <- mapM sequence $ reverse $ matrix
  spread hdist (constant keyDist) $ (keys !! 1)
  spread vdist (constant keyDist) $ map head keys
  alignMatrix $ map (map (# Center)) keys
  return $ reverse keys

keyBDiag :: CheatSheet -> TexDiagram ()
keyBDiag CS {..} = do
  keys <- matrixDiag (map (map (keyDiagram commandsInfo)) (leftHandK +++ rightHandK))
  esc <- keyFull keySize "esc" "back to normal mode" None
  esc # SW .=. (keys !! 0 !! 0) # NW + (Point zero (constant keyDist))
  bar <- keyFull (keySize * 6 + keyDist * 5) "space" "select region" TextRegion
  keys !! 2 !! 2 # SW .=. bar # NW  + (Point zero (constant keyDist))
  return ()

regDiag :: CheatSheet -> TexDiagram ()
regDiag CS {..} = do
  txt <- label "lhtrs" "Left-hand text region specifiers:"
  keys <- matrixDiag (map (map (keyHalf selectorsInfo)) leftHandK)
  spread vdist (constant 7) [keys!!0!!0,txt]
  return ()

(+++) :: [[a]] -> [[a]] -> [[a]]
x +++ y = zipWith (++) x y

mkCS (commandMap,movesMap,selectMap) =
  CS {leftHandK = [], rightHandK = []
     ,commandsInfo = ("",(mempty,Reserved,mempty)):
                     map massageInfo (commandMap ++ movesMap)
     ,selectorsInfo = map massageInfo selectMap
     }

main :: IO ()
main = do
  [flavor] <- getArgs
  let cs' = case flavor of
         "colemak" -> (mkCS colemak) {
           leftHandK = [["q","w","f","p","g"]
                       ,["a","r","s","t","d"]
                       ,["z","x","c","v","b"]]
           ,rightHandK = [["j","l","u","y",";",""]
                         ,["h","n","e","i","o","'"]
                         ,["k","m",",",".","/",""]]}
         "qwerty" -> (mkCS qwerty)
               {leftHandK = [["q","w","e","r","t"]
                   ,["a","s","d","f","g"]
                   ,["z","x","c","v","b"]]

               ,rightHandK = [["y","u","i","o","p",""]
                    ,["h","j","k","l",";","'"]
                    ,["n","m",",",".","/",""]]}
         "qwertz" -> (mkCS qwertz)
               {leftHandK = [["q","w","e","r","t"]
                            ,["a","s","d","f","g"]
                            ,["y","x","c","v","b"]]

               ,rightHandK = [["z","u","i","o","p",""]
                             ,["h","j","k","l","ö","ä"]
                             ,["n","m",";",":","-",""]]}
         "workman" -> (mkCS workman)
               {leftHandK = [["q","d","r","w","b"]
                            ,["a","s","h","t","g"]
                            ,["z","x","m","c","v"]]

               ,rightHandK = [["j","f","u","p","k",";"]
                             ,["y","n","e","o","i","'"]
                             ,["k","l",",",".","/",""]]}
  renderTex Plain flavor (docu cs')

docu :: CheatSheet -> TeX
docu csData = preamble «
BOON cheat sheet. It is recommended to read the M-x boon-tutorial to make sense of this. The color of a key indicates the type of argument it expects.

Command mode bindings.
@keyBDiag(csData)

@vspace"1em"

@regDiag(csData)
@hfill
@legend
»