!94 case-vector, vector-filter in (liii vector)

Merge pull request !94 from 沈达/da/case_vector

GoldfishScheme.tmu

@@ -11838,6 +11838,8 @@
 
     (import (srfi srfi-133)
 
+    \ \ \ \ \ \ \ \ (srfi srfi-13)
+
     \ \ \ \ \ \ \ \ (liii base))
 
     (export
@@ -11866,7 +11868,13 @@
 
     \ \ vector-swap! vector-cumulate reverse-list-\<gtr\>vector
 
-    \ \ vector=)
+    \ \ vector=
+
+    \ \ ; Liii Extras
+
+    \ \ vector-filter case-vector case-vector? case-vector=?
+
+    )
 
     (begin
 
@@ -11882,6 +11890,8 @@
 
     \ \ \ \ \ \ \ \ (liii vector)
 
+    \ \ \ \ \ \ \ \ (liii cut)
+
     \ \ \ \ \ \ \ \ (only (scheme base) let-values))
 
     \;
@@ -13409,6 +13419,176 @@
     \;
   </scm-chunk>
 
+  <section|增补函数>
+
+  <paragraph|vector-filter>
+
+  <\scm-chunk|goldfish/liii/vector.scm|true|true>
+    (define (vector-filter pred vec)
+
+    \ \ (let* ((result-list (vector-fold (lambda (elem acc)
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (if (pred elem)
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (cons elem acc)
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ acc))
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ '()
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ vec))
+
+    \ \ \ \ \ \ \ \ \ (result-length (length result-list))
+
+    \ \ \ \ \ \ \ \ \ (result-vec (make-vector result-length)))
+
+    \ \ \ \ (let loop ((i (- result-length 1)) (lst result-list))
+
+    \ \ \ \ \ \ (if (null? lst)
+
+    \ \ \ \ \ \ \ \ \ \ result-vec
+
+    \ \ \ \ \ \ \ \ \ \ (begin
+
+    \ \ \ \ \ \ \ \ \ \ \ \ (vector-set! result-vec i (car lst))
+
+    \ \ \ \ \ \ \ \ \ \ \ \ (loop (- i 1) (cdr lst)))))))
+
+    \;
+  </scm-chunk>
+
+  <\goldfish-chunk|tests/goldfish/liii/vector-test.scm|true|true>
+    (check (vector-filter even? #(1 2 3 4 5 6)) =\<gtr\> #(2 4 6))
+
+    (check (vector-filter (lambda (x) (\<gtr\> x 3)) #(1 2 3 4 5 6)) =\<gtr\> #(4 5 6))
+
+    (check (vector-filter (lambda (x) (string? x)) #(1 "a" 2 "b" 3)) =\<gtr\> #("a" "b"))
+
+    (check (vector-filter (lambda (x) #t) #()) =\<gtr\> #())
+
+    (check (vector-filter (lambda (x) #f) #(1 2 3)) =\<gtr\> #())
+
+    \;
+  </goldfish-chunk>
+
+  <paragraph|case-vector>
+
+  <\scm-chunk|goldfish/liii/vector.scm|true|true>
+    (define-case-class case-vector ((data vector?))
+
+    \ \ (define (%collect) data)
+
+    \;
+
+    \ \ (define (%map x . xs)
+
+    \ \ \ \ (let1 r (case-vector (vector-map x data))
+
+    \ \ \ \ \ \ (if (null? xs) r (apply r xs))))
+
+    \ \ 
+
+    \ \ (define (%filter x . xs)
+
+    \ \ \ \ (let1 r (case-vector (vector-filter x data))
+
+    \ \ \ \ \ \ (if (null? xs) r (apply r xs))))
+
+    \;
+
+    \ \ (define (%for-each x)
+
+    \ \ \ \ (vector-for-each x data))
+
+    \;
+
+    \ \ (define (%count . xs)
+
+    \ \ \ \ (cond ((null? xs) (vector-length data))
+
+    \ \ \ \ \ \ \ \ \ \ ((length=? 1 xs) (vector-count (car xs) data))
+
+    \ \ \ \ \ \ \ \ \ \ (else (error 'wrong-number-of-args "case-vector%count" xs))))
+
+    \;
+
+    \ \ (define (%make-string . xs)
+
+    \ \ \ \ (define (parse-args xs)
+
+    \ \ \ \ \ \ (cond
+
+    \ \ \ \ \ \ \ \ ((null? xs) (values "" "" ""))
+
+    \ \ \ \ \ \ \ \ ((length=? 1 xs)
+
+    \ \ \ \ \ \ \ \ \ (let1 sep (car xs)
+
+    \ \ \ \ \ \ \ \ \ \ \ (if (string? sep)
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (values "" sep "")
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (type-error "case-vector%make-string: separator must be a string" sep))))
+
+    \ \ \ \ \ \ \ \ ((length=? 2 xs)
+
+    \ \ \ \ \ \ \ \ \ (error 'wrong-number-of-args "case-vector%make-string: expected 0, 1, or 3 arguments, but got 2" xs))
+
+    \ \ \ \ \ \ \ \ ((length=? 3 xs)
+
+    \ \ \ \ \ \ \ \ \ (let ((start (car xs))
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (sep (cadr xs))
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (end (caddr xs)))
+
+    \ \ \ \ \ \ \ \ \ \ \ (if (and (string? start) (string? sep) (string? end))
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (values start sep end)
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (type-error "case-vector%make-string: prefix, separator, and suffix must be strings" xs))))
+
+    \ \ \ \ \ \ \ \ (else (error 'wrong-number-of-args "case-vector%make-string: expected 0, 1, or 3 arguments" xs))))
+
+    \;
+
+    \ \ \ \ (receive (start sep end) (parse-args xs)
+
+    \ \ \ \ \ \ (string-append start (string-join (map object-\<gtr\>string (vector-\<gtr\>list data)) sep) end)))
+
+    )
+
+    \;
+  </scm-chunk>
+
+  <\goldfish-chunk|tests/goldfish/liii/vector-test.scm|true|true>
+    (let1 v (case-vector #(1 2 3))
+
+    \ \ (check (v :count) =\<gtr\> 3)
+
+    \ \ (check (v :count (cut \<gtr\> \<less\>\<gtr\> 1)) =\<gtr\> 2)
+
+    \ \ (check (v :make-string) =\<gtr\> "123")
+
+    \ \ (check (v :make-string " ") =\<gtr\> "1 2 3")
+
+    \ \ (check (v :make-string "[" "," "]") =\<gtr\> "[1,2,3]")
+
+    \ \ 
+
+    \ \ (check-catch 'wrong-number-of-args (v :make-string "[" ","))
+
+    \ \ (check-catch 'type-error (v :make-string 123 "," "]"))
+
+    \ \ (check-catch 'type-error (v :make-string "[" 123 "]"))
+
+    \ \ (check-catch 'type-error (v :make-string "[" "," 123))
+
+    )
+
+    \;
+  </goldfish-chunk>
+
   <section|结尾>
 
   <\scm-chunk|goldfish/srfi/srfi-133.scm|true|false>

goldfish/liii/vector.scm

@@ -16,6 +16,7 @@
 
 (define-library (liii vector)
 (import (srfi srfi-133)
+        (srfi srfi-13)
         (liii base))
 (export
   ; S7 Scheme built-in
@@ -30,9 +31,71 @@
   vector-any vector-every vector-copy vector-copy!
   vector-index vector-index-right vector-skip vector-skip-right vector-partition
   vector-swap! vector-cumulate reverse-list->vector
-  vector=)
+  vector=
+  ; Liii Extras
+  vector-filter case-vector case-vector? case-vector=?
+)
 (begin
 
+(define (vector-filter pred vec)
+  (let* ((result-list (vector-fold (lambda (elem acc)
+                                     (if (pred elem)
+                                         (cons elem acc)
+                                         acc))
+                                   '()
+                                   vec))
+         (result-length (length result-list))
+         (result-vec (make-vector result-length)))
+    (let loop ((i (- result-length 1)) (lst result-list))
+      (if (null? lst)
+          result-vec
+          (begin
+            (vector-set! result-vec i (car lst))
+            (loop (- i 1) (cdr lst)))))))
+
+(define-case-class case-vector ((data vector?))
+  (define (%collect) data)
+
+  (define (%map x . xs)
+    (let1 r (case-vector (vector-map x data))
+      (if (null? xs) r (apply r xs))))
+
+  (define (%filter x . xs)
+    (let1 r (case-vector (vector-filter x data))
+      (if (null? xs) r (apply r xs))))
+
+  (define (%for-each x)
+    (vector-for-each x data))
+
+  (define (%count . xs)
+    (cond ((null? xs) (vector-length data))
+          ((length=? 1 xs) (vector-count (car xs) data))
+          (else (error 'wrong-number-of-args "case-vector%count" xs))))
+
+  (define (%make-string . xs)
+    (define (parse-args xs)
+      (cond
+        ((null? xs) (values "" "" ""))
+        ((length=? 1 xs)
+         (let1 sep (car xs)
+           (if (string? sep)
+               (values "" sep "")
+               (type-error "case-vector%make-string: separator must be a string" sep))))
+        ((length=? 2 xs)
+         (error 'wrong-number-of-args "case-vector%make-string: expected 0, 1, or 3 arguments, but got 2" xs))
+        ((length=? 3 xs)
+         (let ((start (car xs))
+               (sep (cadr xs))
+               (end (caddr xs)))
+           (if (and (string? start) (string? sep) (string? end))
+               (values start sep end)
+               (type-error "case-vector%make-string: prefix, separator, and suffix must be strings" xs))))
+        (else (error 'wrong-number-of-args "case-vector%make-string: expected 0, 1, or 3 arguments" xs))))
+
+    (receive (start sep end) (parse-args xs)
+      (string-append start (string-join (map object->string (vector->list data)) sep) end)))
+)
+
 ) ; end of begin
 ) ; end of define-library
 

tests/goldfish/liii/vector-test.scm

@@ -17,6 +17,7 @@
 (import (liii list)
         (liii check)
         (liii vector)
+        (liii cut)
         (only (scheme base) let-values))
 
 (check-set-mode! 'report-failed)
@@ -305,5 +306,24 @@
 
 (check-catch 'out-of-range (string->vector "0123" 2 10))
 
+(check (vector-filter even? #(1 2 3 4 5 6)) => #(2 4 6))
+(check (vector-filter (lambda (x) (> x 3)) #(1 2 3 4 5 6)) => #(4 5 6))
+(check (vector-filter (lambda (x) (string? x)) #(1 "a" 2 "b" 3)) => #("a" "b"))
+(check (vector-filter (lambda (x) #t) #()) => #())
+(check (vector-filter (lambda (x) #f) #(1 2 3)) => #())
+
+(let1 v (case-vector #(1 2 3))
+  (check (v :count) => 3)
+  (check (v :count (cut > <> 1)) => 2)
+  (check (v :make-string) => "123")
+  (check (v :make-string " ") => "1 2 3")
+  (check (v :make-string "[" "," "]") => "[1,2,3]")
+
+  (check-catch 'wrong-number-of-args (v :make-string "[" ","))
+  (check-catch 'type-error (v :make-string 123 "," "]"))
+  (check-catch 'type-error (v :make-string "[" 123 "]"))
+  (check-catch 'type-error (v :make-string "[" "," 123))
+)
+
 (check-report)