[210_10] 实现 bag 查询与转换接口 (#393)

* feat: add bag query helpers

* wip

* wip

* wip

* 修改实现方式

* wip

* wip

Author: 17802723

devel/210_10.md

@@ -10,6 +10,27 @@
 bin/goldfish tests/goldfish/liii/bag-test.scm
 ```
 
+## 2026/01/29 实现 bag 查询与转换接口
+### What
+补齐 SRFI-113 的 bag 查询能力与复制/列表转换接口，并在 (liii bag) 中导出与补齐测试。
+
+1. 在 goldfish/srfi/srfi-113.scm 中实现 bag-size / bag-find / bag-count / bag-any? / bag-every? / bag-copy / list->bag / list->bag! 并添加到导出列表
+2. 在 goldfish/liii/bag.scm 中导出以上函数，并提供默认比较器的 list->bag
+3. 在 tests/goldfish/liii/bag-test.scm 中添加注释与覆盖测试（含空 bag、空列表与类型错误分支）
+
+### Why
+提供多重集的基础查询能力与列表互操作接口，支持按条件计数与搜索，并符合 SRFI-113 语义。
+
+### How
+1. bag-size 汇总 entries 的计数，返回元素总数（含重复）
+2. bag-find 遍历 entries，找到满足 predicate 的元素立即返回，否则调用 failure
+3. bag-count 统计满足 predicate 的元素出现次数（含重复）
+4. bag-any? / bag-every? 使用短路遍历判断是否存在/是否全部满足
+5. bag-copy 复制 entries 的计数并保持 comparator
+6. list->bag 使用 comparator 构造 bag，保留重复元素
+7. list->bag! 将列表元素累加到现有 bag
+8. 关键路径与类型错误通过测试覆盖
+
 ## 2026/01/29 实现 bag 构造器、访问器与谓词
 ### What
 实现 SRFI-113 的 bag 基础构造、访问与谓词函数，并在 (liii bag) 中提供默认比较器封装与测试用例。

goldfish/liii/bag.scm

@@ -16,18 +16,25 @@
 
 (define-library (liii bag)
   (import (rename (srfi srfi-113)
-                  (bag make-bag-with-comparator))
+                  (bag make-bag-with-comparator)
+                  (list->bag list->bag-with-comparator))
           (only (srfi srfi-113)
                 bag-unfold bag-member bag-comparator bag->list
-                bag? bag-contains? bag-empty? bag-disjoint?)
+                list->bag! bag-copy
+                bag? bag-contains? bag-empty? bag-disjoint?
+                bag-size bag-find bag-count bag-any? bag-every?)
           (srfi srfi-128))
   (export bag bag-unfold bag-member bag-comparator
-          bag->list
-          bag? bag-contains? bag-empty? bag-disjoint?)
+          bag->list list->bag list->bag! bag-copy
+          bag? bag-contains? bag-empty? bag-disjoint?
+          bag-size bag-find bag-count bag-any? bag-every?)
 
   (define comp (make-default-comparator))
 
   (define (bag . elements)
     (apply make-bag-with-comparator comp elements))
 
+  (define (list->bag elements)
+    (list->bag-with-comparator comp elements))
+
 ) ; end of define-library

goldfish/srfi/srfi-113.scm

@@ -39,7 +39,9 @@
           set-adjoin set-adjoin! set-replace set-replace!
           set-delete set-delete! set-delete-all set-delete-all!
           bag bag-unfold bag-member bag-comparator bag->list
-          bag? bag-contains? bag-empty? bag-disjoint?)
+          bag-copy list->bag list->bag!
+          bag? bag-contains? bag-empty? bag-disjoint?
+          bag-size bag-find bag-count bag-any? bag-every?)
   (begin
 
     (define-record-type set-impl
@@ -626,6 +628,24 @@
                 (bag-increment! result (mapper seed) 1)
                 (loop (successor seed)))))))
 
+    (define (list->bag comparator elements)
+      (apply bag comparator elements))
+
+    (define (list->bag! bag elements)
+      (check-bag bag)
+      (for-each (lambda (x) (bag-increment! bag x 1)) elements)
+      bag)
+
+    (define (bag-copy bag)
+      (check-bag bag)
+      (let ((entries (make-hash-table (bag-comparator bag))))
+        (hash-table-for-each
+          (lambda (k entry)
+            (hash-table-set! entries k entry))
+          (bag-entries bag))
+        (%make-bag entries (bag-comparator bag))))
+
+
     (define (bag-member bag element default)
       (check-bag bag)
       (if (hash-table-contains? (bag-entries bag) element)
@@ -644,5 +664,42 @@
          (bag-entries bag))
         result))
 
+    (define (bag-size bag)
+      (bag-count (lambda (x) #t) bag))
+
+    (define (bag-find predicate bag failure)
+      (check-bag bag)
+      (let ((found (find predicate (hash-table-keys (bag-entries bag)))))
+        (or found (failure))))
+
+    (define (bag-count predicate bag)
+      (check-bag bag)
+      (let ((entries (bag-entries bag)))
+        (hash-table-fold
+         (lambda (k entry acc)
+           (if (predicate k)
+               (+ acc entry)
+               acc))
+         0
+         entries)))
+
+    (define (bag-any? predicate bag)
+      (check-bag bag)
+      (let ((found
+             (hash-table-find
+              (lambda (k entry) (predicate k))
+              (bag-entries bag)
+              #f)))
+        (if found #t #f)))
+
+    (define (bag-every? predicate bag)
+      (check-bag bag)
+      (let ((found
+             (hash-table-find
+              (lambda (k entry) (not (predicate k)))
+              (bag-entries bag)
+              #f)))
+        (if found #f #t)))
+
     ) ; end of begin
   ) ; end of define-library

tests/goldfish/liii/bag-test.scm

@@ -55,6 +55,87 @@ element ... : any
 (check-false (not (member 2 b-list)))
 (check (length b-list) => 3)
 
+#|
+bag-copy
+复制一个 bag。
+
+语法
+----
+(bag-copy bag)
+
+参数
+----
+bag : bag
+目标 bag。
+
+返回值
+-----
+返回一个新的 bag，包含原 bag 的所有元素，比较器相同。
+|#
+(let ((copy (bag-copy b-1-2)))
+  (check-true (bag? copy))
+  (check-false (eq? copy b-1-2))
+  (check-true (eq? (bag-comparator copy) comp))
+  (check (bag-size copy) => 3)
+  (check (bag-count (lambda (x) (= x 2)) copy) => 2))
+(check-true (bag-empty? (bag-copy b-empty)))
+(check-catch 'type-error (bag-copy "not a bag"))
+
+#|
+list->bag
+将列表转换为 bag。
+
+语法
+----
+(list->bag list)
+
+参数
+----
+list : list
+要转换的列表。
+
+返回值
+-----
+返回包含列表中所有元素的 bag（使用默认比较器，重复元素保留）。
+|#
+(define b-list-1 (list->bag '(1 2 2 3)))
+(check-true (bag? b-list-1))
+(check-true (eq? (bag-comparator b-list-1) comp))
+(check (bag-size b-list-1) => 4)
+(check (bag-count (lambda (x) (= x 2)) b-list-1) => 2)
+(define b-list-empty (list->bag '()))
+(check-true (bag-empty? b-list-empty))
+
+#|
+list->bag!
+将列表元素并入 bag（可变操作）。
+
+语法
+----
+(list->bag! bag list)
+
+参数
+----
+bag : bag
+目标 bag。
+
+list : list
+要并入的元素列表。
+
+返回值
+------
+返回修改后的 bag（与传入的 bag 是同一个对象）。
+|#
+(define b-list-merge (bag 1 2))
+(define b-list-merge-result (list->bag! b-list-merge '(2 3 3)))
+(check-true (eq? b-list-merge-result b-list-merge))
+(check (bag-size b-list-merge) => 5)
+(check (bag-count (lambda (x) (= x 2)) b-list-merge) => 2)
+(check (bag-count (lambda (x) (= x 3)) b-list-merge) => 2)
+(list->bag! b-list-merge '())
+(check (bag-size b-list-merge) => 5)
+(check-catch 'type-error (list->bag! "not a bag" '(1 2)))
+
 
 
 
@@ -258,6 +339,129 @@ bag2 : bag
 (check-catch 'type-error (bag-disjoint? "not a bag" (bag 1)))
 (check-catch 'type-error (bag-disjoint? (bag 1) "not a bag"))
 
+#|
+bag-size
+返回 bag 中元素总数（含重复）。
+
+语法
+----
+(bag-size bag)
+
+参数
+----
+bag : bag
+目标 bag。
+
+返回值
+-----
+返回 bag 中元素总数（包含重复元素）。
+|#
+(check (bag-size b-empty) => 0)
+(check (bag-size b-1-2) => 3)
+(check-catch 'type-error (bag-size "not a bag"))
+
+#|
+bag-find
+查找满足条件的元素。
+
+语法
+----
+(bag-find predicate bag failure)
+
+参数
+----
+predicate : procedure
+判断函数，接收元素并返回布尔值。
+
+bag : bag
+目标 bag。
+
+failure : procedure
+未找到时调用的过程。
+
+返回值
+-----
+返回第一个满足 predicate 的元素，否则返回 failure 的结果。
+|#
+(check (bag-find even? b-1-2 (lambda () 'none)) => 2)
+(check (bag-find (lambda (x) (> x 9)) b-1-2 (lambda () 'missing)) => 'missing)
+(check-catch 'type-error (bag-find even? "not a bag" (lambda () 'none)))
+
+#|
+bag-count
+统计满足条件的元素数量（含重复）。
+
+语法
+----
+(bag-count predicate bag)
+
+参数
+----
+predicate : procedure
+判断函数，接收元素并返回布尔值。
+
+bag : bag
+目标 bag。
+
+返回值
+-----
+返回满足 predicate 的元素总数（含重复）。
+|#
+(check (bag-count even? b-1-2) => 2)
+(check (bag-count (lambda (x) (> x 9)) b-1-2) => 0)
+(check-catch 'type-error (bag-count even? "not a bag"))
+
+#|
+bag-any?
+判断是否存在满足条件的元素。
+
+语法
+----
+(bag-any? predicate bag)
+
+参数
+----
+predicate : procedure
+判断函数，接收元素并返回布尔值。
+
+bag : bag
+目标 bag。
+
+返回值
+-----
+如果存在满足 predicate 的元素，返回 #t，否则返回 #f。
+|#
+(check-true (bag-any? even? b-1-2))
+(check-false (bag-any? (lambda (x) (> x 9)) b-1-2))
+(check-false (bag-any? even? b-empty))
+(check-catch 'type-error (bag-any? even? "not a bag"))
+
+#|
+bag-every?
+判断是否所有元素都满足条件。
+
+语法
+----
+(bag-every? predicate bag)
+
+参数
+----
+predicate : procedure
+判断函数，接收元素并返回布尔值。
+
+bag : bag
+目标 bag。
+
+返回值
+-----
+如果 bag 中所有元素都满足 predicate 返回 #t，否则返回 #f。
+空 bag 返回 #t。
+|#
+(check-true (bag-every? (lambda (x) (> x 0)) b-1-2))
+(check-false (bag-every? even? b-1-2))
+(check-true (bag-every? even? b-empty))
+(check-catch 'type-error (bag-every? even? "not a bag"))
+
 #|
 bag-comparator
 获取 bag 的 comparator。