module Research where

import Data.List                 (intercalate)
import Data.Map                  (Map)
import Data.Text                 (Text, replace)
import System.Console.CmdArgs    (Data, Typeable)

import qualified Data.Map        as Map
import qualified Data.Text as T

-- Tree Calculus Types
data T = Leaf | Stem T | Fork T T
  deriving (Show, Eq, Ord)

-- Abstract Syntax Tree for tricu
data TricuAST
  = SVar String
  | SInt Integer
  | SStr String
  | SList [TricuAST]
  | SDef String [String] TricuAST
  | SApp TricuAST TricuAST
  | TLeaf
  | TStem TricuAST
  | TFork TricuAST TricuAST
  | SLambda [String] TricuAST
  | SEmpty
  | SImport String String
  deriving (Show, Eq, Ord)

-- Lexer Tokens
data LToken
  = LKeywordT
  | LIdentifier String
  | LNamespace String
  | LIntegerLiteral Integer
  | LStringLiteral String
  | LAssign
  | LColon
  | LDot
  | LOpenParen
  | LCloseParen
  | LOpenBracket
  | LCloseBracket
  | LNewline
  | LImport String String
  deriving (Show, Eq, Ord)

-- Output formats
data EvaluatedForm = TreeCalculus | FSL | AST | Ternary | Ascii | Decode
  deriving (Show, Data, Typeable)

-- Environment containing previously evaluated TC terms
type Env = Map.Map String T

-- Tree Calculus Reduction Rules
{- 
  The t operator is left associative.
  1.  t  t      a b       -> a
  2.  t (t a)   b c       -> a c (b c)
  3a. t (t a b) c t       -> a
  3b. t (t a b) c (t u)   -> b u
  3c. t (t a b) c (t u v) -> c u v
-}
apply :: T -> T -> T
apply (Fork Leaf a)         _         = a
apply (Fork (Stem a) b) c             = apply (apply a c) (apply b c)
apply (Fork (Fork a  b) c)  Leaf      = a
apply (Fork (Fork a  b) c) (Stem u)   = apply b u
apply (Fork (Fork a  b) c) (Fork u v) = apply (apply c u) v
-- Left associative `t`
apply  Leaf b                         = Stem b
apply (Stem a) b                      = Fork a b

-- Booleans
_false :: T
_false = Leaf

_true :: T
_true = Stem Leaf

_not :: T
_not = Fork (Fork _true (Fork Leaf _false)) Leaf

-- Marshalling
ofString :: String -> T
ofString str = ofList $ map (ofNumber . toInteger . fromEnum) str

ofNumber :: Integer -> T
ofNumber 0 = Leaf
ofNumber n =
  Fork
    (if odd n then Stem Leaf else Leaf)
    (ofNumber (n `div` 2))

ofList :: [T] -> T
ofList = foldr Fork Leaf

toNumber :: T -> Either String Integer
toNumber Leaf = Right 0
toNumber (Fork Leaf rest) = case toNumber rest of
  Right n -> Right (2 * n)
  Left err -> Left err
toNumber (Fork (Stem Leaf) rest) = case toNumber rest of
  Right n -> Right (1 + 2 * n)
  Left err -> Left err
toNumber _ = Left "Invalid Tree Calculus number"

toString :: T -> Either String String
toString tc = case toList tc of
  Right list -> traverse (fmap (toEnum . fromInteger) . toNumber) list
  Left err -> Left "Invalid Tree Calculus string"

toList :: T -> Either String [T]
toList Leaf = Right []
toList (Fork x rest) = case toList rest of
  Right xs -> Right (x : xs)
  Left err -> Left err
toList _ = Left "Invalid Tree Calculus list"

-- Outputs
formatT :: EvaluatedForm -> T -> String
formatT TreeCalculus = toSimpleT . show
formatT FSL          = show
formatT AST          = show . toAST
formatT Ternary      = toTernaryString
formatT Ascii        = toAscii
formatT Decode       = decodeResult

toSimpleT :: String -> String
toSimpleT s = T.unpack
  $ replace "Fork" "t"
  $ replace "Stem" "t"
  $ replace "Leaf" "t"
  $ T.pack s

toTernaryString :: T -> String
toTernaryString Leaf = "0"
toTernaryString (Stem t) = "1" ++ toTernaryString t
toTernaryString (Fork t1 t2) = "2" ++ toTernaryString t1 ++ toTernaryString t2

toAST :: T -> TricuAST
toAST Leaf = TLeaf
toAST (Stem a) = TStem (toAST a)
toAST (Fork a b) = TFork (toAST a) (toAST b)

toAscii :: T -> String
toAscii tree = go tree "" True
  where
    go :: T -> String -> Bool -> String
    go Leaf prefix isLast =
      prefix ++ (if isLast then "`-- " else "|-- ") ++ "Leaf\n"
    go (Stem t) prefix isLast =
      prefix ++ (if isLast then "`-- " else "|-- ") ++ "Stem\n"
        ++ go t (prefix ++ (if isLast then "    " else "|   ")) True
    go (Fork left right) prefix isLast =
      prefix ++ (if isLast then "`-- " else "|-- ") ++ "Fork\n"
        ++ go left (prefix ++ (if isLast then "    " else "|   ")) False
        ++ go right (prefix ++ (if isLast then "    " else "|   ")) True

decodeResult :: T -> String
decodeResult Leaf = "t"
decodeResult tc =
  case (toString tc, toList tc, toNumber tc) of
    (Right s, _, _) | all isCommonChar s -> "\"" ++ s ++ "\""
    (_, _, Right n) -> show n
    (_, Right xs@(_:_), _) -> "[" ++ intercalate ", " (map decodeResult xs) ++ "]"
    (_, Right [], _) -> "[]"
    _ -> formatT TreeCalculus tc
  where
    isCommonChar c =
      let n = fromEnum c
      in (n >= 32 && n <= 126)
         || n == 9
         || n == 10
         || n == 13