/*
    Copyright (C) 2005, 2006      Robin Redeker <elmex@x-paste.de>, <r.redeker@gmail.com>
*/

/*
  This is a try to implement a s-expression evaluator for
  s-expressions as described in the paper:

    "Recursive Functions of Symbolic Expressions and their Computation by Machine (Part I)"
    - written by John McCarthy April 1960

  I realized that the eval described in that paper can't
  be implemented in an 1:1 manner. When binding names with LABELS
  and calling LAMBDA, something goes wrong with evaluation
  of the arguments.

  It's maybe just an error in my thinking and interpretation
  of the paper, but i come to the same results as my interpreter
  when thinking through McCarthys examples in the end of the paper.

  The evaluation of:
     apply [(LABEL, FF, (LAMBDA, (X), (COND, (ATOM, X), X), 
            ((QUOTE, T),(FF, (CAR, X))))));((A . B))
           ] = A

  The error is somewhere in evaluation of LABEL, LAMBDA and the quotation
  of the arguments.

  This is the corresponding code for the m-expression above:

  (apply
    (label ff 
      (lambda (x)
        (cond
          ((atom x) (x))
          ('T       (ff (car x))))))
    ((A . B)))

  When lip interprets this, you get the output:

    (apply
      (label ff
        (lambda
          (x)
          (cond
            ((atom x) x)
            ('T
              (ff
                (car x))))))
      ((A . B)))
    eval:
    variable 'A' has no value?!

  The error happens when an argument which is not quoted as it should
  becomes evaluated. - I don't know why and where the error is, maybe it's
  a misinterpretation of the paper or just a bug in my code.

  I stopping work on this, because i'm more interested in implementing a Scheme
  interpreter and because i found a better example of eval[] in the LISP 1.5
  Manual, which seems to be more thought out and better for an implementation.

  I also stop work on this because the paper itself says that the real implementation
  differs. I don't have the time to sort out the problems and differencies at the
  moment, but i want to preserver the code here as an example for anyone who
  is interested.

  Feel free to hack around in it, fix it, or change it to your purposes!

  Please note that it's not a serious piece of software, which is not ment to run 
  in a serious appliaction, as it leaks memory as hell... i was too lazy to implement 
  a garbage collector or pay much attention to freeing the allocated memory. 

  This is a proof of concept, not more.
  
  Questions?
  Write me: <elmex@x-paste.de>, <r.redeker@gmail.com>, <robin@nethype.de>
*/

#include <iostream>
#include <fstream>
#include <cstring>
#include <map>

using namespace std;

// this is the pair-structure, 
// which holds the car/cdr pointers
struct sexpr {
  sexpr *car; // if this pointer is 0x1, this sexpr is an atom and
              // the cdr pointer points to a string (const char*)
  void *cdr;  // the cdr pointer will be misused as const char * pointer for atoms

  sexpr () 
    : car (0), cdr (0) 
  {}

  sexpr (sexpr *ca) 
    : car (ca), cdr (0) 
  {}

  // this constructor works like: (list <ca> <cd>) = (<ca> (<cd> . nil))
  sexpr (sexpr *ca, sexpr *cd) 
    : car (ca), cdr (0)
  {
    cdr = new sexpr (cd);
  }

  // constructs the pair as atom
  sexpr (const char *c) 
    : car ((sexpr *)0x1), cdr (0) 
  {
    cdr = (void *) strdup (c); 
  }

  // some predicates
  bool is_atom ()         { return car == (sexpr *) 0x1; }
  bool is_pair ()         { return car != (sexpr *) 0x1; }
  // this checks whether the sexpr
  // has a real value and is not an atom or nil, determined by the car field
  bool car_is_expr ()     { return car != (sexpr *) 0x1 && car != (sexpr *) 0x0; }

  // this is just a cast helper
  const char *get_atom () { return (const char *) cdr; }

  // accessors for the pointers
  sexpr *get_car () { return car; }
  sexpr *get_cdr () { return (sexpr *)cdr; }

