(module translate
	(main main))

;;;; elminiate-letrec -> eliminate-let -> curry -> explicify-apply -> eliminate-lambda -> unlambdify

(define (atom? x)
    (not (list? x)))

(define (eliminate-high-level x)
    (match-case x
      (#t #t)
      (#f #f)
      (() `(lambda (f) ,(eliminate-high-level #t)))
      (cons '(lambda (a b) (lambda (f) (f a b))))
      (car '(lambda (l) (l (lambda (a b) a))))
      (cdr '(lambda (l) (l (lambda (a b) b))))
      (null? `(lambda (l) (l (lambda (a b) ,(eliminate-high-level #f)))))
      ((lambda ?args ?body)
       `(lambda ,args ,(eliminate-high-level body)))
      ((if ?condition ?consequent ?alternative)
       `((**if**
	  ,(eliminate-high-level condition)
	  (lambda (**if-dummy**) ,(eliminate-high-level consequent))
	  (lambda (**if-dummy**) ,(eliminate-high-level alternative))) **i**))
      ((cond)
       (eliminate-high-level #f))
      ((cond (else ?expr))
       (eliminate-high-level expr))
      ((cond (?condition ?consequent) . ?rest)
       (eliminate-high-level `(if ,condition
			       ,consequent
			       (cond ,@rest))))
      (((kwote not) ?b)			;should we make this a pure function?
       (eliminate-high-level `(if ,b #f #t)))
      (((kwote and) ?x)
       (eliminate-high-level x))
      (((kwote and) ?a . ?rest)
       (eliminate-high-level `(if ,a (and ,@rest) #f)))
      (((kwote or) ?x)
       (eliminate-high-level x))
      (((kwote or) ?a . ?rest)
       (eliminate-high-level `(if ,a #t (or ,@rest))))
      ((begin ?expr)
       (eliminate-high-level expr))
      ((begin ?expr . ?rest)
       `((lambda (*dummy*) ,(eliminate-high-level `(begin ,@rest)))
	 ,(eliminate-high-level expr)))
      ((write-char ?c)
       `((*write-char* ,c) **i**))
      ((is-char? ?c)
       `((*is-char* ,c) **i**))
      ((read-char?)
       `(**read-char** **i**))
      ((read-char=? ?c)
       `((**read-char=** ,c) **i**))
      (?-
       (if (atom? x)
	   x
	   (map eliminate-high-level x)))))

(define (eliminate-letrec x)
    (letrec ((eliminate (lambda (x fs)
			  (cond ((or (atom? x) (null? x))
				 (let ((a (assq x fs)))
				   (if a
				       (cdr a)
				       x)))
				((eq? (car x) 'lambda)
				 (let ((a (cadr x))
				       (b (caddr x)))
				   `(lambda ,a ,(eliminate b (filter (lambda (x) (not (memq (car x) a))) fs)))))
				((eq? (car x) 'letrec)
				 (let* ((fns (map car (cadr x)))
					(new-fs (append (map (lambda (x)
							       (let ((l (cadr x)))
								 (cons (car x)
								       `(lambda ,(cadr l) (,(car x) ,@(cadr l) ,@fns)))))
							     (cadr x))
							fs)))
				   `((lambda ,fns
				       ,(eliminate (caddr x) new-fs))
				     ,@(map (lambda (x)
					      (let ((l (cadr x)))
						`(lambda (,@(cadr l) ,@fns)
						  ,(eliminate (caddr l) new-fs))))
					    (cadr x)))))
				(else
				 (map (lambda (x) (eliminate x fs)) x))))))
	    (eliminate x '())))

(define (eliminate-let x)
    (cond ((or (atom? x) (null? x))
	   x)
	  ((eq? (car x) 'lambda)
	   `(lambda ,(cadr x) ,(eliminate-let (caddr x))))
	  ((eq? (car x) 'let)
	   (if (symbol? (cadr x))
	       `(letrec ((,(cadr x) (lambda ,(map car (caddr x))
				      ,(eliminate-let (cadddr x)))))
		 (,(cadr x) ,@(map (lambda (x) (eliminate-let (cadr x))) (caddr x))))
	       `((lambda ,(map car (cadr x)) ,(eliminate-let (caddr x))) ,@(map (lambda (x) (eliminate-let (cadr x))) (cadr x)))))
	  (else
	   (map eliminate-let x))))

(define (eliminate-lambda* x)
    (match-case x
      ((lambda* ?name ?args ?body)
       `((lambda (x) (x x))
	 (lambda (,name ,@args)
	   ,(eliminate-lambda* (macroexpand (list (cons name (lambda (args)
							       (append (list name name) args))))
					    body)))))
      (?-
       (if (or (atom? x) (null? x))
	   x
	   (map eliminate-lambda* x)))))

(define (eliminate-lets x)
    (eliminate-letrec (eliminate-let (eliminate-lambda* x))))

(define (curry x)
    (cond ((atom? x)
	   x)
	  ((eq? (car x) 'lambda)
	   (let ((a (cadr x))
		 (b (caddr x)))
	     (cond ((null? a)
		    `(lambda (**dummy**) ,(curry b)))
		   ((null? (cdr a))
		    `(lambda ,a ,(curry b)))
		   (else
		    `(lambda (,(car a)) ,(curry `(lambda ,(cdr a) ,b)))))))
	  (else
	   (let ((f (curry (car x)))
		 (a (map curry (cdr x))))
	     (cond ((null? a)
		    `(,f **i**))
		   ((null? (cdr a))
		    `(,f ,@a))
		   (else
		    (curry `((,f ,(car a)) ,@(cdr a)))))))))

(define (pass-through? x)
    (or (boolean? x)
	(and (list? x)
	     (or (eq? (car x) '*write-char*)
		 (eq? (car x) '**read-char=**)
		 (eq? (car x) '*is-char*)))
	(or (eq? x '**i**) (eq? x '**k**) (eq? x '**v**) (eq? x '**if**) (eq? x '**read-char**))))

(define (pass-through-predicate? x)
    (or (and (list? x) (eq? (car x) '**read-char=**))
	(eq? x '**read-char**)))

;(define (**i** x) x)
;(define (**k** x) (lambda (y) x))
;(define (**s** x) (lambda (y) (lambda (z) ((x z) (y z)))))
;(define (*write-char* x) (lambda (y) (write-char x) y))

(define (optimize-curried x)
    (cond ((or (atom? x) (pass-through? x))
	   x)
	  ((eq? (car x) 'lambda)	;(lambda (a) (lambda (b) a)) -> **k**
	   (let ((a (caadr x))
		 (b (caddr x)))
	     (if (and (list? b)
		      (eq? (car b) 'lambda)
		      (not (eq? (caadr b) a))
		      (eq? (caddr b) a))
		 '**k**
		 `(lambda (,a) ,(optimize-curried b)))))
	  (else
	   (list (optimize-curried (car x)) (optimize-curried (cadr x))))))

(define (compile-to-bytecode x)
    (letrec ((index (lambda (x e)
		      (cond ((null? e)
			     (error "compile-to-bytecode" "symbol not bound" x))
			    ((eq? x (car e))
			     0)
			    (else
			     (+ 1 (index x (cdr e)))))))
	     (compile (lambda (x e)
			(cond ((eq? x '**i**)
			       (compile '(lambda (x) x) '()))
			      ((eq? x #t)
			       (compile '(lambda (t) (lambda (f) t)) '()))
			      ((eq? x #f)
			       (compile '(lambda (t) (lambda (f) f)) '()))
			      ((eq? x '**if**)
			       (compile '(lambda (c) (lambda (t) (lambda (e) ((c t) e)))) '()))
			      ((pass-through-predicate? x)
			       (list 'native `(lambda (**dummy**)
					       (if (,x **i**)
						   ,(bytecode->scheme (scheme->bytecode #t))
						   ,(bytecode->scheme (scheme->bytecode #f))))))
			      ((pass-through? x)
			       (list 'native x))
			      ((atom? x)
			       (let ((i (index x e)))
				 (list 'get i)))
			      ((eq? (car x) 'lambda)
			       (list 'lambda (compile (caddr x) (cons (caadr x) e))))
			      (else
			       (list 'apply (compile (car x) e) (compile (cadr x) e)))))))
	    (compile x '())))

(define (bytecode->scheme x)
    (letrec ((number->scheme (lambda (n)
			       (if (= 0 n)
				   '()
				   `(cons ,(if (= (remainder n 2) 1)
					       'cdr
					       '**i**)
				     ,(number->scheme (quotient n 2))))))
	     (transform (lambda (x)
			  (let ((type (car x)))
			    (cond ((eq? type 'lambda)
				   `((cons ((cons #t) #t)) ,(transform (cadr x))))
				  ((eq? type 'apply)
				   `((cons ((cons #t) #f)) ((cons ,(transform (cadr x))) ,(transform (caddr x)))))
				  ((eq? type 'get)
				   `((cons ((cons #f) #t)) ,(number->scheme (cadr x))))
				  ((eq? type 'native)
				   `((cons ((cons #f) #f)) ,(cadr x))))))))
	    (transform x)))

(define (unbound-in? a x)
    (cond ((atom? x)
	   (eq? x a))
	  ((pass-through? x)
	   #f)
	  ((eq? (car x) 'lambda)
	   (if (eq? (caadr x) a)
	       #f
	       (unbound-in? a (caddr x))))
	  (else
	   (or (unbound-in? a (car x)) (unbound-in? a (cadr x))))))

(define (contains-variables? x)
    (cond ((pass-through? x)
	   #f)
	  ((atom? x)
	   #t)
	  (else
	   (or (contains-variables? (car x))
	       (contains-variables? (cadr x))))))

(define (lambda-depth x)
    (cond ((or (atom? x) (pass-through? x))
	   0)
	  ((eq? (car x) 'lambda)
	   (let ((depth (lambda-depth (caddr x))))
	     (if (unbound-in? (caadr x) (caddr x))
		 (+ 1 depth)
		 depth)))
	  (else
	   (max (lambda-depth (car x)) (lambda-depth (cadr x))))))

(define (eliminate-lambda x)
    (letrec ((eliminate (lambda (x)
			  (cond ((or (atom? x) (pass-through? x))
				 x)
				((eq? (car x) '**d**)
				 x)
				((eq? (car x) 'lambda)
				 (let ((a (caadr x))
				       (b (caddr x)))
				   (cond ((eq? a b)
					  '**i**)
					 ((or (atom? b)
					      (pass-through? b))
					  (if (eq? b '**d**)
					      (display "kurd"))
					  `(**k** ,b))
					 ((and (not (unbound-in? a b))
					       (not (contains-variables? b)))
					  `(**d** (**k** ,(eliminate b))))
					 ((eq? (car b) 'lambda)
					  (eliminate `(lambda (,a) ,(eliminate b))))
					 (else
					  (let ((g (car b))
						(h (cadr b)))
					    (if (eq? g '**d**)
						(begin
						 (if (contains-variables? h)
						     (display "heusl"))
						 `(**k** ,b))
						`((**s** ,(eliminate `(lambda (,a) ,g))) ,(eliminate `(lambda (,a) ,h)))))))))
				(else
				 `(,(eliminate (car x)) ,(eliminate (cadr x))))))))
	    (eliminate x)))

(define (eliminate-d x)
    (cond ((or (atom? x) (pass-through? x))
	   x)
	  ((eq? (car x) '**d**)
	   `(lambda (x) (,(eliminate-d (cadr x)) x)))
	  (else
	   `(,(eliminate-d (car x)) ,(eliminate-d (cadr x))))))

(define (unlambdify x)
    (match-case x
      (**i** (write-char #\i))
      (**k** (write-char #\k))
      (**s** (write-char #\s))
      (**d** (write-char #\d))
      (**v** (write-char #\v))
      (#t (write-char #\i))
      (#f (write-char #\v))
      (**if**
       (display "``s`kc``s`k`s`k`k`ki``ss`k`kk"))
      (**read-char**
       (write-char #\@))
      ((**read-char=** ?c)
       (write-char #\?)
       (write-char c))
      ((*write-char* ?c)
       (write-char #\.)
       (write-char (cadr x)))
      ((?f ?a)
       (write-char #\`)
       (unlambdify f)
       (unlambdify a))
      (?-
       (error "unlambdify" "illegal unlambda" x))))

;;; some compiler driver functions

(define (scheme->unlambda x)
    (unlambdify (eliminate-lambda (optimize-curried (curry (eliminate-high-level (eliminate-lets x)))))))

(define (scheme->bytecode x)
    (compile-to-bytecode (curry (eliminate-high-level (eliminate-lets x)))))

(define (scheme->bytecompile-unlambda x)
    (scheme->unlambda (bytecode->scheme (scheme->bytecode x))))

;;; macroexpansion

(define (eliminate-names macros names)
    (filter (lambda (macro) (not (member (car macro) names))) macros))

(define (macroexpand-arg arg)
    (lambda (arg-args)
      (if (null? arg-args)
	  arg
	  (cons arg arg-args))))

(define (make-macros args arg-names)
    (if (or (null? args) (null? arg-names))
	(values '() args arg-names)
	(multiple-value-bind (macros rest-args rest-arg-names)
	    (make-macros (cdr args) (cdr arg-names))
	  (values (cons (cons (car arg-names) (macroexpand-arg (car args))) macros)
		  rest-args rest-arg-names))))

(define (macroexpand-application arg-names body macros)
    (lambda (args)
      (multiple-value-bind (arg-macros args arg-names)
	  (make-macros args arg-names)
	(let ((macros (append arg-macros macros)))
	  (cond ((and (null? args) (null? arg-names))
		 (macroexpand macros body))
		((null? args)
		 (macroexpand macros `(lambda ,arg-names ,body)))
		((null? arg-names)
		 (cons (macroexpand macros body) args))
		(else
		 (error "macroexpand-application" "make-macros does not work" (cons args arg-names))))))))

;; a macro is a (name . (lambda (macro-args) *body*))
(define (macroexpand macros expr)
    ;(printf "macroexpand called for ~a with macros ~a~%" expr (map car macros))
    (match-case expr
      ((lambda ?args ?body)
       `(lambda ,args ,(macroexpand (eliminate-names macros args) body)))
      ((lambda* ?name ?args ?body)
       `(lambda* ,name ,args ,(macroexpand (eliminate-names macros (cons name args)) body)))
      ((let ?name ?args ?body)
       `(let ,name ,(map (lambda (arg)
			   (list (car arg) (macroexpand macros (cadr arg))))
			 args)
	 ,(macroexpand (eliminate-names macros (map car args)) body)))
      ((let ?bindings ?body)
       `(let ,(map (lambda (binding)
		     (list (car binding) (macroexpand macros (cadr binding))))
		   bindings)
	 ,(macroexpand (eliminate-names macros (map car bindings)) body)))
      ((letrec ?bindings ?body)
       (let ((macros (eliminate-names macros (map car bindings))))
	 `(letrec ,(map (lambda (binding)
			  (list (car binding) (macroexpand macros (cadr binding))))
			bindings)
	   ,(macroexpand macros body))))
      ((?func . ?args)
       (if (and (atom? func) (member func (map car macros)))
	   (let ((macro (cdr (assoc func macros))))
	     (macro (map (lambda (arg) (macroexpand macros arg)) args)))
	   (cons (macroexpand macros func) (map (lambda (arg) (macroexpand macros arg)) args))))
      (?-
       (let ((macro (assoc expr macros)))
	 (if macro
	     ((cdr macro) '())
	     expr)))))

;;; program input

(define (read-program file)
    (with-input-from-file file
      (lambda ()
	(let read-program ((macros '()))
	     (match-case (read)
	       ((defmacro (?name . ?args) ?body)
		(read-program (cons (cons name (macroexpand-application args body macros)) macros)))
	       ((defmacro ?name ?body)
		(read-program (cons (cons name (macroexpand-application '() body macros)) macros)))
	       ((defrecmacro (?name . ?args) ?body)
		(read-program (cons (cons name (macroexpand-application '() `(lambda* ,name ,args ,body) macros)) macros)))
	       ((defrecmacro ?name ?body)
		(read-program (cons (cons name (macroexpand-application '() `(lambda* ,name () ,body) macros)) macros)))
	       (?program
		(macroexpand macros program)))))))

;;; command line handling

(define (main argv)
    (args-parse (cdr argv)
		(("-c" ?file (help "directly compile to unlambda"))
		 (scheme->unlambda (read-program file)))
		(("-b" ?file (help "bytecompile to unlambda"))
		 (scheme->bytecompile-unlambda (read-program file)))
		(("-d" ?file (help "bytecompile and dump bytecode"))
		 (write (scheme->bytecode (read-program file)))
		 (newline))
		(("-h" ?file (help "dump after eliminating high level"))
		 (write (eliminate-high-level (eliminate-lets (read-program file))))
		 (newline))
		(("-m" ?file (help "dump after macroexpansion"))
		 (write (read-program file))
		 (newline))
		(else
		 (args-parse-usage #f))))
