;;; Wok Prelude library 0.1
;;; (c) 2008 Thomas Munro <munro@ip9.org>
;;;
;;; A little prelude for my Emacs Lisp code to provide simple tail call
;;; elimination and some other bits and pieces that might help when porting
;;; Scheme-style code*.  These macros are ugly and it may be dangerous to 
;;; stare at them directly without peril-sensitive sunglasses.
;;;
;;; Use wok-defun in place of defun to define a function that uses tail
;;; call recursion.  Use wok-let to get Scheme-style 'named let' syntax.  
;;; These macros expand to function definitions in which certain kinds of
;;; tail calls are replaced with reassignment inside a while loop.  Tail
;;; calls are detected in appropriate 'and', 'if', 'cond', 'let', 'or' and
;;; 'progn' forms.
;;;
;;; (*) Schemers and programmers of purely functional languages use recursive
;;; syntax to implement iterative processes (see SICP), which can blow Emacs's
;;; stack.  Emacs Lisp programs typically use explicit destruction for 
;;; iterative processes, which I do not like.

(defun wok-map (f &rest arguments)
  "A mapcar that supports any-arity functions.  Similar to the example
  given in the Emacs Lisp manual."
  (if (not (memq nil arguments))              
      (cons (apply f (mapcar #'car arguments))  
            (apply #'wok-map f             
                   (mapcar #'cdr arguments)))))

(assert (equal (wok-map #'cons '() '(a b)) '()))
(assert (equal (wok-map #'cons '(1) '(a b)) '((1 . a))))
(assert (equal (wok-map #'cons '(1 2) '(a b)) '((1 . a) (2 . b))))

(defun wok-take (list count)
  "Returns the first 'count' elements from 'list'."
  (if (and list (> count 0))
      (cons (car list)
            (wok-take (cdr list) (- count 1)))))

(assert (equal (wok-take '(1 2 3) 0) '()))
(assert (equal (wok-take '(1 2 3) 1) '(1)))
(assert (equal (wok-take '(1 2 3) 2) '(1 2)))
(assert (equal (wok-take '(1 2 3) 3) '(1 2 3)))
(assert (equal (wok-take '(1 2 3) 4) '(1 2 3)))

(defun wok-last (list)
  "Returns the last elements from 'list'."
  (if (cdr list)
      (wok-last (cdr list))
    (car list)))

(assert (eq (wok-last '()) nil))
(assert (eq (wok-last '(1 2 3)) 3))

(defun wok-loopify-tail-calls (expression name formals iterate)
  "A helper function for macros that define functions with optimisation for
   tail calls.  Keep out."
  (cond ((null expression) nil)
        ((consp expression)
         (let ((head (car expression)))
           (cond ((eq head name) ; tail call
                  (if (= (length formals)
                         (length (cdr expression)))
                      `(progn
                         ,@(wok-map (lambda (name value)
                                      (list 'setq name value))
                                    formals
                                    (cdr expression))
                         ,iterate)
                         ;(setq ,more t))
                    (error "Wrong number of formal arguments in %s" 
                           expression)))
                 ((eq head 'if)
                  (case (length (cdr expression))
                    ((3) `(if ,(cadr expression)
                              ,(wok-loopify-tail-calls (caddr expression)
                                                       name
                                                       formals
                                                       iterate)
                              ,(wok-loopify-tail-calls (cadddr expression)
                                                       name
                                                       formals
                                                       iterate)))
                    ((2) `(if ,(cadr expression)
                              ,(wok-loopify-tail-calls (caddr expression)
                                                       name
                                                       formals
                                                       iterate)))
                    (t (error "Bad expression: %s" expression))))
                 ((memq head '(progn and or))
                  (let ((len (length (cdr expression))))
                    (if (> len 0)
                        `(,head ,@(wok-take (cdr expression) (- len 2))
                                ,(wok-loopify-tail-calls (wok-last expression)
                                                         name
                                                         formals
                                                         iterate))
                      (error "Bad expression: %s" expression))))
                 ((eq head 'cond)
                  (if (>= (length expression) 2)
                      `(cond ,@(mapcar (lambda (clause)
                                         (if (>= (length clause) 2)
                                             (list (car clause)
                                                   (wok-loopify-tail-calls 
                                                    (append '(progn)
                                                            (cdr clause))
                                                    name
                                                    formals
                                                    iterate))
                                           (error "Bad cond clause: %s" 
                                                  clause)))
                                       (cdr expression)))
                    (error "Bad cond expression: %s" expression)))
                 ((eq head 'let)
                  (let ((len (length (cdr expression))))
                    (if (>= len 2)
                        `(let ,(cadr expression)
                              ,@(wok-take (cddr expression) (- len 1))
                              ,(wok-loopify-tail-calls (wok-last expression)
                                                       name
                                                       formals
                                                       iterate))
                      (error "Bad expression: %s" expression))))
                 (t expression))))
        (t expression)))

(defmacro wok-defun (name formals &rest body)
  "A loopy version of defun.  No &rest or &optional yet."
  (let ((result (gensym "result-"))
         (more (gensym "more-")))
    `(defun ,name ,formals
       (let ((,result nil)
             (,more t))
         (while ,more
           (setq ,more nil)
           (setq ,result
                 ,(wok-loopify-tail-calls (append '(progn) body )
                                          name 
                                          formals 
                                          (list 'setq more t))))
         ,result))))

(defmacro wok-let (name defs &rest body)
  "A poor man's named let.  Supports recursion with tail call elimination."
  (if (and (symbolp name)
           (or (null defs) 
               (consp defs)))
      (let ((save (gensym))
            (old-function (gensym "old-function-"))
            (result (gensym "result-"))
            (more (gensym "more-"))
            (formals (mapcar #'car defs))
            (initial-values (mapcar #'cadr defs)))
        `(let ((,old-function (if (fboundp ',name)
                                 (symbol-function ',name)
                               nil)))
           (fset ',name 
                 (lambda ,formals
                   (let ((,result nil)
                         (,more t))
                     (while ,more
                       (setq ,more nil)
                       (setq ,result
                             ,(wok-loopify-tail-calls (append '(progn) body)
                                                      name
                                                      formals
                                                      (list 'setq more t))))
                     ,result)))
           (unwind-protect 
               (,name ,@initial-values)
             (if ,old-function
                 (fset ',name ,old-function)
               (makunbound ',name)))))
    (error "wok-let expects <name> <definitions> <body> ...")))
  
(provide 'wok-prelude)