  // a recursive print function,
  // this could also be a non-member function.
  void print (int pad = 0) 
  {
#define PRINTPAD(x) do { int i = 0; for (i = 0; i <= (x); i++) { cout << "  "; } } while (0)

    // first check whether this is an atom
    if (is_atom ())
      {
        cout << (const char *) cdr;
        return;
      }

    // this block converts a (quote ...) to '...
    if (this->get_car () 
        && this->get_car ()->is_atom () 
        && string (this->get_car ()->get_atom ()) == "quote")
      {
        cout << "'";
        if (this->get_cdr () && this->get_cdr ()->get_car ())
          this->get_cdr ()->get_car ()->print (pad + 1);
        else
          cout << "nil";
        
        return;
      }

    // print the list
    cout << "(";

      // this is the first element (the current sexpr)
      if (car)
        this->get_car ()->print (pad + 1);

      // now print the list on the tail of this sexpr
      sexpr *l = get_cdr ();
      while (l)
        {
          // if there is an atom here, and not a list,
          // this can only look like: (<list> . <atom>) - the '.' syntax
          if (l->is_atom ())
            {
              cout << " . ";
              l->print (pad + 1);
              break;
            }

          // print either nil or padding + value
          if (!l->get_car ())
            cout << " nil";
          else
            {
              if (!l->get_car ()->is_atom ())
                {
                  cout << endl;
                  PRINTPAD(pad);
                }
              else
                cout << " ";

              l->get_car ()->print (pad + 1);
            }

          l = l->get_cdr ();
        }

    cout << ")";
  }
};

// the environment map for atoms (ensures that every
// occurence of an atom has the same pointer for the
// same atom)
typedef map<string, sexpr *> envmap;

// the accessor for the envmap, which returns 0
// for nil and a newly allocated atom for not
// exisisting atoms
sexpr *get_env_atom (envmap *atoms, const string &atom)
{
  if (atom == "nil")
    return 0;

  if (atoms->find (atom) != atoms->end ())
    return (*atoms)[atom];

  return ((*atoms)[atom] = new sexpr (atom.c_str ()));
}

// thie is the parser class
class LISP_parser
{

  envmap *atoms;  // will contain the allocated atoms
  int nestcnt;

#define WHITE_SPACE " \r\n\t"

  // some private error helper
  void error (const string &s)
  {
    cerr << "Parse error, nested: " << nestcnt << ": " << s << endl;
    throw LISP_parser_exception (nestcnt, s);
  }

  // a typedef for less pain
  typedef string::size_type st;

  public:

    struct LISP_parser_exception {
      int nestcnt;
      string error;

      LISP_parser_exception (int n, const string &e)
        : nestcnt (n), error (e)
      { }
    };

    LISP_parser () : nestcnt (0) { atoms = new envmap; }
  
    // accessor for the allocated atom map
    envmap *get_env () { return atoms; }
  
    // this routine parses an inputstream (cin, ifstream, whatever)
    sexpr *parse (istream &f)
    {
      char buf[1024];
      string input;

      while (f)
        {
          f.read (buf, 1024);
          input.append (buf, f.gcount ());
        }

      return parse (input);
    }

    // this procedure skips white space on the beginning
    // of the string
    void skip_ws (string &input)
    {
      st i = input.find_first_not_of (WHITE_SPACE);

      if (i != 0)
        input.erase (0, i);
    }

    // a wrapper for the global atom retrival function
    sexpr *get_atom (const string &atom)
    {
      return get_env_atom (atoms, atom);
    }

