func-lettes, currying and other useful macros

[jsmall]

Below is a generic way to curry arguments
for user defined functions. For example

Code: Select all

   (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 all

  (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 all

  (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 all

  (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 all

  (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 all

  (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 all

(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