basic CAS

6 files changed, 166 insertions, 182 deletions

diff --git a/cas.scm b/cas.scm
new file mode 100644
index 0000000..88762d2
--- /dev/null
+++ b/cas.scm
@@ -0,0 +1,116 @@
+;;; Copyright 2024 Peter McGoron
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;;     http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
+;;; implied. See the License for the specific language governing
+;;; permissions and limitations under the License.
+;;; 
+;;; Computer algebra system written using COND-VALUES.
+
+(cond-expand
+ (chicken (import r7rs)))
+
+(load "cond-values.r7rs.scm")
+(load "values-lib.r7rs.scm")
+
+(import (mcgoron.com cond-values)
+        (mcgoron.com values-lib)
+        srfi-1)
+
+;;; Record type that stores information about a known function. The CAS
+;;; allows for unknown functions.
+(define-record-type/destructor <function-data>
+  (function-data procedure properties)
+  function-data?
+  destruct-function-data
+  (procedure %get-procedure)
+  (properties %get-properties))
+
+;;; Database for known functions as an assocation list.
+(define *functions*
+  (list (cons '/ (function-data / '()))
+        (cons 'exp (function-data exp '()))
+        (cons 'expt (function-data expt '()))
+        (cons '+ (function-data + '(abelian)))
+        (cons '* (function-data * '(abelian)))))
+
+;;; Destructures a function application.
+(define function=> pair=>)
+
+;;; Destructures a known function into
+;;; (VALUES HEAD EXPRS PROCEDURE ARGNUM PROPERTIES)
+;;; 
+;;; where (HEAD EXPRS) was the application and the rest of the arguments
+;;; are from the known function record.
+(define (known-function=> expr)
+  (after ((let (function=> expr) => (head arguments))
+          (let (assq=> head *functions*) => (desc)))
+    (cond-values
+      (after ((let (destruct-function-data desc) => desc))
+        (apply values head arguments desc))
+      (else (error "improper function description" expr desc)))))
+
+;;; Destructures an abelian function into
+;;; (VALUES HEAD EXPRS PROC)
+;;; where (HEAD . EXPRS) was the original application and PROC is the
+;;; implementation of HEAD.
+(define (abelian=> expr)
+  (after ((let (known-function=> expr) => (head arguments proc props))
+          (when (memq 'abelian props)))
+    (values head arguments proc)))
+
+;;; ABELIAN-FOLD implements constant folding on abelian operations (such
+;;; as +, *, etc.).
+;;; 
+;;; The function scans ARGUMENTS for arguments, and:
+;;; 
+;;; * If an argument is an application of the same function, then the
+;;;   arguments to that function are lifted up to the arguments of the
+;;;   calling function.
+;;; * If an argument is an application to a different function, call
+;;;   the constant folder on it.
+;;; * If the argument is an atom, do nothing to it.
+;;; 
+;;; Once all the arguments are constant folded, the function returns
+;;; 
+;;; * a number, which is the application of PROC to the folded arguments
+;;;   when all arguments reduce to numbers, or
+;;; * (CONS HEAD-TO-MATCH FOLDED), where FOLDED has at most one constant
+;;;   argument in front, and the other folded arguments in arbitrary order.
+(define (abelian-fold head-to-match arguments proc)
+  (define (fold-expr expr constants non-constants)
+    (let ((expr (constant-fold expr)))
+      (cond-values
+        (after ((let (function=> expr) => (head tail))
+                (when (eq? head head-to-match)))
+          (fold-values fold-expr (list constants non-constants) tail))
+        (after ((when (number? expr)))
+          (values (cons expr constants) non-constants))
+        (else (values constants (cons expr non-constants))))))
+  (let*-values (((constants non-constants)
+                 (fold-values fold-expr '(() ()) arguments)))
+    (if (null? constants)
+        (cons head-to-match non-constants)
+        (let ((constant (apply proc constants)))
+          (if (null? non-constants)
+              constant
+              (cons head-to-match (cons constant non-constants)))))))
+
+;;; Fold constant expressions in EXPR.
+;;; 
+;;; NOTE: This will apply algebraic operations like commutation and
+;;; distribution. This can cause cancellations using floating point
+;;; numbers. This function should only be used with exact numbers.
+(define (constant-fold expr)
+  (cond-values
+    (apply-after (abelian=> expr) abelian-fold)
+    (else expr)))
+
+(constant-fold '(+ 5 (+ x 6)))
+(constant-fold '(+ 5 (* 11 20 (+ 16 x))))
diff --git a/cond-values-impl.scm b/cond-values-impl.scm
deleted file mode 100644
index e0b4889..0000000
--- a/cond-values-impl.scm
+++ /dev/null
@@ -1,159 +0,0 @@
-;;; Copyright 2024 Peter McGoron
-;;; Licensed under the Apache License, Version 2.0 (the "License");
-;;; you may not use this file except in compliance with the License.
-;;; You may obtain a copy of the License at
-;;; 
-;;;     http://www.apache.org/licenses/LICENSE-2.0
-;;; 
-;;; Unless required by applicable law or agreed to in writing, software
-;;; distributed under the License is distributed on an "AS IS" BASIS,
-;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
-;;; implied. See the License for the specific language governing
-;;; permissions and limitations under the License.
-
-;;; AFTER executes a body after multiple tests.
-;;; 
-;;; The form of the syntax is
-;;; (AFTER (BINDING ...) BODY ...)
-;;; 
-;;; where BODY ... is a Scheme body. Each BINDING is evaluated in order,
-;;; where BINDING is
-;;; 
-;;; (VALUE => FORMAL): FORMAL is a LAMBDA formal and VALUE is a something
-;;; that returns multiple values. If VALUE evaluates to no values, the
-;;; test fails and the entire AFTER form returns no values.
-;;; 
-;;; (WHEN TEST): Evaluates TEST. If TEST is #F then the entire AFTER form
-;;; returns no values.
-;;; 
-;;; If all BINDINGs pass, then BODY is executed and its return value is
-;;; the return of AFTER.
-(define-syntax after
-  (syntax-rules (when let =>)
-    ((after ((let value => formal) conditionals ...) body ...)
-     (call-with-values (lambda () value)
-       (lambda returned
-         (if (null? returned)
-             (values)
-             (apply (lambda formal (after (conditionals ...) body ...))
-                    returned)))))
-    ((after ((let formal value ...) conditionals ...) body ...)
-     (after ((let (begin value ...) => formal) conditionals ...)
-       body ...))
-    ((after ((when boolean) conditionals ...) body ...)
-     (if boolean
-         (after (conditionals ...) body ...)
-         (values)))
-    ((after () body ...)
-     (begin body ...))))
-
-(define-syntax apply-after
-  (syntax-rules ()
-    ((apply-after value receiver)
-     (after ((let value => formal))
-       (apply receiver formal)))))
-
-;;; (COND-VALUES CLAUSE ...) is like COND, but it tests for empty VALUES
-;;; instead of #F.
-;;; 
-;;; Each CLAUSE is:
-;;; 
-;;; (BODY ...): Executes BODY. If BODY returns no values, then try the
-;;; rest of the clauses. If BODY returns values, those values are the
-;;; return values of COND-VALUES.
-;;; (ELSE BODY ...): Must occur at the end. Executes BODY and returns
-;;; whatever BODY returns.
-;;; 
-;;; If there is no ELSE clause and all CLAUSEs fail, COND-VALUES returns
-;;; no values.
-(define-syntax cond-values
-  (syntax-rules (else)
-    ((cond-values (else body ...))
-     (begin body ...))
-    ((cond-values value rest ...)
-     (call-with-values (lambda () value)
-       (lambda returned
-         (if (null? returned)
-             (cond-values rest ...)
-             (apply values returned)))))
-    ((cond-values) (values))))
-
-;;; (DEFINE-RECORD-TYPE/DESTRUCTOR TYPENAME
-;;;   (CSTR FIELDS ...)
-;;;   PREDICATE?
-;;;   DESTRUCTOR
-;;;   (FIELD GETTER SETTER ...)
-;;;   ...)
-;;; 
-;;; creates an SRFI-9/R7RS record type. The syntax is the same, except
-;;; that after the PREDICATE field and before the getter/setter fields
-;;; is an identifier, DESTRUCTOR.
-;;; 
-;;; This macro defines a procedure (DESTRUCTOR RECORD) that returns each
-;;; field of RECORD as values, or no values if RECORD is not a TYPENAME
-;;; record.
-(define-syntax define-record-type/destructor
-  (syntax-rules ()
-    ((define-record-type/destructor typename
-       (cstr fields ...)
-       predicate?
-       destructor
-       (field getter setter ...)
-       ...)
-     (begin
-       (define-record-type typename
-         (cstr fields ...)
-         predicate?
-         (field getter setter ...)
-         ...)
-       (define (destructor record)
-         (after ((when (predicate? record)))
-           (values (getter record) ...)))))))
-
-;;; ;;;;;;;;;;;;;
-;;; Helper functions
-;;; ;;;;;;;;;;;;;
-
-;;; Returns the CAR and CDR of X as values when X is a pair, and no values
-;;; otherwise.
-(define (pair-d x)
-  (after ((when (pair? x)))
-    (values (car x) (cdr x))))
-
-(define (assq-d val alist)
-  (let ((pair (assq val alist)))
-    (after ((when (pair? pair)))
-      (cdr pair))))
-
-;;; Returns the list as values when WHOLE-LIST has length NUM, and no
-;;; values otherwise.
-(define (length* whole-list num)
-  (when (<= num 0)
-    (error "invalid number" 'length* whole-list num))
-
-  (let length* ((lst whole-list)
-                (num num))
-    (cond-values
-      (after ((when (null? lst))
-        (when (= num 0)))
-        (apply values whole-list))
-      (after ((when (pair? lst))
-             (when (> num 0)))
-        (length* (cdr lst) (- num 1))))))
-
-;;; Returns the list as values when WHOLE-LIST has at least length NUM,
-;;; and no values otherwise.
-(define (length-at-least whole-list num)
-  (when (<= num 0)
-    (error "invalid number" 'length-at-least whole-list num))
-
-  (let length-at-least ((lst whole-list)
-                        (num num))
-    (cond-values
-      (after ((when (= num 0))
-              (when (or (null? lst)
-                        (pair? lst))))
-        (apply values whole-list))
-      (after ((when (> num 0))
-              (when (pair? lst)))
-        (length-at-least (cdr lst) (- num 1))))))
diff --git a/cond-values.r7rs.scm b/cond-values.r7rs.scm
index 22c7f8a..f7d7213 100644
--- a/cond-values.r7rs.scm
+++ b/cond-values.r7rs.scm
@@ -16,8 +16,9 @@
 
 (define-library (mcgoron.com cond-values)
   (import (scheme base))
-  (export after cond-values
+  (export after cond-values apply-after
           define-record-type/destructor
-          pair-d assq-d
-          length* length-at-least)
-  (import "cond-values.scm"))
+          pair=> assq=>
+          length=> length-at-least=>)
+  (include "cond-values.scm"))
+
diff --git a/units.scm b/units.scm
index 08694a9..70b130b 100644
--- a/units.scm
+++ b/units.scm
@@ -45,43 +45,43 @@
   `((/ . ,/)
     (* . ,*)))
 
-(define (atom-d unit)
+(define (atom=> unit)
   (after ((when (or (symbol? unit)
                     (and (number? unit) (exact? unit)))))
     unit))
 
-(define (prefixed-d unit)
+(define (prefixed=> unit)
   (after ((let (length* unit 2) => (head unit))
           (let (assq-d head *si-prefixes*) => (factor)))
     (values factor unit)))
 
-(define (power-d unit)
+(define (power=> unit)
   (after ((let (length* unit 3) => (head number unit))
           (when (eq? head '^)))
     (values number unit)))
 
-(define (algebra-function-d unit)
+(define (algebra-function=> unit)
   (after ((let (length-at-least unit 3) => (head . rest))
           (let (assq-d head *si-algebra*) => (procedure)))
     (values head procedure rest)))
 
 (define (remove-prefixes unit)
   (cond-values
-    (after ((let (atom-d unit) => (unit)))
+    (after ((let (atom=> unit) => (unit)))
       (values 1 unit))
     ;; 
-    (after ((let (prefixed-d unit) => (factor unit)))
+    (after ((let (prefixed=> unit) => (factor unit)))
       (let-values (((sub-factor unit-w/o-factors)
                     (remove-prefixes unit)))
         (values (* sub-factor factor) unit-w/o-factors)))
     ;; 
-    (after ((let (power-d unit) => (power unit)))
+    (after ((let (power=> unit) => (power unit)))
       (let-values (((sub-factor sub-unit)
                     (remove-prefixes unit)))
         (values (expt sub-factor power)
                 (list '^ power sub-unit))))
     ;; 
-    (after ((let (algebra-function-d unit) => (head proc units)))
+    (after ((let (algebra-function=> unit) => (head proc units)))
       (let-values (((factors units)
                     (map-values remove-prefixes units)))
         (values (apply proc factors)
@@ -98,10 +98,10 @@
 (define (make-unit-destructor atom prefixed power algebra-function on-else)
   (lambda (unit)
     (cond-values
-      (apply-after (atom-d unit) atom)
-      (apply-after (prefixed-d unit) prefixed)
-      (apply-after (power-d unit) power)
-      (apply-after (algebra-function-d unit) algebra-function)
+      (apply-after (atom=> unit) atom)
+      (apply-after (prefixed=> unit) prefixed)
+      (apply-after (power=> unit) power)
+      (apply-after (algebra-function=> unit) algebra-function)
       (else (on-else unit)))))
 
 (import r7rs)
@@ -145,20 +145,20 @@
                 remove-prefixes-handlers)
     (else (error "invalid unit" unit))))
 
-(add-remove-prefixes-handler atom-d (lambda (unit)
+(add-remove-prefixes-handler atom=> (lambda (unit)
                                       (values 1 unit)))
 
 (remove-prefixes 'gram)
 (remove-prefixes '(kilo gram))
 
-(add-remove-prefixes-handler prefixed-d
+(add-remove-prefixes-handler prefixed=>
                              (lambda (factor unit)
                                (let-values (((sub-factor sub-unit)
                               (remove-prefixes unit)))
                                  (values (* factor sub-factor) sub-unit))))
 
 (add-remove-prefixes-handler
- algebra-function-d
+ algebra-function=>
  (lambda (head procedure units)
    (let-values (((factors units) (map-values remove-prefixes units)))
      (values (apply procedure factors)
diff --git a/values-lib.r7rs.scm b/values-lib.r7rs.scm
index df50d04..3fef60c 100644
--- a/values-lib.r7rs.scm
+++ b/values-lib.r7rs.scm
@@ -15,6 +15,6 @@
  (chicken (import r7rs)))
 
 (define-library (mcgoron.com values-lib)
-  (import (scheme base) srfi-1)
-  (export map-values any-values)
-  (import "values-lib.scm"))
+  (import (scheme base) srfi-1 (mcgoron.com cond-values))
+  (export map-values any-values revmap-values fold-values)
+  (include "values-lib.scm"))
diff --git a/values-lib.scm b/values-lib.scm
index 79e8d98..88ba4b4 100644
--- a/values-lib.scm
+++ b/values-lib.scm
@@ -31,8 +31,34 @@
 ;;; If any of the lists end, then ANY-VALUES returns no values.
 (define (any-values f . lists)
   (after ((when (not (null? lists)))
-          (when (all pair? lists)))
+          (when (every pair? lists)))
     (let-values ((returned (apply f (map car lists))))
       (if (null? returned)
           (apply any-values f (map cdr lists))
           (apply values returned)))))
+
+;;; REVMAP-VALUES is a tail-recursive version of MAP-VALUES that returns
+;;; (REVERSE (MAP-VALUES F . LISTS)).
+(define (revmap-values f . lists)
+  (if (or (null? lists)
+          (any null? lists))
+      '()
+      (let revmap-values ((collected (apply f (map car lists)))
+                          (lists (map cdr lists)))
+        (if (any null? lists)
+            collected
+            (let-values ((returned (apply f (map car lists))))
+              (revmap-values (map cons returned collected)
+                             (map cdr lists)))))))
+
+;;; (FOLD-VALUES F (LIST INIT-ARG ...) LIST ...)
+;;; does
+;;; (F (CAR LIST) ... INIT-ARG ...) => (NEW-ARG ...)
+;;; (F (CADR LIST) ... NEW-ARG ..) => (NEW-ARG2 ...)
+;;; and so on until at least one of LIST is NULL?.
+(define (fold-values f init-arguments . lists)
+  (if (any null? lists)
+      (apply values init-arguments)
+      (let-values ((returned (apply f (append (map car lists)
+                                              init-arguments))))
+        (apply fold-values f returned (map cdr lists)))))