From 6d54abd6aa66d2a835e85c9f63b2ae9bf44fe0ac Mon Sep 17 00:00:00 2001 From: admin Date: Wed, 6 Sep 2023 17:49:42 +0900 Subject: [PATCH] Fix currying of higher order functions --- curry-tests.scm | 53 ++++++++++++++++++++++++++++++++++++++----------- curry.scm | 52 +++++++++++++++++++++++++++++++++++------------- misc.scm | 12 +++++++++++ 3 files changed, 91 insertions(+), 26 deletions(-) create mode 100644 misc.scm diff --git a/curry-tests.scm b/curry-tests.scm index b5a53a0..4d01adb 100644 --- a/curry-tests.scm +++ b/curry-tests.scm @@ -1,35 +1,64 @@ -(define-module (vdc curry) +(define-module (vdc curry tests) #:use-module (vdc curry) #:use-module (srfi srfi-64)) (define e (compose primitive-eval expand-cfs)) -(test-begin "test-curry") +(test-begin "curry") + +;;;; curry-proc and enhance-cf + +(let ((+ (enhance-cf (curry-proc + 3) 3))) + (test-equal 6 (+ 1 2 3)) + (test-equal 6 (((+ 1) 2) 3)) + (test-equal 6 ((+ 1 2) 3)) + (test-equal 6 ((+ 1) 2 3)) + (let ((f (enhance-cf (lambda (f) (f 1)) 3))) + (test-equal 6 (f + 2 3)) + (test-equal 6 ((f + 2) 3)) + (test-equal 6 (((f +) 2) 3)))) + +(let* ((f (enhance-cf (curry-proc * 2) 2)) + (g (enhance-cf (lambda (x) (f x)) 2))) + (test-equal 6 (g 2 3)) + (test-equal 6 ((g 2) 3))) ;; CF-free expression (test-equal 3 (e '(+ 1 2))) ;; invalid zero variable CF -(test-error (e '((λp () #t)))) +(test-error (e '((λc () #t)))) ;; unclosed CF -(test-error (e '(λp (x) x))) +(test-error (e '(λc (x) x))) ;; open CF as argument to a CF -(test-equal 3 (e '((λp (f) (f 2)) - ((λp (a b) (+ a b)) +(test-equal 3 (e '((λc (f) (f 2)) + ((λc (a b) (+ a b)) 1)))) ;; CF applied to too many arguments -(test-error (e '((λp (x) x) 1 2))) +(test-error (e '((λc (x) x) 1 2))) ;; open CF as argument to something other than a CF -(test-error (e '(+ 1 (λp (x) x)))) +(test-error (e '(+ 1 (λc (x) x)))) + +;; composition +;; we are going for (∘ * 1+ 1 3) ≡ ((∘ * 1+) 1 3) ≡ (((∘ * 1+) 1) 3) where: +;; ∘ ≡ (λc (g f) (λc (x) (g (f x)))) +;; * ≡ (λc (x y) (* x y)) +;; and 1+ is the Scheme procedure. +(test-equal (* (1+ 1) 3) + (e '((λc (g f) (λc (x) (g (f x)))) (λc (x y) (* x y)) 1+ 1 3))) +(test-equal (* (1+ 1) 3) + (e '(((λc (g f) (λc (x) (g (f x)))) (λc (x y) (* x y)) 1+) 1 3))) +(test-equal (* (1+ 1) 3) + (e '((((λc (g f) (λc (x) (g (f x)))) (λc (x y) (* x y)) 1+) 1) 3))) ;; misc -(test-equal 3 (e '(+ 1 ((λp (x) x) 2)))) -(test-equal 6 (e '((((λp (x y z) +(test-equal 3 (e '(+ 1 ((λc (x) x) 2)))) +(test-equal 6 (e '((((λc (x y z) (+ x y z)) - 1) 2) 3))) + 1) 2) 3))) -(test-end "test-curry") +(test-end "curry") diff --git a/curry.scm b/curry.scm index cb533af..c1b5fc2 100644 --- a/curry.scm +++ b/curry.scm @@ -1,9 +1,9 @@ ;;;; The following code adds syntax for creating and partially applying curried ;;;; functions (CFs) in Scheme. The code also raise errors, at syntax expansion ;;;; time, if CFs aren't applied properly. A simple valid use case is as follow: -;;;; (((λp (x y z) (+ x y z)) 1 2) 3) +;;;; (((λc (x y z) (+ x y z)) 1 2) 3) ;;;; while the following raises an error: -;;;; ((λp (x) x) 1 2) +;;;; ((λc (x) x) 1 2) ;;;; See "partial-tests.scm" for more examples and continue reading for ;;;; implementation details. ;;;; @@ -11,7 +11,7 @@ ;;;; (RMANA) is associated to it. The RMANA decreases as the CF gets applied ;;;; and, when it reaches zero, it can no longer be applied. The system also ;;;; associates `#f' RMANA to Scheme expressions that can't be partially -;;;; applied.We say that an expression is closed when its RMANA is false or zero +;;;; applied. We say that an expression is closed when its RMANA is false or zero ;;;; and opened otherwise. The distinction between expressions with false vs ;;;; zero RMANA is that the former is applicable to any number of closed ;;;; argument while the latter can't be applied at all. The system verifies @@ -25,13 +25,15 @@ #:use-module (ice-9 match) #:use-module (ice-9 receive) #:export - (expand-cfs)) + (curry-proc + enhance-cf + expand-cfs)) (define (bind-var bindings var val) (assoc-set! bindings var val)) (define (bind-vars bindings vars vals) - (fold bind-var bindings vars vals)) + (fold (lambda (x y prev) (bind-var prev x y)) bindings vars vals)) (define (closed? x) (or (not x) @@ -39,6 +41,25 @@ (define opened? (compose not closed?)) +(define (curry-proc proc n) + (let curry ((n n) + (stack '())) + (if (= 0 n) + (apply proc (reverse stack)) + (lambda (x) + (curry (1- n) + (cons x stack)))))) + +(define (enhance-cf f n) + (lambda (x . xs) + (let ((r (- n 1 (length xs)))) + ((if (= 0 r) + identity + (lambda (x) (enhance-cf x r))) + (fold (lambda (x prev) + (prev x)) + (f x) xs))))) + (define* (preturn expr_ m #:optional ns) "Return an expanded expression and it's RMANA or throw an error if we are trying to apply it to too many. `expr_' is an expanded expression, `m' its @@ -49,7 +70,7 @@ RMANA, and `ns' the RMANAs of the applied arguments, if any." ((and (not m) ns (any opened? ns)) (error "non-CFs can't be applied to opened CFs.")) ((and m ns (< m (length ns))) - (error "too many arguments.")) + (error "too many arguments." expr_ m ns)) ((and m ns) (- m (length ns))) (else m)))) @@ -58,13 +79,16 @@ RMANA, and `ns' the RMANAs of the applied arguments, if any." (define (it x args bindings) (match x - (('λp (vars ..1) body) - (let ((body_ n (it body '() (bind-vars bindings vars args)))) - (preturn - `(enhance-proc (lambda ,vars ,body_) - ,(length vars)) - (or (and n (+ n (length vars))) - (length vars))))) + (('λc (vars ..1) body) + (let* ((body_ n (it body '() (bind-vars bindings vars args))) + (m (length vars)) + (rmana (or (and n (+ n m)) + m))) + (preturn + `(enhance-cf (curry-proc (lambda ,vars ,body_) + ,m) + ,rmana) + rmana))) ((f as ...) (let* ((as (map (lambda (a) @@ -73,7 +97,7 @@ RMANA, and `ns' the RMANAs of the applied arguments, if any." (as_ asn (unzip2 as)) (f_ fn (if-let (x (assoc-ref bindings f)) - (values (first x) (second x)) + (values f (second x)) (it f as bindings)))) (preturn (cons f_ as_) fn asn))) diff --git a/misc.scm b/misc.scm new file mode 100644 index 0000000..efbaa78 --- /dev/null +++ b/misc.scm @@ -0,0 +1,12 @@ +(define-module (vdc misc) + #:export + (if-let)) + +(define-syntax if-let + (syntax-rules () + [(_ (x test) consequent alternate) + (let ([x test]) + (if x consequent alternate))] + [(_ (x test) consequent) + (let ([x test]) + (if x consequent))])) -- 2.39.2