    // this function parses a list
    sexpr *parse_list (string &input)
    {
      sexpr *first = 0, *last = 0;
      
      while (input[0] != ')' && input.size () > 0)
        {
          if (input[0] == '.')
            {
              if (!first || !last)
                error ("have no first element for a '. X' pair");
              
              input.erase (0, 1);
              sexpr *sval = parse (input);
              last->cdr = sval;

              if (input[0] != ')')
                error ("while parsing '. X' pair");

              return first;
            }
          else 
            {
              sexpr *sval = parse (input);
              sexpr *cnode = new sexpr;

              cnode->car = sval;

              if (!first)
                first = cnode;
              
              if (last)
                last->cdr = cnode;

              last = cnode;
            }

          skip_ws (input);          
        }

      return first;
    }

    // this function is the main parser/lexer, it takes a string an
    // erases the parsed parts from it
    sexpr *parse (string &input)
    {
      skip_ws (input);

      if (input.size () == 0)
        error ("couldn't find any token");

      sexpr *ret = 0;

      if (input[0] == '\'')
        {
          input.erase (0, 1);
          // construct (quote b)
          ret = new sexpr (get_atom ("quote"), parse (input));
        }
      else if (input[0] == '(')
        {
          nestcnt++;

          input.erase (0, 1); // '('

          ret = parse_list (input);

          if (input.size () == 0)
            error ("EOF found but expected ')'");

          input.erase (0, 1); // ')'

          nestcnt--;
        }
      else
        ret = parse_atom (input);

      skip_ws (input);

      return ret;
    }

    // this function parses an atom string and returns
    // a pointer to the atom sexpr structure
    sexpr *parse_atom (string &input)
    {
      skip_ws (input);

      // after we skipped any space, we search for the next
      // space to determine the length of the atom
      st i = input.find_first_of (WHITE_SPACE"()");
      
      string atom;

      if (i == string::npos) // npos means: there is no space
        {
          // so we take the whole input as atom string
          atom = input;
          input = "";
        }
      else if (i == 0 && (input[0] == '(' || input[0] == ')'))
        error ((string) "expected atom but found: " + input);
      else
        {
          // take the atom from the string and erase it
          atom = input.substr (0, i);
          input.erase (0, i);
        }

      // just making sure there is no whitespace
      // on the string anymore...
      skip_ws (input);

      // return the pointer for that atom string
      return get_atom (atom);
    }
};

// here are some helper macros for the evaluator:
#define ATOM(x)  ((x)->is_atom ())

#define CAR(x)   ((x)->get_car ())
#define CDR(x)   ((x)->get_cdr ())
  
#define CDDR(x)  (CDR(CDR(x)))
#define CAAR(x)  (CAR(CAR(x)))
#define CDAR(x)  (CDR(CAR(x)))
#define CADR(x)  (CAR(CDR(x)))
  
#define CADAR(x)  (CADR(CAR(x)))
#define CADDR(x)  (CADR(CDR(x)))
#define CDDAR(x)  (CDDR(CAR(x)))
#define CADDAR(x) (CADDR(CAR(x)))

#define CHECK_ARG1(x,a) if (!CDR(x)) { cerr << "no argument given to '" << (a) << "'" << endl; return 0; }
#define CHECK_ARG2(x,a) if (!CDDR(x)) { cerr << "no second argument given to '" << (a) << endl; return 0; }

#define EVAL(x)     (eval ((x), atoms, env))
#define EVALE(x,e)  (eval ((x), atoms, (e)))
#define ENVGET(x)   (get_env_atom (env, (x)))
#define GETATOM(x)  (get_env_atom (atoms, (x)))

#define DEBUG(str,expr) cout << str << " [" << endl; if (expr) (expr)->print (); cout << "]" << endl;

// this functions finds the value for an atom interpreted
// as variable
bool env_find (sexpr *env, sexpr *atom, sexpr **res)
{
  sexpr *el = env;
  while (el)
    {
      sexpr *assigment = CAR(el);

      if (assigment && assigment->is_pair ())
        {
          if (CAAR(el) == atom)
            {
              if (CDAR(el))
                *res = CADAR(el);
              else
                *res = 0;

              return true;
            }
        }

      el = CDR(el);
    }

  return false;
}

