(in-package :lambda-riffs)

(eval-when (:compile-toplevel :load-toplevel :execute)
  ;;; some fucntions for workign with substitution variables

  (defun substitute-var-p (symbol prefix)
    (and (not (eql '$ symbol))
         (symbolp symbol)
         (<= (length prefix)
             (length (symbol-name symbol)))
         (string-equal (symbol-name symbol) prefix
                       :end1 (length prefix))))

  (defun numeric-var-p (symbol prefix)
    (and (substitute-var-p symbol prefix)
         (digit-char-p
          (elt (symbol-name symbol) (length prefix)))))


  (set-dispatch-macro-character
   #\# #\$
   (lambda (stream subchar infix)
     (declare (ignore subchar infix))
     (let ((form1 (read stream)))
       (if (symbolp form1)
           (list '$ (list (concatenate 'string "$"
                                       (symbol-name form1)))
                 (read stream))
           (list '$ () form1))))))

;; Note, presently references to upper level variables in nested
;; partials requires tha tthose upper level variables acttually appear
;; in the upper level partials.

;; e.g. 
;; 
;; #$(mapcar #$$(cons $$x (length $xs)) $xs)
;;
;;  is OK but 
;;
;; #$(mapcar #$$(cons $$x (length $passed-in-list)) '(1 2 3 4))
;;
;; is not ok. 

(defmacro $ ((&optional (prefix "$")) expr)
  "Function splicer. A kind of partial evaluation.

Meant to be used in conjunction with the reader macro #$.

E.g. 

#$(+ $X 1)  

is roughly equivalent to 

(LAMBDA ($X) (+ $X 1))

The order of arguments can be controlled by using positional
variables. E.g.

#$(+ $2 $1) 

is equivalent to 

(LAMBDA ($1 $2) (+ $2 $1))

Limited nestiing is supported.  E.g.

#$(MAPCAR #$$(CONS $$INNER (LENGTH $OUTER))  $OUTER) 

is equvalent to

(LAMBDA ($OUTER) 
  (MAPCAR (LAMBDA ($$INNER) (CONS $$INNER (LENGTH $OUTER)))
          $OUTER))

However, a variable inside a nested form must actually appear in the
surrounding form. 

THIS WONT WORK: #$(+ #$$(* $X $$Y)) because $$Y doesn't appear in the
surrounding form.

 "
  (let ((new-params (list))
        (numeric-params nil))
    (labels ((walk (node)
               (cond ((and
                       (consp node)
                       (consp (car node))
                       (eq '$ (caar node)))
                      (walk (cdr node)))
                     
                     ((consp node)
                      (walk (car node))
                      (walk (cdr node)))
                     (t
                      (when (substitute-var-p node prefix)
                        (pushnew node new-params))
                      (when (numeric-var-p node prefix)
                        (setf numeric-params t))))))
      (walk expr))
    (setf new-params
          (if numeric-params
              (sort new-params #'<
                    :key (lambda (var)
                           (parse-integer (symbol-name var)
                                          :junk-allowed t
                                          :start (length prefix))))
              (reverse new-params)))
    `(lambda ,new-params ,expr)))