diff options
Diffstat (limited to 'cring.scm')
| -rw-r--r-- | cring.scm | 99 |
1 files changed, 66 insertions, 33 deletions
@@ -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) |