module Research where

import Control.Monad.State
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 Int
  | SStr String
  | SList [TricuAST]
  | SFunc String [String] TricuAST
  | SApp TricuAST TricuAST
  | TLeaf
  | TStem TricuAST
  | TFork TricuAST TricuAST
  | SLambda [String] TricuAST
  | SEmpty
  deriving (Show, Eq, Ord)

-- Tokens from Lexer
data LToken
  = LKeywordT
  | LIdentifier String
  | LIntegerLiteral Int
  | LStringLiteral String
  | LAssign
  | LColon
  | LBackslash
  | LOpenParen
  | LCloseParen
  | LOpenBracket
  | LCloseBracket
  | LNewline
  deriving (Show, Eq, Ord)

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

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

-- Tree Calculus Reduction
apply :: T -> T -> T
apply Leaf b                            = Stem b
apply (Stem a) b                        = Fork a b
apply (Fork Leaf a) _                   = a
apply (Fork (Stem a1) a2) b             = apply (apply a1 b) (apply a2 b)
apply (Fork (Fork a1 a2) a3) Leaf       = a1
apply (Fork (Fork a1 a2) a3) (Stem u)   = apply a2 u
apply (Fork (Fork a1 a2) a3) (Fork u v) = apply (apply a3 u) v

-- SKI Combinators
_S :: T
_S = Fork (Stem (Fork Leaf Leaf)) Leaf

_K :: T
_K = Stem Leaf

-- Identity
-- We use the "point-free" style which drops a redundant node
-- Full I form (SKK): Fork (Stem (Stem Leaf)) (Stem Leaf)
_I :: T
_I = Fork (Stem (Stem Leaf)) Leaf 

-- 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 (map fromEnum str))

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

ofList :: [T] -> T
ofList [] = Leaf
ofList (x:xs) = Fork x (ofList xs)

toNumber :: T -> Either String Int
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 . 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
formatResult :: CompiledForm -> T -> String
formatResult TreeCalculus = toSimpleT . show
formatResult FSL          = show
formatResult AST          = show . toAST
formatResult Ternary      = toTernaryString
formatResult Ascii        = toAscii

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

-- Utility