--------------------------------------------------------------------------------
{-# LANGUAGE LambdaCase #-}


--------------------------------------------------------------------------------
module Console.Garepinoh.Preludes
    ( abstractPrelude
    , floatingPrelude
    , boolPrelude
    ) where


--------------------------------------------------------------------------------
import Console.Garepinoh.Types
import Console.Garepinoh.Utils


--------------------------------------------------------------------------------
-- |The abstract 'Prelude' which implements functions typical for concatenative 
-- programming languages.
abstractPrelude :: (Read t, Show t, Eq t) => Prelude t
abstractPrelude =
    [ Func
      { symb = NEL "swap" ["swp","s"]
      , func = [ Fun $ const $ \case
                 (a:b:es) -> Right (b:a:es)
                 _ -> Left "swap expects two elements."
               ]
      }
    , Func
      { symb = NEL "drop" ["drp","d"]
      , func = [ Fun $ const $ \case
                 (_:es) -> Right es
                 _ -> Left "drop expects an element."
               ]
      }
    , Func
      { symb = NEL "flip" []
      , func = [ Fun $ const $ \case
                 (Fu (Func (NEL sy _) fu)):es -> Right $ (:es) $ Fu $ Func
                         (NEL ("flip "++sy) [])
                         (Ref "swap":fu)
                 _ -> Left "flip expects one argument, being a function."
               ]
      }
    , Func
      { symb = NEL "emptylist" ["el","[]"]
      , func = [ Fun $ const $ Right . (Li []:)
               ]
      }
    , Func
      { symb = NEL "cons" ["#",":"] -- FIXME: : doesn't work
      , func = [ Fun $ const $ \case
                 x:Li l:es -> Right $ (:es) $ Li (l++[x]) -- order? i belive it's nice like this.
                 _ -> Left "cons expects two arguments, the second being a list."
               ]
      }
    , Func
      { symb = NEL "dup" ["duplicate"]
      , func = [ Fun $ const $ \case
                 a:es -> Right (a:a:es)
                 _ -> Left "dup expects one argument."
               ]
      }
    , Func
      { symb = NEL "map" []
      , func = [ Fun $ \p -> \case
                 f:Li l:es ->
                     fmap
                         ((:es) . Li . concat)
                         (mapM (apply p f . return) l)
                 _ -> Left "map expects two arguments, the second being a list."
               ]
      }
    , Func
      { symb = NEL "curry" [",","c"] -- FIXME: buggy: 1 sqrt c
      , func = [ Fun $ \p -> \case
                 (f@(Fu (Func (NEL sy _) fu)):x:es) ->
                     case apply p f [x] of
                         Right resultStack -> Right (resultStack++es)
                         Left _ -> Right $ (:es) $ Fu $
                                   Func (NEL (sy++" "++show x) []) (Ele x:fu)
                 _ -> Left $ "curry expects two arguments, "
                          ++ "the first being a function."
               ]
      }
    , Func
      { symb = NEL "apply" ["$","a"]
      , func = [ Fun $ \p -> \case
                 (f:es) -> apply p f es
                 _ -> Left $ "apply expects two arguments, "
                          ++ "the first being a function."
               ]
      }
    , Func
      { symb = NEL "id" ["identity"]
      , func = [ Fun $ const Right
               ]
      }
    , Func
      { symb = NEL "geneq" ["generalequality"]
      , func = [ Fun $ const $ \case
                 t:e:a:a':es -> Right $ (:es) $ if a == a' then t else e
                 _ -> Left $ "generalequality expects four arguments."
               ]
      }
    , Func
      { symb = NEL "appendlist" ["unlist"]
      , func = [ Fun $ const $ \case
                 Li l:es -> Right $ l++es
                 _ -> Left $ "appendlist expects one argument, being a list."
               ]
      }
    , Func
      { symb = NEL "." ["functioncomposition","comp","∘"]
      , func = [ Fun $ const $ \case
                 Fu (Func (NEL fsy _) fhs):Fu (Func (NEL gsy _) ghs):es ->
                     Right $ (:es) $ Fu $ Func (NEL ("("++unwords [gsy,fsy,"∘"]++")") []) (ghs++fhs) -- order? i believe it' correct this way.
                 _ -> Left $ "appendlist expects one argument, being a list."
               ]
      }
    ]

--------------------------------------------------------------------------------
-- |'Prelude' floating-point numbers.
--
-- Beside arithmetic operations and common mathematical constants etc.,
-- it also contains the 'abstractPrelude'.
floatingPrelude :: (Show t, Read t, Eq t, Floating t) => Prelude t
floatingPrelude = abstractPrelude ++
    [ Func
      { symb = NEL "addition" ["add","plus","+"]
      , func = [ Fun $ const $ \case
                 (Va a:Va b:es) -> Right $ (:es) $ Va $ a+b
                 _ -> Left "addition expects two arguments, both being values."
               ]
      }
    , Func
      { symb = NEL "subtraction" ["-","minus","take","subtract"]
      , func = [ Fun $ const $ \case
                 (Va a:Va b:es) -> Right $ (:es) $ Va $ a-b
                 _ -> Left "subtraction expects two arguments, both being values."
               ]
      }
    , Func
      { symb = NEL "multiplication" ["times","*","·","×"]
      , func = [ Fun $ const $ \case
                 (Va a:Va b:es) -> Right $ (:es) $ Va $ a*b
                 _ -> Left "multiplication expects two arguments, both being values."
               ]
      }
    , Func
      { symb = NEL "division" ["div","/","%","\\","÷"]
      , func = [ Fun $ const $ \case
                 (Va a:Va b:es) -> Right $ (:es) $ Va $ a/b
                 _ -> Left "division expects two arguments, both being values."
               ]
      }
    , Func
      { symb = NEL "exponentiation" ["pow","power","^","**"]
      , func = [ Fun $ const $ \case
                 (Va a:Va b:es) -> Right $ (:es) $ Va $ a**b
                 _ -> Left "exponentiation expects two arguments, both being values."
               ]
      }
    , Func
      { symb = NEL "logarithm" ["log","logbase","?"]
      , func = [ Fun $ const $ \case
                 (Va a:Va b:es) -> Right $ (:es) $ Va $ logBase a b -- TODO order
                 _ -> Left "logarithm expects two arguments, both being values."
               ]
      }
    , Func
      { symb = NEL "pi" ["π"]
      , func = [ Fun $ const $ Right . (Va pi:)
               ]
      }
    , Func
      { symb = NEL "e" ["euler"]
      , func = [ Fun $ const $ Right . (Va (exp 1):)
               ]
      }
    , Func
      { symb = NEL "i" []
      , func = [ Ele $ Va $ sqrt (-1)
               ]
      }
    , Func
      { symb = NEL "sqrt" []
      , func = [ Fun $ const $ \case
                 (Va a:es) -> Right $ (:es) $ Va $ sqrt a
                 _ -> Left "sqrt expects one argument, being a value."
               ]
      }
    , Func
      { symb = NEL "bool" ["tei","thenelseif"]
      , func = [ Fun $ const $ \case
                 t:e:Va i:es -> Right $ if i /= 0 then t:es else e:es
                 _ -> Left "bool expects three argument, the third being a value."
               ]
      }
    ]


--------------------------------------------------------------------------------
-- |'Prelude' for Booleans.
--
-- Beside Boolean operations (e.g. conjunction and disjunction), it also
-- contains the 'abstractPrelude'.
boolPrelude :: Prelude Bool
boolPrelude = abstractPrelude ++
    [ Func
      { symb = NEL "conjunction" ["and","&","&&","∧"]
      , func = [ Fun $ const $ \case
                 (Va a:Va b:es) -> Right (Va (a && b):es)
                 _ -> Left "conjunction expects two arguments, both being values."
               ]
      }
    , Func
      { symb = NEL "disjunction" ["or","|","||","∨"]
      , func = [ Fun $ const $ \case
                 (Va a:Va b:es) -> Right (Va (a || b):es)
                 _ -> Left "disjunction expects two arguments, both being values."
               ]
      }
    , Func
      { symb = NEL "not" ["-","~","¬"]
      , func = [ Fun $ const $ \case
                 (Va a:es) -> Right (Va (not a):es)
                 _ -> Left "not expects one arguments, being a value."
               ]
      }
    , Func
      { symb = NEL "nand" []
      , func = [ Ref "and"
               , Ref "not"
               ]
      }
    , Func
      { symb = NEL "bool" ["tei","thenelseif"]
      , func = [ Fun $ const $ \case
                 t:e:Va i:es -> Right $ if i then t:es else e:es
                 _ -> Left "bool expects one argument, being a value."
               ]
      }
    , Func
      { symb = NEL "true" ["t","1"]
      , func = [ Ele (Va True)
               ]
      }
    , Func
      { symb = NEL "false" ["f","0"]
      , func = [ Ele (Va False)
               ]
      }
    ]