!99 option in (liii scala)

GoldfishScheme.tmu

@@ -404,7 +404,7 @@
 
     \ \ ; Extra routines
 
-    \ \ == != loose-car loose-cdr display* in? compose identity
+    \ \ == != loose-car loose-cdr display* in? compose identity any?
 
     \ \ ; Extra structure
 
@@ -3705,6 +3705,16 @@
     \;
   </scm-chunk>
 
+  <paragraph|any?>
+
+  任意类型的参数传入，都会返回真值。
+
+  <\goldfish-chunk|goldfish/liii/base.scm|true|true>
+    (define (any? x) #t)
+
+    \;
+  </goldfish-chunk>
+
   <section|增补结构>
 
   <paragraph|let1><index|let1>

goldfish/liii/base.scm

@@ -56,7 +56,7 @@
   ; SRFI-8
   receive
   ; Extra routines
-  == != loose-car loose-cdr display* in? compose identity
+  == != loose-car loose-cdr display* in? compose identity any?
   ; Extra structure
   let1  typed-lambda typed-define define-case-class
 )
@@ -104,6 +104,8 @@
       (lambda (x)
         ((car fs) ((apply compose (cdr fs)) x)))))
 
+(define (any? x) #t)
+
 (define-macro (let1 name1 value1 . body)
   `(let ((,name1 ,value1))
      ,@body))

goldfish/liii/scala.scm

@@ -17,10 +17,44 @@
 (define-library (liii scala)
 (import (liii string) (liii vector) (liii list))
 (export
+  option option? option=?
   case-list case-list? case-list=?
   case-vector case-vector? case-vector=?)
 (begin
 
+(define-case-class option ((value any?))
+  (define (%map f . xs)
+    (let1 r (if (null? value)
+                (option '())
+                (option (f value)))
+      (if (null? xs) r (apply r xs))))
+
+  (define (%flat-map f . xs)
+    (let1 r (if (null? value)
+                (option '())
+                (f value))
+      (if (null? xs) r (apply r xs))))
+
+  (define (%filter pred . xs)
+    (let1 r (if (or (null? value) (not (pred value)))
+               (option '())
+               (option value))
+      (if (null? xs) r (apply r xs))))
+
+  (define (%defined?) (not (null? value)))
+
+  (define (%empty?) (null? value))
+
+  (define (%get)
+    (if (null? value)
+        (value-error "option is empty, cannot get value")
+        value))
+
+  (define (%get-or-else default)
+    (if (null? value)
+        (if (procedure? default) (default) default)
+        value))
+)
 (define-case-class case-list ((data list?))
   (define (%collect) data)
 

liii_scala.tmu

@@ -94,6 +94,8 @@
 
     (export
 
+    \ \ option option? option=?
+
     \ \ case-list case-list? case-list=?
 
     \ \ case-vector case-vector? case-vector=?)
@@ -121,6 +123,162 @@
 
   <section|实现>
 
+  <paragraph|option>
+
+  <\goldfish-chunk|goldfish/liii/scala.scm|true|true>
+    (define-case-class option ((value any?))
+
+    \ \ (define (%map f . xs)
+
+    \ \ \ \ (let1 r (if (null? value)
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (option '())
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (option (f value)))
+
+    \ \ \ \ \ \ (if (null? xs) r (apply r xs))))
+
+    \;
+
+    \ \ (define (%flat-map f . xs)
+
+    \ \ \ \ (let1 r (if (null? value)
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (option '())
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (f value))
+
+    \ \ \ \ \ \ (if (null? xs) r (apply r xs))))
+
+    \;
+
+    \ \ (define (%filter pred . xs)
+
+    \ \ \ \ (let1 r (if (or (null? value) (not (pred value)))
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (option '())
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (option value))
+
+    \ \ \ \ \ \ (if (null? xs) r (apply r xs))))
+
+    \ \ 
+
+    \ \ (define (%defined?) (not (null? value)))
+
+    \;
+
+    \ \ (define (%empty?) (null? value))
+
+    \;
+
+    \ \ (define (%get)
+
+    \ \ \ \ (if (null? value)
+
+    \ \ \ \ \ \ \ \ (value-error "option is empty, cannot get value")
+
+    \ \ \ \ \ \ \ \ value))
+
+    \;
+
+    \ \ (define (%get-or-else default)
+
+    \ \ \ \ (if (null? value)
+
+    \ \ \ \ \ \ \ \ (if (procedure? default) (default) default)
+
+    \ \ \ \ \ \ \ \ value))
+
+    )
+  </goldfish-chunk>
+
+  <\scm-chunk|tests/goldfish/liii/scala-test.scm|true|true>
+    (let ((opt1 (option 42))
+
+    \ \ \ \ \ \ (opt2 (option '())))
+
+    \;
+
+    \ \ (check (opt1 :map (lambda (x) (+ x 1))
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ :map (lambda (x) (* x 2))
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ :get) =\<gtr\> 86)
+
+    \ \ (check (opt2 :map (lambda (x) (+ x 1))
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ :map (lambda (x) (* x 2))
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ :empty?) =\<gtr\> #t)
+
+    \;
+
+    \ \ (check (opt1 :flat-map (lambda (x) (option (+ x 1)))
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ :flat-map (lambda (x) (option (* x 2)))
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ :get) =\<gtr\> 86)
+
+    \ \ (check (opt2 :flat-map (lambda (x) (option (+ x 1)))
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ :flat-map (lambda (x) (option (* x 2)))
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ :empty?) =\<gtr\> #t)
+
+    \;
+
+    \ \ (check (opt1 :filter (lambda (x) (\<gtr\> x 40))
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ :filter (lambda (x) (\<less\> x 50))
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ :get) =\<gtr\> 42)
+
+    \ \ (check (opt1 :filter (lambda (x) (\<gtr\> x 50))
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ :filter (lambda (x) (\<less\> x 60))
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ :empty?) =\<gtr\> #t)
+
+    \ \ (check (opt2 :filter (lambda (x) (\<gtr\> x 40))
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ :filter (lambda (x) (\<less\> x 50))
+
+    \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ :empty?) =\<gtr\> #t)
+
+    \;
+
+    \ \ (check (opt1 :defined?) =\<gtr\> #t)
+
+    \ \ (check (opt1 :empty?) =\<gtr\> #f)
+
+    \ \ (check (opt2 :defined?) =\<gtr\> #f)
+
+    \ \ (check (opt2 :empty?) =\<gtr\> #t)
+
+    \;
+
+    \ \ (check (opt1 :get) =\<gtr\> 42)
+
+    \ \ (check-catch 'value-error (opt2 :get))
+
+    \;
+
+    \ \ (check (opt1 :get-or-else 0) =\<gtr\> 42)
+
+    \ \ (check (opt2 :get-or-else 0) =\<gtr\> 0)
+
+    \;
+
+    \ \ (check (opt1 :get-or-else (lambda () 0)) =\<gtr\> 42)
+
+    \ \ (check (opt2 :get-or-else (lambda () 0)) =\<gtr\> 0)
+
+    )
+
+    \;
+  </scm-chunk>
+
   <paragraph|case-list>
 
   <\scm-chunk|goldfish/liii/scala.scm|true|true>

tests/goldfish/liii/scala-test.scm

@@ -20,6 +20,48 @@
 
 (check-set-mode! 'report-failed)
 
+(let ((opt1 (option 42))
+      (opt2 (option '())))
+
+  (check (opt1 :map (lambda (x) (+ x 1))
+               :map (lambda (x) (* x 2))
+               :get) => 86)
+  (check (opt2 :map (lambda (x) (+ x 1))
+               :map (lambda (x) (* x 2))
+               :empty?) => #t)
+
+  (check (opt1 :flat-map (lambda (x) (option (+ x 1)))
+               :flat-map (lambda (x) (option (* x 2)))
+               :get) => 86)
+  (check (opt2 :flat-map (lambda (x) (option (+ x 1)))
+               :flat-map (lambda (x) (option (* x 2)))
+               :empty?) => #t)
+
+  (check (opt1 :filter (lambda (x) (> x 40))
+               :filter (lambda (x) (< x 50))
+               :get) => 42)
+  (check (opt1 :filter (lambda (x) (> x 50))
+               :filter (lambda (x) (< x 60))
+               :empty?) => #t)
+  (check (opt2 :filter (lambda (x) (> x 40))
+               :filter (lambda (x) (< x 50))
+               :empty?) => #t)
+
+  (check (opt1 :defined?) => #t)
+  (check (opt1 :empty?) => #f)
+  (check (opt2 :defined?) => #f)
+  (check (opt2 :empty?) => #t)
+
+  (check (opt1 :get) => 42)
+  (check-catch 'value-error (opt2 :get))
+
+  (check (opt1 :get-or-else 0) => 42)
+  (check (opt2 :get-or-else 0) => 0)
+
+  (check (opt1 :get-or-else (lambda () 0)) => 42)
+  (check (opt2 :get-or-else (lambda () 0)) => 0)
+)
+
 (let ((lst (case-list '(1 2 3 4 5))))
   (check (lst :take -1 :collect) => '())
   (check (lst :take 0 :collect) => '())