;; lambda-k.scm - (c) rohan drape, 2000-2007

(module lambda-k scheme/base
(require (only-in srfi/1 drop every find find-tail list-index take)
	 (only-in srfi/23 error)
	 ;; (only-in srfi/48 format)
	 (only-in (lib "plt-match.ss") match))
(provide lambda-k define-k)

(define (compose f g)
  (lambda (k) (f (g k))))

;; A SuperCollider keyword is a symbol that terminates with a colon.
;; Keywords can be made self-evaluating.

(define (sc3-keyword? s)
  (and (symbol? s)
       (let ((s_ (symbol->string s)))
	 (eq? (string-ref s_ (- (string-length s_) 1)) #\:))))

;; Make a <function> that will rewrite an input <list> to conform to
;; the <list> `descriptor'.  Each element of `descriptor' must be a
;; duple (name default).  The rewriter parses keywords for variable
;; names.  The result is a <list> of exactly the number of arguments
;; required by the specification `descriptor', default values are used
;; if any arguments are not supplied.  Raises an error if `descriptor'
;; is not legal.  The resulting procedure will raise an error if it's
;; input is malformed, in which case the <symbol> `title' is given as
;; part of the error.

(define (valid-descriptor? descriptor)
  (every (lambda (e)
	   (and (list? e) 
		(= (length e) 2)
		(symbol? (car e))))
	 descriptor))

(define (lambda-k-rewriter title descriptor)
  (if (not (valid-descriptor? descriptor))
      (error 'lambda-k-rewriter "illegal descriptor" title descriptor)
      (match 
       (let ((d (map (lambda (e) 
		       (if (list? e) e (list e #f)))
		     descriptor)))
	 (list (length d) 
	       (map (compose (lambda (n) 
			       (string->symbol (format "~a:" n)))
			     car) 
		    d) 
	       (map cadr d)))
       ((list arity names defaults)
	(lambda (input)
	  (let ((n (length input)))
	    ;; Fast path for the case where there are no keywords and
	    ;; all arguments are specified.
	    (if (not (find sc3-keyword? input))
		(cond ((= n arity) input)
		      ((> n arity) (error 'lambda-k-rewriter 
					  "too many arguments" 
					  title input))
		      (else (append input (drop defaults n))))
		(let* ((pivot (list-index sc3-keyword? input))
		       (ordinary (take input pivot))
		       (alternate (drop input pivot)))
		  (append ordinary
			  (map (lambda (n d)
				 (let ((t (find-tail (lambda (e) 
						       (eq? e n)) 
						     alternate)))
				   (if t (cadr t) d)))
			       (drop names pivot)
			       (drop defaults pivot)))))))))))

;; A variant <function> constructor that supports default values,
;; positional arguments, and keyword arguments.

(define-syntax lambda-k/title
  (syntax-rules ()
    ((_ t () e) (lambda () e))
    ((_ t ((n d) ...) e) (let ((rewriter (lambda-k-rewriter t '((n d) ...))))
			   (lambda args
			     (apply (lambda (n ...) e)
				    (rewriter args)))))))

(define-syntax lambda-k
  (syntax-rules () 
    ((_ a e) (lambda-k/title 'unknown a e))))

(define-syntax define-k
  (syntax-rules ()
    ((_ (n a ...) e) (define n (lambda-k/title 'n (a ...) e)))))

;; A variant that redefines an exising value using set!

(define-syntax define-k* 
  (syntax-rules ()
    ((_ (n a ...) e) (set! n (lambda-k/title 'n (a ...) e)))))

)