\begin{code}
module HylotabLex

where

import Prelude
import Char
\end{code}

Names for all tokens: 

\begin{code}
data Token = 
    TokenAt1         | TokenAt2         | TokenDot         |
    TokenImpl        | TokenDimp        | TokenNeg         | 
    TokenAnd         | TokenOr          |
    TokenConj        | TokenDisj        |
    TokenProp String | TokenCst String  | TokenVar String  |
    TokenTrue        | TokenFalse       |
    TokenA           | TokenE           |
    TokenBox String  | TokenDia String  |
    TokenCbox String | TokenCdia String | TokenComma       |
    TokenBnd         | TokenOB          | TokenCB      
                                                  deriving Show
\end{code}

The lexer transforms an input string into a list of tokens. 

\begin{code}
lexer :: String -> [Token]
lexer [] = []
lexer ('<':'-':'>':cs) = TokenDimp : lexer cs
lexer ('-':'>':cs) = TokenImpl : lexer cs
lexer ('(':cs) = TokenOB : lexer cs
lexer (')':cs) = TokenCB : lexer cs
lexer ('A':cs) = TokenA : lexer cs 
lexer ('E':cs) = TokenE : lexer cs 
lexer ('d':'i':'a':cs) = (TokenDia "0") : lexer cs
lexer ('c':'d':'i':'a':cs) = (TokenCdia "0") : lexer cs
lexer ('<':cs) = lexDia cs 
lexer ('b':'o':'x':cs)     = (TokenBox "0") : lexer cs
lexer ('c':'b':'o':'x':cs) = (TokenCbox "0") : lexer cs
lexer ('[':cs) = lexBox cs 
lexer ('|':cs) = TokenOr: lexer cs 
lexer ('v':'v':cs) = TokenDisj: lexer cs 
lexer ('v':cs) = TokenOr: lexer cs 
lexer ('&':'&':cs) = TokenConj: lexer cs 
lexer ('&':cs) = TokenAnd: lexer cs 
lexer ('~':cs) = TokenNeg: lexer cs 
lexer ('-':cs) = TokenNeg: lexer cs 
lexer ('!':cs) = TokenNeg: lexer cs 
lexer (',':cs) = TokenComma: lexer cs 
lexer ('.':cs) = TokenDot: lexer cs 
lexer ('c':'o':'n':j':cs) = TokenConj: lexer cs 
lexer ('d':'i':'s':j':cs) = TokenDisj: lexer cs 
lexer (':':cs) = TokenAt1: lexer cs 
lexer ('@':cs) = TokenAt2: lexer cs 
lexer ('D':cs) = TokenBnd: lexer cs 
lexer ('d':'o':'w':'n':cs) = TokenBnd: lexer cs 
lexer ('{':cs) = lexComment cs 0
lexer (c:cs) 
      | isSpace c = lexer cs
      | isAlpha c = lexName (c:cs)
\end{code}

Allow nested comments: 

\begin{code}
lexComment :: [Char] -> Integer -> [Token]
lexComment (c:cs) n | c == '}'  = case n <= 0  of 
                                    True  -> lexer cs
                                    False -> lexComment cs (n-1)
                    | c == '{'  = lexComment cs (n+1)
                    | otherwise = lexComment cs n 
\end{code}

Recognize boxes, while distinguishing between regular boxes and
converse boxes.

\begin{code}
lexBox :: [Char] -> [Token]
lexBox cs = 
    case break (==']') cs of
       ([],     h:rest) -> (TokenBox "0") : lexer rest
       (['^'],  h:rest) -> (TokenCbox "0") : lexer rest
       (['~'],  h:rest) -> (TokenCbox "0") : lexer rest
       (rel, h:rest) -> case readRel rel of
                      Just (num,False) -> (TokenBox num)  : lexer rest 
                      Just (num,True)  -> (TokenCbox num) : lexer rest 
\end{code}

Recognize diamonds, while distinguishing between regular and converse. 

\begin{code}
lexDia :: [Char] -> [Token]
lexDia cs = 
    case break (=='>') cs of
      ([],     h:rest) -> (TokenDia "0") : lexer rest
      (['^'],  h:rest) -> (TokenCdia "0") : lexer rest
      (['~'],  h:rest) -> (TokenCdia "0") : lexer rest
      (rel,    h:rest) -> case readRel rel of 
                Just (num,False) -> (TokenDia num)  : lexer rest 
                Just (num,True)  -> (TokenCdia num) : lexer rest 
\end{code}

Read the contents of a box or diamond expression: 

\begin{code}
readRel :: [Char] -> Maybe ([Char],Bool)
readRel (' ':rel) = readRel rel
readRel ('R':rel) = readRel rel
readRel      rel  = 
    case span isDigit rel of
       (num, res) -> if null num then Nothing else Just (num,isConv res)
\end{code}

Check whether a relation is regular or converse: 

\begin{code}
isConv :: [Char] -> Bool
isConv (' ':xs) = isConv xs
isConv ('~':_)  = True
isConv  _       = False
\end{code}

Scan and tokenize names: 

\begin{code}
lexName cs =
   case span isAlphaDigit cs of
      ("true",rest)   -> TokenTrue      : lexer rest
      ("false",rest)  -> TokenFalse     : lexer rest
      ("T",rest)      -> TokenTrue      : lexer rest
      ("t",rest)      -> TokenTrue      : lexer rest
      ("F",rest)      -> TokenFalse     : lexer rest
      ("f",rest)      -> TokenFalse     : lexer rest
      ("P",rest)      -> TokenProp "0"  : lexer rest
      ('P':name,rest) -> TokenProp name : lexer rest
      ("p",rest)      -> TokenProp "0"  : lexer rest
      ('p':name,rest) -> TokenProp name : lexer rest
      ("C",rest)      -> TokenCst  "0"  : lexer rest
      ('C':name,rest) -> TokenCst  name : lexer rest
      ("c",rest)      -> TokenCst "0"   : lexer rest
      ('c':name,rest) -> TokenCst  name : lexer rest
      ("X",rest)      -> TokenVar "0"   : lexer rest
      ('X':name,rest) -> TokenVar  name : lexer rest
      ("x",rest)      -> TokenVar "0"   : lexer rest
      ('x':name,rest) -> TokenVar  name : lexer rest
    where isAlphaDigit c = isAlpha c || isDigit c
\end{code}