module NonDet where 

import NonDetType
import NonDetParser

{----------------------------------------------------------------------

 インタプリタ

 ----------------------------------------------------------------------}

type Env = [(String, Value)]

lookupM :: String -> Env -> M Value
lookupM x ((n,v):rest)  = if n==x then unitM v else lookupM x rest
lookupM x []            = failM ("Variable: "++x++" is not found")

interp :: Expr -> Env -> M Value
interp (Const c) e = unitM c
interp (Var x) e   = lookupM x e
interp (Let (x, m) n) e = interp m e `bindM` \ v ->
                          interp n ((x,v):e)
interp (App f x) e = interp f e `bindM` \ g ->
                     case g of 
                       Fun h -> interp x e `bindM` \ y ->
                                h y
                       _     -> failM "Function expected."
interp (Letrec (x, m) n) e = mfixU (\ v -> 
                                    interp m ((x, Fun v):e) `bindM` \  v1 ->
                                    case v1 of  
                                      Fun f -> unitM f 
                                      _     -> failM "function expected") `bindM` \ v  ->
                             interp n ((x, Fun v):e)
interp (Lambda x m) e = unitM (Fun (\ v -> interp m ((x,v):e)))
interp (If e1 e2 e3) e = interp e1 e `bindM` \ v ->
                         case v of
                           Bool b -> if b then interp e2 e
                          		  else interp e3 e
                           _      -> failM "Boolean expected"
interp (Amb e1 e2) e = interp e1 e `append` interp e2 e
interp (Try e1 e2) e = tryM (interp e1 e) (interp e2 e)
interp (Fail e1) e   = interp e1 e `bindM` \ v ->
                       failM (showValue v)
{- 
interp (Uniq e) = \ env -> case interp e env of 
                             Cons (v:_) -> unitM v
                             f          -> f
-}
binop op =  Fun (\ v ->
              case v of
                Num c -> unitM (Fun (\ w ->
                           case w of
                             Num d -> unitM (Num (op c d))
                             _     -> failM "Number expected"))
                _     -> failM "Number expected")

binop2 op =  Fun (\ v ->
	       case v of 
		 Num c -> unitM (Fun (\ w ->
			    case w of 
			      Num d -> unitM (Bool (op c d))
			      _     -> failM "Number expected"))
		 _     -> failM "Number expected")

divop = Fun (\ v ->
              case v of 
                Num c -> unitM (Fun (\ w ->
                           case w of
                             Num 0 -> failM "Division by 0"
                             Num d -> unitM (Num (c/d))
                             _     -> failM "Number expected"))
                _     -> failM "Number expected")

myPair   = Fun (\ v1 -> unitM (Fun (\ v2 -> unitM (Pair v1 v2))))

myFst = Fun (\ v -> 
  case v of
    Pair v1 v2 -> unitM v1
    _          -> failM "Pair expected")

mySnd = Fun (\ v -> 
  case v of
    Pair v1 v2 -> unitM v2
    _          -> failM "Pair expected")

myIsPair = Fun (\ v -> case v of
                         Pair _ _ -> unitM (Bool True)
                         _        -> unitM (Bool False))

myIsUnit = Fun (\ v -> case v of
                       	 Unit -> unitM (Bool True)
                       	 _    -> unitM (Bool False))

myToString = Fun (\ v -> unitM (Str (showValue v)))
myStrAppend = Fun (\ v1 -> unitM (Fun (\ v2 ->
              unitM (Str (showValue v1 ++ showValue v2)))))

initEnv = [("+", binop (+)), ("-", binop (-)),
           ("*", binop (*)), ("/", divop),
           ("%", binop (\ x y -> fromInteger (round x `rem` round y))),
           ("not", Fun (\ (Bool b) -> unitM (Bool (not b)))), 
           ("==", binop2 (==)), ("/=", binop2 (/=)),
           (">", binop2 (>)), (">=", binop2 (>=)),
           ("<", binop2 (<)), ("<=", binop2 (<=)),
           ("True", Bool True), ("False", Bool False),
	   ("pair", myPair), ("isPair", myIsPair), 
	   ("Unit", Unit), ("isUnit", myIsUnit),
           ("fst", myFst), ("snd", mySnd),
	   ("++", myStrAppend), ("toString", myToString)	   
	   {-,
	   ("cons", Fun myPair), ("isNull", Fun myIsUnit),
           ("head", Fun myFst), ("tail", Fun mySnd),
	   ("nil", Unit) -}
	  ]

run :: String -> String
run str = showL (interp (myParse str) initEnv)

run1 :: String -> String
run1 str = showValue (hdL (interp (myParse str) initEnv))

main :: IO ()
main = interact run

load :: String -> IO ()
load path = readFile path >>= \ prog ->
   	    putStrLn (run prog)

-- for example, 
-- run "(amb 1 or 2) * (amb 3 or 4)"
-- run "letrec fact = \\ n -> if n<=0 then 1 else n*fact(amb n-1 or n-2) in fact 9"