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 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)))))