diff --git a/GoldfishScheme.tmu b/GoldfishScheme.tmu index 3364f52..7b82963 100644 --- a/GoldfishScheme.tmu +++ b/GoldfishScheme.tmu @@ -5780,17 +5780,21 @@ \ \ ; Liii List extensions - \ \ list-view flatmap + \ \ flat-map \ \ list-null? list-not-null? not-null-list? \ \ length=? length\? length\=? flatten + \ \ case-list case-list? case-list=? + ) (import (srfi srfi-1) - \ \ \ \ \ \ \ \ (liii error)) + \ \ \ \ \ \ \ \ (liii error) + + \ \ \ \ \ \ \ \ (liii case)) (begin @@ -5852,6 +5856,8 @@ \ \ \ \ \ \ \ \ (liii check) + \ \ \ \ \ \ \ \ (liii cut) + \ \ \ \ \ \ \ \ (only (srfi srfi-1) delete-duplicates)) \; @@ -8129,158 +8135,24 @@ \; - - - 由于Scheme的List和数据的流向是相反的: - - <\scm-code> - (map (lambda (x) (* x x)) - - \ \ \ \ \ (map (lambda (x) (+ x 1)) - - \ \ \ \ \ \ \ \ \ \ (list 1 2 3))) - - - \; - - 所以我们实现了,采用和Scala的List类似的语法来处理数据: - - <\scm-chunk|tests/goldfish/liii/list-test.scm|true|true> - (check ((list-view (list 1 2 3))) =\ (list 1 2 3)) - - \; - - (check (((list-view (list 1 2 3)) - - \ \ \ \ \ \ \ \ map (lambda (x) (+ x 1)))) =\ (list 2 3 4)) - - \; - - (check (((list-view (list 1 2 3)) - - \ \ \ \ \ \ \ \ map (lambda (x) (+ x 1)) - - \ \ \ \ \ \ \ \ map (lambda (x) (* x x)))) - - \ \ \ \ \ \ \ =\ (list 4 9 16)) - - \; - - - 得到的是函数,需要在外面再加一层括号才能得到。 - - <\big-figure| - <\scm-code> - (map (lambda (x) (* x x)) - - \ \ \ \ \ (map (lambda (x) (+ x 1)) - - \ \ \ \ \ \ \ \ \ \ (list 1 2 3))) - - |<\cell> - <\scm-code> - (((list-view 1 2 3) - - \ \ \ \ \ \ \ \ map (lambda (x) (+ x 1)) - - \ \ \ \ \ \ \ \ map (lambda (x) (* x x)))) - - >>>>> - 使用list处理数据和使用list-view处理数据的对比 - - - 实现list-view时需要考虑三种情况和一种例外情况。 - - <\description> - 也就是直接在list-view得到的结果外面添加括号,此时得到的是list-view对应的list - - 这里举例说明,实际的计算过程是: - - <\enumerate> - 计算并得到结果 (list 2 3 4)> - - 将计算结果包装到 里面,这里使用了这个内置函数 - - - 其实也是树的转换: - - <\big-figure|>>>> - 原理的可视化 - - - 在上述两个递归退出条件写好的情况下,在思考这种一般的情况。 - - 需要计算,其中hf指的是high-order function,也就是高阶函数。也就是需要计算: - - <\scm> - ((((list-view 1 2 3) hf1 f1) hf2 f2) ... hfn fn) - - - \; - + <\scm-chunk|goldfish/liii/list.scm|true|true> - (define (list-view scheme-list) - - \ \ (define (f-inner-reducer scheme-list filter filter-func rest-funcs) - - \ \ \ \ (cond ((null? rest-funcs) (list-view (filter filter-func scheme-list))) - - \ \ \ \ \ \ \ \ \ \ (else - - \ \ \ \ \ \ \ \ \ \ \ (f-inner-reducer (filter filter-func scheme-list) - - \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (car rest-funcs) - - \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (cadr rest-funcs) - - \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (cddr rest-funcs))))) - - \ \ (define (f-inner . funcs) - - \ \ \ \ (cond ((null? funcs) scheme-list) - - \ \ \ \ \ \ \ \ \ \ ((length=? 2 funcs) - - \ \ \ \ \ \ \ \ \ \ \ (list-view ((car funcs) (cadr funcs) scheme-list))) - - \ \ \ \ \ \ \ \ \ \ ((even? (length funcs)) - - \ \ \ \ \ \ \ \ \ \ \ (f-inner-reducer scheme-list - - \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (car funcs) - - \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (cadr funcs) - - \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (cddr funcs))) - - \ \ \ \ \ \ \ \ \ \ (else (error 'wrong-number-of-args - - \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ "list-view only accepts even number of args")))) - - \ \ f-inner) - - \; - - - - - <\scm-chunk|goldfish/liii/list.scm|true|true> - (define flatmap append-map) + (define flat-map append-map) \; <\scm-chunk|tests/goldfish/liii/list-test.scm|true|true> - (check (flatmap (lambda (x) (list x x)) + (check (flat-map (lambda (x) (list x x)) - \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (list 1 2 3)) + \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (list 1 2 3)) \ \ =\ (list 1 1 2 2 3 3)) \; - (check-catch 'type-error (flatmap 1 (list 1 2 3))) + (check-catch 'type-error (flat-map 1 (list 1 2 3))) \; @@ -8593,6 +8465,66 @@ \; + + + <\goldfish-chunk|goldfish/liii/list.scm|true|true> + (define-case-class case-list ((data list?)) + + \ \ (define (%collect) data) + + \; + + \ \ (define (%map x . xs) + + \ \ \ \ (let1 r (case-list (map x data)) + + \ \ \ \ \ \ (if (null? xs) r (apply r xs)))) + + \ \ + + \ \ (define (%flat-map x . xs) + + \ \ \ \ (let1 r (case-list (flat-map x data)) + + \ \ \ \ \ \ (if (null? xs) r (apply r xs)))) + + \ \ + + \ \ (define (%filter x . xs) + + \ \ \ \ (let1 r (case-list (filter x data)) + + \ \ \ \ \ \ (if (null? xs) r (apply r xs)))) + + \; + + \ \ (define (%for-each x) + + \ \ \ \ (for-each x data)) + + \ \ + + \ \ (define (%count . xs) + + \ \ \ \ (cond ((null? xs) (length data)) + + \ \ \ \ \ \ \ \ \ \ ((length=? 1 xs) (count (car xs) data)) + + \ \ \ \ \ \ \ \ \ \ (else (error 'wrong-number-of-args "case-list%count" xs)))) + + ) + + \; + + + <\scm-chunk|tests/goldfish/liii/list-test.scm|true|true> + (check ((case-list (list 1 2 3)) :count) =\ 3) + + (check ((case-list (list 1 2 3)) :count (cut \ \\ 1)) =\ 2) + + \; + + <\scm-chunk|goldfish/liii/list.scm|true|false> diff --git a/goldfish/liii/list.scm b/goldfish/liii/list.scm index 49cf0d1..af0013c 100644 --- a/goldfish/liii/list.scm +++ b/goldfish/liii/list.scm @@ -39,12 +39,14 @@ ; SRFI 1: Association List assoc assq assv alist-cons ; Liii List extensions - list-view flatmap + flat-map list-null? list-not-null? not-null-list? length=? length>? length>=? flatten + case-list case-list? case-list=? ) (import (srfi srfi-1) - (liii error)) + (liii error) + (liii case)) (begin (define (length=? x scheme-list) @@ -70,28 +72,7 @@ ((pair? lst) (loop (cdr lst) (+ cnt 1))) (else (<= len cnt))))) -(define (list-view scheme-list) - (define (f-inner-reducer scheme-list filter filter-func rest-funcs) - (cond ((null? rest-funcs) (list-view (filter filter-func scheme-list))) - (else - (f-inner-reducer (filter filter-func scheme-list) - (car rest-funcs) - (cadr rest-funcs) - (cddr rest-funcs))))) - (define (f-inner . funcs) - (cond ((null? funcs) scheme-list) - ((length=? 2 funcs) - (list-view ((car funcs) (cadr funcs) scheme-list))) - ((even? (length funcs)) - (f-inner-reducer scheme-list - (car funcs) - (cadr funcs) - (cddr funcs))) - (else (error 'wrong-number-of-args - "list-view only accepts even number of args")))) - f-inner) - -(define flatmap append-map) +(define flat-map append-map) (define (not-null-list? l) (cond ((pair? l) @@ -164,6 +145,30 @@ " but got a ~A") depth))) ) ; end of (define* (flatten)) +(define-case-class case-list ((data list?)) + (define (%collect) data) + + (define (%map x . xs) + (let1 r (case-list (map x data)) + (if (null? xs) r (apply r xs)))) + + (define (%flat-map x . xs) + (let1 r (case-list (flat-map x data)) + (if (null? xs) r (apply r xs)))) + + (define (%filter x . xs) + (let1 r (case-list (filter x data)) + (if (null? xs) r (apply r xs)))) + + (define (%for-each x) + (for-each x data)) + + (define (%count . xs) + (cond ((null? xs) (length data)) + ((length=? 1 xs) (count (car xs) data)) + (else (error 'wrong-number-of-args "case-list%count" xs)))) +) + ) ; end of begin ) ; end of library diff --git a/tests/goldfish/liii/list-test.scm b/tests/goldfish/liii/list-test.scm index 9cbf7b1..96dbe92 100644 --- a/tests/goldfish/liii/list-test.scm +++ b/tests/goldfish/liii/list-test.scm @@ -16,6 +16,7 @@ (import (liii list) (liii check) + (liii cut) (only (srfi srfi-1) delete-duplicates)) (check-set-mode! 'report-failed) @@ -375,21 +376,11 @@ (check-false (length>=? '(1 2 . 3) 3)) (check-true (length>=? '(1 2 . 3) 2)) -(check ((list-view (list 1 2 3))) => (list 1 2 3)) - -(check (((list-view (list 1 2 3)) - map (lambda (x) (+ x 1)))) => (list 2 3 4)) - -(check (((list-view (list 1 2 3)) - map (lambda (x) (+ x 1)) - map (lambda (x) (* x x)))) - => (list 4 9 16)) - -(check (flatmap (lambda (x) (list x x)) - (list 1 2 3)) +(check (flat-map (lambda (x) (list x x)) + (list 1 2 3)) => (list 1 1 2 2 3 3)) -(check-catch 'type-error (flatmap 1 (list 1 2 3))) +(check-catch 'type-error (flat-map 1 (list 1 2 3))) (check (not-null-list? (list 1)) => #t) (check (list-not-null? (list 1)) => #t) @@ -446,5 +437,8 @@ (check-catch 'type-error (flatten '((a) () (b ()) () (c)) 'a)) (check-catch 'type-error (flatten '((a) () (b ()) () (c)) (make-vector 1 1))) +(check ((case-list (list 1 2 3)) :count) => 3) +(check ((case-list (list 1 2 3)) :count (cut > <> 1)) => 2) + (check-report) diff --git a/tests/test_all.scm b/tests/test_all.scm index 5c23ceb..fe559c4 100644 --- a/tests/test_all.scm +++ b/tests/test_all.scm @@ -25,11 +25,12 @@ ; (display (listdir2 "tests")) (define (all-tests) - (((list-view (listdir2 "tests/goldfish")) - filter path-dir? - flatmap listdir2 - filter (lambda (x) (path-file? x)) - filter (lambda (x) (not (string-ends? x "srfi-78-test.scm")))))) + ((case-list (listdir2 "tests/goldfish")) + :filter path-dir? + :flat-map listdir2 + :filter (lambda (x) (path-file? x)) + :filter (lambda (x) (not (string-ends? x "srfi-78-test.scm"))) + :collect)) (define (goldfish-cmd) (if (os-windows?)