From bd9733926076885e3417b74de76e4c9c7bc56254 Mon Sep 17 00:00:00 2001
From: Bryan Newbold <bnewbold@robocracy.org>
Date: Mon, 20 Feb 2017 00:05:28 -0800
Subject: Import Upstream version 2c7

---
 cring.scm | 99 ++++++++++++++++++++++++++++++++++++++++++---------------------
 1 file changed, 66 insertions(+), 33 deletions(-)

(limited to 'cring.scm')

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)
-- 
cgit v1.2.3