(in-package "CL-USER")


(defun zip (fn l1 l2)
  (cond ((or (null l1) (null l2)) nil)
        (t (cons (funcall fn (car l1) (car l2)) (zip fn (cdr l1) (cdr l2))))))


(defun fold (fn start lis)
  (cond ((null lis) start)
        (t (funcall fn (car lis) (fold fn start (cdr lis))))))

(defun findl (elm lis)
  (cond ((null lis) nil)
        ((eql elm (car lis)) lis)
        (t (findl elm (cdr lis)))))

(defun enumerate (lis strt)
  (cond ((null lis) nil)
        (t (cons (cons (car lis) strt) (enumerate (cdr lis) (+ 1 strt)))))) 

(defun length=2 (lis)
  (and (consp lis) (not (null (cdr lis))) (null (cddr lis))))

(defun length=1 (lis)
  (and (consp lis) (null (cdr lis))))

;

(defun show-error (&rest lis)
  (let ()
    (format t "error: " )
    (mapcar #'(lambda (z) (format t "~S" z)) lis)))



;

(defparameter *primitive-list* 
'(cons car cdr set-car set-cdr consp listp eq null

make-string char set-char stringp

make-vector svref set-svref arrayp

%make-vector

%svref
%set-svref

%set-symbol-function
%symbol-function

%set-symbol-value
%symbol-value

%make-closure
%closure-ref

%print
%read

do-until

vector
apply

funcall

make-symbol intern
symbol-name symbol-value symbol-function symbol-plist
set-symbol-value set-symbol-function set-symbol-plist 
symbolp

char-code
code-char
characterp

%+ %- %* %div %rem %<= %>= %< %> %= %/=))

(defun is-primitive (form)
  (member (car form) *primitive-list*))



(defun make-let (vars vals body)
  (cons 'let (cons (zip #'(lambda (x y) (list x y)) vars vals) body)))

(defun make-let* (vars vals body)
  (cons 'let* (cons (zip #'(lambda (x y) (list x y)) vars vals) body)))

(defun let-vars (e)
  (cadr e))

(defun let-body (e)
  (cddr e))


(defun progn-ify (e)
  (if (is-progn e)
      e
    (cons 'progn e)))



(defun is-lambda (form)
  (and (consp form) (eq (car form) 'lambda)))

(defun make-lambda (vars body)
  (cons 'lambda (cons vars body)))

(defun lambda-vars (form)
  (cadr (un-annotate form)))

(defun lambda-body (form)
  (cddr (un-annotate form)))


(defun if-expr-tst (e)
  (cadr e))

(defun if-expr-branch-t (e)
  (caddr e))

(defun if-expr-branch-f (e)
  (cadddr e))

(defun if-expr-has-3 (e)
  (not (null (cdddr e))))







(defun is-labels (form)
  (eq (car form) 'labels))

(defun make-labels-lambda (funs fun-lambdas body)
  (cons 'labels 
        (cons
         (zip #'(lambda (x y) (annotate (list x (lambda-vars y) (car (lambda-body y))) (get-annotate y)))
              funs fun-lambdas)
        body)))

(defun labels-body (form)
  (cddr form))




(defparameter *special-form-list* '(progn if cond quote function)) 

(defun is-form (form)
  (atom (car form)))

(defun is-special-form (form)
  (member (car form) *special-form-list*))

(defun is-if (form)
  (and (listp form) (eq (car form) 'if)))

(defun is-progn (form)
  (and (listp form) (eq (car form) 'progn)))

(defun is-setq (form)
  (and (listp form) (eq (car form) 'setq)))

(defun is-quote (form)
  (and (listp form) (eq (car form) 'quote)))

(defun is-function (form)
  (and (listp form) (eq (car form) 'function)))

(defun is-defun (form)
  (and (listp form) (eq (car form) 'defun)))


(defun un-annotate (form)
  (if (and (listp form) (eq (car (cadr form)) '&&annotate))
      (cons (car form) (cddr form))
    form))

(defun get-annotate (form)
  (if (and (listp form) (eq (car (cadr form)) '&&annotate))
      (cadr (cadr form))
    nil))

(defun annotate (form val)
  (if (null val)
      form
    (let ((form-1 (un-annotate form)))
      (cons (car form-1) (cons (list '&&annotate val) (cdr form-1))))))

(defun annotate-prop (form prop)
  (let ((ann (get-annotate form)))
    (if ann
        (let ()
          (setf ann (findl prop ann))
          (if ann
              (cadr ann)
            nil))
      nil)))



(defun get-form (e)
  (car e))

(defun get-aux (e)
  (cadr e))