text:
{- Copyright (c) 2020 by André van Meulebrouck.  All rights reserved worldwide.

File:  Scheme.hs
2020-07-12:  tab control working
2020-07-10:  reached parity (and beyond) with F# lazy Scheme interpreter (modulo some math functions that only return floats)
2020-06-28:  hooked up threepenny-gui
2020-06-15:  single quote implemented
2020-03-13:  initial commit to github
2019-08-23:  resumed prototype (used for guiding F# implementation) after termination from Smartronix (8/20/2019)

-}

{-
to do:
    -> output pane for print statements
    -> canvas for plotting, hookup graphic primitives to interpreter
    -> tab for transcript (that allows saving)
-}

module Scheme
    -- (
    --   evalResults
    -- , heapifyResults
    -- , parseTests
    -- , parseTest'
    -- , strToTok
    -- , ScmObject
    -- , ScmCons
    -- -- , ObjCons
    -- , evalString
    -- , printHeap
    -- , safeCar
    -- , safeCdr
    -- )
    where

import Text.Regex.Posix
import Text.Read
-- import Test.HUnit
import Data.List
-- import Control.Monad.State.Lazy
import Control.Monad.State
import Data.IORef
-- import Data.Aeson
-- import Test.HSpec
import Text.Show.Functions
import Data.Maybe
import Data.Complex

{-
Open question:  if true and false were defined as combinators, the user could define if.

However:  how would you make sure that true is equal to true given that equality of functions is undecidable?

Answer:  yes, equal only cares about structural equality (not semantic equality).

Solution:  keep #t, but behind the scenes make it a curried TRUE combinator.
-}

--to do:

{-

to do:  change Lib.hs to scheme.hs?

to do:  sin, cos, sqrt return only floats; change to return ints (when possible), also return doubles rather than floats

to do:  implement plotting screens; full parity with old program reached (record it in comments before moving on)

to do:  implement a lambda tab (for lambda calculus) and an SKI tab for combinators (possibly an X tab for the X combinator)

    Note:  lambda would have a tokenizer, and would emit lazy Scheme code; therefore no need for alpha reductions (they are handled with environments and bindings)

to do:  begin, equal (useful for creating a test suite)

to do:  refactor numbers:  ObjNumber ScmNumber

to do:  type rational, update math to use type rational, letrec; numeric predicates:  number?, complex?, real?, integer?

to do:  TokComment, TokCommwentBlockStart, TokCommentBlockEnd, TokCrLf

-}

data Token =
    TokComment String |
    TokLeftParen |
    TokRightParen |
    TokDot |
    TokSymbol String |
    TokInteger String |
    TokFloat String |
    TokWhitespace String |
    TokLiteral String |
    TokSingleQuote |
    TokString String
    deriving (Eq, Show)

data ScmNumber =
    NumInt Int |
    NumFloat Double --to do:  change to double

data ScmImm =
    ImmSym String |
    ImmString String |
    ImmRat (Int, Int) |
    ImmInt Int |
    ImmFloat Double |
    ImmComplex (Double, Double)
    deriving (Eq, Show)

--to do:  ScmImm has Symbol, Number, String

data ScmPrimitive = ScmPrimitive
    { priName :: String
    , priFunction :: ScmContext -> ScmObject -> Either [ScmError] ScmObject }
    deriving (Show) --to do:  ad Eq

data ScmClosure = ScmClosure
    { clsCtx :: ScmContext
    , clsParameters :: ScmObject
    , clsBody :: ScmObject }
    deriving (Show)

data ScmObject =
    ObjContext ScmContext |
    ObjSymbol String |
    ObjImmediate ScmImm |
    ObjBlock ScmBlock |
    ObjCons ScmCons |
    ObjError String |
    ObjThunk ScmThunk |
    ObjClosure ScmClosure |
    ObjPrimitive ScmPrimitive
    deriving (Show) --to do:  add Eq

data ScmThunk = ScmThunk
    { thkCtx :: ScmContext
    , thkValue :: ScmObject
    , thkEvaled :: Bool }
    deriving (Show) --to do:  add Eq

data ScmCons = ScmCons
    { scmCar :: ScmObject
    , scmCdr :: ScmObject }
    deriving (Show) --to do:  ad Eq

data ScmError = ScmError
    { errCaller :: String
    , errMessage :: String }
    deriving (Eq, Show)

data ScmBlockType =
    SbtLet |
    SbtLetStar |
    SbtLetRec
    deriving (Eq, Show)

data ScmBlock = ScmBlock
    { blkParent :: Maybe ScmBlock
    , blkType :: ScmBlockType --to do:  maybe remove this
    , blkBindings :: [(String, ScmObject)] }
    deriving (Show)

data ScmContext = ScmContext --to do:  ctx prefix
    { ctxStk :: [ScmBlock]
    , ctxEnv :: [(String, ScmObject)] }
    deriving (Show)

data ScmInterop
    = SopInt Int
    | SopDouble Double
    | SopTuple (Double, Double)
    deriving (Show)

getToken :: [Token] -> (Maybe Token, [Token])
getToken [] = (Nothing, [])
getToken ((TokComment _) : t) = getToken t
getToken ((TokWhitespace _) : t) = getToken t
getToken (h : t) = (Just h, t)

-- type Stack = [Int]

-- test :: State Int Int
-- test = do
--   put 3
--   modify (+1)
--   Control.Monad.State.get

symNil :: ScmObject
symNil = ObjImmediate $ ImmSym "()"

symTrue :: ScmObject
symTrue = ObjImmediate $ ImmSym "#t"

symFalse :: ScmObject
symFalse = ObjImmediate $ ImmSym "#f"

addToCons :: ScmCons -> [ScmObject] -> Maybe ScmCons
addToCons cons [] = Just cons
addToCons cons (h : t) =
    let next =  ScmCons { scmCar = h, scmCdr = ObjCons cons }
    in addToCons next t

createCons :: [ScmObject] -> Maybe ScmCons
createCons [] = Nothing
createCons (h : t) =
    let cons = ScmCons { scmCar = h, scmCdr = symNil }
    in addToCons cons t

createPair :: [ScmObject] -> Maybe ScmCons
createPair [] = Nothing
createPair [h] = Nothing
createPair (h1 : h2 : t) =
    let cons = ScmCons { scmCar = h2, scmCdr = h1 }
    in addToCons cons t

tokNonSemantic :: Token -> Bool
tokNonSemantic (TokWhitespace _) = True
tokNonSemantic (TokComment _) = True
tokNonSemantic _ = False

toksRemoveNonSemantic :: [Token] -> [Token]
toksRemoveNonSemantic = filter $ not . tokNonSemantic

buildHeap :: [Token] -> Either (String, [Token]) (ScmObject, [Token]) --to do:  should be ScmError rather than String
buildHeap [] =
    Left ("out of tokens", [])
buildHeap ((TokSymbol i@('#' : s)) : t) =
    Right (ObjImmediate (ImmSym i), t)
buildHeap ((TokSymbol x) : t) =
    Right (ObjSymbol x, t)
buildHeap (TokSingleQuote : t) =
    case buildHeap t of
        Left (m, t) -> Left (m, t)
        Right (x, t) ->
            case createCons [x, ObjSymbol "quote"] of
                Nothing -> Left ("buildHeap:  failed to create object of a quote", t)
                Just x -> Right (ObjCons x, t)
buildHeap ((TokString x) : t) =
    Right (ObjImmediate $ ImmString x, t)
buildHeap ((TokInteger x) : t) =
    case (readMaybe x :: Maybe Int) of
        Just i -> Right (ObjImmediate $ ImmInt i, t)
        Nothing -> Right (ObjError $ "buildHeap:  parse fail on int:  " ++ x, t)
buildHeap ((TokFloat x) : t) =
    case (readMaybe x :: Maybe Double) of
        Just f -> Right (ObjImmediate $ ImmFloat f, t)
        Nothing -> Right (ObjError $ "buildHeap:  parse fail on float:  " ++ x, t)
buildHeap (TokLeftParen : TokRightParen : t) =
    Right (ObjImmediate $ ImmSym "()", t)
buildHeap (TokLeftParen : t) = --walk across top level list until a right paren is discovered
    let res = iter t []
        iter :: [Token] -> [ScmObject] -> Either (String, [Token]) (ScmCons, [Token])
        iter [] lst =
            Left ("out of tokens", [])
        iter (TokRightParen : t) lst =
            let res = createCons lst in
                case res of
                    Nothing -> Left ("buildHeap:  failure to create cons cells, site 1", t)
                    Just x -> Right (x, t)
        iter (TokDot : t) lst =
            let cdr = buildHeap t in
                case cdr of
                    Right (o, TokRightParen : rst) ->
                        let res = createPair (o : lst) in
                            case res of
                                Nothing -> Left ("buildHeap:  failure to create dotted pair", rst)
                                Just x -> Right (x, rst)
                    _ ->
                        Left ("buildHeap:  bad tail in dotted pair", t)
        iter toks lst =
            case buildHeap toks of
                Left x -> Left x
                Right (o, t) -> iter t (o : lst)
    in
        case res of
            Left (e, t) -> Left ("buildHeap:  failed to create cons cells, site 2", t)
            Right (x, t) -> Right (ObjCons x, t)
buildHeap (TokRightParen : t) = --if this happens, it indicates that a right occurred without a prior left, i.e. )(
    Left ("buildHeap:  right paren before left", t)
buildHeap (TokWhitespace x : t) =
    buildHeap t --this is just in case these aren't filtered out before calling buildHeap
buildHeap (TokComment x : t) =
    buildHeap t --this is just in case these aren't filtered out before calling buildHeap
buildHeap tokens = --this should never happen
    Left ("not implemented", tokens)

printHeap :: ScmObject -> String
printHeap (ObjSymbol x) = x
printHeap (ObjImmediate (ImmSym x)) = x
printHeap (ObjImmediate (ImmInt x)) = show x
printHeap (ObjImmediate (ImmFloat x)) = show x
printHeap (ObjImmediate (ImmString x)) = "\"" ++ x ++ "\""
printHeap (ObjImmediate _) = "#<error:  unknown immediate>"
printHeap (ObjPrimitive ScmPrimitive { priName = nm, priFunction = _ }) = "#<primitive " ++ nm ++ ">"
printHeap (ObjClosure x) = "#<closure>"
printHeap (ObjThunk x) = "#<thunk>"
printHeap (ObjError x) = "#<error>"
printHeap (ObjCons x) = concat $ reverse $ iter ["("] $ ObjCons x where
    iter :: [String] -> ScmObject -> [String]
    iter lst (ObjCons ScmCons { scmCar = h, scmCdr = (ObjImmediate (ImmSym "()")) }) =
        ")" : printHeap h : lst
    iter lst (ObjCons ScmCons { scmCar = h, scmCdr = (ObjCons t) }) = --cdr has more list elements
        iter (" " : printHeap h : lst) (ObjCons t)
    iter lst (ObjCons ScmCons { scmCar = h, scmCdr = t }) = --cdr isn't cons and isn't ()
        ")" : printHeap t : " . " : printHeap h : lst
    iter lst _ = error "unexpected Scheme argument given to printHeap"
printHeap (ObjContext x) = "#<context>"
printHeap x = "#<unknown object type:  " ++ show x ++ ">"

{-
Haskell LISP equivalents of LISP:

cnsCons
cnsHead
cnsTail
cnsNil
-}

scmQuote :: ScmContext -> ScmObject -> Either [ScmError] ScmObject
scmQuote ctx (ObjCons ScmCons { scmCar = h, scmCdr = ObjImmediate (ImmSym "()") }) = Right h
scmQuote _ _ = Left [ ScmError { errCaller = "scmQuote", errMessage = "bad arg" } ]

scmHead :: ScmContext -> ScmObject -> Either [ScmError] ScmObject --to do:  refactor case to equations
scmHead ctx (ObjCons ScmCons { scmCar = h, scmCdr = ObjImmediate (ImmSym "()") }) =
    case eval ctx h of
        Right (ObjCons ScmCons { scmCar = h, scmCdr = _ }) -> Right h
        _ -> Left [ ScmError { errCaller = "head (site 1)", errMessage = "bad arg" } ]
scmHead _ _ = Left [ ScmError { errCaller = "head (site 2)", errMessage = "bad arg" } ]

scmTail :: ScmContext -> ScmObject -> Either [ScmError] ScmObject
scmTail ctx (ObjCons ScmCons { scmCar = h, scmCdr = ObjImmediate (ImmSym "()") }) =
    case eval ctx h of
        Right (ObjCons ScmCons { scmCar = _, scmCdr = t }) -> Right t
        _ -> Left [ ScmError { errCaller = "tail (site 1)", errMessage = "bad arg" } ]
scmTail _ _ = Left [ ScmError { errCaller = "tail (site 2)", errMessage = "bad arg" } ]

scmDefine :: ScmContext -> ScmObject -> Either [ScmError] ScmObject
scmDefine ctx args =
    let arg = Just args
        sym = safeCar arg
        obj = safeCar $ safeCdr arg
    in
        case (sym, obj) of
            (Just (ObjSymbol s), Just o) ->
                let thunks = thunkifyArgList ctx [o]
                    env = filter (\ (l, v) -> l /= s) $ ctxEnv ctx --this needs to be the extended environment
                in
                    if length thunks == 1 && null (ctxStk ctx) then
                        Right $ ObjContext (ScmContext { ctxEnv = (s, head thunks) : env, ctxStk = [] })
                    else
                        Left [ScmError { errCaller = "scmDefine", errMessage = "too many args or not at top level" }]
            _ ->
                Left [ScmError { errCaller = "scmDefine", errMessage = "arguments to define were invalid" }]

scmIf :: ScmContext -> ScmObject -> Either [ScmError] ScmObject
scmIf ctx args =
    let arg = Just args
        cdr1 = safeCdr arg
        cdr2 = safeCdr cdr1
        cdr3 = safeCdr cdr2
        predicate = safeCar arg
        thenClause = safeCar cdr1
        elseClause = safeCar cdr2
    in
        case (predicate, thenClause, elseClause, cdr3) of
            (Just p, Just t, Just e, Just (ObjImmediate (ImmSym "()"))) ->
                case eval ctx p of
                    Right (ObjImmediate (ImmSym "#t")) ->
                        eval ctx t
                    Right (ObjImmediate (ImmSym "#f")) ->
                        eval ctx e
                    Right x ->
                        Left [ScmError { errCaller = "scmIf", errMessage = "invalid predicate:  " ++ show x }]
                    Left x ->
                        Left $ ScmError { errCaller = "scmIf", errMessage = "predicate evaluation failed:  " ++ show p } : x
            _ ->
                let msg = "invalid if:  predicate = " ++ show predicate ++ " then = " ++ show thenClause ++ ", else = " ++ show elseClause in
                    Left [ScmError { errCaller = "scmIf", errMessage = msg }]

scmZero :: ScmContext -> ScmObject -> Either [ScmError] ScmObject
scmZero ctx args =
    let arg = safeCar $ Just args
    in
        case arg of
            Just x ->
                case eval ctx x of
                    Right (ObjImmediate (ImmInt x)) ->
                        if x == 0 then
                            Right symTrue
                        else
                            Right symFalse
                    Right (ObjImmediate (ImmFloat x)) ->
                        if x == 0.0 then
                            Right symTrue
                        else
                            Right symFalse
                    Left x ->
                        Left $ ScmError { errCaller = "scmZero", errMessage = "bad argument:  " ++ show x } : x
                    _ ->
                        Left [ScmError { errCaller = "scmZero", errMessage = "bad argument:  " ++ show x }]
            Nothing ->
                Left [ScmError { errCaller = "scmZero", errMessage = "bad argument:  " ++ show arg }]

scmAdd :: ScmContext -> ScmObject -> Either [ScmError] ScmObject
scmAdd ctx args =
    case cnsToList args of
        Just x ->
            iter x (Just 0, Just 0.0) where
                iter :: [ScmObject] -> (Maybe Int, Maybe Double) -> Either [ScmError] ScmObject
                iter [] (Just i, Just f) = Right $ ObjImmediate $ ImmInt i
                iter [] (Nothing, Just x) = Right $ ObjImmediate $ ImmFloat x
                iter (h : t) (sumi, Just f) =
                    case eval ctx h of
                        Right (ObjImmediate (ImmInt x)) ->
                            case sumi of
                                Just i -> iter t (Just $ i + x, Just $ f + fromIntegral x)
                                _ -> iter t (Nothing, Just $ f + fromIntegral x)
                        Right (ObjImmediate (ImmFloat x)) ->
                            iter t (Nothing, Just $ f + x)
                        Right x ->
                            Left [ScmError { errCaller = "scmAdd", errMessage = "bad argument:  " ++ show h }]
                        Left x ->
                            Left (ScmError { errCaller = "scmAdd", errMessage = "bad argument:  " ++ show h} : x)
                iter _ _ = Left [ScmError { errCaller = "scmAdd", errMessage = "unexpected argument:  " ++ show x }]
        Nothing -> Left [ScmError { errCaller = "scmAdd", errMessage = "bad argument:  " ++ show args }]

scmMul :: ScmContext -> ScmObject -> Either [ScmError] ScmObject
scmMul ctx args =
    case cnsToList args of
        Just x ->
            iter x (Just 1, Just 1.0) where
                iter :: [ScmObject] -> (Maybe Int, Maybe Double) -> Either [ScmError] ScmObject
                iter [] (Just i, Just f) = Right $ ObjImmediate $ ImmInt i
                iter [] (Nothing, Just x) = Right $ ObjImmediate $ ImmFloat x
                iter (h : t) (sumi, Just f) =
                    case eval ctx h of
                        Right (ObjImmediate (ImmInt x)) ->
                            case sumi of
                                Just i -> iter t (Just $ i * x, Just $ f * fromIntegral x)
                                _ -> iter t (Nothing, Just $ f * fromIntegral x)
                        Right (ObjImmediate (ImmFloat x)) ->
                            iter t (Nothing, Just $ f * x)
                        Right x ->
                            Left [ScmError { errCaller = "scmMul", errMessage = "bad argument:  " ++ show h }]
                        Left x ->
                            Left $ ScmError { errCaller = "scmMul", errMessage = "argument caused failure:  " ++ show h } : x
                iter _ _ = Left [ScmError { errCaller = "scmMul", errMessage = "unexpected argument:  " ++ show x }]
        Nothing -> Left [ScmError { errCaller = "scmMul", errMessage = "bad argument:  " ++ show args }]

scmSub :: ScmContext -> ScmObject -> Either [ScmError] ScmObject --plus, minus, times, divide; add, sub, mul, div (to do:  rename to the latter)
scmSub ctx args =
    case cnsToList args of
        Just [] ->
            Left [ScmError { errCaller = "scmSub", errMessage = "arity must be greater than 0" }]
        Just [h] ->
            case eval ctx h of
                Right (ObjImmediate (ImmInt x)) -> Right (ObjImmediate (ImmInt $ negate x))
                Right (ObjImmediate (ImmFloat x)) -> Right (ObjImmediate (ImmFloat $ 0.0 - x))
                _ ->
                    Left [ScmError { errCaller = "scmSub", errMessage = "bad argument:  " ++ show h }]
        Just x@(h : t) -> iter x (Nothing, Nothing) where
            iter :: [ScmObject] -> (Maybe Int, Maybe Double) -> Either [ScmError] ScmObject
            iter [] (Just i, Just f) = Right $ ObjImmediate $ ImmInt i
            iter [] (Nothing, Just x) = Right $ ObjImmediate $ ImmFloat x
            iter (h : t) (resi, resf) =
                case eval ctx h of
                    Right (ObjImmediate (ImmInt x)) ->
                        case (resi, resf) of
                            (Nothing, Nothing) -> iter t (Just x, Just $ fromIntegral x)
                            (Just i, Just f) -> iter t (Just $ i - x, Just $ f - fromIntegral x)
                            (Nothing, Just f) -> iter t (Nothing, Just $ f - fromIntegral x)
                            _ -> Left [ScmError { errCaller = "scmSub", errMessage = "unexpected arguments:  " ++ show (resi, resf) }]
                    Right (ObjImmediate (ImmFloat x)) ->
                        case (resi, resf) of
                            (Nothing, Nothing) -> iter t (Nothing, Just x)
                            (_, Just f) -> iter t (Nothing, Just $ f - x)
                            _ -> Left [ScmError { errCaller = "scmSub", errMessage = "bad argument:  " ++ show (resi, resf) }]
                    Right x ->
                        Left [ScmError { errCaller = "scmSub", errMessage = "bad argument:  " ++ show h }]
                    Left x ->
                        Left $ ScmError { errCaller = "scmSub", errMessage = "bad argument:  " ++ show x } : x
            iter _ _ = Left [ScmError { errCaller = "scmSub", errMessage = "unexpected argument to scmSub" }]
        Nothing ->
            Left [ScmError { errCaller = "scmSub", errMessage = "bad argument:  " ++ show args }]

divOp :: ScmNumber -> ScmNumber -> ScmNumber
divOp (NumInt x) (NumInt y) =
    let (quotient, remainder) = x `quotRem` y
    in
        if remainder == 0 then
            NumInt quotient
        else
            let q = fromIntegral quotient
                r = fromIntegral remainder
                divisor = fromIntegral y
            in
                NumFloat $ q + (r / divisor)
divOp (NumInt x) (NumFloat y) =
    NumFloat (fromIntegral x / y)
divOp (NumFloat x) (NumInt y) =
    NumFloat (x / fromIntegral y)
divOp (NumFloat x) (NumFloat y) =
    NumFloat (x / y)

scmDiv :: ScmContext -> ScmObject -> Either [ScmError] ScmObject
scmDiv ctx args = --to do:  maybe not convert to a Haskell list (adds overhead), and maybe create ObjNumber to remove numbers from ObjImmediate
    case cnsToList args of
        Just [] ->
            Left [ScmError { errCaller = "scmDiv", errMessage = "arity must be greater than 0" }]
        Just [h] ->
            case eval ctx h of
                Right (ObjImmediate (ImmInt x)) ->
                    case divOp (NumInt 1) (NumInt x) of
                        NumInt x -> Right $ ObjImmediate $ ImmInt x
                        NumFloat x -> Right $ ObjImmediate $ ImmFloat x
                _ ->
                    Left [ScmError { errCaller = "scmDiv", errMessage = "bad argument (site 1):  " ++ show h }]
        Just x@(h : t) -> iter x Nothing where
            iter :: [ScmObject] -> Maybe ScmNumber -> Either [ScmError] ScmObject
            iter [] (Just (NumFloat x)) = Right $ ObjImmediate $ ImmFloat x
            iter [] (Just (NumInt x)) = Right $ ObjImmediate $ ImmInt x
            iter (h : t) Nothing =
                case eval ctx h of
                    Right (ObjImmediate (ImmInt x)) ->
                        iter t (Just (NumInt x))
                    Right (ObjImmediate (ImmFloat x)) ->
                        iter t (Just (NumFloat x))
                    Right x ->
                        Left [ScmError { errCaller = "scmDiv", errMessage = "bad argument (site 2):  " ++ show h }]
                    Left x ->
                        Left $ ScmError { errCaller = "scmDiv", errMessage = "bad argument (site 3):  " ++ show x } : x
            iter (h : t) (Just n@(NumFloat f)) =
                case eval ctx h of
                    Right (ObjImmediate (ImmInt x)) ->
                        iter t (Just (divOp n (NumFloat (fromIntegral x)))) --(Just (NumFloat $ f / (fromIntegral x)))
                    Right (ObjImmediate (ImmFloat x)) ->
                        iter t (Just (divOp n (NumFloat x)))
                    Right x ->
                        Left [ScmError { errCaller = "scmDiv", errMessage = "bad argument (site 4):  " ++ show h }]
                    Left x ->
                        Left $ ScmError { errCaller = "scmDiv", errMessage = "bad argument (site 5):  " ++ show x } : x
            iter (h : t) (Just n@(NumInt i)) =
                case eval ctx h of
                    Right (ObjImmediate (ImmInt x)) ->
                        iter t $ Just $ divOp n $ NumInt x
                    Right (ObjImmediate (ImmFloat x)) ->
                        iter t $ Just $ divOp n $ NumFloat x
                    Right x ->
                        Left [ScmError { errCaller = "scmDiv", errMessage = "bad argument (site 4):  " ++ show h }]
                    Left x ->
                        Left $ ScmError { errCaller = "scmDiv", errMessage = "bad argument (site 5):  " ++ show x } : x
            iter _ _ = Left [ScmError { errCaller = "scmDiv", errMessage = "unexpected arguments to scmDiv:  " ++ show h }]
        Nothing ->
            Left [ScmError { errCaller = "scmDiv", errMessage = "bad argument:  " ++ show args }]

evalCar :: ScmContext -> ScmObject -> Either [ScmError] ScmObject
evalCar ctx args =
    case safeCar $ Just args of
        Just x ->
            eval ctx x
        Nothing ->
            Left [ScmError { errCaller = "safeEval", errMessage = "bad args:  " ++ show args }]

scmSin :: ScmContext -> ScmObject -> Either [ScmError] ScmObject --never returns an int (unlike Scheme)
scmSin ctx args =
    case evalCar ctx args of
        Right (ObjImmediate (ImmInt x)) ->
            Right $ ObjImmediate $ ImmFloat $ sin $ fromIntegral x
        Right (ObjImmediate (ImmFloat x)) ->
            Right $ ObjImmediate $ ImmFloat $ sin x
        Right x ->
            Left [ScmError { errCaller = "scmSin", errMessage = "bad argument:  " ++ show x }]
        Left x -> Left $ ScmError { errCaller = "scmSin", errMessage = "evaluation failed" } : x

-- scmSin :: ScmContext -> ScmObject -> Either [ScmError] ScmObject
-- scmSin ctx args =
--     case (evalCar ctx args) of
--         Right (ObjImmediate (ImmInt x)) ->
--             let (arg :: Int) = x
--                 (res :: Float) = sin arg
--             in
--                 case (res) of
--                     0.0 -> Right $ ObjImmediate $ ImmInt 0
--                     1.0 -> Right $ ObjImmediate $ ImmInt 1
--                     (-1.0) -> Right $ ObjImmediate $ ImmInt (-1)
--                     x -> Right $ ObjImmediate $ ImmFloat $ fromIntegral x
--         Right (ObjImmediate (ImmFloat x)) ->
--             case (sin x) of
--                 0.0 -> Right $ ObjImmediate $ ImmInt 0
--                 1.0 -> Right $ ObjImmediate $ ImmInt 1
--                 (-1.0) -> Right $ ObjImmediate $ ImmInt (-1)
--                 x -> Right $ ObjImmediate $ ImmFloat x
--         Right x ->
--             Left [ScmError { errCaller = "scmSin", errMessage = "bad argument:  " ++ (show x) }]
--         Left x -> Left $ ScmError { errCaller = "scmSin", errMessage = "evaluation failed" } : x

scmCos :: ScmContext -> ScmObject -> Either [ScmError] ScmObject --never returns an int (unlike Scheme)
scmCos ctx args =
    case evalCar ctx args of
        Right (ObjImmediate (ImmInt x)) ->
            Right $ ObjImmediate $ ImmFloat $ cos $ fromIntegral x
        Right (ObjImmediate (ImmFloat x)) ->
            Right $ ObjImmediate $ ImmFloat $ cos x
        Right x ->
            Left [ScmError { errCaller = "scmCos", errMessage = "bad argument:  " ++ show x }]
        Left x -> Left $ ScmError { errCaller = "scmCos", errMessage = "evaluation failed" } : x

scmSqrt :: ScmContext -> ScmObject -> Either [ScmError] ScmObject --never returns an int (unlike Scheme)
scmSqrt ctx args =
    case evalCar ctx args of
        Right (ObjImmediate (ImmInt x)) ->
            Right $ ObjImmediate $ ImmFloat $ sqrt $ fromIntegral x
        Right (ObjImmediate (ImmFloat x)) ->
            Right $ ObjImmediate $ ImmFloat $ sqrt x
        Right x ->
            Left [ScmError { errCaller = "scmSqrt", errMessage = "bad argument:  " ++ show x }]
        Left x -> Left $ ScmError { errCaller = "scmSqrt", errMessage = "evaluation failed" } : x

scmNull :: ScmContext -> ScmObject -> Either [ScmError] ScmObject
scmNull ctx args =
    let arg = safeCar $ Just args in
        case arg of
            Just x ->
                case eval ctx x of
                    Right (ObjImmediate (ImmSym "()")) ->
                        Right symTrue
                    Right (ObjCons x) ->
                        Right symFalse
                    Left x ->
                        Left $ ScmError { errCaller = "scmNull", errMessage = "bad argument:  " ++ show x } : x
                    _ ->
                        Left [ScmError { errCaller = "scmNull", errMessage = "bad argument:  " ++ show x }]
            Nothing ->
                Left [ScmError { errCaller = "scmNull", errMessage = "bad argument:  " ++ show arg }]

scmConstructor :: ScmContext -> ScmObject -> Either [ScmError] ScmObject
scmConstructor ctx args =
    let arg = Just args
        el = safeCar arg
        lst = safeCar $ safeCdr arg
    in
        case (el, lst) of --should cons evaluate its argument?
            (Just e, Just l) ->
                let arg1 = eval ctx e
                    arg2 = eval ctx l
                in
                    case (arg1, arg2) of
                        (Right e, Right l) ->
                            Right $ ObjCons ScmCons { scmCar = e, scmCdr = l }
                        (Left e, Left l) ->
                            Left $ concat [[ScmError { errCaller = "scmConstructor", errMessage = "eval of args failed" }], e, l]
                        (Left e, Right l) ->
                            Left $ ScmError { errCaller = "scmConstructor", errMessage = "eval of arg1 failed" } : e
                        (Right e, Left l) ->
                            Left $ ScmError { errCaller = "scmConstructor", errMessage = "eval of arg2 failed" } : l
            _ ->
                Left [ScmError { errCaller = "scmConstructor", errMessage = "arguments to cons were invalid" }]

createLetBindings :: ScmContext -> ScmObject -> Either [ScmError] [(String, ScmObject)]
createLetBindings ctx obj = iter obj [] where
    iter :: ScmObject -> [(String, ScmObject)] -> Either [ScmError] [(String, ScmObject)]
    iter (ObjImmediate (ImmSym "()")) res = Right $ reverse res
    iter (ObjCons c@ScmCons { scmCar = h, scmCdr = t }) res =
        case cnsToList h of
            Just [ObjSymbol l, o] ->
                iter t $ (l, head $ thunkifyArgList ctx [o]) : res
            Nothing ->
                Left [ ScmError { errCaller = "createLetBindings", errMessage = "bad arguments:  " ++ show c }]
            _ -> Left [ ScmError { errCaller = "createLetBindings", errMessage = "unexpected arguments" }]
    iter _ _ =  Left [ ScmError { errCaller = "createLetBindings", errMessage = "unexpected arguments" }]

scmLet :: ScmContext -> ScmObject -> Either [ScmError] ScmObject
scmLet ctx args =
    let arg = Just args
        bindings = safeCar arg
        body = safeCar $ safeCdr arg
    in case (bindings, body) of
        (Just p, Just b) ->
            let stk = ctxStk ctx
                env = ctxEnv ctx
                parent = if null stk then Nothing else Just $ head stk
                bindings = createLetBindings ctx p
            in case bindings of
                Right p ->
                    let blk = ScmBlock { blkBindings = p, blkParent = parent, blkType = SbtLet } --create block
                    in
                        if length (nub (fmap fst p)) == length p then
                            eval (ScmContext { ctxStk = blk : stk, ctxEnv = env }) b
                        else
                            Left [ ScmError { errCaller = "scmLet", errMessage = "duplicate bindings are not allowed in let" } ]
                Left e ->
                    Left $ ScmError { errCaller = "scmLet", errMessage = "failure on binding creation"} : e
        (Nothing, Nothing) ->
            Left [ ScmError { errCaller = "scmLet", errMessage = "bad bindings:  " ++ show bindings ++ ", bad body:  " ++ show body } ]
        (Just p, Nothing) ->
            Left [ ScmError { errCaller = "scmLet", errMessage = "bad body:  " ++ show body } ]
        (Nothing, Just b) ->
            Left [ ScmError { errCaller = "scmLet", errMessage = "bad bindings:  " ++ show bindings } ]

--this one requires creating a reverse list of bindings and doing tails of it

{-

(let* ((x 1) ; bindings = []
       (y (+ x 1))) bindings = [x]
    (+ x y)) ; => 3

Prelude Data.List> take 2 $ reverse $ tails $ reverse [("x", 1), ("y", 2)]
[[],[("x",1)]]

eval stk = [("x", 1), ("y", 2)]

data ScmThunk = ScmThunk
    { thkCtx :: ScmContext
    , thkValue :: ScmObject
    , thkEvaled :: Bool }
    deriving (Show) --to do:  add Eq

data ScmBlock = ScmBlock
    { blkParent :: Maybe ScmBlock
    , blkType :: ScmBlockType
    , blkBindings :: [(String, ScmObject)] }
    deriving (Show)

data ScmContext = ScmContext --to do:  ctx prefix
    { ctxStk :: [ScmBlock]
    , ctxEnv :: [(String, ScmObject)] }
    deriving (Show)

thunkifyArgList :: ScmContext -> [ScmObject] -> [ScmObject] --thunkify anything that isn't immediate
thunkifyArgList ctx args = recur args where
    recur :: [ScmObject] -> [ScmObject]
    recur [] = []
    recur (h : t) =
        case h of
            i@(ObjImmediate x) -> i : ( recur t)
            otherwise -> (ObjThunk ScmThunk { thkCtx = ctx, thkEvaled = False, thkValue = h }) : (recur t)

createLetBindings :: ScmContext -> ScmObject -> Either [ScmError] [(String, ScmObject)] --assumes same context for every element
createLetBindings ctx obj = iter obj [] where
    iter :: ScmObject -> [(String, ScmObject)] -> Either [ScmError] [(String, ScmObject)]
    iter (ObjImmediate (ImmSym "()")) res = Right $ reverse res
    iter (ObjCons c@(ScmCons { scmCar = h, scmCdr = t })) res =
        case (cnsToList h) of
            Just (ObjSymbol l : o : []) ->
                iter t $ (l, head $ thunkifyArgList ctx [o]) : res
            Nothing ->
                Left [ ScmError { errCaller = "createLetBindings", errMessage = "bad arguments:  " ++ (show c)}]

-}

--to do:  strategy:  need a function to create unthunkified bindindings, so that they bindings can be thunkified later?

--need thunkify that takes in a list of [(String, ScmObject)]

--
thunkifyArgs :: [ScmContext] -> [ScmObject] -> [ScmObject]
thunkifyArgs = undefined

createBindings :: ScmContext -> Maybe ScmObject -> Maybe [(String, ScmObject)] --Either [ScmError] [(String, ScmObject)]
createBindings ctx obj = --returns a list of tuples of labels + thunkified objects
    case obj of
        Just o ->
            undefined
        Nothing ->
            undefined

createContexts :: ScmContext -> Maybe [(String, ScmObject)] -> Maybe [ScmContext]
createContexts parent bindings = undefined

createLetStarBindings :: ScmContext -> ScmObject -> Either [ScmError] [(String, ScmObject)]
createLetStarBindings ctx obj = iter obj [] ctx where
    iter :: ScmObject -> [(String, ScmObject)] -> ScmContext -> Either [ScmError] [(String, ScmObject)]
    iter (ObjImmediate (ImmSym "()")) res ctx = Right $ reverse res
    iter (ObjCons c@ScmCons { scmCar = h, scmCdr = t }) res ctx =
        case cnsToList h of
            Just [ObjSymbol l, o] ->
                if null res then
                    iter t ((l, head $ thunkifyArgList ctx [o]) : res) ctx
                else
                    let stk = ctxStk ctx
                        parent = if null stk then Nothing else Just $ head stk
                        blk = ScmBlock { blkBindings = res, blkParent = parent, blkType = SbtLetStar }
                        newCtx = ScmContext { ctxEnv = ctxEnv ctx, ctxStk = [blk] }
                    in
                        iter t ((l, head $ thunkifyArgList newCtx [o]) : res) newCtx
            Just _ -> Left [ ScmError { errCaller = "createLetStarBindings", errMessage = "unexpected let star bindings" }]
            Nothing ->
                Left [ ScmError { errCaller = "createLetStarBindings", errMessage = "bad arguments:  " ++ show c}]
    iter _ _ _ = Left [ ScmError { errCaller = "createLetStarBindings", errMessage = "unexpected arguments" }]

scmLetStar :: ScmContext -> ScmObject -> Either [ScmError] ScmObject
scmLetStar ctx args =
    -- let arglst = Just args
    --     contexts = Nothing
    --     -- contexts = createContexts ctx bindings
    --     bindings = createBindings ctx $ safeCar arglst --must create bindinds and collect the contexts
    --     body = safeCar $ safeCdr arglst
    --     stk = ctxStk ctx
    --     env = ctxEnv ctx
    --     parent = if (null stk) then Nothing else Just $ head stk
    -- in
    --     undefined
    let arg = Just args
        bindings = safeCar arg
        body = safeCar $ safeCdr arg
    in case (bindings, body) of
        (Just p, Just b) ->
            let stk = ctxStk ctx
                env = ctxEnv ctx
                parent = if null stk then Nothing else Just $ head stk
                bindings = createLetStarBindings ctx p
            in case bindings of
                Right p ->
                    let blk = ScmBlock { blkBindings = p, blkParent = parent, blkType = SbtLet } --create block
                    in
                        eval (ScmContext { ctxStk = blk : stk, ctxEnv = env }) b
                Left e ->
                    Left $ ScmError { errCaller = "scmLetStar", errMessage = "failure on binding creation"} : e
        (Nothing, Nothing) ->
            Left [ ScmError { errCaller = "scmLetStar", errMessage = "bad bindings:  " ++ show bindings ++ ", bad body:  " ++ show body } ]
        (Just p, Nothing) ->
            Left [ ScmError { errCaller = "scmLetStar", errMessage = "bad body:  " ++ show body } ]
        (Nothing, Just b) ->
            Left [ ScmError { errCaller = "scmLetStar", errMessage = "bad bindings:  " ++ show bindings } ]

thunkifyRecArgs :: ScmContext -> [ScmObject] -> [ScmObject] --thunkify anything that isn't immediate
thunkifyRecArgs ctx = recur where
    recur :: [ScmObject] -> [ScmObject]
    recur [] = []
    recur (h : t) =
        case h of
            i@(ObjImmediate x) ->
                i : recur t
            _ ->
                ObjThunk ScmThunk { thkCtx = ctx, thkEvaled = False, thkValue = h } : recur t

createLetRecBindings :: ScmContext -> ScmObject -> Either [ScmError] [(String, ScmObject)]
createLetRecBindings ctx obj = iter obj [] ctx where
    iter :: ScmObject -> [(String, ScmObject)] -> ScmContext -> Either [ScmError] [(String, ScmObject)]
    iter (ObjImmediate (ImmSym "()")) res ctx = Right $ reverse res
    iter (ObjCons c@ScmCons { scmCar = h, scmCdr = t }) res ctx =
        case cnsToList h of
            Just [ObjSymbol l, o] ->
                if null res then
                    iter t ((l, head $ thunkifyRecArgs ctx [o]) : res) ctx
                else
                    let stk = ctxStk ctx
                        parent = if null stk then Nothing else Just $ head stk
                        blk = ScmBlock { blkBindings = res, blkParent = parent, blkType = SbtLetStar }
                        newCtx = ScmContext { ctxEnv = ctxEnv ctx, ctxStk = [blk] }
                    in
                        iter t ((l, head $ thunkifyArgList newCtx [o]) : res) newCtx
            Just _ -> Left [ ScmError { errCaller = "", errMessage = "unexpected argument" }]
            Nothing ->
                Left [ ScmError { errCaller = "createLetRecBindings", errMessage = "bad arguments:  " ++ show c}]
    iter _ _ _ = Left [ ScmError { errCaller = "createLetRecBindings", errMessage = "unexpected arguments" }]

scmLetRec :: ScmContext -> ScmObject -> Either [ScmError] ScmObject
scmLetRec ctx args =
    let arg = Just args
        bindings = safeCar arg
        body = safeCar $ safeCdr arg
    in case (bindings, body) of
        (Just p, Just b) ->
            let stk = ctxStk ctx
                env = ctxEnv ctx
                parent = if null stk then Nothing else Just $ head stk
                bindings = createLetRecBindings ctx p
            in case bindings of
                Right p ->
                    let blk = ScmBlock { blkBindings = p, blkParent = parent, blkType = SbtLet } --create block
                    in
                        eval (ScmContext { ctxStk = blk : stk, ctxEnv = env }) b
                Left e ->
                    Left $ ScmError { errCaller = "scmLetStar", errMessage = "failure on binding creation"} : e
        (Nothing, Nothing) ->
            Left [ ScmError { errCaller = "scmLetStar", errMessage = "bad bindings:  " ++ show bindings ++ ", bad body:  " ++ show body } ]
        (Just p, Nothing) ->
            Left [ ScmError { errCaller = "scmLetStar", errMessage = "bad body:  " ++ show body } ]
        (Nothing, Just b) ->
            Left [ ScmError { errCaller = "scmLetStar", errMessage = "bad bindings:  " ++ show bindings } ]

-- scmLetRec :: ScmContext -> ScmObject -> Either [ScmError] ScmObject
-- scmLetRec ctx args =
--     let arg = Just args
--         bindings = safeCar arg
--         body = safeCar $ safeCdr arg
--     in case (bindings, body) of
--         (Just p, Just b) ->
--             let stk = ctxStk ctx
--                 env = ctxEnv ctx
--                 parent = if (null stk) then Nothing else Just $ head stk
--                 bindings = createLetBindings ctx p
--             in case bindings of
--                 Right p ->
--                     let --self = ScmBlock { blkBindings = p, blkParent = Just parent, blkType = SbtLetRec }
--                         blk = ScmBlock { blkBindings = p, blkParent = parent, blkType = SbtLetRec }
--                     in
--                         eval (ScmContext { ctxStk = blk : stk, ctxEnv = env }) b
--                 Left e ->
--                     Left $ ScmError { errCaller = "scmLet", errMessage = "failure on binding creation"} : e
--         (Nothing, Nothing) ->
--             Left [ ScmError { errCaller = "scmLet", errMessage = "bad bindings:  " ++ (show bindings) ++ ", bad body:  " ++ (show body) } ]
--         (Just p, Nothing) ->
--             Left [ ScmError { errCaller = "scmLet", errMessage = "bad body:  " ++ (show body) } ]
--         (Nothing, Just b) ->
--             Left [ ScmError { errCaller = "scmLet", errMessage = "bad bindings:  " ++ (show bindings) } ]

lazyEvalArgs :: ScmContext -> [ScmObject] -> Either [ScmError] [ScmObject] --returns reversed list of evaluated items
lazyEvalArgs ctx args = iter args [] where
    iter :: [ScmObject] -> [ScmObject] -> Either [ScmError] [ScmObject]
    iter [] res = Right res
    iter (h : t) res =
        case eval ctx h of
            Right x -> iter t $ x : res
            Left x -> Left $ ScmError { errCaller = "lazyEvalArgs", errMessage = "evaluation failed for:  " ++ show x } : x

revListToCons :: [ScmObject] -> ScmObject
revListToCons (h : t) = iter t $ ObjCons $ ScmCons { scmCar = h, scmCdr = ObjImmediate $ ImmSym "()" } where
    iter :: [ScmObject] -> ScmObject -> ScmObject
    iter [] obj = obj
    iter (h : t) obj =
        iter t $ ObjCons $ ScmCons { scmCar = h, scmCdr = obj }
revListToCons [] = ObjError "unexpected argument to revListToCons:  []"

scmList :: ScmContext -> ScmObject -> Either [ScmError] ScmObject
scmList ctx args =
    if isNil args then
        Right symNil
    else
        case cnsToList args of
            Just x ->
                case lazyEvalArgs ctx x of
                    Right x -> Right $ revListToCons x
                    Left x ->
                        Left $ ScmError { errCaller = "scmList", errMessage = "evaluation of args failed = " ++ show args } : x
            Nothing ->
                Left [ ScmError { errCaller = "scmList", errMessage = "bad args:  " ++ show args } ]

globalEnv :: [(String, ScmObject)] --lambda isn't a primitive; but let, let*, and letrec are
globalEnv =
    [ ("quote", ObjPrimitive ScmPrimitive { priName = "quote", priFunction = scmQuote })
    , ("head", ObjPrimitive ScmPrimitive { priName = "head", priFunction = scmHead })
    , ("tail", ObjPrimitive ScmPrimitive { priName = "tail", priFunction = scmTail })
    , ("define", ObjPrimitive ScmPrimitive { priName = "define", priFunction = scmDefine })
    , ("if", ObjPrimitive ScmPrimitive { priName = "if", priFunction = scmIf })
    , ("zero?", ObjPrimitive ScmPrimitive { priName = "zero?", priFunction = scmZero })
    , ("+", ObjPrimitive ScmPrimitive { priName = "+", priFunction = scmAdd })
    , ("-", ObjPrimitive ScmPrimitive { priName = "-", priFunction = scmSub })
    , ("*", ObjPrimitive ScmPrimitive { priName = "*", priFunction = scmMul })
    , ("/", ObjPrimitive ScmPrimitive { priName = "/", priFunction = scmDiv })
    , ("sin", ObjPrimitive ScmPrimitive { priName = "sin", priFunction = scmSin })
    , ("cos", ObjPrimitive ScmPrimitive { priName = "cos", priFunction = scmCos })
    , ("sqrt", ObjPrimitive ScmPrimitive { priName = "sqrt", priFunction = scmSqrt })
    , ("null?", ObjPrimitive ScmPrimitive { priName = "null?", priFunction = scmNull })
    , ("cons", ObjPrimitive ScmPrimitive { priName = "cons", priFunction = scmConstructor })
    , ("let", ObjPrimitive ScmPrimitive { priName = "let", priFunction = scmLet })
    , ("let*", ObjPrimitive ScmPrimitive { priName = "let*", priFunction = scmLetStar })
    , ("letrec", ObjPrimitive ScmPrimitive { priName = "letrec", priFunction = scmLetRec })
    , ("list", ObjPrimitive ScmPrimitive { priName = "list", priFunction = scmList })
    ]

findLabel :: [(String, ScmObject)] -> String -> Maybe ScmObject
findLabel env sym =
    let tgt = find (\ (lbl, value) -> lbl == sym) env in
        case tgt of
            Just (_, x) -> Just x
            Nothing -> Nothing

findLabelInBlock :: [(String, ScmObject)] -> String -> Maybe ScmBlock -> Maybe ScmObject
findLabelInBlock gbl lbl = iter where
    iter :: Maybe ScmBlock -> Maybe ScmObject
    iter Nothing = findLabel gbl lbl --find in the global env
    iter (Just ScmBlock { blkParent = p, blkBindings = b, blkType = t} ) =
        case findLabel b lbl of
            o@(Just _) -> o
            Nothing -> iter p --try my parent (to do:  create recursive lookup that doesn't try parent, instead tries recursive environment)

findLabelInContext :: ScmContext -> String -> Maybe ScmObject
findLabelInContext ScmContext { ctxStk = [], ctxEnv = e } lbl = findLabel e lbl
--to do:  add equation that checks for a recursive function so that it can first look in its own environment
findLabelInContext ScmContext { ctxStk = (h : _), ctxEnv = e } lbl = findLabelInBlock e lbl $ Just h

findGlobal :: String -> Maybe ScmObject --to do:  remove this
findGlobal = findLabel globalEnv

--to do:  create a show-internals that will show internals of a closure (etc.)

--to do:  use fmap to make these simpler

{-
Prelude> fmap (+1) (Just 3)
Just 4
-}

--to do:  change scmCar to cnsCar and scmCdr to cnsCdr?

isNil :: ScmObject -> Bool
isNil (ObjImmediate (ImmSym "()")) = True
isNil _ = False

car :: ScmObject -> Maybe ScmObject
car (ObjCons ScmCons { scmCar = h, scmCdr = _ }) = Just h
car _ = Nothing

cdr :: ScmObject -> Maybe ScmObject
cdr (ObjCons ScmCons { scmCar = _, scmCdr = t }) = Just t
cdr _ = Nothing

safeCar :: Maybe ScmObject -> Maybe ScmObject
safeCar (Just x) = car x
safeCar Nothing = Nothing

safeCdr :: Maybe ScmObject -> Maybe ScmObject
safeCdr (Just x) = cdr x
safeCdr Nothing = Nothing

eval :: ScmContext -> ScmObject -> Either [ScmError] ScmObject
eval ctx n@(ObjImmediate _) = Right n
eval ctx (ObjSymbol x) =
    case findLabelInContext ctx x of
        Just o -> eval ctx o
        Nothing -> Left [ ScmError { errCaller = "eval", errMessage = "symbol lookup failed:  " ++ x ++ ", ctx = " ++ show ctx } ]
eval ctx p@(ObjPrimitive _) = Right p
eval ctx (ObjCons n@ScmCons { scmCar = ObjSymbol "lambda", scmCdr = t }) =
    let args = safeCar $ Just t
        body = safeCar $ safeCdr $ Just t
        ScmContext { ctxEnv = e, ctxStk = s } = ctx
    in
        case (args, body) of
            (Just a, Just b) ->
                Right (ObjClosure (ScmClosure { clsCtx = ctx, clsParameters = a, clsBody = b }))
            _ ->
                Left [ ScmError { errCaller = "eval", errMessage = "bad args or body" }]
eval ctx (ObjCons n@ScmCons { scmCar = h, scmCdr = t }) =
    case eval ctx h of
        Left l -> Left (ScmError { errCaller = "eval", errMessage = "bad function " } : l)
        Right x -> apply ctx x t
eval ctx (ObjThunk ScmThunk { thkCtx = c, thkEvaled = e, thkValue = v }) =
    let stk = ctxStk c --stack comes from thunk
        env = ctxEnv ctx --env comes from eval (which has the latest version of the global env)
        ectx = ScmContext { ctxStk = stk, ctxEnv = env }
    in eval ectx v
eval ctx c@(ObjClosure _) = Right c
eval ctx (ObjError e) = Left [ ScmError { errCaller = "eval", errMessage = e }]
eval _ obj = Left [ ScmError { errCaller = "eval", errMessage = "could not evaluate " ++ show obj }]

--to do?  create cnsToRevList that doesn't reverse the list, have cnsToList call it

cnsToRevList :: ScmObject -> Maybe [ScmObject]
cnsToRevList x = iter x [] where --lesson learned:  calling without the prime can result in a curried result (not intended!)
    iter :: ScmObject -> [ScmObject] -> Maybe [ScmObject]
    iter (ObjImmediate (ImmSym "()")) result = Just result
    iter (ObjCons ScmCons { scmCar = h, scmCdr = t}) result = iter t (h : result)
    iter _ _ = Nothing

cnsToList :: ScmObject -> Maybe [ScmObject]
cnsToList x =
    case cnsToRevList x of
        Just x -> Just $ reverse x
        Nothing -> Nothing

thunkifyArgList :: ScmContext -> [ScmObject] -> [ScmObject] --thunkify anything that isn't immediate
thunkifyArgList ctx = recur where
    recur :: [ScmObject] -> [ScmObject]
    recur [] = []
    recur (h : t) =
        case h of
            i@(ObjImmediate x) -> i : recur t
            _ -> ObjThunk ScmThunk { thkCtx = ctx, thkEvaled = False, thkValue = h } : recur t

symbolsToLabels :: [ScmObject] -> [String]
symbolsToLabels lst = iter lst [] where
    iter :: [ScmObject] -> [String] -> [String]
    iter [] res = reverse res
    iter ((ObjSymbol x) : t) res = iter t (x : res)
    iter (_ : t) res = iter t res

apply :: ScmContext -> ScmObject -> ScmObject -> Either [ScmError] ScmObject
apply ctx (ObjPrimitive ScmPrimitive { priName = nm, priFunction = fct }) args = fct ctx args
apply ctx (ObjClosure ScmClosure { clsBody = body, clsCtx = ctxOfClosure, clsParameters = params }) args =
    let arglst = cnsToList args
        paramlst = cnsToList params
        ScmContext { ctxStk = parent, ctxEnv = env } = ctxOfClosure
    in
        case (arglst, paramlst) of
            (Just a, Just p) ->
                let labels = symbolsToLabels p
                    len = length a
                in
                    if len == length labels && len == length p then
                        let bindings = zip labels $ thunkifyArgList ctx a --create bindings, zip params with thunkified args
                            p = if null parent then Nothing else Just (head parent)
                            blk = ScmBlock { blkBindings = bindings, blkParent = p, blkType = SbtLet } --create block
                        in
                            if length (nub (fmap fst bindings)) == length bindings then
                                eval (ScmContext { ctxStk = blk : parent, ctxEnv = env }) body
                            else
                                Left [ ScmError { errCaller = "apply", errMessage = "duplicate bindings are not allowed in lambdas" } ]
                    else
                        Left [ ScmError { errCaller = "apply", errMessage = "closure not implemented yet, and params <> args in length" } ]
            _ -> Left [ ScmError { errCaller = "apply", errMessage = "unexpected argument" } ]
apply ctx f args = Left [ ScmError { errCaller = "apply", errMessage = "bad function " ++ show f } ]

symbolChars :: String
symbolChars =
    ['a'..'z'] ++
    ['A'..'Z'] ++
    ['0'..'9'] ++
    "-_.~>=+&*^%!@#$:?<>/"

whitespaceChars :: String
whitespaceChars = " \r\n\t"

isSymbolChar :: Char -> Bool
isSymbolChar c = c `elem` symbolChars

isWhitespace :: Char -> Bool
isWhitespace x = x `elem` whitespaceChars

parseLeftParen :: String -> (Maybe Token, String)
parseLeftParen [] = (Nothing, [])
parseLeftParen s =
    if head s == '('
    then (Just TokLeftParen, tail s)
    else (Nothing, s)

tokParseLeftParen :: String ->Either String (Maybe Token, String)
tokParseLeftParen s = Right $ parseLeftParen s

parseRightParen :: String -> (Maybe Token, String)
parseRightParen [] = (Nothing, [])
parseRightParen s =
    if head s == ')'
    then (Just TokRightParen, tail s)
    else (Nothing, s)

tokParseRightParen :: String -> Either String (Maybe Token, String)
tokParseRightParen s = Right $ parseRightParen s

parseSingleQuote :: String -> (Maybe Token, String)
parseSingleQuote [] = (Nothing, [])
parseSingleQuote s =
    if head s == '\''
    then (Just TokSingleQuote, tail s)
    else (Nothing, s)

tokParseSingleQuote :: String -> Either String (Maybe Token, String)
tokParseSingleQuote s = Right $ parseSingleQuote s

parseInteger :: String -> (Maybe Token, String)
parseInteger s =
    let m = s =~ "^[+|-]?[[:digit:]]+" :: String in
    if m == ""
    then (Nothing, s)
    else (Just (TokInteger m), drop (length m) s)

parseFloat :: String -> (Maybe Token, String)
parseFloat s =
    let m = s =~ "^[+|-]?[[:digit:]]+[.][[:digit:]]*" :: String in
        if m == ""
        then (Nothing, s)
        else (Just (TokFloat m), drop (length m) s)

-- let schemeParseComplex c =
--     let pat = "([+|-]{0,1}[0-9]*[.]*[0-9]+)([+|-]{1}[0-9]*[.]*[0-9]*)[i]"
--     if Regex.IsMatch (c, pat) then
--         let r = Regex pat
--         let s = r.Match c
--         let n = s.Groups
--         if n.Count = 3 then
--             let real = n.[1]
--             let imag = n.[2]
--             let s, v = Double.TryParse real.Value
--             let real = if s then Some v else None
--             let s, v = Double.TryParse imag.Value
--             let imag = if s then Some v else None
--             if real.IsSome && imag.IsSome then
--                 Some (complex real.Value imag.Value)
--             else
--                 None
--         else None
--     else
--         None

--not sure this is needed

schemeParseComplex :: String -> Maybe (Complex Double)
schemeParseComplex c =
    let m = c =~ "([+|-]{0,1}[0-9]*[.]*[0-9]+)([+|-]{1}[0-9]*[.]*[0-9]*)[i]" :: String
    in
        if m == ""
        then Nothing
        else
            undefined

parseDot :: String -> (Maybe Token, String)
parseDot [] = (Nothing, [])
parseDot s =
    if head s == '.'
    then (Just TokDot, tail s)
    else (Nothing, s)

parseSymbol :: String -> (Maybe Token, String)
parseSymbol [] = (Nothing, [])
parseSymbol s =
    let sym = takeWhile isSymbolChar s in
        if sym == ""
        then (Nothing, s)
        else (Just (TokSymbol sym), drop (length sym) s)

parseAtom :: String -> (Maybe Token, String)
parseAtom [] = (Nothing, [])
parseAtom s = parseAtom' [parseDot, parseFloat, parseInteger] s

parseAtom' :: [String -> (Maybe Token, String)] -> String -> (Maybe Token, String) --to do:  refactor to equations
parseAtom' [] s = parseSymbol s
parseAtom' (h : t) s =
    let tok = h s
        toks = snd tok
    in
        case fst tok of
            Nothing -> parseAtom' t s
            Just x ->
                if not (null toks) && elem (head toks) symbolChars then
                    parseSymbol s --to do:  don't parse from start, just parse from beyond this point?
                else
                    tok

tokParseAtom :: String -> Either String (Maybe Token, String)
tokParseAtom s = Right $ parseAtom s

parseWhitespace :: String -> (Maybe Token, String)
parseWhitespace [] = (Nothing, [])
parseWhitespace s =
    let sym = takeWhile isWhitespace s
    in
        if sym == "" then (Nothing, s)
        else (Just (TokWhitespace sym), drop (length sym) s)

tokParseWhitespace :: String -> Either String (Maybe Token, String)
tokParseWhitespace s = Right $ parseWhitespace s

parseComment :: String -> (Maybe Token, String)
parseComment [] = (Nothing, [])
parseComment s =
    if head s == ';' then
        let tok = takeWhile (/= '\n') (tail s) in
        (Just (TokComment tok), drop (length tok + 1) s)
    else
        (Nothing, s)

tokParseComment :: String -> Either String (Maybe Token, String)
tokParseComment s = Right $ parseComment s

takeFromWhile :: String -> (Char -> Bool) -> (String, String)
takeFromWhile s p = iter s [] where
    iter s acc
        | null s = (reverse acc, [])
        | p $ head s = iter (tail s) (head s : acc)
        | otherwise = (reverse acc, s)

parseString :: String -> Either String (Maybe Token, String)
parseString [] = Right (Nothing, [])
parseString s =
    if head s == '\"' then
        let close = elemIndex '\"' $ tail s in
            case close of
                Nothing -> Left "unterminated string"
                Just x -> Right (Just $ TokString $ take x $ drop 1 $ s, drop (x + 2) s)
        -- let (str, rst) = takeFromWhile (tail s) (/='"')
        -- in
        --     if rst == [] then Left "unterminated string"
        --     else Right (Just $ TokString str, tail rst)
    else Right (Nothing, s)

tokParseFunctions :: [String -> Either String (Maybe Token, String)]
tokParseFunctions =
    [ tokParseComment
    , tokParseLeftParen
    , tokParseRightParen
    , tokParseSingleQuote
    , tokParseWhitespace
    , tokParseAtom
    , parseString ]

tokParse :: String -> Either String [Token]
tokParse [] = Right []
tokParse s = parse' tokParseFunctions s [] where
    parse' :: [String -> Either String (Maybe Token, String)] -> String -> [Token] -> Either String [Token]
    parse' [] s tokens = Left $ "tokParse:  unparsable expression:  " ++ s --should this just return tokens?
    parse' parsers [] tokens = Right $ reverse tokens
    parse' parsers s tokens = --undefined
        let res = head parsers s in
            case res of
                Right (Nothing, y) -> parse' (tail parsers) y tokens
                Right (Just x, y) -> parse' tokParseFunctions y (x : tokens)
                Left x -> Left x

strToTokens :: String -> Either (ScmError, String) [Token]
strToTokens [] = Right []
strToTokens s = iter tokParseFunctions s [] where
    iter :: [String -> Either String (Maybe Token, String)] -> String -> [Token] -> Either (ScmError, String) [Token]
    iter [] s tokens = Left (ScmError { errCaller = "strToTokens", errMessage = "unparsable expression:  " ++ s }, s)
    iter parsers [] tokens = Right $ reverse tokens
    iter parsers s tokens =
        case head parsers s of
            Right (Nothing, y) -> iter (tail parsers) y tokens
            Right (Just x, y) -> iter tokParseFunctions y (x : tokens)
            Left e -> Left (ScmError { errCaller = "strToTokens", errMessage = e }, s)

strToTok :: String -> String
strToTok s =
    let res = tokParse s
    in
        case res of
            Left x -> "error:  " ++ x
            Right x -> "success:  " ++ show x

strToHeaps :: String -> Either ([ScmError], [Token]) [ScmObject]
strToHeaps x =
    case strToTokens x of
        Right x -> iter [] (toksRemoveNonSemantic x) where
            iter :: [ScmObject] -> [Token] -> Either ([ScmError], [Token]) [ScmObject]
            iter res [] = Right $ reverse res
            iter res toks =
                case buildHeap toks of
                    Right (o, t) -> iter (o : res) t
                    Left (s, t) -> Left ( [ScmError { errCaller = "strToHeaps", errMessage = s}], t)
        Left (e, t) -> Left (ScmError { errCaller = "strToHeaps", errMessage = "tokenization failed, can't build heaps" } : [e], [])

evalHeaps :: ScmContext -> [ScmObject] -> Either [ScmError] [(ScmObject, ScmObject)] --the tuple is (before, after) evaluations
evalHeaps ctx lst = iter ctx lst [] where
    iter :: ScmContext -> [ScmObject] -> [(ScmObject, ScmObject)] -> Either [ScmError] [(ScmObject, ScmObject)]
    iter ctx [] res = Right $ reverse res
    iter ctx (h : t) res =
        case eval ctx h of
            Right x@(ObjContext c) -> iter c t $ (h, x) : res
            Right x -> iter ctx t $ (h, x) : res
            Left x -> Left (ScmError { errCaller = "evalHeaps", errMessage = "failed in evaluating " ++ show h } : x)

evalString :: String -> Either [ScmError] [ScmObject]
evalString str =
    case strToHeaps str of
        Right x ->
            case evalHeaps (ScmContext { ctxStk = [], ctxEnv = globalEnv }) x of
                Right x ->
                    Right $ fmap snd x
                Left x -> Left x
        Left (e, t) -> Left e

evalResults :: String -> String
evalResults str =
    case strToHeaps str of
        Right x ->
            case evalHeaps (ScmContext { ctxStk = [], ctxEnv = globalEnv }) x of
                Right x ->
                    intercalate "\r\n" $ fmap (\ (_, r) -> printHeap r) x
                Left x -> show x
        Left x -> show x

heapifyResults :: String -> String
heapifyResults str =
    case strToHeaps str of
        -- Right x -> concat $ intersperse "\r\n" $ fmap printHeap x
        Right x -> intercalate "\r\n" $ fmap printHeap x
        Left x -> show x

listToCons :: [ScmObject] -> ScmObject
listToCons fcall = revListToCons $ reverse fcall

scmApply :: ScmObject -> [ScmObject] -> Either [ScmError] ScmObject
scmApply func args =
    let fcall = listToCons $ func : args
        evaled = evalHeaps (ScmContext { ctxStk = [], ctxEnv = globalEnv }) [fcall]
    in
        case evaled of
            Right r ->
                let (_, f) = last r
                in Right f
            Left x -> Left $ reverse x

toScheme :: ScmInterop -> ScmObject
toScheme (SopInt i) = ObjImmediate $ ImmInt i
toScheme (SopDouble d) = ObjImmediate $ ImmFloat d
toScheme (SopTuple (x, y)) =
    let tup = ObjCons $ ScmCons { scmCar = ObjImmediate $ ImmFloat x, scmCdr = ObjImmediate $ ImmFloat y }
    in listToCons [ObjSymbol "quote", tup] --to do:  does this need to be added?

scmScalarToDouble :: ScmObject -> Maybe Double
scmScalarToDouble (ObjImmediate (ImmInt x)) = Just $ fromIntegral x
scmScalarToDouble (ObjImmediate (ImmFloat x)) = Just x
scmScalarToDouble _ = Nothing

fmScheme :: ScmObject -> Maybe ScmInterop
fmScheme (ObjImmediate (ImmInt i)) = Just $ SopInt i
fmScheme (ObjImmediate (ImmFloat f)) = Just $ SopDouble f
fmScheme (ObjCons ScmCons { scmCar = x, scmCdr = y }) =
    case (scmScalarToDouble x, scmScalarToDouble y) of
        (Just h, Just t) -> Just $ SopTuple (h, t)
        (Nothing, Nothing) -> Nothing
        (Nothing, Just _) -> Nothing
        (Just _, Nothing) -> Nothing
fmScheme x = Nothing

{-
need test for unterminated string
need to create function for paren checking using fold and returns a tuple (current, highest, lefts, rights, errorMaybe); maybe already done a different way
need backup
-}

parseTests =
    [ ("car", [TokSymbol "car"])
    , ("(car '(a b c))", [TokLeftParen,TokSymbol "car",TokWhitespace " ",TokSingleQuote,TokLeftParen,TokSymbol "a",TokWhitespace " ",TokSymbol "b",TokWhitespace " ",TokSymbol "c",TokRightParen,TokRightParen])
    , ("(car '(a b . c))", [TokLeftParen,TokSymbol "car",TokWhitespace " ",TokSingleQuote,TokLeftParen,TokSymbol "a",TokWhitespace " ",TokSymbol "b",TokWhitespace " ",TokDot,TokWhitespace " ",TokSymbol "c",TokRightParen,TokRightParen])
    , ("(car '(234324fsdfds-sdfdsfsdf3.5))", [TokLeftParen,TokSymbol "car",TokWhitespace " ",TokSingleQuote,TokLeftParen,TokSymbol "234324fsdfds-sdfdsfsdf3.5",TokRightParen,TokRightParen])
    , ("(car (cdr (cons '(-3. . +5) (cons 4.5 23423432))))",
        [TokLeftParen
        ,TokSymbol "car"
        ,TokWhitespace " "
        ,TokLeftParen,TokSymbol "cdr"
        ,TokWhitespace " "
        ,TokLeftParen
        ,TokSymbol "cons"
        ,TokWhitespace " "
        ,TokSingleQuote
        ,TokLeftParen,TokFloat "-3."
        ,TokWhitespace " "
        ,TokDot,TokWhitespace " "
        ,TokInteger "+5"
        ,TokRightParen
        ,TokWhitespace " "
        ,TokLeftParen
        ,TokSymbol "cons"
        ,TokWhitespace " "
        ,TokFloat "4.5"
        ,TokWhitespace " "
        ,TokInteger "23423432"
        ,TokRightParen
        ,TokRightParen
        ,TokRightParen
        ,TokRightParen])
    , ( "(car '(\"a\" \"b\" \"c\"))"
      , [TokLeftParen, TokSymbol "car", TokWhitespace " ", TokSingleQuote, TokLeftParen, TokString "a", TokWhitespace " ", TokString "b", TokWhitespace " ", TokString "c", TokRightParen, TokRightParen])
    , ( "(car '(\"sdfdsfds\" 3 arsd\"sd()fdsf\"))"
      , [TokLeftParen,TokSymbol "car",TokWhitespace " ",TokSingleQuote,TokLeftParen,TokString "sdfdsfds",TokWhitespace " ",TokInteger "3",TokWhitespace " ",TokSymbol "arsd",TokString "sd()fdsf",TokRightParen,TokRightParen])
    , ( "(define foo'(sdfsdf.sdfsdfds sdfds\"dsfdsf\" 3 -3 \"fdsfdsf()dfssdf)\" abc(sd sd d)))"
      , [TokLeftParen,TokSymbol "define",TokWhitespace " ",TokSymbol "foo",TokSingleQuote,TokLeftParen,TokSymbol "sdfsdf.sdfsdfds",TokWhitespace " ",TokSymbol "sdfds",TokString "dsfdsf",TokWhitespace " ",TokInteger "3",TokWhitespace " ",TokInteger "-3",TokWhitespace " ",TokString "fdsfdsf()dfssdf)",TokWhitespace " ",TokSymbol "abc",TokLeftParen,TokSymbol "sd",TokWhitespace " ",TokSymbol "sd",TokWhitespace " ",TokSymbol "d",TokRightParen,TokRightParen,TokRightParen])
    , ( "(define foo'(sdfsdf.sdfsdfds sdfds\"dsfdsf\" 3 -3 \"fdsf'dsf()dfssdf)\" abc(sd sd d)))"
      , [TokLeftParen,TokSymbol "define",TokWhitespace " ",TokSymbol "foo",TokSingleQuote,TokLeftParen,TokSymbol "sdfsdf.sdfsdfds",TokWhitespace " ",TokSymbol "sdfds",TokString "dsfdsf",TokWhitespace " ",TokInteger "3",TokWhitespace " ",TokInteger "-3",TokWhitespace " ",TokString "fdsf'dsf()dfssdf)",TokWhitespace " ",TokSymbol "abc",TokLeftParen,TokSymbol "sd",TokWhitespace " ",TokSymbol "sd",TokWhitespace " ",TokSymbol "d",TokRightParen,TokRightParen,TokRightParen])
    ]

-- assertBool :: String -> Bool -> Assertion
-- assertBool msg b = unless b (assertFailure msg)

-- testEmpty = TestCase $ assertEqual
--   "Should get Nothing from an empty string" Nothing ( Just "5" )

-- parseTest :: [(String, [Token])] -> [((String, [Token]), [Token])]
-- parseTest [] = []
-- parseTest p = foldl (\acc x -> let res = parse (fst x) in if res == (snd x) then acc else ((x, res) : acc)) [] p

parseTest' :: [(String, [Token])] -> [((String, [Token]), [Token])]
parseTest' [] = []
parseTest' p = foldl (\acc x ->
    let res = tokParse (fst x) in
        case res of
            Right r ->
                if r == snd x then acc else (x, r) : acc
            Left l ->
                (x, []) : acc) [] p

tokTest =
    [ TokComment "hey"
    , TokLeftParen
    , TokRightParen ]

someFunc :: IO ()
someFunc = do
    -- print $ execState test 0
    -- putStrLn $ show $ tokParse "(define foo'(sdfsdf.sdfsdfds sdfds\"dsfdsf\" 3 -3 \"fdsf'dsf()dfssdf)\" abc(sd sd d)))"
    -- putStrLn $ show $ elemIndex 'a' "cat"
    -- putStrLn $ show $ parseFloat "-3."
    -- putStrLn $ show $ parseInteger "33"
    -- putStrLn $ show $ parseLeftParen "("
    -- putStrLn $ show $ parseString "\"cat\""
    -- putStrLn $ show $ tokParse "(car '(\"a\"))"
    --runTestTT testEmpty
--     putStrLn $ show $ parse ";ok\n\
-- \(let ((TRUE (lambda (x) (lambda (y) x)))\
--       \(FALSE (lambda (x) (lambda (y) y))))\
--   \(let ((IF (lambda (p) (lambda (t) (lambda (e) (((p t) e)))))))\
--         \(((IF FALSE) (lambda () 1)) (lambda () 2))))"
    -- let foo = tester parseTests in
    -- -- assertBool "It should be true" True
    -- -- assertBool "It should be true" False
    -- -- assertBool "It should be true (again)" False
    -- -- testEmpty
    -- -- putStrLn (p1)
    -- -- assertBool "test 1" ((parse "(car '(234324fsdfds-sdfdsfsdf3.5))") == "(car '(234324fsdfds-sdfdsfsdf3.5))")
    -- -- putStrLn $ show p1
    -- -- assertBool "test1" $ p1 == [LeftParen,Symbol "car",Whitespace " ",SingleQuote,LeftParen,Symbol "a",Whitespace " ",Symbol "b",Whitespace " ",Symbol "c",RightParen,RightParen]
    -- -- putStrLn $ show $ parse "car"
    -- -- putStrLn $ show p11
    -- -- putStrLn $ show "hey \"you\""
    -- -- putStrLn $ show $ Symbol "car" == (Symbol "car")
    -- -- putStrLn $ show $ (show p0) == "[Symbol \"car\"]"
    -- -- assertBool "test1" $ s1 == "[LeftParen, Symbol \"car\"]"
    -- -- putStrLn $ show [Symbol "car", Symbol "cdr"]
    -- -- assertBool "test0" $ p0 == [Symbol "car"]
    -- -- assertBool "test11" $ p11 == [LeftParen,Symbol "car",Whitespace " ",SingleQuote,LeftParen,Symbol "234324fsdfds-sdfdsfsdf3.5",RightParen,RightParen]
    -- putStrLn $ show $ parseTest parseTests
    -- putStrLn $ show $ fac 5
    print $ parseTest' parseTests
    print $ getToken tokTest
    print $ buildHeap [TokString "hey"]
    -- putStrLn $ show $ buildHeap [TokLeftParen, TokSymbol "a", TokSymbol "b", TokSymbol "c", TokRightParen]
    print $  buildHeap [TokLeftParen, TokSymbol "a", TokLeftParen, TokSymbol "b", TokRightParen, TokSymbol "c", TokRightParen]
    -- let x = readMaybe "3" :: Integer
    -- putStrLn $ show $ readMaybe "3" :: Integer
    -- putStrLn $ show $ printHeap $ ObjAtom $ AtmSymbol "hey"
    -- putStrLn $ show $ printHeap $ buildHeap [TokLeftParen, TokSymbol "a", TokLeftParen, TokSymbol "b", TokRightParen, TokSymbol "c", TokRightParen]
    let Right (x, _) = buildHeap [TokLeftParen, TokSymbol "a", TokLeftParen, TokSymbol "b", TokRightParen, TokSymbol "c", TokRightParen] in
        print $ printHeap x
    let Right (x, _) = buildHeap [TokLeftParen, TokSymbol "a", TokSymbol "b", TokSymbol "c", TokRightParen] in
        print $ printHeap x
    putStrLn "(a . c) = "
    let Right (x, _) = buildHeap [TokLeftParen, TokSymbol "a", TokDot, TokSymbol "c", TokRightParen] in
        print x
    let Right (x, _) = buildHeap [TokLeftParen, TokSymbol "a", TokDot, TokSymbol "c", TokRightParen] in
        print $ printHeap x
    putStrLn "(a b . c) = "
    let Right (x, _) = buildHeap [TokLeftParen, TokSymbol "a", TokSymbol "b", TokDot, TokSymbol "c", TokRightParen] in
        print $ printHeap x
    let Right (x, _) = buildHeap [TokLeftParen, TokSymbol "a", TokLeftParen, TokSymbol "b", TokSymbol "c", TokRightParen, TokSymbol "d", TokRightParen] in
        print $ printHeap x
    let Right (x, _) = buildHeap [TokSingleQuote, TokSymbol "a"] in
        print $ printHeap x
    let Right (x, _) = buildHeap [TokFloat "3.5"] in
        let Right y = eval (ScmContext { ctxStk = [], ctxEnv = []}) x  in
            print $ printHeap y
    putStrLn "done"

{--
to do:  block comments
--}

{--
*Main> parse "(car '(234324fsdfds-sdfdsfsdf3.5))"
[LeftParen,Symbol "car",Whitespace " ",SingleQuote,LeftParen,Symbol "234324fsdfds-sdfdsfsdf3.5",RightParen,RightParen]

*Main Text.Regex.Posix> parse "(car (cdr (cons '(-3. . +5) (cons 4.5 23423432))))"
[LeftParen,Symbol "car",Whitespace " ",LeftParen,Symbol "cdr",Whitespace " ",LeftParen,Symbol "cons",Whitespace " ",SingleQuote,LeftParen,Float "-3.",Whitespace " ",Dot,Whitespace " ",Integer "+5",RightParen,Whitespace " ",LeftParen,Symbol "cons",Whitespace " ",Float "4.5",Whitespace " ",Integer "23423432",RightParen,RightParen,RightParen,RightParen]

*Main> tokenize "(car '(\"sdfdsfds\" 3 arsd\"sd()fdsf\"))"
[LeftParen,Atom "car",SingleQuote,LeftParen,Str "sdfdsfds",Whitespace " ",Atom "3",Atom "arsd",Str "sd()fdsf",RightParen,RightParen]

*Main> tokenize "(define foo'(sdfsdf.sdfsdfds sdfds\"dsfdsf\" 3 -3 \"fdsfdsf()dfssdf)\" abc(sd sd d)))"
[LeftParen,Atom "define",SingleQuote,Atom "foo",Atom "sdfsdf.sdfsdfds",Atom "sdfds",Str "dsfdsf",Whitespace " ",Atom "3",Atom "-3",Str "fdsfdsf()dfssdf)",Whitespace " ",Atom "abc",Atom "sd",Atom "sd",Atom "d",RightParen,RightParen]

*Main> tokenize "(define foo'(sdfsdf.sdfsdfds sdfds\"dsfdsf\" 3 -3 \"fdsf'dsf()dfssdf)\" abc(sd sd d)))"
[LeftParen,Atom "define",Atom "foo",SingleQuote,LeftParen,Atom "sdfsdf.sdfsdfds",Atom "sdfds",Str "dsfdsf",Whitespace " ",Atom "3",Atom "-3",Str "fdsf'dsf()dfssdf)",Whitespace " ",Atom "abc",Atom "sd",Atom "sd",Atom "d",RightParen,RightParen]
--}

max_stars_repo_name: avanmeul/PlottingAndSchemingHaskell

max_issues_repo_name: avanmeul/PlottingAndSchemingHaskell

max_forks_repo_name: avanmeul/PlottingAndSchemingHaskell


text:
{-# LANGUAGE FlexibleContexts, TemplateHaskell #-}

module School.FileIO.Test.Source
( sourceTest ) where

import Conduit ((.|), ConduitM, MonadResource, runConduit, sinkList, yield)
import Control.Monad.Except (MonadError)
import Data.ByteString (ByteString)
import Data.ByteString.Conversion (toByteString')
import Data.Either (isLeft, isRight)
import Data.Monoid ((<>))
import School.FileIO.AppIO (AppIO, runAppIO)
import School.FileIO.ConduitHeader (conduitHeader)
import School.FileIO.FileHeader (FileHeader(..))
import School.FileIO.Source
import School.TestUtils (def, dummyList, dummyMatrix)
import School.Types.Decoding (binToMatrixDouble)
import School.Types.Encoding (doubleToBin)
import School.Types.Error (Error)
import School.Types.DataType (DataType(..), getSize)
import School.Types.LiftResult (LiftResult(..))
import Numeric.LinearAlgebra.Data (Matrix)
import Test.Tasty (TestTree)
import Test.Tasty.QuickCheck
import Test.Tasty.TH
import Test.QuickCheck.Monadic (PropertyM, assert, monadicIO, pre, run)

matrixDoubleSource :: (LiftResult m, MonadError Error m, MonadResource m)
                   => FileHeader
                   -> FilePath
                   -> ConduitM () (Matrix Double) m ()
matrixDoubleSource = source

testHeader :: FileHeader
           -> ByteString
           -> PropertyM IO (Either String [ByteString])
testHeader header byteString = run . runAppIO . runConduit $
  yield byteString .| conduitHeader header .| sinkList

poolMatrixDouble :: Positive Int
                 -> Positive Int
                 -> ConduitM ByteString (Matrix Double) AppIO ()
poolMatrixDouble (Positive r) (Positive c) =
  let trans = liftResult . binToMatrixDouble DBL64B r c
      size = getSize DBL64B
  in pool (r * c * size) trans

testMatrix :: Positive Int
           -> Positive Int
           -> ByteString
           -> PropertyM IO (Either String [Matrix Double])

testMatrix pr pc bytes = run . runAppIO . runConduit $
    yield bytes
 .| poolMatrixDouble pr pc
 .| sinkList

prop_accepts_header :: DataType -> Positive Int -> Property
prop_accepts_header name (Positive n) =
  monadicIO $ do
    let h = FileHeader name n n
    result <- testHeader h (toByteString' h)
    assert $ isRight result

prop_preserves_rest :: String -> Property
prop_preserves_rest content =
  monadicIO $ do
    pre $ content /= ""
    let h = def
    let bContent = toByteString' content
    let bytes = toByteString' h <> bContent
    result <- testHeader h bytes
    assert $ result == Right [bContent]

prop_rejects_wrong_separator :: Char -> String -> Property
prop_rejects_wrong_separator separator content =
  monadicIO $ do
    pre $ separator /= '#'
    let bytes = toByteString' separator <> toByteString' content
    result <- testHeader def bytes
    assert $ isLeft result

prop_rejects_wrong_header :: DataType
                          -> DataType
                          -> Positive Int
                          -> Positive Int
                          -> Positive Int
                          -> Positive Int
                          -> Property
prop_rejects_wrong_header name1
                          name2
                          (Positive n1)
                          (Positive n2)
                          (Positive n3)
                          (Positive n4) =
  monadicIO $ do
    pre $ name1 /= name2
       || mod n3 n1 /= 0
       || n2 /= n4
    let h1 = FileHeader name1 n1 n2
    let h2 = FileHeader name2 n3 n4
    result <- testHeader h1 (toByteString' h2)
    assert $ isLeft result

encodeDoubles :: [Double] -> ByteString
encodeDoubles = foldMap doubleToBin

prop_read_double_matrix :: Positive Int
                      -> Positive Int
                      -> Property
prop_read_double_matrix pr@(Positive r) pc@(Positive c) =
  monadicIO $ do
    let bytes = encodeDoubles $ dummyList r c
    matrix <- testMatrix pr pc bytes
    assert $ matrix == Right [dummyMatrix r c]

prop_read_two_double_matrices :: Positive Int
                           -> Positive Int
                           -> Property
prop_read_two_double_matrices pr@(Positive r) pc@(Positive c) =
  monadicIO $ do
    let list = dummyList r c
    let bytes = encodeDoubles $ list <> list
    matrices <- testMatrix pr pc bytes
    let check = dummyMatrix r c
    assert $ matrices == Right [check, check]

prop_read_with_extra :: Positive Int
                   -> Positive Int
                   -> Property
prop_read_with_extra pr@(Positive r) pc@(Positive c) =
  monadicIO $ do
    pre $ c > 1
    let extra = encodeDoubles [3]
    let bytes = encodeDoubles $ dummyList r c
    matrix <- testMatrix pr pc (bytes <> extra)
    assert $ isLeft matrix

prop_read_3x3_matrix :: Property
prop_read_3x3_matrix = monadicIO $ do
  let h = FileHeader DBL64B 3 3
  let path = "test/data/matrix3x3.sm"
  stack <- run . runAppIO . runConduit $
    matrixDoubleSource h path .| sinkList
  assert $ stack == Right [dummyMatrix 3 3]

prop_read_3x3_matrix_twice :: Property
prop_read_3x3_matrix_twice = monadicIO $ do
  let h = FileHeader DBL64B 3 3
  let path = "test/data/matrix3x3Twice.sm"
  stack <- run . runAppIO . runConduit $
    matrixDoubleSource h path .| sinkList
  let mat = dummyMatrix 3 3
  assert $ stack == Right [mat, mat]

sourceTest :: TestTree
sourceTest = $(testGroupGenerator)

ext: hs

max_stars_repo_name: jfulseca/School

max_issues_repo_name: jfulseca/School

max_forks_repo_name: jfulseca/School


text:
module Lib.Utility.Differentiation (
    numericalGradient
 ) where

import Numeric.LinearAlgebra
import Numeric.LinearAlgebra.Devel

h = 1e-4

type F = X -> Double
type X = Matrix Double
numericalGradient :: F -> X -> X
numericalGradient f xs = runSTMatrix $ do
    xs' <- thawMatrix xs
    let (rows, columns) = size xs
    let grad = newMatrix 0 rows columns
    let allIndex = [(r,c) | r <- [0..rows-1], c <- [0..columns-1]]
    foldr (\(r, c) grad -> do
        x <- readMatrix xs' r c
        grad' <- grad
        writeMatrix xs' r c $ x+h
        xs'' <- freezeMatrix xs'
        let fxHPlus = f xs''
        writeMatrix xs' r c $ x-h
        xs'' <- freezeMatrix xs'
        let fxHMinus = f xs''
        let delta = (fxHPlus - fxHMinus) / (2 * h)
        writeMatrix xs' r c x
        writeMatrix grad' r c delta
        return grad'
        ) grad allIndex


text:
{-# LANGUAGE ConstraintKinds        #-}
{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE KindSignatures         #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE UndecidableInstances   #-}

module Numeric.Optimization.TwoPhase.Tableau
    ( -- * Tableaus
      Tableau
    , IsTableau
    , mkPhaseI
    , mkPhaseII
    , maximizeEntering
    , maximizeOptimal
    , minimizeEntering
    , minimizeOptimal
    , phaseIEntering
    , phaseIOptimal
    , tableauInfeasible
    , tableauLeaving
    , tableauResult
    , tableauStep
    ) where

import           Data.Finite                                    (Finite)
import qualified Data.List as List
import           Data.Maybe                                     (fromJust)
import           Data.Ord                                       (comparing)
import qualified Data.Vector.Sized as Vec
import qualified Data.Vector.Storable.Sized as SVec
import           GHC.TypeLits
import           Numeric.LinearAlgebra                          (Extractor(..), (??))
import qualified Numeric.LinearAlgebra as LA
import           Numeric.LinearAlgebra.Static                   (L)
import qualified Numeric.LinearAlgebra.Static as LS
import qualified Numeric.LinearAlgebra.Static.Vector as LS
import           Text.Printf                                    (printf)
import           Unsafe.Coerce                                  (unsafeCoerce)

import           Numeric.Optimization.Problem
import           Numeric.Optimization.TwoPhase.Tableau.Build
import           Numeric.Optimization.TwoPhase.Tableau.Pivot
import           Numeric.Optimization.TwoPhase.Tableau.VarMap
import           Numeric.Optimization.TwoPhase.Types

type IsTableau p v s a c =
    ( KnownNat v
    , KnownNat s
    , KnownNat a
    , KnownNat c
    , KnownNat (Rows p c)
    , KnownNat (Cols p v s a)
    )

data Tableau (p :: Phase) (d :: Direction) v s a c =
    Tableau
        { varMap :: VarMap (Rows p c) (Cols p v s a)
        , table  :: L (Rows p c) (Cols p v s a)
        }

instance (IsTableau p v s a c) => Show (Tableau p d v s a c) where
    show (Tableau vs x) = unlines (cols : rows)
      where
        cols        = concatMap (printf "%8s" . show)
            . Vec.toList $ columnVars vs

        rows        = zipWith (printf "%s   %s") rowVals rowNames
        rowVals     = lines . LA.format "" (printf "%8.2f") $ LS.unwrap x
        rowNames    = Vec.toList . Vec.map show $ rowVars vs

mkPhaseI
    :: (IsTableau 'PhaseI v s a c)
    => Problem d v s a c
    -> Tableau 'PhaseI d v s a c
mkPhaseI x =
    Tableau (mkVarMap x) (mkTable x)

mkPhaseII
    :: forall d v s a c.
        ( IsTableau 'PhaseI  v s a c
        , IsTableau 'PhaseII v s a c
        )
    => Tableau 'PhaseI  d v s a c
    -> Tableau 'PhaseII d v s a c
mkPhaseII (Tableau vs x) =
    Tableau (VarMap newRows newColumns) newMatrix
  where
    newRows     = Vec.tail . unsafeCoerce $ rowVars vs

    newColumns  =
        let is = fromJust $ Vec.fromList indices
        in  Vec.backpermute (columnVars vs) is

    newMatrix   =
        let xs = LS.unwrap x ?? (Drop 1, Pos (LA.idxs indices))
        in  fromJust $ LS.create xs

    indices     = fromIntegral <$> findIndicesColumns isPhaseII vs
    isPhaseII n = n /= Objective PhaseI && not (isArtificial n)

-- Read the value associated with a variable in the tableau. If the variable is
-- in the basis (has a row in the tableau), it's value is the value in the RHS
-- of that row divided by the value in the variable's column in that row. If
-- the variable is not in the basis it has a value of 0 (non-basic).
--
readValue
    :: (IsTableau p v s a c)
    => VarName
    -> Tableau p d v s a c
    -> Double
readValue n (Tableau vs x) =
    case (valRowIx, valColIx, rhsColIx) of
        (Just i,  Just j, Just r) -> index (i, r) x / index (i, j) x
        (Nothing, Just _, Just _) -> 0
        _                         -> error "readValue: Variable not in tableau"
  where
    valRowIx    = elemIndexRows n vs
    valColIx    = elemIndexColumns n vs
    rhsColIx    = elemIndexColumns RHS vs

-- Read the value associated with the current objective and each decision
-- variable, and store them in the Vars type for this solver. This is what is
-- returned when optimization succeeds.
--
tableauResult
    :: (IsTableau p v s a c)
    => Tableau p d v s a c
    -> TwoPhaseResult d v
tableauResult x =
    TwoPhaseResult . Vec.zip names $ Vec.map toValue names
  where
    toValue i   = readValue i x
    names       = fromJust . Vec.fromList . findColumns isVar $ varMap x

    isVar n     =
        let objective = indexColumns 0 (varMap x)
        in  n == objective || isDecision n

-- A phase I tableau is infeasible if the value of the objective function is
-- greater than 0. This means that at least one artificial variable has to be
-- non-zero, so there can be no feasible BFS to start phase II from.
--
tableauInfeasible
    :: (IsTableau 'PhaseI v s a c)
    => Tableau 'PhaseI d v s a c
    -> Bool
tableauInfeasible x
    | phaseIOptimal x   = readValue (Objective PhaseI) x /= 0
    | otherwise         = False

-- A tableau is optimal if the given test passes for each cell corresponding to
-- a variable (everything apart from columns for objectives and the RHS column)
-- in the current objective.
--
tableauOptimal
    :: (IsTableau p v s a c)
    => (Double -> Bool)
    -> Tableau p d v s a c
    -> Bool
tableauOptimal f (Tableau vs x) =
    SVec.and . SVec.imap optimal . LS.rVec . head . Vec.toList $ LS.lRows x
  where
    coeffs                  = findIndicesColumns isCoeff vs
    isCoeff                 = not . isSpecial

    optimal i a
        | i `elem` coeffs   = f a
        | otherwise         = True

-- A phase I problem is always a minimization. This is a separate function
-- from 'minimizeOptimal' as the problem being solved in phase II may not be
-- a minimization problem.
--
phaseIOptimal
    :: (IsTableau 'PhaseI v s a c)
    => Tableau 'PhaseI d v s a c
    -> Bool
phaseIOptimal =
    tableauOptimal (<= 0)

-- A phase II problem which is a maximization is optimal when all coefficients
-- in the objective function are non-negative.
--
maximizeOptimal
    :: (IsTableau 'PhaseII v s a c)
    => Tableau 'PhaseII 'Max v s a c
    -> Bool
maximizeOptimal =
    tableauOptimal (>= 0)

-- A phase I problem which is a minimization is optimal when all coefficients
-- in the objective function are non-negative.
--
minimizeOptimal
    :: (IsTableau 'PhaseII v s a c)
    => Tableau 'PhaseII 'Min v s a c
    -> Bool
minimizeOptimal =
    tableauOptimal (<= 0)

-- The entering variable is the lowest indexed variable where the value in the
-- objective column passes a test, and the name of the variable passes another
-- test. The tests change depending on the phase, and whether the optimization
-- is a maximization or a minimization.
--
enteringVar
    :: (IsTableau p v s a c)
    => (Finite (Cols p v s a) -> Bool)
    -> (VarName -> Bool)
    -> Tableau p d v s a c
    -> Either TwoPhaseError (Finite (Cols p v s a))
enteringVar validCol validVar (Tableau vs _) =
    case filter canEnter columns of
        [] -> Left NoEntering
        xs -> Right . fst $ List.minimumBy (comparing snd) xs
  where
    canEnter (j, n) = validCol j && validVar n
    columns         = Vec.toList . Vec.indexed $ columnVars vs

-- In phase I, the entering variable must be a positive value, as the problem
-- is a minimization. Artificial variables are still in the table at this
-- point, so the valid variable test must make sure artificial variables cannot
-- enter the basis (as they should be non-basic).
--
phaseIEntering
    :: (IsTableau 'PhaseI v s a c)
    => Tableau 'PhaseI d v s a c
    -> Either TwoPhaseError (Finite (Cols 'PhaseI v s a))
phaseIEntering x =
    enteringVar validCol validVar x
  where
    validCol j = index (0, j) (table x) > 0
    validVar n = isDecision n || isSlack n

-- When maximizing, the variable to enter the basis is the lowest indexed
-- variable with a negative coefficient in the objective function row.
--
maximizeEntering
    :: (IsTableau 'PhaseII v s a c)
    => Tableau 'PhaseII 'Max v s a c
    -> Either TwoPhaseError (Finite (Cols 'PhaseII v s a))
maximizeEntering x =
    enteringVar validCol validVar x
  where
    validCol j = index (0, j) (table x) < 0
    validVar   = not . isSpecial

-- When minimizing, the variable to enter the basis is the lowest indexed
-- variable with a positive coefficient in the objective function row.
--
minimizeEntering
    :: (IsTableau 'PhaseII v s a c)
    => Tableau 'PhaseII 'Min v s a c
    -> Either TwoPhaseError (Finite (Cols 'PhaseII v s a))
minimizeEntering x =
    enteringVar validCol validVar x
  where
    validCol j = index (0, j) (table x) > 0
    validVar   = not . isSpecial

-- The variable to leave the basis is the lowest indexed variable which has
-- the minimum ratio between it's coefficient and the RHS value. A variable
-- with a coefficient of 0 is not allowed to leave (as the ratio is infinite).
-- This function is the same regardless of the direction of optimization.
--
tableauLeaving
    :: (IsTableau p v s a c)
    => Finite (Cols p v s a)
    -> Tableau p d v s a c
    -> Either TwoPhaseError (Finite (Rows p c))
tableauLeaving enter (Tableau vs x) =
    case toRatio <$> filter canLeave rows of
        [] -> Left Unbounded
        xs -> Right . fst $ List.minimumBy (comparing snd) xs
  where
    rows            = Vec.toList . Vec.indexed $ rowVars vs
    rhsColumn       = fromJust $ elemIndexColumns RHS vs

    toRatio (i, _)  =
        let val = index (i, enter) x
            rhs = index (i, rhsColumn) x
        in  (i, rhs / val)

    canLeave (i, n) =
        let val = index (i, enter) x
            rhs = index (i, rhsColumn) x
        in  val > 0 && rhs /= 0 && not (isSpecial n)

tableauStep
    :: (IsTableau p v s a c)
    => (Tableau p d v s a c
        -> Either TwoPhaseError (Finite (Cols p v s a)))
    -> Tableau p d v s a c
    -> Either TwoPhaseError (Tableau p d v s a c)
tableauStep tableauEntering t@(Tableau vs x) = do
    enter <- tableauEntering t
    leave <- tableauLeaving enter t

    let cell = (leave, enter)
    pure $ Tableau (updateRow cell vs) (pivot cell x)

max_stars_repo_name: alex-mckenna/optimum

max_issues_repo_name: alex-mckenna/optimum

max_forks_repo_name: alex-mckenna/optimum


text:
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}

{--
 - Author: haym
 -
 - Helper functions common to multiple projects
--}

module Lib where

import Control.Monad
import Control.Monad.State
import Data.Char
import Data.Colour.Names
import Data.Maybe

import Data.Complex
import Graphics.Rendering.Chart.Backend.Diagrams
import Graphics.Rendering.Chart.Easy
import System.Process

type C = Complex Double

class Mag a where
    mag :: a -> Double

instance Mag Double where
    mag = id

instance Mag C where
    mag = magnitude

plotPoints' :: FilePath -> String -> Double -> [(Double, Double)] -> IO ()
plotPoints' file title rad xs = plotPoints file title rad xs >> callCommand ("inkview " ++ file)

plotPoints :: FilePath -> String -> Double -> [(Double, Double)] -> IO ()
plotPoints = plotPointsColor black

plotPointsColor :: Colour Double -> FilePath -> String -> Double -> [(Double, Double)] -> IO ()
plotPointsColor color file title rad xs = toFile def file $ do
        layout_title .= title
        plot (pointsConfig color rad <$> points "points" xs)

pointsConfig :: Colour Double -> Double -> PlotPoints x y -> PlotPoints x y
pointsConfig color rad
    = set (plot_points_style.point_color) (opaque color)
    . set (plot_points_style.point_radius) rad

diverges :: (Mag a) => Int -> (a -> a) -> a -> Bool
diverges maxIters func x0 = any (\x -> mag x > 4) . take maxIters $ iterate func x0

c2t :: Complex Double -> (Double, Double)
c2t (r :+ i) = (r, i)

letterCoeff :: Char -> Double
letterCoeff c = fromIntegral (fromEnum (toLower c) - fromEnum 'a') / 10 - 1.2

type Attractor = (Double -> Double -> Double, Double -> Double -> Double)

mkAttractor :: [Double] -> Attractor
mkAttractor cs = (fx, fy)
    where
        getNum = get >>= \case
            (x:xs) -> put xs >> return x
            _ -> return 0
        mkMap = do
            n <- replicateM 6 getNum
            return $ case n of
                [a1, a2, a3, a4, a5, a6] ->
                    let f x y = a1 + a2*x + a3*x*x + a4*x*y + a5*y + a6*y*y
                    in f
                [] -> error "lol"

        [fx, fy] = evalState (replicateM 2 mkMap) cs

attrFromLetters :: String -> Attractor
attrFromLetters = mkAttractor . fmap letterCoeff

runAttractor :: Attractor -> (Double, Double) -> (Double, Double)
runAttractor (fx, fy) (x, y) = (fx x y, fy x y)

class VSpace a where
    (^+) :: a -> a -> a
    (^*) ::  Double -> a -> a

instance VSpace Double where
    (^+) = (+)
    (^*) = (*)

instance VSpace (Double, Double) where
    (^+) (x0, y0) (x1, y1) = (x0 + x1, y0 + y1)
    (^*) a (x, y) = (a*x, a*y)

instance VSpace (Double, Double, Double) where
    (^+) (x0, y0, z0) (x1, y1, z1) = (x0 + x1, y0 + y1, z0 + z1)
    (^*) a (x, y, z) = (a*x, a*y, a*z)

rkStep :: (VSpace a) => (a -> a) -> Double -> (Double, a) -> (Double, a)
rkStep f dt (t, y) = (t + dt, y ^+ ((dt / 6)^*(k1 ^+ (2.0^*k2) ^+ (2.0^*k3) ^+ k4)))
    where
        k1 = f y
        k2 = f (y ^+ ((0.5*dt)^*k1))
        k3 = f (y ^+ ((0.5*dt)^*k2))
        k4 = f (y ^+ (dt^*k3))

rkStep' :: (VSpace a) => (a -> a -> a) -> Double -> (Double, a, a) -> (Double, a, a)
rkStep' f dt (t, y, y') = (t + dt, y ^+ (dt^*y'), y'New)
    where
        y'New = y' ^+ ((dt / 6)^*(k1 ^+ (2.0^*k2) ^+ (2.0^*k3) ^+ k4))
        k1 = f y y'
        k2 = f y (y' ^+ ((0.5*dt)^*k1))
        k3 = f y (y' ^+ ((0.5*dt)^*k2))
        k4 = f y (y' ^+ (dt^*k3))

eulerStep' :: VSpace a => (a -> a -> a) -> Double -> (Double, a, a) -> (Double, a, a)
eulerStep' a dt (t, y, y') = (tNew, yNew, y'New)
    where
    y'New = y' ^+ (dt^*a y y')
    yNew = y ^+ (dt^*y'New)
    tNew = t + dt

eulerStep :: (VSpace a) => (a -> a) -> Double -> (Double, a) -> (Double, a)
eulerStep f dt (t, y) = (t + dt, y ^+ (dt^*f y))

max_stars_repo_name: ahaym/dynamics

max_issues_repo_name: ahaym/dynamics

max_forks_repo_name: ahaym/dynamics