mirror of
https://github.com/vale981/boon
synced 2025-03-04 09:01:39 -05:00
242 lines
7.7 KiB
Haskell
242 lines
7.7 KiB
Haskell
{-# 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 Layout
|
|
import System.Environment
|
|
|
|
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
|
|
|
|
|
|
main :: IO ()
|
|
main = do
|
|
[flavor] <- getArgs
|
|
let cs = CS {leftHandK = [], rightHandK = []
|
|
,commandsInfo = ("",(mempty,Reserved,mempty)):
|
|
map massageInfo (Layout.commandMap ++ Layout.movesMap)
|
|
,selectorsInfo = map massageInfo Layout.selectMap
|
|
}
|
|
let cs' = case flavor of
|
|
"colemak" -> cs {
|
|
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" -> cs
|
|
{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" -> cs
|
|
{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" -> cs
|
|
{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 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
|
|
»
|
|
|