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"
}