From b1605ef9a7f21e7caf3d033b5ac7df0b8da5c3fe Mon Sep 17 00:00:00 2001 From: Leah Neukirchen Date: Fri, 18 Nov 2022 19:55:47 +0100 Subject: add xfold, xfold-right, xreduce, xreduce-right, xscan, xscan-right Make scan, scan-right work with multiple lists. --- mew.scm | 101 ++++++++++++++++++++++++++++++++++++++++++++++++++------- mew.svnwiki | 13 ++++++++ tests/test.mew | 30 +++++++++++++++-- 3 files changed, 130 insertions(+), 14 deletions(-) diff --git a/mew.scm b/mew.scm index 520001f..aa438bd 100644 --- a/mew.scm +++ b/mew.scm @@ -22,7 +22,7 @@ while uniq-accumulator unlist until vals void? - xcond + xcond xfold xfold-right xreduce xreduce-right xscan xscan-right -> fun-> fun->> set-> =? <>? ~? @@ -197,7 +197,7 @@ (seq body ...))) (if (null? vals) (void) - (car vals)))))) + (car vals)))))) (define-syntax fin (syntax-rules () @@ -844,25 +844,102 @@ (loop (+ i (get t (get haystack (+ i ln) #f) (inc ln))))) #f))))))) + (define-syntax imp + (syntax-rules () + ((_ a b) + (or (not a) b)) + ((_ a b c ...) + (or (not a) (imp b c ...))))) + + ;; adapted from https://code.call-cc.org/svn/chicken-eggs/release/5/srfi-1/trunk/srfi-1.scm ------------------------------ + (define (##srfi1#cars+cdrs lists) + (##sys#call-with-current-continuation + (lambda (abort) + (let recur ((lists lists)) + (if (pair? lists) + (receive (list other-lists) (car+cdr lists) + (if (null-list? list) + (abort '() '()) ; LIST is empty -- bail out + (receive (a d) (car+cdr list) + (receive (cars cdrs) (recur other-lists) + (values (cons a cars) (cons d cdrs)))))) + (values '() '())))))) + + (define (##srfi1#cdrs lists) + (##sys#call-with-current-continuation + (lambda (abort) + (let recur ((lists lists)) + (if (pair? lists) + (let ((lis (car lists))) + (if (null-list? lis) + (abort '()) + (cons (cdr lis) (recur (cdr lists))))) + '()))))) + + (define (xfold kons knil lis1 . lists) + (if (pair? lists) + (let lp ((lists (cons lis1 lists)) (ans knil)) ; N-ary case + (receive (cars cdrs) (##srfi1#cars+cdrs lists) + (if (null? cars) + ans ; Done. + (lp cdrs (apply kons ans cars))))) + + (let lp ((lis lis1) (ans knil)) ; Fast path + (if (null-list? lis) + ans + (lp (cdr lis) (kons ans (car lis))))))) + + (define (xfold-right kons knil lis1 . lists) + (if (pair? lists) + (let recur ((lists (cons lis1 lists))) ; N-ary case + (let ((cdrs (##srfi1#cdrs lists))) + (if (null? cdrs) + knil + (apply kons (recur cdrs) (map car lists))))) + + (let recur ((lis lis1)) ; Fast path + (if (null-list? lis) + knil + (let ((head (car lis))) + (kons (recur (cdr lis)) head)))))) + + (define (xreduce f ridentity lis) + (if (null-list? lis) + ridentity + (xfold f (car lis) (cdr lis)))) + + (define (xreduce-right f ridentity lis) + (if (null-list? lis) + ridentity + (let recur ((head (car lis)) (lis (cdr lis))) + (if (pair? lis) + (f (recur (car lis) (cdr lis)) head) + head)))) + ;; end of code lifted from srfi-1.scm ------------------------------ + (define (scan kons knil . lists) - (reverse (apply fold (lambda (elt acc) - (cons (kons elt (car acc)) acc)) + (reverse (apply xfold (lambda (acc . elts) + (cons (apply kons (append elts (list (car acc)))) acc)) (list knil) lists))) (define (scan-right kons knil . lists) - (apply fold-right (lambda (elt acc) - (cons (kons elt (car acc)) acc)) + (apply xfold-right (lambda (acc . elts) + (cons (apply kons (append elts (list (car acc)))) acc)) (list knil) lists)) - (define-syntax imp - (syntax-rules () - ((_ a b) - (or (not a) b)) - ((_ a b c ...) - (or (not a) (imp b c ...))))) + (define (xscan kons knil . lists) + (reverse (apply xfold (lambda (acc . elts) + (cons (apply kons (car acc) elts) acc)) + (list knil) + lists))) + (define (xscan-right kons knil . lists) + (apply xfold-right (lambda (acc . elts) + (cons (apply kons (car acc) elts) acc)) + (list knil) + lists)) (let ((old-repl-prompt (repl-prompt))) (repl-prompt (lambda () diff --git a/mew.svnwiki b/mew.svnwiki index f11e5d6..c10a557 100644 --- a/mew.svnwiki +++ b/mew.svnwiki @@ -253,6 +253,19 @@ Returns true if {{}} is an unspecified value, else false. (scan-right ...) Like {{fold}}/{{fold-right}}, but collects all accumulator values. +Prefer {{xscan}}/{{xscan-right}}. + +(xfold ...) +(xfold-right ...) +(xreduce ...) +(xreduce-right ...) +(xscan ...) +(xscan-right ...) + +Like {{fold}}/{{fold-right}}/{{reduce}}/{{reduce-right}}/{{scan}}/{{scan-right}}, +but {{}} always takes the accumulator as first arguments, +and the items after. This is more practical when multiple {{lists}} +are passed. (imp ... ) diff --git a/tests/test.mew b/tests/test.mew index 328e282..e638377 100644 --- a/tests/test.mew +++ b/tests/test.mew @@ -532,11 +532,37 @@ (test-group "scan" (test '(0 -4 -9 -15) (scan (flip -) 0 '(4 5 6))) - (test '(42) (scan * 42 '()))) + (test '(42) (scan * 42 '())) + (test '(0 6 14 24 36) (scan + 0 '(1 2 3 4) '(5 6 7 8))) + (test '(0 -4 0 -4 0) (scan - 0 '(1 2 3 4) '(5 6 7 8)))) + +(test-group "xscan" + (test '(0 6 14 24 36) (xscan + 0 '(1 2 3 4) '(5 6 7 8))) + (test '(0 -6 -14 -24 -36) (xscan - 0 '(1 2 3 4) '(5 6 7 8)))) (test-group "scan-right" (test '(5 -1 6 0) (scan-right - 0 '(4 5 6))) - (test '(42) (scan-right * 42 '()))) + (test '(42) (scan-right * 42 '())) + (test '(36 30 22 12 0) (scan-right + 0 '(1 2 3 4) '(5 6 7 8)))) + +(test-group "xscan-right" + (test '(36 30 22 12 0) (xscan-right + 0 '(1 2 3 4) '(5 6 7 8)))) + +(test-group "xfold" + (test -10 (xfold - 0 '(1 2 3 4))) + (test '((((() 1 5) 2 6) 3 7) 4 8) (xfold list '() '(1 2 3 4) '(5 6 7 8)))) + +(test-group "xfold-right" + (test '((((() 4 8) 3 7) 2 6) 1 5) (xfold-right list '() '(1 2 3 4) '(5 6 7 8))) + (test -10 (xfold-right - 0 '(1 2 3 4)))) + +(test-group "xreduce" + (test -8 (xreduce - 0 '(1 2 3 4))) + (test #f (xreduce - #f '()))) + +(test-group "xreduce-right" + (test -2 (xreduce-right - 0 '(1 2 3 4))) + (test #f (xreduce-right - #f '()))) (test-group "imp" (test #t (imp #t #t)) -- cgit 1.4.1