;;;; Startup Initialization LISP Code for the
;;;; lisp51 Interpreter
;;;;
;;;; File:	    lisp51.lsp
;;;; Author:        {your name} <{your e-mail address}>
;;;; Assignment:    8

; Set limit large enough
;
(set-gc-limit 8000)

(set-symbol-function 'list '(lambda (&rest x) x))

;; (PROGN . body) ===> (COND (T . body))
;;
(set-symbol-function 'progn
  '(macro (&rest body)
	  (list 'cond (cons 't body))))

;; (DEFMACRO name arguments . body) ===>
;;     (PROGN (SET-SYMBOL-FUNCTION
;;	       'name '(MACRO arguments . body))
;;            'name)
;;
(set-symbol-function 'defmacro
  '(macro (name arguments &rest body)
	  (list
	   'progn
	   (list 'set-symbol-function
		 (list 'quote name)
		 (list 'quote
		       (cons 'macro
			     (cons arguments body))))
	   (list 'quote name))))

;; (DEFUN name arguments . body) ===>
;;     (PROGN (SET-SYMBOL-FUNCTION
;;	       'name '(LAMBDA arguments . body))
;;            'name)
;;
(defmacro defun (name arguments &rest body)
  (list
   'progn
   (list 'set-symbol-function
	 (list 'quote name)
	 (list 'function
	       (cons 'lambda (cons arguments body))))
   (list 'quote name)))


(defun cddr (x) (cdr (cdr x)))
(defun cadr (x) (car (cdr x)))
(defun caddr (x) (car (cddr x)))
(defun cdddr (x) (cdr (cddr x)))
(defun cadddr (x) (car (cdddr x)))
(defun cddddr (x) (cdr (cdddr x)))

(defun null (x) (eql x nil))
(defun not (x) (eql x nil))
(defun atom (x) (not (consp x)))

;; (MAPCAR #'f '()) ===> nil
;; (MAPCAR #'f '(x . y))
;;     ===> (CONS (FUNCALL #'f 'x)
;;	          (MAPCAR #'f 'y))
;;
(defun mapcar (f lst)
  (cond
   ((null lst) nil)
   (t (cons (funcall f (car lst))
	    (mapcar f (cdr lst))))))

;; (OR) ===> (COND)
;; (OR x1 x2 ...) ===> (COND (x1) (x2) ...)
;;
(defmacro or (&rest args)
  (cons 'cond (mapcar #'list args)))

;; (AND) ===> T
;; (AND x) ===> x
;; (AND x . y) ===> (COND (x (AND . y)))
;;
(defmacro and (&rest args)
  (cond
   ((null args) t)
   ((null (cdr args)) (car args))
   (t (list 'cond (list (car args)
			(cons 'and (cdr args)))))))

;; (IF x y) ===> (COND (x y))
;; (IF x y z) ===> (COND (x y) (t z))
;; (IF x y z w . u) ===>
;;	(ERROR '|IF: too many arguments|)
;;
(defmacro if (x y &rest z)
  (cond
   ((null z) (list 'cond (list x y)))
   ((null (cdr z))
    (list 'cond (list x y) (cons t z)))
   (t (error '|IF: too many arguments|))))

;; (EQUAL '(w . x) '(y . z)
;;     ===> (AND (EQUAL 'w 'y) (EQUAL 'x 'z))
;; (EQUAL 'x 'y) ===> (EQL 'x 'y) otherwise
;;
(defun equal (x y)
  (cond
   ((and (consp x) (consp y))
    (and (equal (car x) (car y))
	 (equal (cdr x) (cdr y))))
   (t (eql x y))))

 
(defun listp (x) (or (null x) (consp x)))
(defun numberp (x) (fixnump x))
(defun zerop (x) (= x 0))

;; (LENGTH 'a) ===> 0		a is an atom
;; (LENGTH '(x . y)) ===> (+ 1 (LENGTH 'y))
;;
(defun length (lst)
  (cond
   ((atom lst) 0)
   (t (+ 1 (length (cdr lst))))))

;; (APPEND) ===> NIL
;; (APPLY #'APPEND '() 'z) ===> (APPLY #'APPEND 'z)
;; (APPLY #'APPEND '(x . y) 'z)
;;     ===> (CONS 'x (APPLY #'APPEND 'y 'z))
;;
(defun append (&rest args)
  nil)	;; Replace this line.

;; (LAST NIL) ===> NIL			a is an atom
;; (LAST '(x . a)) ===> '(x . a)
;; (LAST '(x . (y . z))) ===> (LAST '(y . z))
;;
(defun last (lst)
  (cond
   ((null lst) nil)
   ((atom (cdr lst)) lst)
   (t (last (cdr lst)))))

;; (TEST--FUNCTION '()) ===> #'EQL
;; (TEST--FUNCTION '(:TEST x)) ===> x
;; (TEST--FUNCTION 'z)
;;     ===> (ERROR '|Bad :TEST argument|)
;;
(defun test--function (testargs)
  (cond
   ((null testargs) #'eql)
   ((not (and (consp testargs)
	      (eql (car testargs) ':test)
	      (consp (cdr testargs))
	      (null (cddr testargs))))
    (error '|Bad :TEST argument|))
   (t (cadr testargs))))

(defun member (x lst &rest testargs)
  (member--helper x lst (test--function testargs)))

;; (MEMBER--HELPER 'x '() #'f) ===> NIL
;; (MEMBER--HELPER 'x '(y . z) #'f)
;;     ===> '(y . z) if (FUNCALL #'f 'x 'y) ===> true
;;     ===> (MEMBER--HELPER 'x 'z '#f)  otherwise
;;
(defun member--helper (x lst test-function)
  (cond
   ((null lst) nil)
   ((funcall test-function x (car lst))
    lst)
   (t (member--helper x (cdr lst) test-function))))

(defun assoc (x lst &rest testargs)
  (assoc--helper x lst (test--function testargs)))

;; (ASSOC--HELPER 'x '() #'f) ===> NIL
;; (ASSOC--HELPER 'x '((y . z) . w) #'f)
;;     ===> '(y . z) if (FUNCALL #'f 'x 'y) ===> true
;;     ===> (ASSOC--HELPER 'x 'w '#f)  otherwise
;; (ASSOC--HELPER 'x 'v #'f)
;;     ===> (ERROR '|ASSOC: non-assoc-list|)
;;
(defun assoc--helper (x lst test-function)
  (cond
   ((null lst) nil)
   ((not (and (consp lst)
	      (consp (car lst))))
    (error '|ASSOC: non-assoc-list|))
   ((funcall test-function x (car (car lst)))
    (car lst))
   (t (assoc--helper x (cdr lst) test-function))))

(defun abs (x) (cond ((>= x 0) x) (t (- x))))

;; (APPLY #'> 'x 'y 'z) ===>
;;     (AND (< 'y 'x) (OR (NULL 'z) (APPLY #'> 'y 'z)))
;;
(defun > (x y &rest z)
  (and (< y x)
       (or (null z) (apply #'> y z))))

;; (APPLY #'<= 'x 'y 'z) ===>
;;     (AND (OR (< 'x 'y) (= 'x 'y))
;;          (OR (NULL 'z) (APPLY #'<= 'y 'z)))
;;
(defun <= (x y &rest z)
  (and (or (< x y) (= x y))
       (or (null z) (apply #'<= y z))))

;; (APPLY #'>= 'x 'y 'z) ===>
;;     (AND (OR (< 'y 'x) (= 'x 'y))
;;          (OR (NULL 'z) (APPLY #'>= 'y 'z)))
;;
(defun >= (x y &rest z)
  (and (or (< y x) (= x y))
       (or (null z) (apply #'>= y z))))

;; (APPLY #'/= 'x 'y) ===>
;;     (AND (NOT (MEMBER 'x 'y :TEST #'=))
;;          (OR (NULL 'y) (APPLY #'/= 'y)))
;;
(defun /= (x &rest y)
  (and (not (member x y :test #'=))
       (or (null y) (apply #'/= y))))

;; (MAX 'x 'y) ===> 'y if (< 'x 'y)
;;	       ===> 'x otherwise
;; (APPLY #'MAX 'x 'y 'z)
;;     ===> (APPLY #'MAX 'y 'z)		if (< 'x 'y)
;;     ===> (APPLY #'MAX 'x 'z)		otherwise
;;
(defun max (x y &rest z)
  (cond
   ((null z)
    (cond
     ((< x y) y)
     (t x)))
   (t
    (cond
     ((< x y) (apply #'max y z))
     (t (apply #'max x z))))))

;; (MIN 'x 'y) ===> 'y if (< 'y 'x)
;;	       ===> 'x otherwise
;; (APPLY #'MIN 'x 'y 'z)
;;     ===> (APPLY #'MIN 'y 'z)		if (< 'y 'x)
;;     ===> (APPLY #'MIN 'x 'z)		otherwise
;;
(defun min (x y &rest z)
  (cond
   ((null z)
    (cond
     ((< y x) y)
     (t x)))
   (t
    (cond
     ((< y x) (apply #'min y z))
     (t (apply #'min x z))))))

;; (SETF s 'v) ===> (SETQ s 'v)		s is a symbol
;; (SETF (SYMBOL-VALUE 'x) 'v) ===> (SET 'x 'v)
;; (SETF (SYMBOL-FUNCTION 'x) 'v)
;;     ===> (SET-SYMBOL-FUNCTION 'x 'v)
;; (SETF (SYMBOL-PLIST 'x) 'v)
;;     ===> (SET-SYMBOL-PLIST 'x 'v)
;; (SETF (CAR 'x) 'v) ;;     ===> (CAR (RPLACA 'x 'v))
;; (SETF (CDR 'x) 'v) ;;     ===> (CDR (RPLACD 'x 'v))
;; (SETF 'x 'v)
;;     ===> (ERROR '|SETF: Bad setf place.|)
;;
(defmacro setf (place value)
  (cond
   ((symbolp place)
    (list 'setq place value))
   ((or (not (consp place))
	(not (consp (cdr place)))
	(not (null (cddr place))))
    (error '|SETF: Bad setf place.|))
   ((eql (car place) 'symbol-value)
    (list 'set (cadr place) value))
   ((eql (car place) 'symbol-function)
    (list 'set-symbol-function (cadr place) value))
   ((eql (car place) 'symbol-plist)
    (list 'set-symbol-plist (cadr place) value))
   ((eql (car place) 'car)
    (list 'car (list 'rplaca (cadr place) value)))
   ((eql (car place) 'cdr)
    (list 'cdr (list 'rplacd (cadr place) value)))
   (t
    (error '|SETF: Bad setf place.|))))

;; (COPY-LIST 'a) ===> 'a	a is an atom
;; (COPY-LIST '(x . y)) ===> (CONS 'x (COPY-LIST 'y))
;;
(defun copy-list (lst)
  (cond
   ((atom lst) lst)
   (t (cons (car lst) (copy-list (cdr lst))))))

;; (COPY-TREE 'a) ===> 'a	a is an atom
;; (COPY-TREE '(x . y)) ===> (CONS (COPY-TREE 'x)
;;				   (COPY-TREE 'y))
;;
(defun copy-tree (lst)
  (cond
   ((atom lst) lst)
   (t (cons (copy-tree (car lst))
	    (copy-tree (cdr lst))))))


;; (LET args . body)
;;     ===> (FUNCALL #'(LAMBDA argnames . body)
;;		     . argvalues)
;;
;; where (MAPCAR #'CAR 'args) ===> 'argnames
;; where (MAPCAR #'CADR 'args) ===> 'argvalues
;;
(defmacro let (args &rest body)
  nil)	;; Replace this line.

;; (DO args clause)
;;     ===> (LET ((DO--F
;;		   #'(LAMBDA (DO----F . argnames)
;;		      (COND clause
;;			    (T (FUNCALL
;;				DO----F
;;				DO----F
;;				.  argnexts))))))
;;	     (FUNCALL DO--F DO--F . arginits))
;;
;; where (MAPCAR #'CAR 'args) ===> 'argnames
;; where (MAPCAR #'CADR 'args) ===> 'arginits
;; where (MAPCAR #'CADDR 'args) ===> 'argnexts
;;
(defmacro do (args clause)
  (list
   'let
   (list
    (list
     'do--f
     (list 'function
	   (list 'lambda
		 (cons 'do----f (mapcar #'car args))
		 (list 'cond
		       clause
		       (list
			't
			(cons
			 'funcall
			 (cons
			  'do----f
			  (cons
			   'do----f
			   (mapcar #'caddr
				   args))))))))))
   (cons 'funcall
	 (cons 'do--f
	       (cons 'do--f (mapcar #'cadr args))))))

(defun reverse (lst)
  (reverse--helper lst nil))

;; (REVERSE--HELPER '() 'z) ===> 'z
;; (REVERSE--HELPER '(x . y) 'z)
;;     ===> (REVERSE--HELPER 'y '(x . z))
;;
(defun reverse--helper (lst result)
  (cond
   ((null lst) result)
   (t (reverse--helper (cdr lst)
		       (cons (car lst) result)))))

(defun subst (value key lst &rest testargs)
  (subst--helper value key lst
		 (test--function testargs)))

;; (SUBST--HELPER 'v 'k 'x #'f) ===> 'v
;;	if (FUNCALL #'f 'k 'x) ===> true
;; (SUBST--HELPER 'v 'k 'a #'f) ===> 'a     a is an atom
;; (SUBST--HELPER 'v 'k '(x . y) #'f)
;;     ===> (CONS (SUBST--HELPER 'v 'k 'x #'f)
;;		  (SUBST--HELPER 'v 'k 'y #'f))
;;
(defun subst--helper (value key lst test-function)
  (cond
   ((funcall test-function key lst) value)
   ((atom lst) lst)
   (t (cons (subst--helper value key (car lst)
			   test-function)
	    (subst--helper value key (cdr lst)
			   test-function)))))

(defun remove (value lst &rest testargs)
  (remove--helper value lst (test--function testargs)))

;; (REMOVE--HELPER 'v 'a #'f) ===> 'a    a is an atom
;; (REMOVE--HELPER 'v '(x . y) #'f)
;;	===> (REMOVE-HELPER 'v 'y #'f)
;;		if (FUNCALL #'f 'v 'x) ===>true
;;	===> (CONS 'x (REMOVE-HELPER 'v 'y #'f))
;;		otherwise
;;
(defun remove--helper (value lst test-function)
  (cond
   ((atom lst) lst)
   ((funcall test-function value (car lst))
    (remove--helper value (cdr lst)
		    test-function))
   (t
    (cons (car lst)
	  (remove--helper value (cdr lst)
			  test-function)))))

;; (NTH n 'lst) ===> (ERROR  '|NTH: negative index|)
;;			if n < 0
;; (NTH n '()) ===> NIL
;; (NTH 0 '(x . y)) ===> 'x
;; (NTH n '(x . y)) ===> (NTH (- n 1) 'y)
;;
(defun nth (n lst)
  (cond
   ((< n 0) (error '|NTH: negative index|))
   ((null lst) nil)
   ((= n 0) (car lst))
   (t (nth (- n 1) (cdr lst)))))

;; (SORT--BUBBLE 'x '() #'f) ===> '(x)
;; (SORT--BUBBLE 'x '(y . z) #'f)
;;     ===> (CONS 'y (SORT--BUBBLE 'x 'z #'f))
;;		if (FUNCALL #'f 'y 'x) ===> true
;;     ===> (CONS 'x (SORT--BUBBLE 'y 'z #'f))
;;		otherwise
;;
(defun sort--bubble (x lst test-function)
  (cond
   ((null lst) (list x))
   ((funcall test-function (car lst) x)
    (cons (car lst)
	  (sort--bubble x (cdr lst) test-function)))
   (t
    (cons x (sort--bubble (car lst)
			  (cdr lst) test-function)))))

;; (SORT '() #'f) ===> '()
;; (SORT '(x . y) #'f)
;;     ===> (SORT--BUBBLE 'x (SORT 'y '#f) #'f)
;;
(defun sort (lst test-function)
  (cond
   ((null lst) nil)
   (t (sort--bubble
       (car lst)
       (sort (cdr lst) test-function)
       test-function))))

(defun compile (s)
  (set-symbol-function
   s (compile--sexpr (symbol-function s))))

;; (COMPILE--SEXPR 'a) ===> 'a		a is an atom
;; (COMPILE--SEXPR '(QUOTE . x)) ===> '(QUOTE . x)
;; (COMPILE--SEXPR '(FUNCTION f))
;;     ===> `(FUNCTION ,(COMPILE--SEXPR 'f))
;; (COMPILE--SEXPR '(LAMBDA args . body))
;;     ===> `(LAMBDA args
;;		     . (MAPCAR #'COMPILE--SEXPR 'body))
;; (COMPILE--SEXPR '(MACRO args . body))
;;     ===> `(MACRO args
;;		    . (MAPCAR #'COMPILE--SEXPR 'body))
;; (COMPILE--SEXPR '(SETQ var . body))
;;     ===> `(SETQ var
;;		   . (MAPCAR #'COMPILE--SEXPR 'body))
;; (COMPILE--SEXPR '(LAMBDA-CLOSURE env args . body))
;;     ===> `(LAMBDA-CLOSURE
;;	      env args
;;            . (MAPCAR #'COMPILE--SEXPR 'body))
;; (COMPILE--SEXPR '(COND . clauses))
;;     ===> (COND . (MAPCAR
;;		     #'(LAMBDA (CLAUSE)
;;		        (MAPCAR #'COMPILE--SEXPR
;;				CLAUSE))
;;		      clauses))
;; (COMPILE--SEXPR 'x)
;;     ===> (COMPILE--SEXPR (MACROEXPAND-1 'x))
;;		if (NOT (EQUAL 'x (MACROEXPAND-1 'x)))
;; (COMPILE--SEXPR '(f . args))
;;     ===> (CONS 'f (MAPCAR #'COMPILE--SEXPR args))
;;

(defun compile--sexpr (e)
  (cond
   ((atom e) e)
   ((eql (car e) 'quote) e)
   ((eql (car e) 'function)
    (list (car e)
	  (compile--sexpr (cadr e))))
   ((member (car e) '(lambda macro setq))
    (cons (car e)
	  (cons (cadr e)
		(mapcar #'compile--sexpr (cddr e)))))
   ((eql (car e) 'lambda-closure)
    (cons (car e)
	  (cons (cadr e)
		(cons (caddr e)
		      (mapcar #'compile--sexpr
			      (cdddr e))))))
   ((eql (car e) 'cond)
    (cons (car e)
	  (mapcar #'(lambda (clause)
		      (mapcar #'compile--sexpr clause))
		  (cdr e))))
   ((not (equal e (macroexpand-1 e)))
    (compile--sexpr (macroexpand-1 e)))
   (t (cons (car e) (mapcar #'compile--sexpr
			    (cdr e))))))


(defun bye () (exit))

;; This takes a long time to run so we do not
;; simply compile everything all the time.
;;
(defun optimize--defines ()
  (compile 'compile)
  (compile 'compile--sexpr)
  
  (compile 'defmacro)
  (compile 'defun)
  (compile 'mapcar)
  (compile 'or)
  (compile 'and)
  (compile 'if)
  (compile 'equal)
  (compile 'length)
  (compile 'append)
  (compile 'last)
  (compile 'test--function)
  (compile 'member)
  (compile 'member--helper)
  (compile 'assoc)
  (compile 'assoc--helper)
  (compile 'abs)
  (compile '>)
  (compile '<=)
  (compile '>=)
  (compile '/=)
  (compile 'max)
  (compile 'min)
  (compile 'setf)
  (compile 'copy-list)
  (compile 'copy-tree)
  (compile 'let)
  (compile 'do)
  (compile 'reverse)
  (compile 'reverse--helper)
  (compile 'subst)
  (compile 'subst--helper)
  (compile 'remove)
  (compile 'remove--helper)
  (compile 'nth)
  (compile 'sort--bubble)
  (compile 'sort)
  'DONE)