sexpr *eval (sexpr *e, envmap *atoms, sexpr *env)
{
  if (!e) return 0;

  if (ATOM(e))
    {
      sexpr *el = 0;

      if (env_find (env, e, &el))
        return el;

      cerr << "variable '" << e->get_atom () << "' has no value?!" << endl;
      exit (1);
    }

  if (CAR(e) && ATOM(CAR(e)))
    {
      string atom = CAR(e)->get_atom ();

      if (atom == "cond")
        {
          sexpr *b = CDR(e);

          while (b)
            {
              if (!CAR(b))
                {
                  cerr << "'nil' caluse in cond" << endl;
                  exit (1);
                }
              sexpr *clause = CAR(b);

              sexpr *cond = EVAL(CAR(clause));
              sexpr *val  = CDR(clause);
              
              if (!cond)
                {
                  b = CDR(b);
                  continue;
                }

              if (val && val->car_is_expr ())
                return EVAL(CAR(val));
              else
                return cond;
            }

          return 0;
        }

      // one and more argument functions follow

      if (atom == "atom")
        {
          CHECK_ARG1(e,atom);
          sexpr *arg = EVAL(CADR(e));

          if (!arg)
            return GETATOM("T");
          
          else if (ATOM(arg))
            return GETATOM("T");
          
          else
            return 0;
        }
      else if (atom == "eval")
        {
          CHECK_ARG1(e,atom);
          CHECK_ARG2(e, atom);
          sexpr *arg  = CADR(e);
          sexpr *arg2 = CADDR(e);

          return EVALE(arg, arg2);
        }
      else if (atom == "eq")
        {
          CHECK_ARG1(e,atom);
          CHECK_ARG2(e, atom);
          sexpr *arg  = EVAL(CADR(e));
          sexpr *arg2 = EVAL(CADDR(e));

          if (arg == arg2)
            return GETATOM("T");
          else
            return 0;
        }
      else if (atom == "null")
        {
          CHECK_ARG1(e,atom);
          sexpr *arg = EVAL(CADR(e));
          
          if (!arg)
            return GETATOM("T");
          else
            return 0;
        }
      else if (atom == "quote")
        {
          CHECK_ARG1(e,atom);
          
          return CADR(e);
        }
      else if (atom == "car")
        {
          CHECK_ARG1(e,atom);
          sexpr *e2 = EVAL(CADR(e));
          
          if (!e2)
            return 0;

          if (!e2->is_pair ())
            {
              e2->print ();
              cout << " is not a pair" << endl;
              exit (1);
            }
          
          return CAR(e2);
        }
      else if (atom == "cdr")
        {
          CHECK_ARG1(e,atom);
          sexpr *e2 = EVAL(CADR(e));
          
          if (!e2)
            return 0;

          if (!e2->is_pair ())
            {
              e2->print ();
              cout << " is not a pair" << endl;
              exit (1);
            }

          return CDR(e2);
        }
      else if (atom == "cons")
        {
          CHECK_ARG1(e,atom);
          CHECK_ARG2(e, atom);
          sexpr *arg  = EVAL(CADR(e));
          sexpr *arg2 = EVAL(CADDR(e));

          sexpr *r = new sexpr (arg);
          r->cdr = arg2;

          return r;
        }
      else if (atom == "append")
        {
          CHECK_ARG1(e,atom);
          CHECK_ARG2(e,atom);
          sexpr *arg  = EVAL(CADR(e));
          sexpr *arg2 = EVAL(CADDR(e));
          
          if (!arg || !arg->is_pair ())
            return arg2;

          sexpr *start = arg;

          while (CDR(arg))
            arg = CDR(arg);

          arg->cdr = new sexpr (arg2);
          
          return start;
        }
      else if (atom == "apply")
        {
          CHECK_ARG1(e,atom);
          CHECK_ARG2(e,atom);
          sexpr *arg  = CADR(e);
          sexpr *arg2 = CADDR(e);
          
          sexpr *start = new sexpr (arg);

          sexpr *oli = 0;
          sexpr *ocnt = 0;
          sexpr *args = arg2;
          
          while (args)
            {
              sexpr *l = new sexpr (new sexpr ("quote"), CAR(args));
              sexpr *node = new sexpr (l);

              if (!oli)
                oli = node;

              if (ocnt)
                ocnt->cdr = node;

              ocnt = node;
              
              args = CDR(args);
            }

          start->cdr = oli;

          return EVALE(start, 0);
        }
       else 
        {
          // evaluate function
          sexpr *fun = 0;

          if (!env_find (env, CAR(e), &fun))
            {
              cout << "cannot find function '";
              CAR(e)->print ();
              cout << "'" << endl;
              exit (1);
            }

          sexpr *s_evli = 0;
          sexpr *evli = s_evli = CDR(e);

          sexpr *first = 0;
          sexpr *lnode = 0;
          
          while (evli)
            {
              sexpr *nnode = new sexpr (EVAL(CAR(evli)));

              if (!first)
                first = nnode;
              
              if (lnode)
                lnode->cdr = nnode;

              lnode = nnode;

              evli = CDR(evli);
            }
          
          sexpr *res = new sexpr (fun);
          res->cdr = first;

          return EVAL(res);
        }
    }
  else if (CAR(e))
    {
      if (CAAR(e) && ATOM(CAAR(e)))
        {
          string atom = CAAR(e)->get_atom ();

          if (atom == "label")
            {
              if (!CDAR(e))
                {
                  cerr << "no first element in label expression" << endl;
                  return 0;
                }
              if (!CDDAR(e))
                {
                  cerr << "no second element in label expression" << endl;
                  return 0;
                }

              sexpr *fst = CADAR(e);
              sexpr *snd = CADDAR(e);

              sexpr *expr = new sexpr (snd);
              expr->cdr = CDR(e);

              sexpr *var = new sexpr (fst, CAR(e));
              sexpr *anode = new sexpr (var);
              anode->cdr = env;

              return EVALE(expr, anode);
            }
          else if (atom == "lambda")
            {
              if (!CDAR(e))
                {
                  cerr << "no first element in lambda expression" << endl;
                  return 0;
                }
              
              if (!CDDAR(e))
                {
                  cerr << "no second element in lambda expression" << endl;
                  return 0;
                }

              sexpr *fst = CADAR(e);
              sexpr *snd = CADDAR(e);

              sexpr *env_add = 0;
              sexpr *env_add_w = 0;

              sexpr *args = fst;
              sexpr *argvals = CDR(e);

              while (args && argvals)
                {
                  sexpr *arg = new sexpr (CAR(args), EVAL(CAR(argvals)));
                  sexpr *anode = new sexpr (arg);

                  if (!env_add)
                    env_add = anode;

                  if (env_add_w)
                    env_add_w->cdr = anode;

                  env_add_w = anode;

                  args = CDR(args);
                  argvals = CDR(argvals);
                }

              if (env_add_w)
                env_add_w->cdr = env;
              else
                env_add = env;

              if (args)
                {
                  cout << "too few argument to function: ";
                  fst->print ();
                  cout << endl;
                  exit (1);
                  return 0;
                }

              return EVALE(snd, env_add);
            }
        }

      cout << "cannot evaluate expression: " << endl;
      CAR(e)->print ();
      cout << endl;
      exit (1);
      return 0;
    }
  else
    {
      cerr << "cannot eval nil" << endl;
      return 0;
    }

  return 0;
}

int main (int argc, char *argv[])
{
  LISP_parser lp;
  sexpr *f = lp.parse (cin);
  
  if (f)
    {
      f->print (); 
      cout << endl;
      cout << "eval:" << endl;
      sexpr *res = eval (f, lp.get_env (), 0);
      cout << "result:" << endl;
      if (res)
        {
          res->print (); 
          cout << endl;
        }
      else
        cout << "nil" << endl;
    }
  else
    cout << "nil";
  
  cout << endl;
}