func-lettes, currying and other useful macros

[jsmall]

Below is a generic way to curry arguments

for user defined functions.  For example

Code Select Expand



   (define (foo x y) (+ x y))

   > (fn-let foo (x 1))
   (lambda (y) (let ((x 1)) (+ x y)))



fn-let creates a new lambda list with the curried

arguments moved into the internalize let expression.

Code Select Expand



  (define-macro (fn-let _f )
    (let ((fargs (first (eval _f)))
          (body (rest (eval _f)))
          (cargs (map (fn (k-v) (first k-v)) (rest (args))))
          (bindings (map (fn (k-v)
                         (list (first k-v)
                               (eval (last k-v))))
                   (rest (args)))))
      (let ((new-fargs (difference fargs cargs))
            (new-body (cons 'let (cons bindings body))))
        (eval
          (expand '(lambda new-fargs new-body)
            'new-fargs 'new-body)))))



This will not work for built-in functions which

are not lambda lists.  The following curry and rcurry

will work for built-ins but are not as generic as fn-let.

Code Select Expand



  (define (eval-args _args)
    (map (fn (arg) (eval arg)) _args))


  (define-macro (curry _f )
    (let ((f (eval _f))
          (cargs (eval-args (rest (args)))))
      (expand
        (lambda-macro ( )
          (apply f (append (quote cargs) (eval-args (args)))))
        'f 'cargs)))


  (define-macro (rcurry _f )
    (let ((f (eval _f))
          (cargs (eval-args (rest (args)))))
      (expand
        (lambda-macro ( )
          (apply f (append (eval-args (args)) (quote cargs))))
        'f 'cargs)))





The following examples show how curried

functions can be used to factor problems.

Code Select Expand



  (define (math-series op init f a a++ >b?)
    (if (>b? a)
      init
      (math-series op (op init (f a)) f (a++ a) a++ >b?)))

  (define (summation f a step b)
    (math-series add 0 f a (curry add step) (rcurry > b)))


  (define (sigma f a b)
    (summation f a 1 b))

  (sigma add 1 3)  ;; ==> 6


  (define (step-integral dx f a)
    (mul dx (f a)))


  (define (integrate f a b dx)
    (summation (fn-let step-integral (dx dx) (f f)) a dx b))


  (define (line m b x)
    (add (mul m x) b))

  (integrate (fn-let line (m 1) (b 0)) 0 1 0.01) ;; 0.495 ...


  (define (product f a b)
    (math-series mul 1 f a (curry + 1) (rcurry > b)))

  (define (factorial n)
    (product mul 1 n))

  (factorial 5)  ;; ==> 120


  (sigma (lambda (n) (/ 1.0 (factorial n))) 0 20)

  ;; ==> 2.7182 ...





I find these additonal macros and list functions

useful also.

Code Select Expand



  (define-macro (disjoin )
    (let ((_f  (eval (first (args))))
          (_fs (eval-args (rest (args)))))
      (expand
        (lambda (arg , result f fs)
          (set 'result false)
          (set 'f _f)
          (set 'fs (quote _fs))
          (while (and f (not result))
            (set 'result (f arg))
            (set 'f (first fs))
            (set 'fs (rest fs)))
          result)
        '_f '_fs)))


  (define-macro (conjoin )
    (let ((_f  (eval (first (args))))
          (_fs (eval-args (rest (args)))))
      (expand
        (lambda (arg , result f fs)
          (set 'result true)
          (set 'f _f)
          (set 'fs (quote _fs))
          (while (and f result)
            (set 'result (f arg))
            (set 'f (first fs))
            (set 'fs (rest fs)))
          result)
        '_f '_fs)))


  (define (fold-left f init xs)
    (if (empty? xs)
        init
        (fold-left f (f init (first xs)) (rest xs))))


  (define (fold-right f xs init)
    (if (empty? xs)
        init
        (f (first xs) (fold-right f (rest xs) init))))


  (define-macro (compose )
    (let ((_fns (eval-args (reverse (args)))))
      (expand
        (lambda-macro ( )
          (let ((fns (quote _fns))
                (init (eval-args (args))))
            (if (empty? fns)
                init
                (fold-left
                  (lambda (init f) (f init))
                  (apply (first fns) init)
                  (rest fns)))))
        '_fns)))


  (define (every pred? xs)
    (or (empty? xs)
        (and (pred? (first xs))
             (every pred? (rest xs)))))


  (define (some pred? xs)
    (and (and (list? xs) (not (empty? xs)))
         (or (pred? (first xs))
             (some pred? (rest xs)))))



The following snippet show how these can be used.

Code Select Expand



  (every integer? '(1 2 3 4))    ;; ==> true
  (some  integer? '(a b c 4 d))  ;; ==> nil

  (filter (disjoin symbol? string?) '(1 a 2 "two" 3))

  ;; (a "two")



[newdep]

;-) Like it, great thinking !



Regards, Norman.

[Lutz]

Thanks for the great currying examples. You could also define 'some' and 'every' non-recursive this way (the newLISP way ;-) ):

Code Select Expand


(define (every predicate lst)
  (apply and (map predicate lst)))

(define (some predicate lst)
  (apply or (map predicate lst)))

;; use it

(every integer? '(1 2 3 4)) => true
(some  integer? '(a b c 4 d)) => true

(define big? (fn (x) (> x 10)))

(some big? '(1 2 3 4 20)) => true
(every big? '(1 2 3 4 20)) => nil



Lutz