basic CAS
This commit is contained in:
parent
13c68fc3fa
commit
63621689a1
|
|
@ -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))))
|
||||
|
|
@ -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))))))
|
||||
|
|
@ -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"))
|
||||
|
||||
|
|
|
|||
30
units.scm
30
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)
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue