summaryrefslogtreecommitdiffstats
path: root/cring.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:28 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:28 -0800
commitbd9733926076885e3417b74de76e4c9c7bc56254 (patch)
tree2c99dced547d48407ad44cb0e45e31bb4d02ce43 /cring.scm
parentfa3f23105ddcf07c5900de47f19af43d1db1b597 (diff)
downloadslib-bd9733926076885e3417b74de76e4c9c7bc56254.tar.gz
slib-bd9733926076885e3417b74de76e4c9c7bc56254.zip
Import Upstream version 2c7upstream/2c7
Diffstat (limited to 'cring.scm')
-rw-r--r--cring.scm99
1 files changed, 66 insertions, 33 deletions
diff --git a/cring.scm b/cring.scm
index c3d67cd..320b1d2 100644
--- a/cring.scm
+++ b/cring.scm
@@ -1,5 +1,5 @@
;;;"cring.scm" Extend Scheme numerics to any commutative ring.
-;Copyright (C) 1997 Aubrey Jaffer
+;Copyright (C) 1997, 1998 Aubrey Jaffer
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
@@ -22,6 +22,68 @@
(require 'database-utilities)
(require 'sort)
+(define cring:db (create-database #f 'alist-table))
+(define (make-ruleset . rules)
+ (define name #f)
+ (cond ((and (not (null? rules)) (symbol? (car rules)))
+ (set! name (car rules))
+ (set! rules (cdr rules)))
+ (else (set! name (gentemp))))
+ (define-tables cring:db
+ (list name
+ '((op symbol)
+ (sub-op1 symbol)
+ (sub-op2 symbol))
+ '((reduction expression))
+ rules))
+ (let ((table ((cring:db 'open-table) name #t)))
+ (and table
+ (list (table 'get 'reduction)
+ (table 'row:update)
+ table))))
+(define *ruleset* (make-ruleset 'default))
+(define (cring:define-rule . args)
+ (if *ruleset*
+ ((cadr *ruleset*) args)
+ (slib:warn "No ruleset in *ruleset*")))
+
+(define (combined-rulesets . rulesets)
+ (define name #f)
+ (cond ((symbol? (car rulesets))
+ (set! name (car rulesets))
+ (set! rulesets (cdr rulesets)))
+ (else (set! name (gentemp))))
+ (apply make-ruleset name
+ (apply append
+ (map (lambda (ruleset) (((caddr ruleset) 'row:retrieve*)))
+ rulesets))))
+
+;;; Distribute * over + (and -)
+(define distribute*
+ (make-ruleset
+ 'distribute*
+ `(* + identity
+ ,(lambda (exp1 exp2)
+ ;;(print 'distributing '* '+ exp1 exp2 '==>)
+ (apply + (map (lambda (trm) (* trm exp2)) (cdr exp1)))))
+ `(* - identity
+ ,(lambda (exp1 exp2)
+ ;;(print 'distributing '* '- exp1 exp2 '==>)
+ (apply - (map (lambda (trm) (* trm exp2)) (cdr exp1)))))))
+
+;;; Distribute / over + (and -)
+(define distribute/
+ (make-ruleset
+ 'distribute/
+ `(/ + identity
+ ,(lambda (exp1 exp2)
+ ;;(print 'distributing '/ '+ exp1 exp2 '==>)
+ (apply + (map (lambda (trm) (/ trm exp2)) (cdr exp1)))))
+ `(/ - identity
+ ,(lambda (exp1 exp2)
+ ;;(print 'distributing '/ '- exp1 exp2 '==>)
+ (apply - (map (lambda (trm) (/ trm exp2)) (cdr exp1)))))))
+
(define (symbol-alpha? sym)
(char-alphabetic? (string-ref (symbol->string sym) 0)))
(define (expression-< x y)
@@ -41,36 +103,6 @@
(else (expression-< (cdr x) (cdr y)))))
(define (expression-sort seq) (sort! seq expression-<))
-(define cring:db (create-database #f 'alist-table))
-(define-tables cring:db
- `(operation
- ((op symbol)
- (sub-op1 symbol)
- (sub-op2 symbol))
- ((reduction expression))
- (;; This is the distributive rule (* over +)
- (* + identity
- ,(lambda (exp1 exp2)
- ;;(print 'distributing '* '+ exp1 exp2 '==>)
- (apply + (map (lambda (trm) (* trm exp2)) (cdr exp1)))))
- (* - identity
- ,(lambda (exp1 exp2)
- ;;(print 'distributing '* '- exp1 exp2 '==>)
- (apply - (map (lambda (trm) (* trm exp2)) (cdr exp1)))))
- (/ + identity
- ,(lambda (exp1 exp2)
- ;;(print 'distributing '/ '+ exp1 exp2 '==>)
- (apply + (map (lambda (trm) (/ trm exp2)) (cdr exp1)))))
- (/ - identity
- ,(lambda (exp1 exp2)
- ;;(print 'distributing '/ '- exp1 exp2 '==>)
- (apply - (map (lambda (trm) (/ trm exp2)) (cdr exp1))))))))
-
-(define cring:op-tab ((cring:db 'open-table) 'operation #t))
-(define cring:rule (cring:op-tab 'get 'reduction))
-(define cring:defrule (cring:op-tab 'row:update))
-(define (cring:define-rule . args) (cring:defrule args))
-
(define number* *)
(define number+ +)
(define number- -)
@@ -425,8 +457,9 @@
(arg-loop arg.pows)))))
(define (cring:try-rule op sop1 sop2 exp1 exp2)
- (let ((rule (cring:rule op sop1 sop2)))
- (and rule (rule exp1 exp2))))
+ (and *ruleset*
+ (let ((rule ((car *ruleset*) op sop1 sop2)))
+ (and rule (rule exp1 exp2)))))
(define (cring:apply-rule op exp1 exp2)
(and (pair? exp1)