summaryrefslogtreecommitdiffstats
path: root/cring.scm
diff options
context:
space:
mode:
authorJames LewisMoss <dres@debian.org>1999-12-06 19:32:57 -0500
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:28 -0800
commitc394920caedf3dac1981bb6b10eeb47fd6e4bb21 (patch)
treef21194653a3554f747dde3df908df993c48db5a0 /cring.scm
parent926b1b647ac830660933a5e63eb52d4a2552e264 (diff)
parentbd9733926076885e3417b74de76e4c9c7bc56254 (diff)
downloadslib-c394920caedf3dac1981bb6b10eeb47fd6e4bb21.tar.gz
slib-c394920caedf3dac1981bb6b10eeb47fd6e4bb21.zip
Import Debian changes 2c7-1debian/2c7-1
slib (2c7-1) unstable; urgency=low * New upstream. * Add slibconfig back in. slib (2c6-2) unstable; urgency=low * Remove the slib$(VERSION).info file. Cut the diff back down to size. slib (2c6-1) unstable; urgency=low * New upstream. * Move docs to /usr/share. Up standards version. add /usr/doc symlink. Move info files. Remove undocumented link. slib (2c5-6) unstable; urgency=low * Lowercase two vars in yasyn.scm (Fixes bug #37222) slib (2c5-5) unstable; urgency=low * Fix it so string-index isn't defined (now there is a strsrch:string-index) (Fixes #38812) slib (2c5-4) unstable; urgency=low * Don't run slibconfig in postinst. (Fixes bug #38253, #37733, #37715, #37746, #37809, #37917, #38123, #38462) slib (2c5-3) unstable; urgency=low * Run slibconfig in postinst. It was commented out there, but I don't see any old bug reports on why it was commented out, so let's try again. :) (Fixes bug #37221) slib (2c5-2) unstable; urgency=low * Link mklibcat.scm to mklibcat. Fixes a problem with using slib with guile. slib (2c5-1) unstable; urgency=low * New upstream. slib (2c3-4) unstable; urgency=low * New maintainer.
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)