(defpackage :fwoar.lisp-sandbox.2
   (:use :cl )
   (:export ))
 (in-package :fwoar.lisp-sandbox.2)
 (defvar *trace-depth* 0)
 
 (defclass bool () ())
 (progn
   (defvar true (make-instance 'bool))
   (defmethod print-object ((o (eql true)) s)
     (format s "#.~s" 'true)))
 (progn
   (defvar false (make-instance 'bool))
   (defmethod print-object ((o (eql false)) s)
     (format s "#.~s" 'false)))
 
 (defmacro define ((name &rest args) &body body)
   `(progn (defun ,name (,@args)
             ,@body)
           (defparameter ,name (function ,name))))
 
 (declaim (inline atom? symbol? string? number? char? boolean? vector?))
 (define (atom? exp)
   (atom exp))
 (define (null? it)
   (null it))
 (define (symbol? exp)
   (symbolp exp))
 (define (number? exp)
   (numberp exp))
 (define (string? exp)
   (stringp exp))
 (define (char? exp)
   (characterp exp))
 (define (boolean? exp)
   (or (eq exp false)
       (eq exp true)))
 (define (vector? exp)
   (vectorp exp))
 (define (eq? a b)
   (eq a b))
 (define (pair? it)
   (consp it))
 (define (set-cdr! it value)
   (rplacd it value))
 
 (define (->cl bool)
   (if (eq bool true) t nil))
 
 (defvar empty-begin 813)
 
 (define (wrong &rest args)
   (error "~{~a~^ ~}" args))
 
 (defvar env.init ())
 (defvar env.global (cons nil env.init))
 (defvar fenv.global (cons nil env.init))
 
 (defun key-eql (key)
   (lambda (a b)
     (eql (funcall key a)
          (funcall key b))))
 
 (defun do-adjoin (list item &rest r)
   (cons item
         (apply #'remove item list r)))
 (define-modify-macro adjoinf (item &rest r) do-adjoin)
 
 (defmacro definitial (name &optional (value nil value-p))
   (if value-p
       `(progn (adjoinf (cdr env.global)
                        (cons ',name ,value)
                        :test (key-eql #'car))
               ',name)
       `(progn (adjoinf (cdr env.global)
                        (cons ',name '#:uninit)
                        :test (key-eql #'car))
               ',name)))
 
 (defmacro definitial-function (name &optional (value nil value-p))
   (if value-p
       `(progn (adjoinf (cdr fenv.global)
                        (cons ',name ,value)
                        :test (key-eql #'car))
               ',name)
       `(progn (adjoinf (cdr fenv.global)
                        (cons ',name '#:uninit)
                        :test (key-eql #'car))
               ',name)))
 
 (defmacro defprimitive (name value arity)
   `(definitial-function ,name
        (lambda (values &optional env)
          (declare (ignore env))
          (if (= ,arity (length values))
              (apply ',value values)
              (wrong "incorrect arity" ',name ,arity values)))))
 
 (defmacro defprimitive-bool (name value arity)
   `(definitial-function ,name
        (lambda (values &optional env)
          (declare (ignore env))
          (if (= ,arity (length values))
              (if (apply ',value values)
                  true
                  false)
              (wrong "incorrect arity" ',name ,arity values)))))
 
 (define (extend env variables values)
   (cond ((pair? variables)
          (if (pair? values)
              (cons (cons (car variables) (car values))
                    (extend env (cdr variables) (cdr values)))
              (wrong "Too less values")))
         ((null? variables)
          (if (null? values)
              env
              (wrong "Too much values")))
         ((symbol? variables) (cons (cons variables values) env))))
 
 (define (invoke fn args)
   (if (functionp fn)
       (funcall fn args)
       (wrong "Not a function" fn)))
 
 (define (lookup id env)
   (if (pair? env)
       (if (eq? (caar env) id)
           (cdar env)
           (lookup id (cdr env)))
       (wrong "No such binding" id)))
 
 (define (f.make-function variables body env fenv)
   (lambda (values)
     (f.eprogn body
               (extend env
                       variables
                       values)
               fenv)))
 
 (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))
       (wrong "No such binding" id)))
 
 (define (f.evaluate e env fenv)
   (if (atom? e)
       (cond ((eq? e 't) true)
             ((eq? e 'f) false)
             ((or (number? e)
                  (string? e)
                  (char? e)
                  (boolean? e)
                  (vector? e))
              e)
             ((symbol? e) (lookup e env))
             ((wrong "Cannot evaluate" e)))
       (case (car e)
         ((quote) (cadr e))
         ((if) (if (->cl (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)))
         ((function) (cond ((symbol? (cadr e))
                            (f.lookup (cadr e)
                                      fenv))
                           ((and (pair? (cadr e))
                                 (eq? (cadr e)
                                      'lambda))
                            (f.make-function (cadr (cadr e))
                                             (cddr (cadr e))
                                             env fenv))
                           ((wrong "Incorrect function" (cadr e)))))
         ((lambda) (make-function (cadr e)
                                  (cddr e)
                                  env))
         ((flet)
          (f.eprogn (cddr e)
                    env
                    (extend fenv
                            (mapcar 'car (cadr e))
                            (mapcar (lambda (def)
                                      (f.make-function (cadr def)
                                                       (cddr def)
                                                       env fenv))
                                    (cadr e)))))
         ((labels)
          (let ((new-fenv (extend fenv
                                  (mapcar 'car
                                          (cadr e))
                                  (mapcar (lambda (def)
                                            'void)
                                          (cadr e)))))
            (mapc (lambda (def)
                    (update! (car def)
                             new-fenv
                             (f.make-function (cadr def)
                                              (cddr def)
                                              env new-fenv)))
                  (cadr e))
            (f.eprogn (cddr e)
                      env new-fenv)))
         (t (f.evaluate-application (car e)
                                    (f.evlis (cdr e)
                                             env fenv)
                                    env fenv)))))
 (define (f.eprogn exps env fenv)
   (if (pair? exps)
       (if (pair? (cdr exps))
           (progn (f.evaluate (car exps) env fenv)
                  (eprogn (cdr exps)
                          env))
           (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 (f.evaluate-application fn args env fenv)
   (cond ((symbol? fn)
          (funcall (f.lookup fn fenv) args))
         ((and (pair? fn)
               (eq? (car fn)
                    'ambda))
          (f.eprogn (cddr fn)
                    (extend env
                            (cadr fn)
                            args)
                    fenv))
         ((wrong "Incorrect functional term" fn))))
 
 (define (f.lookup id fenv)
   (if (pair? fenv)
       (if (eq? (caar fenv)
                id)
           (cdar fenv)
           (f.lookup id
                     (cdr fenv)))
       (lambda (values)
         (declare (ignore values))
         (wrong "No such functional binding" id))))
 
 (defparameter def.extend
   (f.make-function '(env variables values)
                    '((if (pair? variables)
                          (if (pair? values)
                              (cons (cons (car variables) (car values))
                                    (extend env (cdr variables) (cdr values)))
                              (wrong "Too less values"))
                          (if (null? variables)
                              (if (null? values)
                                  env
                                  (wrong "Too much values"))
                              (if (symbol? variables)
                                  (cons (cons variables values) env)
                                  nil))))
                    env.global
                    fenv.global))
 
 (defun scheme-atom? (it)
   (if (atom it)
       true
       false))
 (defun scheme-not (it)
   (if (eq it true) false true))
 (defun scheme-eq? (a b)
   (if (eq a b)
       true
       false))
 (defun display (it)
   (format *trace-output* "~&~v,2@t ===> ~s~%" (* 2 *trace-depth*) it)
   it)
 
 (define (chapter2-scheme)
   (definitial apply
       (lambda (values)
         (apply (car values) (cdr values))))
 
   (definitial t true)
   (definitial f false)
   (definitial nil '())
   (definitial foo)
   (definitial bar)
   (definitial-function fib)
   (definitial-function fact)
   (definitial-function evaluate)
   (definitial-function evlis)
   (definitial-function eprogn)
   (definitial-function lookup)
   (definitial-function wrong)
   (definitial-function update!)
   (definitial-function make-function)
   (definitial-function invoke)
   (definitial-function foldl
       (f.make-function '(fn init list)
                        '((if (null? list)
                              init
                              (fn (foldl fn init (cdr list))
                                  (car list))))
                        env.global
                        fenv.global))
 
   (definitial-function extend def.extend)
   (definitial env.global env.global)
   (defprimitive atom? scheme-atom? 1)
   (defprimitive-bool number? number? 1)
   (defprimitive-bool vector? vector? 1)
   (defprimitive-bool char? char? 1)
   (defprimitive-bool boolean? boolean? 1)
   (defprimitive-bool string? string? 1)
   (defprimitive-bool symbol? symbol? 1)
   (defprimitive-bool pair? pair? 1)
   (defprimitive-bool function? functionp 1)
   (defprimitive-bool null? null? 1)
   (defprimitive not scheme-not 1)
   (defprimitive cons cons 2)
 
   (defprimitive car car 1)
   (defprimitive cdr cdr 1)
 
   (defprimitive caar caar 1)
   (defprimitive cadr cadr 1)
   (defprimitive cdar cdar 1)
   (defprimitive cddr cddr 1)
 
   (defprimitive #1=caaar #1# 1)
   (defprimitive #2=caadr #2# 1)
   (defprimitive #3=cadar #3# 1)
   (defprimitive #4=caddr #4# 1)
   (defprimitive #5=cdaar #5# 1)
   (defprimitive #6=cdadr #6# 1)
   (defprimitive #7=cddar #7# 1)
   (defprimitive #8=cdddr #8# 1)
 
   (defprimitive #9=caaaar #9# 1)
   (defprimitive #10=caaadr #10# 1)
   (defprimitive #11=caadar #11# 1)
   (defprimitive #12=caaddr #12# 1)
   (defprimitive #13=cadaar #13# 1)
   (defprimitive #14=cadadr #14# 1)
   (defprimitive #15=caddar #15# 1)
   (defprimitive #16=cadddr #16# 1)
   (defprimitive #17=cdaaar #17# 1)
   (defprimitive #18=cdaadr #18# 1)
   (defprimitive #19=cdadar #19# 1)
   (defprimitive #20=cdaddr #20# 1)
   (defprimitive #21=cddaar #21# 1)
   (defprimitive #22=cddadr #22# 1)
   (defprimitive #23=cdddar #23# 1)
   (defprimitive #24=cddddr #24# 1)
 
   (defprimitive set-cdr! rplacd 2)
   (defprimitive + + 2)
   (defprimitive * * 2)
   (defprimitive-bool = = 2)
   (defprimitive eq? scheme-eq? 2)
   (defprimitive < < 2)
   (defprimitive eql eql 2)
   (defprimitive display display 1)
   (definitial list
       (f.make-function 'v
                        '((if (null? v)
                              ()
                              (cons (car v)
                                    (list (cdr v)))))
                        env.global
                        fenv.global))
   (setf (cdr (assoc 'invoke fenv.global))
         (f.make-function '(fn args)
                          '((if (function? fn)
                                (apply fn args)
                                (wrong "Not a function" fn)))
                          env.global
                          fenv.global)
 
         (cdr (assoc 'make-function fenv.global))
         (f.make-function '(variables body env)
                          '((lambda (values)
                              (eprogn body
                                      (extend env variables values))))
                          env.global
                          fenv.global)
 
         (cdr (assoc 'update! fenv.global))
         (f.make-function '(id env value)
                          '((if (pair? env)
                                (if (eq? (caar env) id)
                                    (begin (set-cdr! (car env) value)
                                           value)
                                    (update! id (cdr env) value))
                                (wrong "No such binding" id)))
                          env.global
                          fenv.global)
 
         (cdr (assoc 'wrong fenv.global))
         (f.make-function '(a b)
                          '((display (cons a b)))
                          env.global
                          fenv.global)
 
         (cdr (assoc 'lookup fenv.global))
         (f.make-function '(id env)
                          '((if (pair? env)
                                (if (eq? (caar env) id)
                                    (cdar env)
                                    (lookup id (cdr env)))
                                (wrong "No such binding" id)))
                          env.global
                          fenv.global)
 
         (cdr (assoc 'evaluate fenv.global))
         (f.make-function '(e env)
                          '((if (atom? e)
                                (if (eq? e 't)
                                    t
                                    (if (eq? e 'f)
                                        f
                                        (if (if (number? e) t
                                                (if (string? e) t
                                                    (if (char? e) t
                                                        (if (boolean? e) t
                                                            (vector? e)))))
                                            e
                                            (if (symbol? e)
                                                (lookup e env)
                                                nil))))
                                ((lambda (case-var)
                                   (if (eq? case-var 'quote)
                                       (begin nil (cadr e))
                                       (if (eq? case-var 'if)
                                           (if (not (eq? (evaluate (cadr e) env) f))
                                               (evaluate (caddr e) env)
                                               (evaluate (cadddr e) env))
                                           (if (eq? case-var 'begin)
                                               (eprogn (cdr e) env)
                                               (if (eq? case-var 'set!)
                                                   (update! (cadr e) env (evaluate (caddr e) env))
                                                   (if (eq? case-var 'lambda)
                                                       (f.make-function (cadr e) (cddr e) env)
                                                       (invoke (evaluate (car e) env)
                                                               (evlis (cdr e) env))))))))
                                 (car e))))
                          env.global
                          fenv.global)
 
         (cdr (assoc 'evlis fenv.global))
         (f.make-function '(exps env)
                          '((if (pair? exps)
                                (cons (evaluate (car exps) env)
                                      (evlis (cdr exps) env))
                                ()))
                          env.global
                          fenv.global)
 
         (cdr (assoc 'eprogn fenv.global))
         (f.make-function '(exps env)
                          '((if (pair? exps)
                                (if (pair? (cdr exps))
                                    (begin (evaluate (car exps) env)
                                           (eprogn (cdr exps)
                                                   env))
                                    (evaluate (car exps)
                                              env))
                                ()))
                          env.global
                          fenv.global))
 
   (labels ((toplevel ()
              (fresh-line)
              (princ "> ")
              (with-simple-restart (continue "continue scheme repl")
                (princ (f.evaluate (let ((it (read)))
                                     (case it
                                       (:quit (return-from toplevel))
                                       (t it)))
                                   env.global
                                   fenv.global)))
              (terpri)
              (toplevel)))
     (toplevel)))