(defpackage :fwoar.interp2
  (:use :cl )
  (:export ))
(in-package :fwoar.interp2)

;; pseudo-scheme

(define-condition not-implemented (error)
  ())
(defun not-implemented (&optional (note ""))
  (error 'not-implemented :note note))

(defstruct true)
(defmethod make-load-form ((o true) &optional environment)
  (declare (ignore environment))
  '(if (boundp true) true (setf true (make-true))))
(defstruct false)
(defmethod make-load-form ((o false) &optional environment)
  (declare (ignore environment))
  '(if (boundp false) false (setf false (make-false))))

(defparameter true
  (if (boundp 'true)
      true
      (make-true)))
(defparameter false
  (if (boundp 'false)
      false
      (make-false)))

(defmacro define (what &body body)
  (etypecase what
    (cons (destructuring-bind (name . args) what
            `(progn (defun ,name ,args
                      ,@body)
                    (defparameter ,name ',name))))
    (symbol `(defparameter ,what
               (progn ,@body)))))

(define (symbol? v) (symbolp v))
(define (string? v) (stringp v))
(define (number? v) (numberp v))
(define (char? v) (characterp v))
(define (boolean? v) (member v (list true false)))
(define (vector? v) (vectorp v))
(define (atom? v) (not (consp v)))
(define (pair? v) (consp v))
(define (null? v) (null v))
(define (procedure? v) (or (symbol? v)
                           (functionp v)))
(define (eq? a b) (eql a b))
(define (set-cdr! pair value) (setf (cdr pair) value))

(defmacro set! (thing val)
  `(setq ,thing ,val))



;; Environments
(define (lookup id env)
  (if (pair? env)
      (if (eq? (caar env) id)
          (cdar env)
          (lookup id (cdr env)))
      (error "No such binding ~s" id)))
(define (update! id env value)
  (if (pair? env)
      (if (eq? (caar env) id)
          (progn (set-cdr! (car env) value)
                 value)
          (update! id (cdr env) value))
      (error "No such binding ~s" id)))
(define (extend env variables values)
  (cond ((pair? variables)
         (if (pair? values)
             (cons (cons (car variables)
                         (car values))
                   (extend env
                           (cdr variables)
                           (cdr values)))
             (error "Too few values")))
        ((null? variables)
         (if (null? values)
             env
             (error "Too many values")))
        ((symbol? variables) (cons (cons variables values) env))))

(define env.init '())
(defmacro definitial (name &optional (value nil value-p))
  (if value-p
      `(progn (set! env.global (acons ',name ,value
                                      env.global))
              ',name)
      `(progn (set! env.global (acons ',name 'void
                                      env.global))
              ',name)))

(defmacro definitial-function (name &optional (value nil value-p))
  (if value-p
      `(progn (set! fenv.global (acons ',name ,value
                                       fenv.global))
              ',name)
      `(progn (set! fenv.global (acons ',name 'void
                                       fenv.global))
              ',name)))

(defmacro defprimitive (name value arity)
  (alexandria:with-gensyms (values)
    `(definitial-function ,name
         (lambda (,values)
           (if (= ,arity (length ,values))
               (apply ,value ,values)
               (error "Incorrect arity: ~s ~s" ',name ,values))))))

(defun embedded< (a b)
  (or (< a b)
      false))
(defun embedded-eq? (a b)
  (or (eq? a b)
      false))

(progn (define env.global (copy-seq env.init))
       (define fenv.global (copy-seq env.init))

       (definitial t true)
       (definitial f false)
       (definitial nil ())

       (definitial-function apply
           (lambda (values)
             (invoke (car values)
                     (cadr values))))

       (definitial foo)
       (definitial bar)
       (definitial fib)
       (definitial fact)

       (defprimitive cons #'cons 2)
       (defprimitive car #'car 1)
       (defprimitive cdr #'cdr 1)
       (defprimitive set-cdr! 'set-cdr! 2)
       (defprimitive + #'+ 2)
       (defprimitive eq? 'embedded-eq? 2)
       (defprimitive < 'embedded< 2))



;; Functions
(define (invoke fn args)
  (if (procedure? fn)
      (funcall fn args)
      (error "Not a function ~s" fn)))

(define (f.make-function variables body env fenv)
  (lambda (values)
    (f.eprogn body
              (extend env variables values)
              fenv)))



;; Interpreter
(define empty-begin 813)
(define (f.eprogn exps env fenv)
  (if (pair? exps)
      (if (pair? (cdr exps))
          (progn (f.evaluate (car exps) env fenv)
                 (f.eprogn (cdr exps) env fenv))
          (f.evaluate (car exps) env fenv))
      empty-begin))

(define (f.evlis exps env fenv)
  (if (pair? exps)
      (cons (f.evaluate (car exps) env fenv)
            (f.evlis (cdr exps) env fenv))
      '()))

(define (evaluate-application fn args env fenv)
  (cond ((symbol? fn)
         (invoke (lookup fn fenv) args))
        ((and (pair? fn) (eq? (car fn) 'lambda))
         (f.eprogn (cddr fn)
                   (extend env (cadr fn) args)
                   fenv))
        (t (error "Incorrect functional term: ~s" fn))))

(define (f.evaluate e env fenv)
  (if (atom? e)
      (cond
        ((symbol? e) (lookup e env))
        ((or (number? e)
             (string? e)
             (char? e)
             (boolean? e)
             (vector? e))
         e)
        (t (error "cannot evaluate ~s" e)))
      (case (car e)
        (quote (cadr e))
        (if (if (not (false-p (f.evaluate (cadr e) env fenv)))
                (f.evaluate (caddr e) env fenv)
                (f.evaluate (cadddr e) env fenv)))
        (begin (f.eprogn (cdr e) env fenv))
        (set! (update! (cadr e) env
                       (f.evaluate (caddr e) env fenv)))
        (lambda (f.make-function (cadr e) (cddr e) env fenv))
        (t
         (evaluate-application (car e)
                               (f.evlis (cdr e) env fenv)
                               env
                               fenv)))))

(define (chapter2-scheme)
  (labels ((toplevel ()
             (let* ((*package* (find-package :fwoar.interp2))
                    (exp (read)))
               (unless (equal exp '(end))
                 (format t "~&~s~%"
                         (f.evaluate exp env.global fenv.global))
                 (toplevel)))))
    (toplevel)))