├── README.org ├── algebraic-extension.lisp ├── avl.lisp ├── classes ├── algebraic-domains.lisp ├── general-classes.lisp └── space-classes.lisp ├── differential-domains.lisp ├── direct-sums.lisp ├── domain-support.lisp ├── fourier.lisp ├── funct-spaces.lisp ├── functions.lisp ├── general.lisp ├── lisp-numbers.lisp ├── lisp-support.lisp ├── maintenance.lisp ├── matrix.lisp ├── mesh.lisp ├── morphisms.lisp ├── multipole.lisp ├── new-domains.lisp ├── new-topology.lisp ├── numbers ├── bigfloat.lisp ├── gfp.lisp └── numbers.lisp ├── packages.lisp ├── polynomials ├── epolynomial.lisp ├── grobner.lisp ├── mpolynomial.lisp ├── poly-tools.lisp ├── sparsegcd.lisp └── upolynomial.lisp ├── quotient-fields.lisp ├── rational-functions.lisp ├── reference ├── AITR-2001-006.pdf └── Weyl Manual.pdf ├── sets.lisp ├── taylor.lisp ├── test ├── combinatorial-tools.lisp ├── defpackage.lisp ├── f-and-g-series.lisp └── weyl-test.asd ├── topology.lisp ├── tpower.lisp ├── vector-spaces ├── projective-space.lisp ├── quaternions.lisp └── vector.lisp ├── walk.lisp └── weyl.asd /README.org: -------------------------------------------------------------------------------- 1 | * Weyl Computer Algebra Substrate 2 | 3 | This repository contains an updated version of the [[https://www.cs.cornell.edu/rz/computer-algebra.html][Weyl computer 4 | algebra substrate]] from [[https://www.cs.cornell.edu/][Cornell University]]. It is [[http://common-lisp.net/project/asdf/][ASDF]] loadable, and 5 | uses [[https://common-lisp.net/project/closer/closer-mop.html][Closer-MOP]]. It currently is known to work with [[http://sbcl.sourceforge.net/][SBCL]], [[http://ccl.clozure.com/][CCL]], [[http://sourceforge.net/projects/ecls/][ECL]], 6 | [[http://www.lispworks.com/][LispWorks]] (and probably many others). 7 | 8 | The original sources were extracted from the [[https://www.cs.cornell.edu/Info/Projects/SimLab/releases/release-1-0.html][SimLab release 1-0]]. 9 | 10 | Weyl is an extensible algebraic manipulation substrate that has been 11 | designed to represent all types of algebraic objects. It deals not 12 | only with the basic symbolic objects like polynomials, algebraic 13 | functions and differential forms, but can also deal with higher level 14 | objects like groups, rings, ideals and vector spaces. Furthermore, to 15 | encourage the use of symbolic techniques within other applications, 16 | Weyl is implemented as an extension of Common Lisp using the Common 17 | Lisp Object Standard so that all of Common Lisp's facilities and 18 | development tools can be used in concert with Weyl's symbolic tools. 19 | 20 | * Installation 21 | 22 | - Install quicklisp http://www.quicklisp.org/beta/. 23 | - Clone the Weyl repository, 24 | #+BEGIN_SRC shell 25 | > git clone git@github.com:matlisp/weyl.git #or, git@github.com:OdonataResearchLLC/weyl.git 26 | > ln -s $PWD/matlisp /local-projects 27 | #+END_SRC 28 | Fire up your lisp implementation and load as usual with quicklisp: 29 | #+BEGIN_SRC lisp 30 | CL-USER> (ql:quickload :weyl) 31 | CL-USER> (in-package :weyl) 32 | WEYL> 33 | #+END_SRC 34 | 35 | * Documentation and Examples 36 | 37 | The PDF form of a comprehensive manual is available in file 38 | #+BEGIN_SRC 39 | weyl/reference/Weyl Manual.pdf 40 | #+END_SRC 41 | This manual gives many examples of the use of Weyl and the meshing code. 42 | 43 | * Tasks 44 | 45 | Please perform pull requests on the devel branch. 46 | ** Scheduled 47 | 48 | - (0.2.0) Write unit tests based on the examples in the manual. 49 | 50 | ** Unscheduled 51 | 52 | - Implement custom conditions. 53 | - Better separate the definitions in WEYL from WEYLI. It would be nice 54 | to have a WEYL-KERNEL, WEYL, and a WEYL-USER package. 55 | 56 | The WEYL-KERNEL package would form the core routines for WEYL and 57 | WEYL-USER. The WEYL package would be used by other packages. The 58 | WEYL-USER package would be for interactive use. This approach would 59 | hopefully negate the necessity for `use-weyl-package`. 60 | 61 | * Copyright / Acknowledgements / Disclaimer 62 | 63 | All code is copyrighted Cornell University, 1995. 64 | 65 | Code has been developed by Paul Chew, Paul Jackson, Shekar Muddana, 66 | Rick Palmer, Todd Wilson and Richard Zippel in the Simlab group at 67 | Cornell University. 68 | 69 | This work was supported in part by the Advanced Research Projects 70 | Agency of the Department of Defense under ONR Contract 71 | N00014--92--J--1989, by ONR Contract N00014--92--J--1839, and in part 72 | by the U.S. Army Research Office through the Mathematical Science 73 | Institute of Cornell University. 74 | 75 | This material is NOT Public Domain, but permission to copy this 76 | software, to redistribute it, and to use it for any purpose is 77 | granted, subject to the following restrictions and understandings. 78 | 79 | 1. Any copy made of this software must include this copyright notice 80 | in full. 81 | 82 | 2. Users of this software agree to make their best efforts (a) to 83 | return to the Cornell Modeling and Simulation Project any 84 | improvements or extensions that they make, so that these may be 85 | included in future releases; and (b) to inform Cornell of 86 | noteworthy uses of this software. 87 | 88 | 3. All redistributions of this software must include the sources, 89 | machine readable documentation and any other machine readable 90 | material provided as part of this distribution by Cornell in full. 91 | 92 | 4. All materials developed as a consequence of the use of this 93 | software shall duly acknowledge such use, in accordance with the 94 | usual standards of acknowledging credit in academic research. 95 | 96 | 5. Cornell University has made no warrantee or representation that the 97 | operation of this software will be error-free, and Cornell 98 | University is under no obligation to provide any services, by way 99 | of maintenance, update, or otherwise. 100 | 101 | 6. In conjunction with products arising from the use of this material, 102 | there shall be no use of the name of Cornell University nor of any 103 | adaptation thereof in any advertising, promotional, or sales 104 | literature without prior written consent from Cornell in each case. 105 | -------------------------------------------------------------------------------- /algebraic-extension.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Package:Weyli; Base:10; Lowercase:T; Syntax:Common-Lisp -*- 2 | ;;; =========================================================================== 3 | ;;; Finite Algebraic Extension 4 | ;;; =========================================================================== 5 | ;;; (c) Copyright 1989, 1993 Cornell University 6 | 7 | ;; algebraic-extension.lisp,v 1.5 1994/10/04 22:30:39 rz Exp 8 | 9 | (in-package :weyli) 10 | 11 | ;;; DELETE (make::adjust-version-numbers Weyl "1.5") 12 | 13 | (eval-when (:compile-toplevel :load-toplevel) 14 | (define-domain-creator factor-ring ((ring ring) (ideal ideal)) 15 | (cond ((eql (ring-of ideal) ring) 16 | (make-instance 'factor-ring :numerator ring :denominator ideal)) 17 | (t (error "Don't know how to compute ~S/~S" ring ideal))) 18 | :predicate 19 | #'(lambda (d) 20 | (and (typep d 'factor-ring) 21 | (eql (factor-numer-of d) ring) 22 | (= (factor-denom-of d) ideal))))) 23 | 24 | (eval-when (:compile-toplevel :load-toplevel) 25 | (define-domain-creator algebraic-extension 26 | ((coefficient-domain ring) variables) 27 | (progn 28 | (unless (integral-domain? coefficient-domain) 29 | (error "Can only create algebraic extensions of integral domains: ~S" 30 | coefficient-domain)) 31 | (let ((domain 32 | (make-instance 'algebraic-extension-ring 33 | :variables (loop for var in variables 34 | collect (coerce var *general*)) 35 | :coefficient-domain coefficient-domain))) 36 | (make-homomorphism coefficient-domain 37 | #'(lambda (c) (make-polynomial domain c)) 38 | domain) 39 | domain)) 40 | :predicate 41 | #'(lambda (d) ;; FIXTHIS: the predicate needs to be improved 42 | (and (typep d 'algebraic-extension-ring) 43 | (eql (coefficient-domain-of d) coefficient-domain) 44 | (equal (ring-variables d) variables))))) 45 | 46 | ;; Use the polynomial print-object method for now 47 | 48 | ;; This returns the term list for the minimal polynomial of the main 49 | ;; variable of the polynomial. This polynomial is expected to be monic. 50 | (defmacro variable-minimal-polynomial (domain var) 51 | `(get-variable-number-property ,domain (poly-order-number ,var) 52 | :minimal-polynomial)) 53 | 54 | (defgeneric minimal-polynomial (domain variable) 55 | (:documentation 56 | "The purpose of this function is unknown.")) 57 | 58 | (defmethod minimal-polynomial ((domain algebraic-extension-ring) variable) 59 | (with-slots (variables) domain 60 | (unless (member variable variables :test #'ge-equal) 61 | (error "~'i~A~ is not a variable of ~S" variable domain))) 62 | (get-variable-number-property domain (variable-index domain variable) 63 | :minimal-polynomial)) 64 | 65 | (defmethod minimal-polynomial 66 | ((domain algebraic-extension-ring) (variable integer)) 67 | (get-variable-number-property domain variable :minimal-polynomial)) 68 | 69 | (defmethod set-minimal-polynomial 70 | ((domain algebraic-extension-ring) variable minimal-polynomial) 71 | (setq variable (coerce variable *general*)) 72 | (with-slots (variables) domain 73 | (unless (member variable variables :test #'ge-equal) 74 | (error "~'i~A~ is not a variable of ~S" variable domain))) 75 | (unless (eql (domain-of minimal-polynomial) domain) 76 | (error "The algebraic relation ~S is not an element of ~S" 77 | minimal-polynomial domain)) 78 | (let ((poly-form (poly-form minimal-polynomial)) 79 | (var-index (variable-index domain variable))) 80 | (unless (= var-index (poly-order-number poly-form)) 81 | (error "~S is not the most main variable of ~S" 82 | (with-output-to-string (string) 83 | (display variable string)) 84 | minimal-polynomial)) 85 | (setf (get-variable-number-property domain var-index :minimal-polynomial) 86 | (poly-terms poly-form)))) 87 | 88 | (defsetf minimal-polynomial set-minimal-polynomial) 89 | 90 | (defmethod make-polynomial ((domain algebraic-extension-ring) form) 91 | (make-instance 'algebraic-object :domain domain :form form)) 92 | 93 | (defmethod-sd times ((x algebraic-object) (y algebraic-object)) 94 | (bind-domain-context domain 95 | (make-polynomial domain (alg-poly-times (poly-form x) (poly-form y))))) 96 | 97 | (defun alg-poly-times (x y) 98 | (cond ((poly-coef? x) 99 | (if (poly-coef? y) (* x y) 100 | (poly-simp y (terms-mon-times (poly-terms y) (e0) x)))) 101 | ((poly-coef? y) 102 | (poly-simp x (terms-mon-times (poly-terms x) (e0) y))) 103 | ((same-variable? x y) 104 | (let ((min-poly (minimal-polynomial *domain* (poly-order-number x)))) 105 | (poly-simp x (if min-poly 106 | (terms-pseudo-remainder 107 | (terms-times (poly-terms x) (poly-terms y)) 108 | min-poly) 109 | (terms-times (poly-terms x) (poly-terms y)))))) 110 | ((more-main? x y) 111 | (poly-simp x (terms-mon-times (poly-terms x) (e0) y))) 112 | (t (poly-simp y (terms-mon-times (poly-terms y) (e0) x))))) 113 | 114 | (defmethod expt ((base algebraic-object) (expt integer)) 115 | (let ((domain (domain-of base))) 116 | (bind-domain-context domain 117 | (make-polynomial domain 118 | (%funcall (repeated-squaring #'alg-poly-times 119 | (one *coefficient-domain*)) 120 | (poly-form base) expt))))) 121 | -------------------------------------------------------------------------------- /classes/general-classes.lisp: -------------------------------------------------------------------------------- 1 | 2 | ;;; -*- Mode:Lisp; Package:Weyli; Base:10; Lowercase:T; Syntax:Common-Lisp -*- 3 | ;;; =========================================================================== 4 | ;;; General Representation Classes 5 | ;;; =========================================================================== 6 | ;;; (c) Copyright 1989, 1993 Cornell University 7 | 8 | ;;; general-classes.lisp,v 1.5 1995/05/24 17:42:00 rz Exp 9 | 10 | (in-package :weyli) 11 | 12 | ;;; DELETE (make::adjust-version-numbers Weyl "1.5") 13 | 14 | (defclass has-memoization () 15 | ((memos :initform (make-hash-table :test #'equal)))) 16 | 17 | ;;; Classes for General expressions 18 | 19 | (defvar *global-functions* () 20 | "These are the functions known by everyone") 21 | 22 | (defclass general-expressions (has-memoization non-strict-domain domain) 23 | ((variables 24 | :initform () 25 | :accessor ge-variables) 26 | (functions 27 | :initform nil 28 | :accessor ge-functions) 29 | (context 30 | :initform () 31 | :accessor ge-context))) 32 | 33 | (defclass general-expression (ge-or-numeric) 34 | ((simplified? 35 | :initform nil 36 | :accessor simplified?))) 37 | 38 | ;; This class is used to define those general expressions that are 39 | ;; indivisible. 40 | (defclass ge-atom () ()) 41 | 42 | (defsubst ge-atom? (x) (typep x 'ge-atom)) 43 | 44 | (defclass ge-variable (general-expression has-property-list ge-atom) 45 | ((symbol 46 | :initarg :symbol 47 | :accessor symbol-of) 48 | (string 49 | :initarg :string 50 | :accessor string-of))) 51 | 52 | ;; N-ary operators are built from this class 53 | (defclass ge-nary (general-expression) 54 | ((terms 55 | :initform nil 56 | :initarg :terms 57 | :accessor terms-of))) 58 | 59 | (defsubst ge-nary? (x) (typep x 'ge-nary)) 60 | 61 | (defclass ge-plus (ge-nary) 62 | ()) 63 | 64 | (defsubst ge-plus? (x) (typep x 'ge-plus)) 65 | 66 | (defclass ge-times (ge-nary) 67 | ()) 68 | 69 | (defsubst ge-times? (x) (typep x 'ge-times)) 70 | 71 | (defclass ge-expt (general-expression) 72 | ((base 73 | :initarg :base 74 | :accessor base-of) 75 | (exp 76 | :initarg :exp 77 | :accessor exponent-of))) 78 | 79 | (defsubst ge-expt? (x) (typep x 'ge-expt)) 80 | 81 | ;; FUNCTIONS 82 | 83 | ;; Functions themselves are first class objects. So we need a representation 84 | ;; for a function, and a second representation for a functional application. 85 | ;; These functions should be cached just the way variables are cached. 86 | 87 | ;; ABSTRACT-FUNCTION is the base class for all functions. At a minimum 88 | ;; all functions have a specified number of arguments, and a property-list 89 | ;; in which additional information can be stored. 90 | (defclass abstract-function (domain-element has-property-list) 91 | ((nargs 92 | :initarg :nargs ; The number of arguments 93 | :accessor nargs-of))) 94 | 95 | ;; This separated out so that we can implemented existential as well 96 | ;; universal quantifiers. 97 | (defclass has-bound-variables () 98 | ((bound-vars 99 | :initarg :bound-vars 100 | :accessor bound-vars-of))) 101 | 102 | ;; APPLICABLE-FUNCTION indicates that this object is a symbolic 103 | ;; lambda expression 104 | (defclass applicable-function (abstract-function has-bound-variables) 105 | ((body 106 | :initarg :body 107 | :reader body-of))) 108 | 109 | (defsubst applicable-function? (x) (typep x 'applicable-function)) 110 | 111 | ;; GE-FUNCTION is the class of named functions, 112 | (defclass ge-function (abstract-function has-name) 113 | ()) 114 | 115 | (defsubst ge-function? (x) (typep x 'ge-function)) 116 | 117 | ;; GE-FUNCTION-DERIV is used to represent the derivative of a function. 118 | ;; The DERIVS slot is used to hold an order list of the derivatives. Each 119 | ;; element of the list is a number from 0 to nars - 1 indicating a derivative 120 | ;; in that position. Numbers can appear more than once and are sorted. 121 | 122 | (defclass ge-function-deriv (ge-function) 123 | ((derivs 124 | :initform () 125 | :initarg :derivs 126 | :accessor derivs-of))) 127 | 128 | ;; Notice that a GE-FUNCTION-DERIV is also a GE-FUNCTION 129 | (defsubst ge-function-deriv? (x) (typep x 'ge-function-deriv)) 130 | 131 | (defclass ge-application (general-expression) 132 | ((funct 133 | :initarg :funct ; The function being applied 134 | :accessor funct-of) 135 | (args 136 | :initarg :args ; Arguments to the function 137 | :accessor args-of))) 138 | 139 | (defsubst ge-application? (x) (typep x 'ge-application)) 140 | 141 | (defclass ge-equation (general-expression) 142 | ((lhs 143 | :initarg :lhs 144 | :accessor lhs-of) 145 | (rhs 146 | :initarg :rhs 147 | :accessor rhs-of))) 148 | 149 | (defclass ge-eqn= (ge-equation) 150 | ()) 151 | 152 | (defsubst ge-eqn=? (exp) 153 | (typep exp 'ge-eqn=)) 154 | 155 | (defclass ge-eqn> (ge-equation) 156 | ()) 157 | 158 | (defsubst ge-eqn>? (exp) 159 | (typep exp 'ge-eqn>)) 160 | 161 | (defclass ge-eqn>= (ge-equation) 162 | ()) 163 | 164 | (defsubst ge-eqn>=? (exp) 165 | (typep exp 'ge-eqn>=)) 166 | 167 | ;; The expression must be general-expression, so I am also make a univerally 168 | ;; quantified set a domain-element 169 | (defclass universal-quantified-set (has-bound-variables set general-expression) 170 | ((exprs 171 | :initarg :expressions 172 | :accessor exprs-of))) 173 | 174 | ;; Fourier transforms 175 | 176 | (defclass ge-fourier (general-expression) 177 | ((argument 178 | :initarg :argument 179 | :accessor argument-of) 180 | (space-var 181 | :initarg :space-var 182 | :accessor space-var-of) 183 | (freq-var 184 | :initarg :freq-var 185 | :accessor freq-var-of))) 186 | 187 | (defsubst ge-fourier? (x) (typep x 'ge-fourier)) 188 | 189 | (defclass ge-ifourier (general-expression) 190 | ((argument 191 | :initarg :argument 192 | :accessor argument-of) 193 | (space-var 194 | :initarg :space-var 195 | :accessor space-var-of) 196 | (freq-var 197 | :initarg :freq-var 198 | :accessor freq-var-of))) 199 | 200 | (defsubst ge-ifourier? (x) (typep x 'ge-ifourier)) 201 | -------------------------------------------------------------------------------- /classes/space-classes.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Package:Weyli; Base:10; Lowercase:T; Syntax:Common-Lisp -*- 2 | ;;; =========================================================================== 3 | ;;; Space Classes 4 | ;;; =========================================================================== 5 | ;;; (c) Copyright 1994 Cornell University 6 | 7 | ;;; space-classes.lisp,v 1.11 1995/05/30 18:10:14 rick Exp 8 | 9 | (in-package :weyli) 10 | 11 | ;;; DELETE (make::adjust-version-numbers Weyl "1.11") 12 | 13 | ;; Topological Domains 14 | 15 | ;; Abstract spaces don't necessarily have a well defined dimension 16 | (defclass abstract-space (domain) ()) 17 | 18 | (defclass dimensional-space (abstract-space dimensional-domain) ()) 19 | 20 | (defclass euclidean-space (vector-space dimensional-space) ()) 21 | 22 | ;; FIXTHIS: This class should probably be in a different file. 23 | ;; Saves any results of coercions in a coercion cache accessible via 24 | ;; Coerce. 25 | (defclass has-coercion-cache () 26 | ((coercion-cache 27 | :initform nil 28 | :accessor %coercion-cache-of))) 29 | 30 | ;; Associates a unique id-number with each instance. 31 | (defclass has-id-number () 32 | ((global-counter 33 | :initform 0 34 | :allocation :class 35 | :accessor %global-id-counter-of) 36 | (id-number 37 | :reader id-number-of))) 38 | 39 | (defclass has-name () 40 | ((name :initarg :name :accessor name-of))) 41 | 42 | (defmethod initialize-instance :after ((obj has-id-number) &rest ignore) 43 | (declare (ignore ignore)) 44 | (with-slots (id-number) obj 45 | (setf id-number (incf (%global-id-counter-of obj))))) 46 | 47 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 48 | ;; Points. 49 | 50 | ;; Base class of different types of points. 51 | (defclass abstract-point (has-id-number domain-element) ()) 52 | 53 | ;; An abstract point with a name. Points with the same name in the 54 | ;; same space are identical. 55 | (defclass named-point (has-name abstract-point) ()) 56 | 57 | ;; A point may have different coordinates in different spaces. The 58 | ;; appropriate coordinates of a point are found using Coerce. 59 | ;; General-Point is for point in possibly non-euclidean coordinate 60 | ;; systems (polar, spherical, etc.) 61 | (defclass general-point (tuple has-coercion-cache abstract-point) ()) 62 | 63 | (defclass point (vector-space-element general-point) ()) 64 | 65 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 66 | ;; Cells and Cell-Complex. 67 | 68 | ;; To fit within a complex, each cell class must have the following 69 | ;; functions: cell-id, facets, and dimension-of. Function cell-id 70 | ;; returns something (it doesn't really matter what) so that two 71 | ;; cell-ids are #'equal iff the two cells are equivalent. [It also 72 | ;; has to hash efficiently, so for Lucid, we have to use id-numbers 73 | ;; instead of points because all points hash to the same location.] 74 | ;; Function facets returns all the subcells that are one dimension 75 | ;; lower than the cell. Function dimension-of does what you'd 76 | ;; expect. 77 | (defclass cell (has-id-number) 78 | ((orient :initform t :initarg :orient :accessor orient-of))) 79 | 80 | (defclass simplex (cell) 81 | (;; Maintained in order of id-number. 82 | (vertices :initform nil :initarg :vertices :reader vertices-of))) 83 | 84 | 85 | ;;; there must be a better place for ORIENTED-SORT 86 | (defun oriented-sort (list) 87 | "Sort keeping track of the number of swaps" 88 | ;; bubble sort 89 | (loop with orient = t 90 | for l1 on list do 91 | (loop for l2 on (rest l1) do 92 | (when (cl:< (id-number-of (first l2)) (id-number-of (first l1))) 93 | (setf orient (null orient)) 94 | (psetf (first l1) (first l2) 95 | (first l2) (first l1)))) 96 | finally (return (values list orient)))) 97 | 98 | (defmethod initialize-instance :after ((simplex simplex) 99 | &rest ignore &key home) 100 | (declare (ignore ignore home)) 101 | (with-slots (vertices orient) simplex 102 | (multiple-value-bind (v o) 103 | (oriented-sort (copy-list vertices)) 104 | (setf vertices v 105 | orient o)))) 106 | 107 | (defclass polygon (cell) 108 | ( ;; Maintained with smallest id-number first, then adjacent 109 | ;; vertex with smaller id-number, followed by other vertices in 110 | ;; order around the polygon. 111 | (vertices :initform nil :initarg :vertices :reader vertices-of))) 112 | 113 | (defmethod initialize-instance :after ((polygon polygon) &rest ignore) 114 | (declare (ignore ignore)) 115 | (warn "Polygons are not completely implemented.")) 116 | 117 | (defclass cell-complex () 118 | ( ;; Used to recognize cells that are equivalent. 119 | (cell-table :initform (make-hash-table :test #'equal) 120 | :reader cell-table-of) 121 | (facet-table :initform (make-hash-table) :reader facet-table-of) 122 | (cofacet-table :initform (make-hash-table) :reader cofacet-table-of))) 123 | 124 | (defclass simplicial-complex (cell-complex) ()) 125 | 126 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 127 | ;; Chains. 128 | 129 | (defclass chain-module (module) 130 | ((complex :initarg :complex :reader complex-of) 131 | (dim :initform 0 :initarg :dimension :reader dimension-of))) 132 | 133 | (defclass cochain-module (module) 134 | ((complex :initarg :complex :reader complex-of) 135 | (dim :initform 0 :initarg :dimension :reader dimension-of))) 136 | 137 | ;; Chains are elements of chain-modules 138 | (defclass chain (domain-element) 139 | ((terms :initarg :terms :accessor chain-terms-of))) 140 | 141 | ;; Mathematically, cochains would probably not inherit from chains. 142 | ;; This is done to simplify implemention -- since chains and cochains 143 | ;; are structurally identical, we'll inherit all functionality from 144 | ;; chains. Fix this later??? 145 | (defclass cochain (chain) 146 | ()) 147 | 148 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 149 | ;; Function Spaces 150 | 151 | (defclass function-space (vector-space dimensional-space ring) 152 | ((funct-domain :initarg :domain :reader funct-domain-of) 153 | (funct-range :initarg :range :reader funct-range-of))) 154 | 155 | (defclass function-space-element (domain-element) 156 | ()) 157 | 158 | (defmethod initialize-instance :after ((h function-space) &rest plist) 159 | (declare (ignore plist)) 160 | (with-slots (print-function) h 161 | (setf print-function 'function-space-print-function))) 162 | 163 | (defun function-space-print-object (h stream) 164 | (format stream "C(~S->~S)" (funct-domain-of h) (funct-range-of h))) 165 | 166 | ;; The domain and range for a Banach space should both be geometric domains 167 | (defclass Banach-space (function-space) 168 | ()) 169 | 170 | ;;Both Banach and Hilbert spaces are supposed to be complete under the 171 | ;;norm. I wonder how that is defined. 172 | 173 | (define-operations Banach-space 174 | (norm (element self)) -> REAL-NUMBERS) 175 | 176 | (defclass Hilbert-space (Banach-space) 177 | ()) 178 | 179 | (define-operations Hilbert-space 180 | (inner-product (element self) (element self)) -> REAL-NUMBERS) 181 | 182 | (defclass hilbert-space-element (function-space-element) 183 | ()) 184 | 185 | (defmethod initialize-instance :after ((h hilbert-space) &rest plist) 186 | (declare (ignore plist)) 187 | (with-slots (print-function) h 188 | (setf print-function 'hilbert-space-print-function))) 189 | 190 | (defun hilbert-space-print-object (h stream) 191 | (format stream "Hilb(~S, ~S)" (funct-domain-of h) (funct-range-of h))) 192 | -------------------------------------------------------------------------------- /differential-domains.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Package:Weyli; Base:10; Lowercase:T; Syntax:Common-Lisp -*- 2 | ;;; =========================================================================== 3 | ;;; Differential Rings 4 | ;;; =========================================================================== 5 | ;;; (c) Copyright 1989, 1993 Cornell University 6 | 7 | ;;; differential-domains.lisp,v 1.7 1995/05/24 17:41:58 rz Exp 8 | 9 | (in-package :weyli) 10 | 11 | ;;; DELETE (make::adjust-version-numbers Weyl "1.7") 12 | 13 | (defmethod ring-variables ((domain differential-polynomial-ring)) 14 | (with-slots ((vars variables)) domain 15 | (loop for v in vars 16 | when (or (atom v) (not (eql (first v) 'derivation))) 17 | collect v))) 18 | 19 | (defsetf variable-derivation set-variable-derivation) 20 | 21 | (eval-when (:compile-toplevel :load-toplevel) 22 | (define-domain-creator differential-ring ((coefficient-domain ring) variables) 23 | (progn 24 | (setq variables (loop for var in variables 25 | collect (coerce var *general*))) 26 | (let ((ring (make-instance 'differential-polynomial-ring 27 | :variables variables 28 | :coefficient-domain coefficient-domain 29 | :print-function 'differential-ring-print-object))) 30 | (loop for var in variables do 31 | (setf (variable-derivation ring var) :generate)) 32 | ring)) 33 | :predicate 34 | #'(lambda (d) 35 | (and (eql (class-name (class-of d)) 'differential-polynomial-ring) 36 | (eql (coefficient-domain-of d) coefficient-domain) 37 | (eql (ring-variables d) variables) 38 | ;; And check that the derivations are the same. 39 | )))) 40 | 41 | (defun differential-ring-print-object (d stream) 42 | (format stream "~A<" (coefficient-domain-of d)) 43 | (display-list (ring-variables d)) 44 | (princ ">" stream)) 45 | 46 | (defmethod coerce ((variable list) (domain differential-polynomial-ring)) 47 | (cond ((member variable (ring-variables domain)) 48 | (make-polynomial domain 49 | (cons (variable-index domain variable) 50 | (make-terms 1 (one (coefficient-domain-of domain)))))) 51 | ((and (not (atom variable)) 52 | (eql (first variable) 'deriv)) 53 | (loop for i below (third variable) 54 | for p = (deriv (coerce (second variable) domain)) then (deriv p) 55 | finally (return p))) 56 | ((coercible? variable (coefficient-domain-of domain))) 57 | (t (call-next-method)))) 58 | 59 | ;; Derivations are more complex than differentation. 60 | ;; This returns the derivation of the main variable of the polynomial. 61 | ;; In general this polynomial is expected to be of degree 1 with 62 | ;; coefficient 1. 63 | (defmacro variable-derivation (domain var) 64 | `(get-variable-number-property ,domain (poly-order-number ,var) 65 | :derivation)) 66 | 67 | (defmacro variable-derivative-order (domain var) 68 | `(get-variable-number-property ,domain (poly-order-number ,var) 69 | :derivative-order)) 70 | 71 | (defgeneric set-variable-derivation (domain variable derivation) 72 | (:documentation 73 | "The purpose of this function is unknown.")) 74 | 75 | (defmethod set-variable-derivation 76 | ((domain differential-polynomial-ring) 77 | (variable symbol) derivation) 78 | (setq variable (coerce variable *general*)) 79 | (with-slots (variables) domain 80 | (unless (member variable variables :test #'ge-equal) 81 | #+Genera 82 | (error "~'i~A~ is not a variable of ~S" variable domain) 83 | #-Genera 84 | (error "~A is not a variable of ~S" variable domain))) 85 | (cond ((eql derivation :generate) 86 | (setf (get-variable-number-property domain 87 | (variable-index domain variable) 88 | :derivation) 89 | :generate)) 90 | (t (cond ((eql (domain-of derivation) *general*) 91 | (setq derivation (coerce derivation domain))) 92 | ((not (eql (domain-of derivation) domain)) 93 | (error "The derivation ~S is not an element of ~S" 94 | derivation domain))) 95 | (setf (get-variable-number-property domain 96 | (variable-index domain variable) 97 | :derivation) 98 | (poly-form derivation))))) 99 | 100 | (defmethod set-variable-derivation 101 | ((domain differential-polynomial-ring) 102 | (variable general-expression) derivation) 103 | (setq variable (coerce variable *general*)) 104 | (with-slots (variables) domain 105 | (unless (member variable variables :test #'ge-equal) 106 | #+Genera 107 | (error "~'i~A~ is not a variable of ~S" variable domain) 108 | #-Genera 109 | (error "~A is not a variable of ~S" variable domain))) 110 | (cond ((eql derivation :generate) 111 | (setf (get-variable-number-property domain 112 | (variable-index domain variable) 113 | :derivation) 114 | :generate)) 115 | (t (cond ((eql (domain-of derivation) *general*) 116 | (setq derivation (coerce derivation domain))) 117 | ((not (eql (domain-of derivation) domain)) 118 | (error "The derivation ~S is not an element of ~S" 119 | derivation domain))) 120 | (setf (get-variable-number-property domain 121 | (variable-index domain variable) 122 | :derivation) 123 | (poly-form derivation))))) 124 | 125 | (defmethod add-new-variable ((domain differential-ring) variable) 126 | (prog1 127 | (call-next-method) 128 | (setq variable (coerce variable *general*)) 129 | (setf (variable-derivation domain variable) :generate))) 130 | 131 | (defun standard-derivation (p) 132 | (let ((deriv (variable-derivation *domain* p))) 133 | (cond ((null deriv) (zero *coefficient-domain*)) 134 | ((eql deriv :generate) 135 | (let* ((old-var (variable-symbol *domain* (poly-order-number p))) 136 | (new-order 137 | (cond ((ge-variable? old-var) 1) 138 | ((eql (first old-var) 'derivation) 139 | (1+ (third old-var))) 140 | (t 1))) 141 | (new-var `(derivation 142 | ,(if (or (ge-variable? old-var) 143 | (not (eql (first old-var) 'derivation))) 144 | old-var 145 | (second old-var)) 146 | ,new-order)) 147 | new-var-num) 148 | (add-new-variable *domain* new-var) 149 | (setq new-var-num (variable-index *domain* new-var)) 150 | (setf (variable-derivation *domain* old-var) new-var) 151 | #+ignore 152 | (setf (variable-derivative-order *domain* new-var) new-order) 153 | (cons new-var-num (make-terms 1 (one *coefficient-domain*))))) 154 | (t deriv)))) 155 | 156 | (defun poly-derivation (p &optional (derivation #'standard-derivation)) 157 | (let ((deriv nil) (temp nil)) 158 | (cond ((poly-coef? p) (zero *coefficient-domain*)) 159 | (t (setq deriv (%funcall derivation p)) 160 | (poly-plus 161 | (if (poly-0? deriv) deriv 162 | (poly-times 163 | (make-poly-form 164 | p 165 | (map-over-each-term (poly-terms p) (e c) 166 | (unless (e0? e) 167 | (unless (poly-0? 168 | (setq temp 169 | (poly-times 170 | (coerce e *coefficient-domain*) 171 | c))) 172 | (collect-term (e1- e) temp))))) 173 | deriv)) 174 | (poly-differentiate-coefs p derivation)))))) 175 | 176 | (defun poly-differentiate-coefs (p derivation) 177 | (let* ((dc nil) 178 | (one (one *coefficient-domain*)) 179 | (terms (poly-terms p)) 180 | (sum (poly-times (make-poly-form p (make-terms (le terms) one)) 181 | (poly-derivation (lc terms) derivation)))) 182 | (map-over-each-term (red terms) (e c) 183 | (setq dc (poly-derivation c derivation)) 184 | (setq sum (poly-plus sum 185 | (poly-times dc 186 | (make-poly-form p 187 | (make-terms e one)))))) 188 | sum)) 189 | 190 | (defmethod derivation ((poly polynomial)) 191 | (let ((domain (domain-of poly))) 192 | (unless (typep domain 'differential-ring) 193 | (error "No derivation operator for ~S" domain)) 194 | (bind-domain-context domain 195 | (make-polynomial domain (poly-derivation (poly-form poly)))))) 196 | 197 | (defmethod derivation ((rat rational-function)) 198 | (let ((domain (domain-of rat))) 199 | (unless (typep (qf-ring domain) 'differential-ring) 200 | (error "No derivation operator for ~S" domain)) 201 | (with-numerator-and-denominator (n d) rat 202 | (bind-domain-context (qf-ring domain) 203 | (ratfun-reduce domain 204 | (poly-difference 205 | (poly-times (poly-derivation n) d) 206 | (poly-times (poly-derivation d) n)) 207 | (poly-times d d)))))) 208 | -------------------------------------------------------------------------------- /direct-sums.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Package:Weyli; Base:10; Lowercase:T; Syntax:Common-Lisp -*- 2 | ;;; =========================================================================== 3 | ;;; Direct Sums 4 | ;;; =========================================================================== 5 | ;;; (c) Copyright 1991,1993 Cornell University 6 | 7 | ;;; direct-sums.lisp,v 1.4 1995/05/24 17:41:59 rz Exp 8 | 9 | (in-package :weyli) 10 | 11 | ;;; DELETE (make::adjust-version-numbers Weyl "1.4") 12 | 13 | (defmethod dimension-of ((domain direct-sum)) 14 | (length (tuple-value domain))) 15 | 16 | (defmethod initialize-instance :after ((domain direct-sum) &rest plist) 17 | (declare (ignore plist)) 18 | (with-slots (print-function) domain 19 | (setf print-function 'direct-sum-print-object))) 20 | 21 | (defun direct-sum-print-object (domain stream) 22 | (%apply #'format stream "~S~@{ (+) ~S~}" 23 | (loop with v = (tuple-value domain) 24 | for i below (array-dimension v 0) 25 | collect (aref v i)))) 26 | 27 | (defgeneric %make-direct-sum (domain1 domain2) 28 | (:documentation 29 | "The purpose of this method is unknown.")) 30 | 31 | (defmacro define-direct-sum (domain-name classes 32 | &optional other-domain-classes other-elt-classes) 33 | (let ((ds-domain (intern (format nil "DIRECT-SUM-~A" domain-name))) 34 | (ds-domain-elt (intern (format nil "DIRECT-SUM-~A-ELT" domain-name)))) 35 | `(progn 36 | (defclass ,ds-domain 37 | (,@(loop for name in classes 38 | collect (intern (format nil "DIRECT-SUM-~A" name))) 39 | ,domain-name ,@other-domain-classes direct-sum) ()) 40 | (defclass ,ds-domain-elt 41 | (,@(loop for name in classes 42 | collect (intern (format nil "DIRECT-SUM-~A-ELT" name))) 43 | ,@other-elt-classes direct-sum-element) ()) 44 | (define-domain-element-classes ,ds-domain ,ds-domain-elt) 45 | (defmethod %make-direct-sum ((a ,domain-name) (b ,domain-name)) 46 | (%make-direct-sum-internal ',ds-domain a b)) 47 | (defmethod make-element ((domain ,ds-domain) elt1 &rest elts) 48 | (%apply #'make-instance ',ds-domain-elt 49 | :domain domain 50 | :values (cons elt1 elts))) 51 | (defmethod weyl::make-element ((domain ,ds-domain) elt1 &rest elts) 52 | (let* ((domains (tuple-value domain)) 53 | (len (array-dimension domains 0))) 54 | (unless (cl:= (1- len) (length elts)) 55 | (error "Incorrect number of elements to MAKE-ELMENT ~A" domain)) 56 | (make-instance ',ds-domain-elt 57 | :domain domain 58 | :values (cons (coerce elt1 (aref domains 0)) 59 | (loop for i upfrom 1 below len 60 | for elt in elts 61 | collect (coerce elt (aref domains i)))))))))) 62 | 63 | (defun make-direct-sum* (domain1 &rest domains) 64 | (when (null domains) 65 | (error "Illegal number of arguments to MAKE-DIRECT-SUM")) 66 | (labels ((iterate (values) 67 | (cond ((null (rest values)) 68 | (first values)) 69 | (t (%make-direct-sum (first values) 70 | (iterate (rest values))))))) 71 | (let ((domain (iterate (cons domain1 domains))) 72 | (Z (get-rational-integers))) 73 | (make-homomorphism Z #'(lambda (x) 74 | (map-with-domain 75 | (first (domain-element-classes domain)) 76 | domain 77 | #'(lambda (d) (coerce x d)) domain)) 78 | domain) 79 | domain))) 80 | 81 | (defun make-direct-sum (domain1 &rest domains) 82 | (add-domain #'false 83 | (%apply #'make-direct-sum* domain1 domains))) 84 | 85 | (defun %make-direct-sum-internal (type a b) 86 | (flet ((domain-list (a) 87 | (loop for i below (dimension-of a) 88 | collect (ref a i)))) 89 | (cond ((typep a 'direct-sum) 90 | (if (typep b 'direct-sum) 91 | (make-instance type :values (nconc (domain-list a) (domain-list b))) 92 | (make-instance type :values (nconc (domain-list a) (list b))))) 93 | ((typep b 'direct-sum) 94 | (make-instance type :values (cons a (domain-list b)))) 95 | (t (make-instance type :values (list a b)))))) 96 | 97 | (defun get-direct-sum (domain1 &rest domains) 98 | (add-domain #'(lambda (d) 99 | (and (typep d 'direct-sum) 100 | (eql domain1 (ref d 0)) 101 | (cl:= (1- (dimension-of d)) (length domains)) 102 | (loop for i below (dimension-of d) 103 | for dom in domains 104 | when (not (eql (ref d i) dom)) 105 | do (return nil) 106 | finally (return t)))) 107 | (%apply #'make-direct-sum* domain1 domains))) 108 | 109 | (defmethod print-object ((domain direct-sum-element) stream) 110 | (%apply #'format stream "~S~@{ (+) ~S~}" 111 | (loop with v = (tuple-value domain) 112 | for i below (array-dimension v 0) 113 | collect (aref v i)))) 114 | 115 | (define-direct-sum semigroup ()) 116 | 117 | (defmethod-sd times ((a direct-sum-semigroup-elt) (b direct-sum-semigroup-elt)) 118 | (map-with-domain 'direct-sum-semigroup-elt domain #'times a b)) 119 | 120 | (define-direct-sum monoid (semigroup)) 121 | 122 | (defmethod one ((domain direct-sum-monoid)) 123 | (map 'direct-sum-monoid-elt #'one domain)) 124 | 125 | (defmethod 0? ((x direct-sum-monoid-elt)) 126 | (let ((v (tuple-value x))) 127 | (loop for i below (array-dimension v 0) 128 | when (not (0? (aref v i))) 129 | do (return nil) 130 | finally (return t)))) 131 | 132 | (define-direct-sum group (monoid)) 133 | 134 | (defmethod-sd quotient ((a direct-sum-group-elt) (b direct-sum-group-elt)) 135 | (map-with-domain 'direct-sum-semigroup-elt domain #'quotient a b)) 136 | 137 | (defmethod recip ((a direct-sum-group-elt)) 138 | (map-with-domain 'direct-sum-semigroup-elt (domain-of a) #'recip a)) 139 | 140 | (define-direct-sum abelian-semigroup ()) 141 | 142 | (defmethod-sd plus ((a direct-sum-semigroup-elt) (b direct-sum-semigroup-elt)) 143 | (map-with-domain 'direct-sum-semigroup-elt domain #'plus a b)) 144 | 145 | (define-direct-sum abelian-monoid (abelian-semigroup)) 146 | 147 | (defmethod zero ((domain direct-sum-monoid)) 148 | (map 'direct-sum-monoid-elt #'zero domain)) 149 | 150 | (defmethod 1? ((x direct-sum-monoid-elt)) 151 | (let ((v (tuple-value x))) 152 | (loop for i below (array-dimension v 0) 153 | when (not (1? (aref v i))) 154 | do (return nil) 155 | finally (return t)))) 156 | 157 | (define-direct-sum abelian-group (abelian-monoid)) 158 | 159 | (defmethod-sd difference ((a direct-sum-abelian-group-elt) (b direct-sum-abelian-group-elt)) 160 | (map-with-domain 'direct-sum-semigroup-elt domain #'difference a b)) 161 | 162 | (defmethod minus ((a direct-sum-abelian-group-elt)) 163 | (map-with-domain 'direct-sum-semigroup-elt (domain-of a) #'minus a)) 164 | 165 | (define-direct-sum module (abelian-group) (has-coefficient-domain)) 166 | 167 | (define-direct-sum algebra (module semigroup)) 168 | 169 | (define-direct-sum ring (algebra monoid)) 170 | -------------------------------------------------------------------------------- /domain-support.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Package:Weyli; Base:10; Lowercase:T; Syntax:Common-Lisp -*- 2 | ;;; =========================================================================== 3 | ;;; Domains 4 | ;;; =========================================================================== 5 | ;;; (c) Copyright 1989, 1993 Cornell University 6 | 7 | ;;; domain-support.lisp,v 1.7 1995/05/24 17:41:59 rz Exp 8 | 9 | (in-package "WEYLI") 10 | 11 | ;;; DELETE (make::adjust-version-numbers Weyl "1.7") 12 | 13 | (defclass has-property-list () 14 | ((property-list :initform nil 15 | :accessor property-list-of))) 16 | 17 | (defmethod getf ((obj has-property-list) key &optional (default nil)) 18 | (common-lisp:getf (property-list-of obj) key default)) 19 | 20 | (defmethod putf ((obj has-property-list) key value) 21 | (setf (common-lisp:getf (property-list-of obj) key) value)) 22 | 23 | (defun domain-print-object (d stream) 24 | (format stream "#" (class-name (class-of d)))) 25 | 26 | (defclass domain (has-property-list) 27 | ((operation-table :initform (make-hash-table)) 28 | (super-domains :initform nil 29 | :initarg :super-domains 30 | :accessor super-domains-of) 31 | (morphisms-from :initform nil 32 | :accessor domain-morphisms-from) 33 | (morphisms-to :initform nil 34 | :accessor domain-morphisms-to) 35 | (print-function :initform #'domain-print-object 36 | :initarg :print-function))) 37 | 38 | ;;; FIXME : Merge with domain-print-object. 39 | (defmethod print-object ((d domain) stream) 40 | (with-slots (print-function) d 41 | ;; This is so that you can pretty print objects in lucid. It 42 | ;; appears, that you are not supposed to use PRINC inside these 43 | ;; methods. 44 | #+Lucid 45 | (let ((*print-pretty* nil)) 46 | (funcall print-function d stream)) 47 | #-Lucid 48 | (funcall print-function d stream))) 49 | 50 | (defmacro define-operations (domain &body operations) 51 | `(defmethod parse-operations :after ((d ,domain)) 52 | (parse-operation-list d ',operations))) 53 | 54 | (defgeneric parse-operation-list (domain operation-list) 55 | (:documentation 56 | "The purpose of this method is not known.")) 57 | 58 | (defmethod parse-operation-list ((d domain) operation-list) 59 | (with-slots (operation-table) d 60 | (loop for ((operation . arguments) nil values) on operation-list by #'cdddr 61 | do (setf (gethash operation operation-table) 62 | (list operation arguments values))))) 63 | 64 | ;;; Need a dummy primary method to hang all the :after methods on. 65 | ;;; FIXME : Organize so that the primary method is not useless. 66 | (defgeneric parse-operations (domain) 67 | (:method ((domain domain)) 68 | nil) 69 | (:documentation 70 | "The purpose of this method is not known.")) 71 | 72 | ;;; FIXME : Audit for merging with parse-operations. 73 | (defmethod initialize-instance :after ((d domain) &rest plist) 74 | (declare (ignore plist)) 75 | (parse-operations d)) 76 | 77 | (defgeneric list-operations (domain) 78 | (:documentation 79 | "Return a list of operations for the domain.")) 80 | 81 | ;;; FIXME : Convert the maphash to a LOOP. 82 | (defmethod list-operations ((d domain)) 83 | (with-slots (operation-table) d 84 | (let (ops) 85 | (maphash #'(lambda (key value) 86 | (declare (ignore value)) 87 | (push key ops)) 88 | operation-table) 89 | ops))) 90 | 91 | (defgeneric operation-arguments (domain operation) 92 | (:documentation 93 | "The purpose of this method is not known.")) 94 | 95 | (defmethod operation-arguments ((d domain) operation) 96 | (with-slots (operation-table) d 97 | (subst (class-name (class-of d)) 'self 98 | (second (gethash operation operation-table))))) 99 | 100 | (defgeneric operation-values (domain operation) 101 | (:documentation 102 | "The purpose of this method is not known.")) 103 | 104 | (defmethod operation-values ((d domain) operation) 105 | (with-slots (operation-table) d 106 | (subst (class-name (class-of d)) 'self 107 | (third (gethash operation operation-table))))) 108 | 109 | (defgeneric describe-operations (domain &optional no-complaints) 110 | (:documentation 111 | "The purpose of this method is not known.")) 112 | 113 | #+Genera 114 | (defmethod describe-operations ((d domain) &optional no-complaints) 115 | (declare (ignore no-complaints)) 116 | (let* ((class-name (class-name (class-of d))) 117 | (domain-element (cond ((null (rest (get class-name 'domain-elements))) 118 | (first (get class-name 'domain-elements))) 119 | (t (format nil "~A element" class-name))))) 120 | (labels ((canonicalize-class (name) 121 | (cond ((eql name 'self) class-name) 122 | ((atom name) name) 123 | ((equal name '(element self)) 124 | domain-element) 125 | (t (mapcar #'canonicalize-class name))))) 126 | (format t "~&~S is a ~A~%" d class-name) 127 | (fresh-line) 128 | (with-slots (operation-table) d 129 | (scl:formatting-table () 130 | (scl:with-character-style ('(nil :italic nil)) 131 | (scl:formatting-row () 132 | (scl:formatting-cell () 133 | (princ "Operation")) 134 | (scl:formatting-cell () 135 | (princ "Arguments")) 136 | (scl:formatting-cell () 137 | (princ "Values")))) 138 | (maphash #'(lambda (key value) 139 | (declare (ignore key)) 140 | (scl:formatting-row () 141 | (scl:formatting-cell () 142 | (princ (first value))) 143 | (scl:formatting-cell () 144 | (format t "~A~{, ~A~}" 145 | (canonicalize-class (first (second value))) 146 | (mapcar #'canonicalize-class 147 | (rest (second value))))) 148 | (scl:formatting-cell () 149 | (princ (canonicalize-class (third value)))))) 150 | operation-table)))))) 151 | 152 | #-Genera 153 | (defmethod describe-operations ((d domain) &optional no-complaints) 154 | (declare (ignore no-complaints)) 155 | (let* ((class-name (class-name (class-of d))) 156 | (element-classes (get class-name 'element-classes)) 157 | (domain-element (cond ((and element-classes 158 | (null (rest element-classes))) 159 | (first element-classes)) 160 | (t (format nil "~A element" class-name))))) 161 | (labels ((canonicalize-class (name) 162 | (cond ((eql name 'self) class-name) 163 | ((atom name) name) 164 | ((equal name '(element self)) 165 | domain-element) 166 | (t (mapcar #'canonicalize-class name))))) 167 | (format t "~&~S is a ~A~%" d class-name) 168 | (fresh-line) 169 | (with-slots (operation-table) d 170 | (format t "Operation Arguments Values") 171 | (maphash #'(lambda (key value) 172 | (declare (ignore key)) 173 | (format t "~&(~A ~A~{, ~A~}) -> ~A~%" 174 | (first value) 175 | (canonicalize-class (first (second value))) 176 | (mapcar #'canonicalize-class 177 | (rest (second value))) 178 | (canonicalize-class (third value)))) 179 | operation-table))))) 180 | 181 | (defgeneric required-operations (domain &optional fun) 182 | (:documentation 183 | "The purpose of this method is not known.")) 184 | 185 | (defmethod required-operations ((d domain) &optional fun) 186 | (let* ((class-name (class-name (class-of d))) 187 | (element-classes (get class-name 'element-classes)) 188 | (domain-element (cond ((and element-classes 189 | (null (rest element-classes))) 190 | (first element-classes)) 191 | (t (cons 'or element-classes)))) 192 | list) 193 | (labels ((canonicalize-class (name) 194 | (cond ((eql name 'self) class-name) 195 | ((atom name) name) 196 | ((equal name '(element self)) 197 | domain-element) 198 | (t (mapcar #'canonicalize-class name))))) 199 | 200 | (unless fun 201 | (setq fun #'(lambda (form) 202 | (push (cons (first form) 203 | (mapcar #'canonicalize-class (second form))) 204 | list)))) 205 | (with-slots (operation-table) d 206 | (maphash #'(lambda (key value) 207 | (declare (ignore key)) 208 | (%funcall fun value)) 209 | operation-table)) 210 | list))) 211 | 212 | (defun map-over-arglist-combinations (self arglist fun) 213 | (labels ((recur (arglist types) 214 | (cond ((null arglist) 215 | (%funcall fun (reverse types))) 216 | ((atom (first arglist)) 217 | (recur (rest arglist) (cons (first arglist) types))) 218 | ((eql (first (first arglist)) 'or) 219 | (loop for type in (rest (first arglist)) 220 | do (recur (cons type (rest arglist)) types))) 221 | ((eql (first (first arglist)) 'element) 222 | (loop for type in (get self 'element-classes) 223 | do (recur (cons type (rest arglist)) types))) 224 | (t (error "Don't understand arglist entry: ~S" 225 | (first arglist)))))) 226 | (recur (first arglist) ()))) 227 | 228 | ;;; DELETE : The method does not appear to be used anywhere. 229 | (defgeneric check-domain (domain) 230 | (:documentation 231 | "The purspose of this method is not known.")) 232 | 233 | ;;; FIXME : SBCL specific. Need to abstract for other implementations. 234 | #+SB-MOP 235 | (defmethod check-domain ((d domain)) 236 | (required-operations 237 | d 238 | (lambda (form) 239 | (let ((operation (first form)) 240 | (args (rest form))) 241 | (map-over-arglist-combinations 242 | (class-name (class-of d)) args 243 | #'(lambda (arg-names) 244 | (let ((args (loop for type in arg-names 245 | collect (find-class type nil)))) 246 | (loop for method in (sb-mop:generic-function-methods 247 | (symbol-function operation)) 248 | do (when (equal args 249 | (sb-mop::method-specializers method)) 250 | (return t)) 251 | finally (format t "No method for ~S~%" 252 | (cons operation arg-names)))))))))) 253 | 254 | ;; Domain creators 255 | 256 | ;;; FIXME : Need to make creating domains atomic so that domains are 257 | ;;; not added to the list unless they are actually created. 258 | (defvar *domains* () 259 | "List of domains currently in use") 260 | 261 | (defvar *general* () 262 | "The general representation domain") 263 | 264 | (defun reset-domains () 265 | (setq *domains* nil) 266 | (setf (domain-morphisms-from *general*) nil) 267 | (setf (domain-morphisms-to *general*) nil)) 268 | 269 | (defmacro add-domain (predicate &body body) 270 | `(add-domain-internal ,predicate #'(lambda () ,@body))) 271 | 272 | (defun add-domain-internal (predicate body) 273 | (let ((domain (find nil *domains* 274 | :test #'(lambda (a b) 275 | (declare (ignore a)) 276 | (%funcall predicate b))))) 277 | (when (null domain) 278 | (setq domain (%funcall body)) 279 | (push domain *domains*)) 280 | domain)) 281 | 282 | (defun false (&rest args) 283 | (declare (ignore args)) 284 | nil) 285 | 286 | (defun true (&rest args) 287 | (declare (ignore args)) 288 | t) 289 | 290 | ;;; FIXME : Need to ensure that the generic function is defined prior 291 | ;;; to the methods. The exact semantics depend on how this is used. It 292 | ;;; either needs to test for the existing of a generic function and 293 | ;;; create one if it doesn't exist or just create one if there should 294 | ;;; not already be one. 295 | (defmacro define-domain-creator (name args creator &key predicate body) 296 | (labels ((parse-args (args) 297 | (cond ((null args) 298 | args) 299 | ((member (first args) '(&optional &key)) 300 | (parse-args (rest args))) 301 | ((eql (first args) '&rest) 302 | (error "Can't handle &rest args here")) 303 | ((atom (first args)) 304 | (cons (first args) (parse-args (rest args)))) 305 | (t (cons (first (first args)) 306 | (parse-args (rest args))))))) 307 | (let ((internal-fun (intern (format nil "MAKE-~A*" name))) 308 | (true-args (parse-args args))) 309 | `(progn 310 | (defmethod ,internal-fun ,args ,creator) 311 | (defmethod ,(intern (format nil "MAKE-~A" name)) ,args 312 | (add-domain #'false (,internal-fun ,@true-args))) 313 | ,@(when predicate 314 | `((defmethod ,(intern (format nil "GET-~A" name)) ,args 315 | (add-domain ,predicate (,internal-fun ,@true-args))))) 316 | ,@(when body 317 | `((defmethod ,(intern (format nil "GET-~A" name)) ,args 318 | ,body))))))) 319 | 320 | (defmacro with-new-weyl-context ((plist) &body body) 321 | `(let ((*domains* nil) 322 | (*allow-coercions* 323 | ,(or (%getf plist :allow-coercions) '*allow-coercions*))) 324 | ,@body)) 325 | 326 | ;; All elements of a domain should include this class 327 | 328 | (defclass domain-element () 329 | ((domain :initarg :domain 330 | :reader domain-of))) 331 | 332 | (defmacro define-domain-element-classes (domain &body element-classes) 333 | `(progn 334 | ;; At one time we thought there would be a one to one 335 | ;; correspondence between classes of domains and the classes of 336 | ;; their elements. This isn't the case. In addition, no uses 337 | ;; the element-class to domain-class correspondence, as you would 338 | ;; expect, so I'm not bothering to keep track of it. --RZ 7/12/94 339 | #+ignore 340 | ,@(loop for element-class in element-classes 341 | collect 342 | `(cond ((eql (get ',element-class 'domain-class) ',domain)) 343 | (t 344 | (when (get ',element-class 'domain-class) 345 | (format t "WARNING: Reset domain-class of ~S~%" 346 | ',element-class)) 347 | (setf (get ',element-class 'domain-class) ',domain)))) 348 | (setf (get ',domain 'element-classes) ',element-classes))) 349 | 350 | (defgeneric domain-element-classes (domain) 351 | (:method ((domain domain)) 352 | (get (class-name (class-of domain)) 'element-classes)) 353 | (:documentation 354 | "The purpose of this method is not known.")) 355 | 356 | ;; This is so that you can pretty print objects in lucid. It appears, 357 | ;; that you are not supposed to use PRINC inside these methods. 358 | #+Lucid 359 | ;; This must be an :around method since it must come before all the 360 | ;; primary methods. 361 | (defmethod print-object :around ((object domain-element) stream) 362 | (let ((*print-pretty* nil)) 363 | (call-next-method))) 364 | 365 | (defgeneric coerce (elt domain) 366 | (:documentation 367 | "Coerce the element into the domain.")) 368 | 369 | (defgeneric coercible? (elt domain) 370 | (:documentation 371 | "Return true if the element is coercible into the domain.")) 372 | 373 | (defmacro defmethod-sd (op (x-spec y-spec) &body body) 374 | #+Genera 375 | (declare (zwei:indentation . wei:indent-for-clos-defmethod)) 376 | (let ((x (if (atom x-spec) x-spec (first x-spec))) 377 | (y (if (atom y-spec) y-spec (first y-spec)))) 378 | `(defmethod ,op (,x-spec ,y-spec) 379 | (let ((domain (domain-of ,x))) 380 | (cond ((eql domain (domain-of ,y)) 381 | ,@body) 382 | (t (call-next-method))))))) 383 | 384 | ;; These are often of use when defining generic operations for domains. 385 | 386 | (defvar *domain* () 387 | "Within the context of an operation, the current domain") 388 | 389 | (defgeneric %bind-dynamic-domain-context (domain function) 390 | (:documentation 391 | "The purpose of this method is not known.") 392 | (:method ((domain domain) function) 393 | (let ((*domain* domain)) 394 | (%funcall function)))) 395 | 396 | (defmacro bind-domain-context (domain &body body) 397 | `(%bind-dynamic-domain-context ,domain 398 | (lambda () 399 | #+Genera (declare (sys:downward-function)) 400 | ,@body))) 401 | -------------------------------------------------------------------------------- /fourier.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Package:Weyli; Base:10; Lowercase:T; Syntax:Common-Lisp -*- 2 | ;;; =========================================================================== 3 | ;;; Fourier Transforms 4 | ;;; =========================================================================== 5 | ;;; (c) Copyright 1989, 1993 Cornell University 6 | 7 | ;;; fourier.lisp,v 1.3 1994/11/15 19:55:25 rz Exp 8 | 9 | (in-package :weyli) 10 | 11 | ;;; DELETE (make::adjust-version-numbers Weyl "1.3") 12 | 13 | (defgeneric make-ge-fourier (domain argument svar fvar) 14 | (:documentation 15 | "The purpose of this method is not known.")) 16 | 17 | (defmethod make-ge-fourier ((domain general-expressions) argument svar fvar) 18 | (make-instance 'ge-fourier :domain domain :argument argument 19 | :space-var svar :freq-var fvar)) 20 | 21 | (defmethod print-object ((expr ge-fourier) stream) 22 | (format stream "Four{~S, ~S->~S}" 23 | (argument-of expr) (space-var-of expr) (freq-var-of expr))) 24 | 25 | (defmethod ge-equal ((x ge-fourier) (y ge-fourier)) 26 | (and (ge-equal (argument-of x) (argument-of y)) 27 | (ge-equal (space-var-of x) (space-var-of y)) 28 | (ge-equal (freq-var-of x) (freq-var-of y)))) 29 | 30 | (defmethod ge-great ((x ge-fourier) (y ge-fourier)) 31 | (cond ((ge-great (argument-of x) (argument-of y)) t) 32 | ((ge-great (argument-of y) (argument-of x)) nil) 33 | ((ge-great (space-var-of x) (space-var-of y)) t) 34 | ((ge-great (space-var-of y) (space-var-of x)) nil) 35 | ((ge-great (freq-var-of x) (freq-var-of y)) t))) 36 | 37 | (defgeneric ge-fourier (exp svar fvar) 38 | (:documentation 39 | "The purpose of this method is unknown.") 40 | (:method (exp svar fvar) 41 | (declare (ignore fvar)) 42 | (error "Don't know how to take the Fourier transform of ~S wrt ~S" 43 | exp svar))) 44 | 45 | (defmethod ge-fourier ((exp general-expression) (svar symbol) (fvar symbol)) 46 | (ge-fourier exp (coerce svar (domain-of exp)) (coerce fvar (domain-of exp)))) 47 | 48 | (defmethod ge-fourier (exp (svar ge-variable) (fvar ge-variable)) 49 | (make-ge-fourier (domain-of svar) (coerce exp (domain-of svar)) svar fvar)) 50 | 51 | (defmethod ge-fourier ((exp numeric) (svar ge-variable) (fvar ge-variable)) 52 | exp) 53 | 54 | (defmethod ge-fourier ((exp ge-variable) (svar ge-variable) (fvar ge-variable)) 55 | (let ((domain (domain-of exp))) 56 | (unless (and (eql domain (domain-of svar)) 57 | (eql domain (domain-of fvar))) 58 | (error "Taking Fourier transform from different domains")) 59 | (cond ((ge-equal exp svar) fvar) 60 | ((depends-on? exp svar) 61 | (make-ge-fourier domain exp svar fvar)) 62 | (t exp)))) 63 | 64 | (defmethod ge-fourier ((exp ge-plus) (svar ge-variable) (fvar ge-variable)) 65 | (let ((domain (domain-of exp))) 66 | (cond ((and (eql domain (domain-of svar)) 67 | (eql domain (domain-of fvar))) 68 | (call-next-method)) 69 | (t (simplify 70 | (make-ge-plus domain 71 | (loop for x in (terms-of exp) 72 | collect (ge-fourier x svar fvar)))))))) 73 | 74 | (defmethod ge-fourier ((exp ge-times) (svar ge-variable) (fvar ge-variable)) 75 | (let ((domain (domain-of exp)) 76 | terms depend-term free-terms) 77 | (unless (and (eql domain (domain-of svar)) 78 | (eql domain (domain-of fvar))) 79 | (error "Taking Fourier transform from different domains")) 80 | (setq terms (terms-of exp)) 81 | (loop for term in terms 82 | do (when (depends-on? term svar) 83 | (cond ((null depend-term) 84 | (setq depend-term term)) 85 | (t (return (setq free-terms :non-linear))))) 86 | finally (setq free-terms 87 | (remove depend-term terms))) 88 | (cond ((eql free-terms :non-linear) 89 | (make-ge-fourier domain exp svar fvar)) 90 | ((null depend-term) 91 | exp) 92 | (t (simplify 93 | (make-ge-times domain 94 | (cons (ge-fourier depend-term svar fvar) 95 | free-terms))))))) 96 | 97 | #+ignore 98 | (defmethod ge-fourier ((exp ge-deriv) (svar ge-variable) (fvar ge-variable)) 99 | (let ((domain (domain-of exp))) 100 | (unless (and (eql domain (domain-of svar)) 101 | (eql domain (domain-of fvar))) 102 | (error "Taking Fourier transform from different domains")) 103 | (loop for entry in (varlist-of exp) 104 | with varlist 105 | do (when (ge-equal svar (first entry)) 106 | (setq varlist (remove entry (varlist-of exp))) 107 | (return 108 | (simplify 109 | (* (expt fvar (second entry)) 110 | (if (null varlist) 111 | (ge-fourier (argument-of exp) svar fvar) 112 | (make-ge-deriv domain 113 | (ge-fourier (argument-of exp) svar fvar) 114 | varlist)))))) 115 | finally 116 | (return 117 | (simplify 118 | (make-ge-deriv domain 119 | (ge-fourier exp svar fvar) 120 | (varlist-of exp))))))) 121 | 122 | (defgeneric fourier (expression &rest variables) 123 | (:documentation 124 | "The purpose of this method is unknown.")) 125 | 126 | (defmethod fourier ((exp number) &rest vars) 127 | (declare (ignore vars)) 128 | (make-element *general* exp)) 129 | 130 | (defmethod fourier ((exp numeric) &rest vars) 131 | (declare (ignore vars)) 132 | exp) 133 | 134 | (defmethod fourier ((exp symbol) &rest vars) 135 | (setq exp (coerce exp *general*)) 136 | (loop for (sv fv) on vars by #'cddr 137 | do (setq exp (ge-fourier exp (coerce sv *general*) 138 | (coerce fv *general*)))) 139 | exp) 140 | 141 | (defmethod fourier ((exp general-expression) &rest vars) 142 | (setq exp (coerce exp *general*)) 143 | (loop for (sv fv) on vars by #'cddr 144 | do (setq exp (ge-fourier exp (coerce sv *general*) 145 | (coerce fv *general*)))) 146 | exp) 147 | 148 | ;; Inverse Fourier Transforms 149 | 150 | (defgeneric make-ge-ifourier (domain argument svar fvar) 151 | (:documentation 152 | "The purpose of this method is unknown.")) 153 | 154 | (defmethod make-ge-ifourier ((domain general-expressions) argument svar fvar) 155 | (make-instance 'ge-ifourier :domain domain :argument argument 156 | :space-var svar :freq-var fvar)) 157 | 158 | (defmethod print-object ((expr ge-ifourier) stream) 159 | (format stream "IFour{~S, ~S->~S}" 160 | (argument-of expr) (space-var-of expr) (freq-var-of expr))) 161 | -------------------------------------------------------------------------------- /functions.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Package:Weyli; Base:10; Lowercase:T; Syntax:Common-Lisp -*- 2 | ;;; =========================================================================== 3 | ;;; Special Functions 4 | ;;; =========================================================================== 5 | ;;; (c) Copyright 1989, 1993 Cornell University 6 | 7 | ;;; functions.lisp,v 1.2 1994/11/15 19:55:26 rz Exp 8 | 9 | 10 | (in-package :weyli) 11 | 12 | ;;; DELETE (make::adjust-version-numbers Weyl "1.2") 13 | 14 | ;; Symbolic Lambda expressions 15 | 16 | (defun make-app-function (args body) 17 | (let* ((domain (domain-of body)) 18 | (old-vars (mapcar #'(lambda (x) (coerce x domain)) args)) 19 | (new-vars nil)) 20 | (loop for i upfrom 1 21 | for v in old-vars 22 | for new-var = (coerce (intern (format nil "V.~D" i)) domain) 23 | do (cond ((ge-equal new-var v) 24 | (push v new-vars)) 25 | (t (setq body (substitute new-var v body)) 26 | (push new-var new-vars)))) 27 | (setq new-vars (reverse new-vars)) 28 | (when (typep body 'general-expression) 29 | (setq body (expand body))) 30 | (cond ((and (typep body 'ge-application) 31 | (loop for v in new-vars 32 | for a in (args-of body) 33 | do (when (not (ge-equal a v)) 34 | (return nil)) 35 | finally (return t))) 36 | (funct-of body)) 37 | (t (make-instance 'applicable-function 38 | :domain domain 39 | :bound-vars new-vars 40 | :nargs (length args) 41 | :body body))))) 42 | 43 | (defmethod print-object ((fun applicable-function) stream) 44 | (format stream "(lambda ~S ~S)" (bound-vars-of fun) (body-of fun))) 45 | 46 | (defmethod apply ((fun applicable-function) &rest args) 47 | (setq args (accum-apply-args args)) 48 | (unless (eql (nargs-of fun) (length args)) 49 | (error "Argument lengths don't match")) 50 | (let* ((body (body-of fun)) 51 | (domain (domain-of body))) 52 | (loop for arg in args 53 | for v in (bound-vars-of fun) 54 | do (setq body (substitute (coerce arg domain) v body))) 55 | body)) 56 | 57 | (defun canonicalize-functions (x y) 58 | (unless (eql (nargs-of x) (nargs-of y)) 59 | (error "Two functions have different number of arguments")) 60 | (let ((x-body (body-of x)) 61 | (y-body (body-of y))) 62 | (loop for x-arg in (bound-vars-of x) 63 | for y-arg in (bound-vars-of y) 64 | do (unless (ge-equal x-arg y-arg) 65 | (setq y-body (substitute x-arg y-arg y-body)))) 66 | (values (bound-vars-of x) x-body y-body))) 67 | 68 | ;;; FIXME : The macro requires substantial auditing. 69 | (defmacro define-applicable-function-binary (operator) 70 | `(progn 71 | (defmethod ,operator ((x applicable-function) y) 72 | (make-app-function (bound-vars-of x) (,operator (body-of x) y))) 73 | 74 | (defmethod ,operator (x (y applicable-function)) 75 | (make-app-function (bound-vars-of y) (,operator x (body-of y)))) 76 | 77 | (defmethod ,operator ((x applicable-function) (y domain-element)) 78 | (make-app-function (bound-vars-of x) (,operator (body-of x) y))) 79 | 80 | (defmethod ,operator ((x domain-element) (y applicable-function)) 81 | (make-app-function (bound-vars-of y) (,operator x (body-of y)))) 82 | 83 | (defmethod-sd ,operator ((x applicable-function) (y applicable-function)) 84 | (multiple-value-bind (args x-body y-body) (canonicalize-functions x y) 85 | (make-app-function args (,operator x-body y-body)))) 86 | 87 | ;; FIXTHIS: Why do the following two methods need to be :around methods? 88 | ;; The :around is only needed for MCL!! 89 | (defmethod ,operator #+MCL :around ((x applicable-function) (y ge-function)) 90 | (unless (= (nargs-of x) (nargs-of y)) 91 | (error "Can't add two functions with different arity: ~S ~S" 92 | x y)) 93 | (make-app-function (bound-vars-of x) 94 | (,operator (body-of x) (apply y (bound-vars-of x))))) 95 | 96 | (defmethod ,operator #+MCL :around ((y ge-function) (x applicable-function)) 97 | (unless (= (nargs-of x) (nargs-of y)) 98 | (error "Can't add two functions with different arity: ~S ~S" 99 | x y)) 100 | (make-app-function (bound-vars-of x) 101 | (,operator (body-of x) (apply y (bound-vars-of x))))) 102 | 103 | (defmethod ,operator ((x ge-function) y) 104 | (make-app-function '(%temp%) (,operator (funcall x '%temp%) y))) 105 | 106 | ;; This is needed because of precidence problems. 107 | ;; (number domain-elt) comes before (t ge-function) 108 | (defmethod ,operator (x (y ge-function)) 109 | (make-app-function '(%temp%) (,operator x (funcall y '%temp%)))) 110 | 111 | (defmethod ,operator ((x number) (y ge-function)) 112 | (make-app-function '(%temp%) (,operator x (funcall y '%temp%)))) 113 | 114 | (defmethod ,operator ((x numeric) (y ge-function)) 115 | (make-app-function '(%temp%) (,operator x (funcall y '%temp%)))) 116 | 117 | (defmethod-sd ,operator ((x ge-function) (y domain-element)) 118 | (make-app-function '(%temp%) (,operator (funcall x '%temp%) y))) 119 | 120 | (defmethod-sd ,operator ((x domain-element) (y ge-function)) 121 | (make-app-function '(%temp%) (,operator x (funcall y '%temp%)))) 122 | 123 | (defmethod-sd ,operator ((x ge-function) (y ge-function)) 124 | (unless (= (nargs-of x) (nargs-of y)) 125 | (error "Can't combine two functions with different arity: (~S ~S ~S)" 126 | ',operator x y)) 127 | (make-app-function '(%temp%) 128 | (,operator (funcall x '%temp%) (funcall y '%temp%)))))) 129 | 130 | (defmethod 0? ((x applicable-function)) 131 | (0? (body-of x))) 132 | 133 | (defmethod 1? ((x applicable-function)) 134 | (1? (body-of x))) 135 | 136 | (define-applicable-function-binary plus) 137 | (define-applicable-function-binary difference) 138 | 139 | (defmethod minus ((x ge-function)) 140 | (make-app-function '(%temp%) (minus (funcall x '%temp%)))) 141 | 142 | (defmethod minus ((x applicable-function)) 143 | (make-app-function (bound-vars-of x) (minus (body-of x)))) 144 | 145 | (define-applicable-function-binary times) 146 | (define-applicable-function-binary quotient) 147 | 148 | (defmethod recip ((x ge-function)) 149 | (make-app-function '(%temp%) (recip (funcall x '%temp%)))) 150 | 151 | (defmethod recip ((x applicable-function)) 152 | (make-app-function (bound-vars-of x) (recip (body-of x)))) 153 | 154 | (defmethod expt ((x applicable-function) (y number)) 155 | (make-app-function (bound-vars-of x) (expt (body-of x) y))) 156 | 157 | (defmethod expt ((x applicable-function) (y symbol)) 158 | (make-app-function (bound-vars-of x) (expt (body-of x) y))) 159 | 160 | (defmethod-sd expt ((x applicable-function) (y domain-element)) 161 | (if (not (typep y 'abstract-function)) 162 | (make-app-function (bound-vars-of x) (expt (body-of x) y)) 163 | (call-next-method))) 164 | 165 | (defmethod expt ((x ge-function) (y number)) 166 | (make-app-function '(%temp%) (expt (funcall x '%temp%) y))) 167 | 168 | (defmethod expt ((x ge-function) (y symbol)) 169 | (make-app-function '(%temp%) (expt (funcall x '%temp%) y))) 170 | 171 | (defmethod-sd expt ((x ge-function) (y domain-element)) 172 | (if (not (typep y 'abstract-function)) 173 | (make-app-function '(%temp%) (expt (funcall x '%temp%) y)) 174 | (call-next-method))) 175 | 176 | (defmethod deriv ((exp applicable-function) &rest vars) 177 | (make-app-function 178 | (bound-vars-of exp) 179 | (apply 180 | #'deriv 181 | (cons (body-of exp) 182 | (loop for v in vars 183 | collect (cond ((typep v 'symbol) v) 184 | ((typep v 'ge-variable) v) 185 | ((and (typep v 'integer) 186 | (not (minusp v)) 187 | (< v (nargs-of exp))) 188 | (elt (bound-vars-of exp) v)) 189 | (t (error "Cannot take deriv of ~A and ~A" 190 | exp v)))))))) 191 | 192 | ;; Special functions 193 | 194 | (defmacro def-ge-1oper (name (arg)) 195 | (let ((maker-name (intern (format nil "MAKE-GE-~A" (string name)))) 196 | (predicate-name (intern (format nil "GE-~A?" (string name))))) 197 | `(progn 198 | (make-function nil ',name 1) 199 | (defun ,maker-name (domain ,arg) 200 | (make-ge-funct domain (make-function domain ',name 1) ,arg)) 201 | (defun ,predicate-name (arg) 202 | (and (ge-application? arg) 203 | (ge-function? (funct-of arg)) 204 | (string-equal (name-of (funct-of arg)) ,(string name)))) 205 | (defmethod ,name ((,arg symbol)) 206 | (simplify (,maker-name *general* (coerce ,arg *general*)))) 207 | (defmethod ,name ((,arg numeric)) 208 | (let* ((arg ,arg) 209 | domain) 210 | (cond ((typep (domain-of arg) 'general-expressions) 211 | (setq domain (domain-of arg))) 212 | (t (setq domain *general*) 213 | (setq arg (coerce arg domain)))) 214 | (simplify (,maker-name domain arg)))) 215 | (defmethod ,name ((,arg general-expression)) 216 | (simplify (,maker-name (domain-of ,arg) ,arg))) 217 | ))) 218 | 219 | (defmacro defsimplify-funct (name args &body body) 220 | (let ((simp-name (intern (format nil "SIMPF-~A" name)))) 221 | `(progn 222 | (defun ,simp-name ,args ,@body) 223 | (setf (getf (make-function nil ',name) 'simplify) ',simp-name)))) 224 | 225 | (defmacro defderiv-funct (name &body body) 226 | (let ((fun-name (intern (format nil ".~A-deriv." name)))) 227 | `(progn 228 | (defun ,fun-name () 229 | (setf (getf (make-function nil ',name) 'deriv) 230 | (list ,@body))) 231 | (pushnew ',fun-name *initialize-contexts-funs*)))) 232 | 233 | ;;; FIXME : Track down the def-ge-1oper macro and generic function 234 | ;;; definition. 235 | (def-ge-1oper ABS (x)) 236 | (def-ge-1oper REALPART (x)) 237 | (def-ge-1oper IMAGPART (x)) 238 | 239 | (defsimplify-funct realpart (domain whole exp) 240 | (declare (ignore domain)) 241 | (cond ((or (ge-abs? exp) 242 | (ge-realpart? exp) 243 | (ge-imagpart? exp)) 244 | exp) 245 | (t whole))) 246 | 247 | (defsimplify-funct imagpart (domain whole exp) 248 | (cond ((or (ge-abs? exp) 249 | (ge-realpart? exp) 250 | (ge-imagpart? exp)) 251 | (zero domain)) 252 | (t whole))) 253 | 254 | (def-ge-1oper LOG (x)) 255 | 256 | (defsimplify-funct log (domain whole exp) 257 | (cond ((cl:floatp exp) 258 | (make-element domain (cl:log exp))) 259 | ((ge-expt? exp) 260 | (simplify 261 | (make-ge-times domain 262 | `(,(exponent-of exp) 263 | ,(make-ge-log (domain-of exp) (base-of exp)))))) 264 | (t whole))) 265 | 266 | (defderiv-funct log 267 | (make-app-function '(x) (expt 'x -1))) 268 | 269 | (def-ge-1oper SIN (x)) 270 | 271 | (defsimplify-funct sin (domain whole exp) 272 | (cond ((cl:floatp exp) 273 | (make-element domain (cl:sin exp))) 274 | ((and (number? exp) (0? exp)) 275 | (make-element domain 0)) 276 | ((ge-minus? exp) 277 | (- (make-ge-sin domain (- exp)))) 278 | (t whole))) 279 | 280 | (defderiv-funct sin 281 | (make-app-function '(x) (cos 'x))) 282 | 283 | (def-ge-1oper COS (x)) 284 | 285 | (defsimplify-funct cos (domain whole exp) 286 | (cond ((cl:floatp exp) 287 | (make-element domain (cl:cos exp))) 288 | ((and (number? exp) (0? exp)) 289 | (make-element domain 1)) 290 | ((ge-minus? exp) 291 | (make-ge-cos domain (- exp))) 292 | (t whole))) 293 | 294 | (defderiv-funct cos 295 | (make-app-function '(x) (- (sin 'x)))) 296 | 297 | (def-ge-1oper TAN (x)) 298 | 299 | (defsimplify-funct tan (domain whole exp) 300 | (cond ((cl:floatp exp) 301 | (make-element domain (cl:tan exp))) 302 | ((and (number? exp) (0? exp)) 303 | (make-element domain 0)) 304 | ((ge-minus? exp) 305 | (- (make-ge-tan domain (- exp)))) 306 | (t whole))) 307 | 308 | (defderiv-funct tan 309 | (make-app-function '(x) (- (expt (cos 'x) -2)))) 310 | 311 | (def-ge-1oper ASIN (x)) 312 | 313 | (defsimplify-funct asin (domain whole exp) 314 | (cond ((cl:floatp exp) 315 | (make-element domain (cl:asin exp))) 316 | ((and (number? exp) (0? exp)) 317 | (make-element domain 0)) 318 | ((ge-minus? exp) 319 | (- (make-ge-asin domain (- exp)))) 320 | (t whole))) 321 | 322 | (defderiv-funct asin 323 | (make-app-function '(x) (- (expt (- 1 (expt 'x 2)) -1/2)))) 324 | 325 | (def-ge-1oper ACOS (x)) 326 | 327 | (defsimplify-funct acos (domain whole exp) 328 | (cond ((cl:floatp exp) 329 | (make-element domain (cl:acos exp))) 330 | (t whole))) 331 | 332 | (defderiv-funct acos 333 | (make-app-function '(x) (expt (- 1 (expt 'x 2)) -1/2))) 334 | 335 | ;;; FIXME : Correct the custom version of ATAN to account for 2 336 | ;;; arguments. 337 | ;; These are conditionalized out since, we might want to have a two 338 | ;; argument version of atan!. 339 | #+FIXTHIS 340 | (def-ge-1oper ATAN (x)) 341 | #+FIXTHIS 342 | (defsimplify-funct atan (domain whole exp) 343 | (cond ((cl:floatp exp) (cl:atan exp)) 344 | (t `(atan ,exp)))) 345 | 346 | #+FIXTHIS 347 | (defderiv-funct atan 348 | (make-app-function '(x) (/ (+ 1 (expt 'x 2))))) 349 | 350 | (def-ge-1oper SINH (x)) 351 | 352 | (defsimplify-funct sinh (domain whole exp) 353 | (cond ((cl:floatp exp) 354 | (make-element domain (cl:sinh exp))) 355 | ((and (number? exp) (0? exp)) 356 | (make-element domain 0)) 357 | ((ge-minus? exp) 358 | (- (make-ge-sinh domain (- exp)))) 359 | (t whole))) 360 | 361 | (defderiv-funct sinh 362 | (make-app-function '(x) (cosh 'x))) 363 | 364 | (def-ge-1oper COSH (x)) 365 | 366 | (defsimplify-funct cosh (domain whole exp) 367 | (cond ((cl:floatp exp) 368 | (make-element domain (cl:cosh exp))) 369 | ((and (number? exp) (0? exp)) 370 | (make-element domain 1)) 371 | ((ge-minus? exp) 372 | (make-ge-cosh domain (- exp))) 373 | (t whole))) 374 | 375 | (defderiv-funct cosh 376 | (make-app-function '(x) (sinh 'x))) 377 | 378 | (def-ge-1oper TANH (x)) 379 | 380 | (defsimplify-funct tanh (domain whole exp) 381 | (cond ((cl:floatp exp) 382 | (make-element domain (cl:tanh exp))) 383 | ((and (number? exp) (0? exp)) 384 | (make-element domain 0)) 385 | ((ge-minus? exp) 386 | (- (make-ge-tanh domain (- exp)))) 387 | (t whole))) 388 | 389 | (defderiv-funct tanh 390 | (make-app-function '(x) (expt (cosh 'x) -2))) 391 | 392 | (def-ge-1oper ASINH (x)) 393 | 394 | (defsimplify-funct asinh (domain whole exp) 395 | (cond ((cl:floatp exp) 396 | (make-element domain (cl:asinh exp))) 397 | ((and (number? exp) (0? exp)) 398 | (make-element domain 0)) 399 | ((ge-minus? exp) 400 | (- (make-ge-asinh domain (- exp)))) 401 | (t whole))) 402 | 403 | (defderiv-funct asinh 404 | (make-app-function '(x) (expt (+ 1 (expt 'x 2)) -1/2))) 405 | 406 | (def-ge-1oper ACOSH (x)) 407 | 408 | (defsimplify-funct acosh (domain whole exp) 409 | (cond ((cl:floatp exp) 410 | (make-element domain (cl:acosh exp))) 411 | (t whole))) 412 | 413 | (defderiv-funct acosh 414 | (make-app-function '(x) (expt (+ 1 (expt 'x 2)) -1/2))) 415 | 416 | #+FIXTHIS 417 | (def-ge-1oper ATANH (x)) 418 | #+FIXTHIS 419 | (defsimplify atanh (domain whole exp) 420 | (cond ((cl:floatp exp) (cl:atanh exp)) 421 | (t `(atanh ,exp)))) 422 | 423 | #+FIXTHIS 424 | (defderiv-funct atanh 425 | (make-app-funciton '(x) (expt (- 1 (expt 'x 2)) -1))) 426 | -------------------------------------------------------------------------------- /lisp-numbers.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Package:Weyli; Base:10; Lowercase:T; Syntax:Common-Lisp -*- 2 | ;;; =========================================================================== 3 | ;;; Lisp Numbers 4 | ;;; =========================================================================== 5 | ;;; (c) Copyright 1989, 1993 Cornell University 6 | 7 | ;;; lisp-numbers.lisp,v 1.6 1995/05/24 17:42:03 rz Exp 8 | 9 | (in-package :weyli) 10 | 11 | ;;; DELETE (make::adjust-version-numbers Weyl "1.6") 12 | 13 | ;; Contains a bunch of routines that allow one to use the Weyl generic 14 | ;; functions on Lisp numbers. There are a number of special 15 | ;; arithmetic routines here also. This is in not in LISP-SUPPORT 16 | ;; because it is more convenient to put write this code in the WEYLI 17 | ;; package. 18 | 19 | ;; The Lisp number domain is a special field whose elements are 20 | ;; represented as Lisp numbers. This class is unique. 21 | 22 | (defgeneric numerator (number) 23 | (:documentation 24 | "Return the numerator of the number.") 25 | (:method ((number integer)) number) 26 | (:method ((number ratio)) (common-lisp:numerator number))) 27 | 28 | (defgeneric denominator (number) 29 | (:documentation 30 | "Return the denominator of the number.") 31 | (:method ((number integer)) 1) 32 | (:method ((number ratio)) (common-lisp:denominator number))) 33 | 34 | (defgeneric factorial (number) 35 | (:documentation 36 | "Return the factorial of the number.")) 37 | 38 | (defmethod factorial ((n integer)) 39 | (labels ((fact (n) 40 | (if (cl:< n 2) 1 41 | (cl:* n (fact (cl:1- n)))))) 42 | (if (cl:minusp n) 43 | (error "Illegal argument to factorial: ~D" n) 44 | (fact n)))) 45 | 46 | (defgeneric pochhammer (number1 number2) 47 | (:documentation 48 | "Return the falling, or lower, factorial.")) 49 | 50 | (defmethod pochhammer ((n integer) (k integer)) 51 | (cond ((cl:minusp k) 52 | (error "Illegal arguments to Pochhammer: (~D, ~D)" 53 | n k)) 54 | ((cl:zerop k) 1) 55 | (t (let ((ans n)) 56 | (loop for i upfrom 1 below k 57 | do (setq ans (cl:* ans (cl:+ n i)))) 58 | ans)))) 59 | 60 | (defgeneric combinations (number1 number2) 61 | (:documentation 62 | "Return a combination of the upper and lower factorial.") 63 | (:method ((number1 integer) (number2 integer)) 64 | (common-lisp:/ (pochhammer (+ number1 (- number2) 1) number2) (factorial number2)))) 65 | 66 | (defun faster-isqrt (n) 67 | "Argument n must be a non-negative integer" 68 | (let (n-len-quarter n-half n-half-isqrt init-value q r iterated-value) 69 | (cond 70 | ((> n 24) 71 | ;; theoretically (> n 7) ,i.e., n-len-quarter > 0 72 | (setq n-len-quarter (ash (integer-length n) -2)) 73 | (setq n-half (ash n (- (ash n-len-quarter 1)))) 74 | (setq n-half-isqrt (faster-isqrt n-half)) 75 | (setq init-value (ash (1+ n-half-isqrt) n-len-quarter)) 76 | (multiple-value-setq (q r) (cl:floor n init-value)) 77 | (setq iterated-value (ash (+ init-value q) -1)) 78 | (if (eq (logbitp 0 q) (logbitp 0 init-value)) ; same sign 79 | ;; average is exact and we need to test the result 80 | (let ((m (- iterated-value init-value))) 81 | (if (> (* m m) r) 82 | (- iterated-value 1) 83 | iterated-value)) 84 | ;; average was not exact, we take value 85 | iterated-value)) 86 | ((> n 15) 4) 87 | ((> n 8) 3) 88 | ((> n 3) 2) 89 | ((> n 0) 1) 90 | ((> n -1) 0) 91 | (t nil)))) 92 | 93 | (defun integer-nth-root (x n) 94 | (cond ((cl:zerop x) x) 95 | ((cl:plusp x) 96 | (let ((n-1 (cl:- n 1)) 97 | (root (ash 1 (cl:truncate (integer-length x) n))) 98 | new-root) 99 | (loop for root^n-1 = (cl:expt root n-1) 100 | do (setq new-root 101 | (cl:round (cl:+ (cl:* n-1 root root^n-1) x) 102 | (* n root^n-1))) 103 | (if (cl:= new-root root) 104 | (return new-root) 105 | (setq root new-root))))) 106 | ((oddp n) 107 | (- (integer-nth-root (cl:- x) n))) 108 | (t nil))) 109 | 110 | ;;; FIXME : Move the prime number related routines to a separate file 111 | ;;; and implement recent algorithms. 112 | 113 | (defvar *pointbound* 2147483629 114 | "Should be largest prime that fits in a word") 115 | 116 | (defvar *big-primes* () 117 | "List of large primes by decending size") 118 | 119 | ;; These two really should be in GFP, but because of LUCID brain damage, 120 | ;; they have to be here to avoid warnings. 121 | 122 | (defun reduce-modulo-integer (value modulus) 123 | (unless (cl:zerop modulus) 124 | (setq value (cl:rem value modulus))) 125 | (if (cl:< value 0) (cl:+ value modulus) 126 | value)) 127 | 128 | (defun expt-modulo-integer (base expt modulus) 129 | (%funcall (repeated-squaring 130 | #'(lambda (a b) (reduce-modulo-integer (cl:* a b) modulus)) 131 | 1) 132 | base expt)) 133 | 134 | (defgeneric prime? (number) 135 | (:documentation 136 | "Return true if the number is prime.")) 137 | 138 | (defmethod prime? ((p integer)) 139 | (and (cl:> p 1) 140 | (or (cl:< p 14.) 141 | (and (cl:= 1 (expt-modulo-integer 13. (1- p) p)) 142 | (cl:= 1 (expt-modulo-integer 3 (1- p) p)))) 143 | (null (cdr (setq p (factor p)))) 144 | (cl:= 1 (cdar p)))) 145 | 146 | ;; Rabin's probabilistic primality algorithm isn't used here because it 147 | ;; isn't much faster than the simple one for numbers about the size of a 148 | ;; word. 149 | (defun find-smaller-prime (p) 150 | "Finds biggest prime less than fixnum p" 151 | (if (evenp p) (setq p (1- p))) 152 | (loop for pp = (cl:- p 2) then (cl:- pp 2) until (cl:< pp 0) 153 | when (prime? pp) 154 | do (return pp))) 155 | 156 | ;; Return the next prime less than its argument, and that fits into a 157 | ;; word. 158 | (defun newprime (&optional p) 159 | (if (null p) *pointbound* 160 | (do ((pl *big-primes* (cdr pl))) 161 | ((null pl) (setq p (find-smaller-prime p)) 162 | (setq *big-primes* (nconc *big-primes* (list p))) 163 | p) 164 | (if (cl:< (car pl) p) (return (car pl)))))) 165 | 166 | ;; Computes a list of primes whose product is greater than the given limit. 167 | (defun choice-primes (limit &optional 168 | (prime-list 169 | (list (find-smaller-prime 170 | most-positive-fixnum)))) 171 | (let ((p (car prime-list))) 172 | (if (< limit p) 173 | prime-list 174 | (choice-primes (ceiling limit p) 175 | (cons (newprime p) prime-list))))) 176 | 177 | ;; Computes (mod a b) symmetric around 0. a and b are assumed to be 178 | ;; lisp integers. 179 | (defun sym-mod (a b) 180 | (let* ((b (cl:abs b)) 181 | (c (cl:mod a b))) 182 | (if (cl:> c (cl:floor (cl:/ b 2))) 183 | (cl:- c b) 184 | c))) 185 | 186 | (defun repeated-squaring (mult one) 187 | (lambda (base exp) 188 | (if (cl:zerop exp) one 189 | (let ((prod one)) 190 | (loop 191 | (if (oddp exp) 192 | (setq prod (%funcall mult prod base))) 193 | (setq exp (cl:truncate exp 2)) 194 | (if (cl:zerop exp) 195 | (return prod)) 196 | (setq base (%funcall mult base base))))))) 197 | 198 | (defgeneric power-of? (number &optional opt-number) 199 | (:documentation 200 | "Return true if number is a power of opt-number.")) 201 | 202 | (defmethod power-of? ((m integer) &optional n) 203 | (cond ((typep n 'integer) 204 | (loop for test = n then (cl:* test n) 205 | for i upfrom 1 206 | do (cond ((cl:= test m) 207 | (return (values n i))) 208 | ((cl:> test m) 209 | (return nil))))) 210 | (t (error "Haven't implemented the rest of the cases")))) 211 | 212 | (defvar *factor-method* 'simple-integer-factor) 213 | 214 | (defmacro count-multiple-integer-factors (N divisor) 215 | `(loop with i = 0 216 | do (multiple-value-bind (quo rem) (cl:truncate ,N ,divisor) 217 | (when (not (cl:zerop rem)) 218 | (if (not (cl:zerop i)) 219 | (push (cons ,divisor i) ans)) 220 | (return t)) 221 | (setq ,N quo) 222 | (incf i)))) 223 | 224 | (defun uniformize-factor-list (ans) 225 | (loop for pairs on (sort ans #'(lambda (a b) (< (first a) (first b)))) 226 | when (or (null (rest pairs)) 227 | (not (cl:= (first (first pairs)) 228 | (first (second pairs))))) 229 | collect (first pairs) 230 | else do (incf (rest (second pairs))))) 231 | 232 | (defgeneric factor (number) 233 | (:documentation 234 | "Return the factors of the number.")) 235 | 236 | (defmethod factor ((N integer)) 237 | (let ((*factor-method* *factor-method*) 238 | ans factors) 239 | (when (cl:minusp N) 240 | (push (cons -1 1) ans) 241 | (setq N (cl:- N))) 242 | (count-multiple-integer-factors N 2) 243 | (count-multiple-integer-factors N 3) 244 | (count-multiple-integer-factors N 5) 245 | (unless (cl:= N 1) 246 | (loop 247 | (multiple-value-setq (N factors) (%funcall *factor-method* N)) 248 | (setq ans (append factors ans)) 249 | (if (cl:= N 1) (return t)))) 250 | (uniformize-factor-list ans))) 251 | 252 | (defun all-divisors (n) 253 | (let ((factors (factor n))) 254 | (loop with divisors = (list 1) 255 | for (prime . times) in factors 256 | do (loop for i from 1 to times 257 | appending (loop for divisor in divisors 258 | collect (* divisor (cl:expt prime i))) 259 | into temp 260 | finally (setq divisors (append temp divisors))) 261 | finally (return (sort divisors #'cl:<))))) 262 | 263 | ;; In general each factorization method should return just one factor. 264 | 265 | (defvar *skip-chain-for-3-and-5* (circular-list 4 2 4 2 4 6 2 6)) 266 | 267 | (defun simple-integer-factor (N) 268 | (let ((increments *skip-chain-for-3-and-5*) 269 | (divisor 7) 270 | ans) 271 | (flet ((simple-integer-factor-internal (N) 272 | (let ((limit (cl:isqrt N))) 273 | (loop 274 | (cond ((cl:= N 1) 275 | (return (values N ans))) 276 | ((cl:> divisor limit) 277 | (return (values 1 (cons (cons N 1) ans)))) 278 | (t (count-multiple-integer-factors N divisor))) 279 | (setq divisor (cl:+ divisor (pop increments))))))) 280 | (setq *factor-method* #'simple-integer-factor-internal) 281 | (simple-integer-factor-internal N)))) 282 | 283 | (defun fermat-integer-factor (N) 284 | (loop for x = (1+ (cl:isqrt N)) then (+ x 1) 285 | for w = (cl:- (cl:* x x) N) 286 | for y = (cl:isqrt w) 287 | do (when (cl:zerop (cl:- w (cl:* y y))) 288 | (let ((u (cl:+ x y)) 289 | (v (cl:- x y))) 290 | (return (if (1? v) 291 | (values 1 (list (cons u 1))) 292 | (values u (factor v)))))))) 293 | 294 | #| Knuth's addition-subtraction version of Fermat's algorithm | 295 | 296 | (defun fermat-integer-factor (N) 297 | (let* ((isqrt-N (cl:isqrt N)) 298 | (x (1+ (* 2 isqrt-N))) 299 | (y 1) 300 | (r (- (* isqrt-N isqrt-N) N))) 301 | (loop 302 | (cond ((= r 0) 303 | (return 304 | (let ((f (/ (+ x y -2) 2)) 305 | (g (/ (- x y) 2))) 306 | (if (= g 1) 307 | (values 1 (list (cons f 1))) 308 | (values 1 (append (factor f) (factor g))))))) 309 | ((< r 0) 310 | (incf r x) 311 | (incf x 2))) 312 | (decf r y) 313 | (incf y 2)))) 314 | 315 | (defun list-of-primes (N) 316 | (cons 2 317 | (loop for p upfrom 3 by 2 below N 318 | when (prime? p) collect p))) 319 | 320 | (defun make-integer-GCD-list (max-prime size-limit) 321 | (let ((GCD-list ())) 322 | (loop for p in (list-of-primes max-prime) 323 | with prod = 1 and prime-list = () 324 | do (setq prod (* prod p)) 325 | (cond ((> prod size-limit) 326 | (push (list (/ prod p) prime-list) 327 | GCD-list) 328 | (setq prod p) 329 | (setq prime-list (list p))) 330 | (t (push p prime-list)))) 331 | GCD-list)) 332 | 333 | 334 | ||# 335 | 336 | (defun totient (x) 337 | (do ((factors (factor x) (rest factors)) 338 | (totient 1 (cl:* totient 339 | (cl:- (cl:expt (caar factors) (cdar factors)) 340 | (cl:expt (caar factors) (1- (cdar factors))))))) 341 | ((null factors) 342 | totient))) 343 | 344 | (defgeneric sin (number) 345 | (:documentation 346 | "Return the sine of the number.") 347 | (:method ((number number)) (common-lisp:sin number))) 348 | 349 | (defgeneric cos (number) 350 | (:documentation 351 | "Return the cosine of the number.") 352 | (:method ((number number)) (common-lisp:cos number))) 353 | 354 | (defgeneric tan (number) 355 | (:documentation 356 | "Return the tangent of the number.") 357 | (:method ((number number)) (common-lisp:tan number))) 358 | 359 | (defgeneric asin (number) 360 | (:documentation 361 | "Return the arc-sine of the number.") 362 | (:method ((number number)) (common-lisp:asin number))) 363 | 364 | (defgeneric acos (number) 365 | (:documentation 366 | "Return the arc-cosine of the number.") 367 | (:method ((number number)) (common-lisp:acos number))) 368 | 369 | (defgeneric atan (number1 &optional number2) 370 | (:documentation 371 | "Return the arc-tangent of the number1 or optionally 372 | number1/number2.")) 373 | 374 | ;;; FIXME : This is a simple example of the motivation for predicate 375 | ;;; dispatching as described in AITR-2001-006. 376 | (defmethod atan ((number1 number) &optional number2) 377 | (cond 378 | ((null number2) 379 | (common-lisp:atan number1)) 380 | ((numberp number2) 381 | (common-lisp:atan number1 number2)) 382 | (t (atan (coerce number1 (domain-of number2)) number2)))) 383 | 384 | (defgeneric sinh (number) 385 | (:documentation 386 | "Return the hyperbolic sine of the number.") 387 | (:method ((number number)) (common-lisp:sinh number))) 388 | 389 | (defgeneric cosh (number) 390 | (:documentation 391 | "Return the hyperbolic cosine of the number.") 392 | (:method ((number number)) (common-lisp:cosh number))) 393 | 394 | (defgeneric tanh (number) 395 | (:documentation 396 | "Return the hyperbolic tangent of the number.") 397 | (:method ((number number)) (common-lisp:tanh number))) 398 | 399 | (defgeneric asinh (number) 400 | (:documentation 401 | "Return the hyperbolic arc sine of the number.") 402 | (:method ((number number)) (common-lisp:asinh number))) 403 | 404 | (defgeneric acosh (number) 405 | (:documentation 406 | "Return the hyperbolic arc cosine of the number.") 407 | (:method ((number number)) (common-lisp:acosh number))) 408 | 409 | (defgeneric atanh (number) 410 | (:documentation 411 | "Return the hyperbolic arc tangent of the number.") 412 | (:method ((number number)) (common-lisp:atanh number))) 413 | 414 | (defgeneric exp (number) 415 | (:documentation 416 | "Return the exponential of the number.") 417 | (:method ((number number)) (common-lisp:exp number))) 418 | 419 | ;;; FIXME : The functions log2 and log need to be merged. This 420 | ;;; provides another simple example of the motivation for predicate 421 | ;;; dispatching as described in AITR-2001-006. 422 | (defgeneric log2 (number base) 423 | (:documentation 424 | "Return the base logarithm of the number.") 425 | (:method ((number number) (base number)) (common-lisp:log number base))) 426 | 427 | (defgeneric log (number) 428 | (:documentation 429 | "Return the natural logarithm of the number.") 430 | (:method ((number number)) (common-lisp:log number))) 431 | 432 | (defgeneric signum (number) 433 | (:documentation 434 | "Returns a numerical value that indicates whether number is 435 | negative, zero or positive.") 436 | (:method ((number number)) (common-lisp:signum number))) 437 | -------------------------------------------------------------------------------- /maintenance.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Package:CL-User; Base:10; Lowercase:T; Syntax:Common-Lisp -*- 2 | ;;; =========================================================================== 3 | ;;; System Maintenance 4 | ;;; =========================================================================== 5 | ;;; (c) Copyright 1989, 1993 Cornell University 6 | 7 | ;;; maintenance.lisp,v 1.2 1994/08/04 14:29:22 rz Exp 8 | 9 | (in-package #-ANSI-CL "USER" #+ANSI-CL "CL-USER") 10 | 11 | (make::adjust-version-numbers Weyl "1.2") 12 | 13 | #+Lucid 14 | (defun dump-weyl (&optional (name "weyl")) 15 | (load-system 'weyl) 16 | (multiple-value-bind (seconds minutes hour date month year d-o-w d-s-t t-z) 17 | (decode-universal-time (get-universal-time)) 18 | (declare (ignore seconds minutes hour d-o-w d-s-t t-z)) 19 | (let ((file (make-pathname 20 | :name (cond ((member :mips *features*) "weyl-mips") 21 | ((member :sparc *features*) "weyl-sparc") 22 | (t "Weyl-Unknown")) 23 | :directory (pathname-directory *weyl-directory*))) 24 | (archive (format nil 25 | (cond ((member :mips *features*) 26 | "~A/~A-mips-~D-~D-~D-~D") 27 | ((member :sparc *features*) 28 | "~A/~A-sparc-~D-~D-~D-~D") 29 | (t "~A/~A-unknown-~D-~D-~D-~D")) 30 | *weyl-archive-directory* 31 | name month date year 32 | (+ minutes (* 100 hour)))) 33 | (banner (weyl-banner))) 34 | (declare (special system::*enter-top-level-hook*)) 35 | (when (probe-file file) 36 | (delete-file file)) 37 | ;; Comment the following line to store binaries in the source directory. 38 | (user::shell (format nil "ln -s ~A ~A" archive file)) 39 | (setq system::*enter-top-level-hook* 40 | #'(lambda () 41 | (format t ";;; ~A~2%" banner) 42 | (lucid::default-enter-top-level-hook))) 43 | (disksave file :full-gc t) 44 | (format t ";;; Weyl ~D.~D successfully dumped into ~A~%~ 45 | ;;; and link was created to it from ~A" 46 | make::*weyl-major-version* make::*weyl-minor-version* 47 | archive file)))) 48 | 49 | #+Lucid 50 | (defun weyl-banner () 51 | (multiple-value-bind (second minute hour date month year day-of-week) 52 | (decode-universal-time (get-universal-time)) 53 | (declare (ignore second)) 54 | (format nil "Weyl Version ~D.~D, saved ~2D:~2D ~A, ~A ~D, ~D" 55 | make::*weyl-major-version* make::*weyl-minor-version* 56 | hour minute 57 | (second (assoc day-of-week 58 | '((0 "Monday") (1 "Tuesday") (2 "Wednesday") 59 | (3 "Thursday") (4 "Friday") (5 "Saturday") 60 | (6 "Sunday")))) 61 | (second (assoc month 62 | '((1 "January") (2 "February") (3 "March") 63 | (4 "April") (5 "May") (6 "June") (7 "July") 64 | (8 "August") (9 "September") (10 "October") 65 | (11 "November") (12 "December")))) 66 | date 67 | year))) 68 | 69 | #+MCL 70 | (defun dump-weyl (&optional (name "Weyl")) 71 | (load-system 'weyl) 72 | (let ((file (make-pathname 73 | :name (format nil "~A ~Db~D" 74 | name 75 | make::*weyl-major-version* 76 | make::*weyl-minor-version*) 77 | :directory (pathname-directory (user-homedir-pathname))))) 78 | (when (probe-file file) 79 | (delete-file file)) 80 | (format t ";;; Weyl ~D.~D successfully being dumped into ~A.~%" 81 | make::*weyl-major-version* make::*weyl-minor-version* 82 | file) 83 | (save-application file :init-file "init"))) 84 | 85 | 86 | -------------------------------------------------------------------------------- /multipole.lisp: -------------------------------------------------------------------------------- 1 | ; This has not been tested well enough. 2 | 3 | (in-package "WEYLI") 4 | 5 | ;; We define a class for representing multipoles here. 6 | ;; We make it a subclass of domain-element,so that we may associate 7 | ;; something in the domain inheritence hierarchy with it later. 8 | ;; Maybe powerseries-domain? 9 | 10 | ;;Also when we want to generalize the transformations 11 | ;;to other interactions , it may be necessarry to inherit mutipole 12 | ;;from xyz that inherits from domain-element 13 | 14 | ;; Center will be a pair of real numbers (a complex number)&& 15 | ;; range will be a real number && 16 | ;; form will be a list of real numbers. 17 | 18 | ;We will assume that each multipole is 10 terms long 19 | 20 | (defvar *number-of-terms* 10) 21 | 22 | ;; The domain of multipole expansions. Multipole expansions are best 23 | ;; thought of as functions from one domain into another, but which 24 | ;; have a very specific represnetation. They are a representation of 25 | ;; a Hilbert space. 26 | (defclass multipole-ring (function-space ring has-coefficient-domain) 27 | ()) 28 | 29 | (defmethod print-object ((domain multipole-ring) stream) 30 | (format stream "MultiPole(~S->~S)" 31 | (funct-domain-of domain) (funct-range-of domain))) 32 | 33 | ;; The form of a multipole expansion is just a list of coefficients. 34 | (defclass multipole-expansion (domain-element) 35 | ((center :initarg :center :reader center-of) 36 | (range :initarg :range :accessor range-of) 37 | (form :initarg :form :reader form-of))) 38 | 39 | (define-domain-creator multipole-ring ((domain domain) (range domain)) 40 | (let ((domain (make-instance 'multipole-ring :domain domain :range range))) 41 | (make-homomorphism coefficient-domain 42 | #'(lambda (c) (make-multipole-expansion domain 0 c)) 43 | domain) 44 | domain)) 45 | 46 | ;; This method creates a multipole for a given charge at a given 47 | ;; position. Is it better not to check for being in-bound? 48 | (defmethod make-multipole-expansion ((domain multipole-ring) 49 | (position number) &rest coefs) 50 | (when (not (in-bound? position)) 51 | (error "Point out of range: ~S" position)) 52 | (let* ((coef-domain (coefficient-domain-of domain)) 53 | (array (make-array *number-of-terms* 54 | :initial-element (zero coef-domain)))) 55 | (loop for i fixnum below *number-of-terms* 56 | for c in coefs 57 | do (setf (svref array i) (coerce c coef-domain))) 58 | (make-instance 'multipole-expansion :domain domain 59 | :center position 60 | :range (zero (range-domain-of domain)) 61 | :form array))) 62 | ;; Shifting multipoles 63 | 64 | (defmethod shift-multipole ((m multipole-expansion) (xy number)) 65 | (let ((domain (domain-of m)))) 66 | (make-instance 'multipole :domain 'power-series? 67 | :center xy 68 | :range (+ (range-of m) (abs xy)) 69 | :form (shift-m-form (form-of m) (center-of m) 70 | (coerce xy (coefficient-domain-of domain))))) 71 | 72 | 73 | 74 | ;; The work involved will be in 75 | ;; 1) computing the new range. 76 | ;; 2) extracting the old form and producing the new one 77 | 78 | 79 | ;;adding two mutipoles 80 | (defmethod-sd plus ((m multipole-expansion) (n multipole-expansion)) 81 | (when (not (eq (center-of m) (center-of n))) 82 | (error "Can't add multipole-expansions with different centers")) 83 | (make-instance 'multipole :domain 'power-series? 84 | :center (center-of m) 85 | :range (max (range-of m) (range-of n)) 86 | :form (mpef-pairwise-m-sum (form-of m) (form-of n)))) 87 | ;;The work involved will be in 88 | ;; 1)error check to ensure that the centers coincide 89 | ;; 2)computing the new form 90 | ;; 3)choosing the greater of the two ranges 91 | ;; 4)fixing the center 92 | 93 | 94 | 95 | 96 | ;;We now define a class called local-field. 97 | ;;This is a representation of the local field. 98 | ;;Again what would the domain be? We may want it to be 99 | ;;powerseries or something else (We might want mutipole expansions 100 | ;;and local expansions to be in different domains) 101 | 102 | (defclass local-field (domain-element) 103 | ((center :initarg :center :reader center-of) 104 | (range :initarg :range :reader range-of) 105 | (form :initarg :form :reader form-of))) 106 | 107 | ;shifting local fields 108 | (defmethod shift-local-field ((l local-field) (posn number)) 109 | (when (> (abs (- posn (center-of l))) 110 | (range-of l)) 111 | (error "Can't make this shift")) 112 | (make-instance 'local-field :domain 'power-series? 113 | :center posn 114 | :range (- (range-of l) (abs (- posn (center-of l)))) 115 | :form (shift-l-form (form-of l) (center-of l) posn))) 116 | 117 | ;the work involved will be in 118 | ;;1)making sure that the position is within the local field (error check) 119 | ;;2)computing the new center (easy) and the new range 120 | ;;3)computing the new form (hard) 121 | 122 | ;adding local fields 123 | (defmethod plus ((l1 local-field)(l2 local-field)) 124 | (cond ((neq (center-of l1) (center-of l2)) nil) 125 | (t (make-instance 'local-field :domain 'power-series? 126 | :center (center-of l1) 127 | :range (min (range-of l1) (range-of l2)) 128 | :form (mpef-pairwise-m-sum (form-of l1) (form-of l2)))))) 129 | 130 | ;;the work involved will be in 131 | ;;1)making sure that the centers coincide(error check) 132 | ;;2)computing the new center (easy) and the new range (easy) 133 | ;;3)computing the new form 134 | 135 | ;this is the key method that localizes a multipole 136 | 137 | (defmethod localize ((m multipole) (posn number)) 138 | (when (< (dist posn (center-of m)) (* (coerce 2 r) (range-of m))) 139 | (error "Some problem in localize")) 140 | (make-instance 'local-field :domain 'power-series? 141 | :center posn 142 | :range (range-of m) 143 | :form (localize-form (form-of m) (center-of m) posn))) 144 | 145 | ;;the work involved will be in 146 | ;;1)Checking that the posn is sufficiently away from the multipole 147 | ;;2)Computing the range 148 | ;;3)Computing the new form(very hard) 149 | 150 | ;; IN-BOUND? checks that the number lies within the vertical strip 151 | ;; bounded by Re = 0 and Re = 1 152 | (defmethod in-bound? ((position complex-number)) 153 | (and (< 0 (cn-realpart position) 1) 154 | (< 0 (cn-imagpart position) 1))) 155 | 156 | (defmethod in-bound? ((position floating-point-number)) 157 | (< 0 (fp-value position) 1)) 158 | 159 | (defmethod in-bound? ((position rational-integer)) 160 | (< 0 (integer-value position) 1)) 161 | 162 | 163 | ;The param order may be confusing.The kth term is ak.(a1,a2...) 164 | 165 | (defmethod the-kthterm (form k) 166 | (or (nth (- k 1) form) (zero *coefficient-domain*))) 167 | 168 | ;(a0,a1,a2...) 169 | (defmethod kthterm (form k) 170 | (let ((result (nth k form))) 171 | (if (eq result nil) (coerce 0 c) 172 | result))) 173 | 174 | ;shift from center z1 to z2 175 | 176 | (defun shift-m-form (form z1 z2) 177 | (shift-m-form* form (difference z1 z2))) 178 | 179 | 180 | (defun shift-m-form* (form z0) 181 | (do ((result nil) (l 1)) 182 | ((eq l *number-of-terms*) result) 183 | (setf result (append result (list (what-is-the-lthterm form z0 l)))) 184 | (setf l (+ l 1)))) 185 | 186 | (defun what-is-the-lthterm (form z0 l) 187 | (do ((result (coerce 0 r)) 188 | (k 1)) 189 | ((= k (+ l 1)) result) 190 | (setf result (+ result (* (the-kthterm form k) 191 | (expt z0 (- l k)) 192 | (combinations (- l 1) (- k 1))))) 193 | (setf k (+ k 1)))) 194 | 195 | (defun dist (cn1 cn2) 196 | (abs (- cn1 cn2))) 197 | 198 | ;; I use mpef- as the prefix before functions that work with multipole 199 | ;; expansion forms. 200 | 201 | 202 | (defun mpef-pairwise-m-sum (f1 f2) 203 | (cond ((null f1) f2) 204 | ((null f2) nil) 205 | (t (cons (+ (first f1) (first f2)) 206 | (mpef-pairwise-m-sum (rest f1) (rest f2)))))) 207 | 208 | ;shift from center z1 to center z2 209 | 210 | (defun shift-l-form (form z1 z2 ) 211 | (shift-l-form* form (- z1 z2))) 212 | 213 | (defun shift-l-form* (form z0) 214 | (let ((result nil)) 215 | (dotimes (l *number-of-terms* result) 216 | (setf result (append result (list (what-is-the-lthterm2 form z0 l))))))) 217 | 218 | (defun what-is-the-lthterm2 (form z0) 219 | (do ((result (coerce 0 c)) (k l)) 220 | ((= k *number-of-terms*) result) 221 | (setf result (+ result (* (the-kthterm form (+ k 1)) 222 | (expt (minus z0) (- k l)) 223 | (combinations k l)))) 224 | (setf k (+ k 1)))) 225 | 226 | (defun localize-form (form z1 z2 ) 227 | (localize-form* form (- z1 z2))) 228 | 229 | (defun localize-form* (form z0 ) 230 | (cons (do ((result (coerce 0 c)) (k 1)) 231 | ((= k *number-of-terms*) result) 232 | (setf result (+ result (* (the-kthterm form k) 233 | (expt (/ (- z0)) k)))) 234 | (setf k (+ k 1))) 235 | (rest-of-local form z0))) 236 | 237 | (defun rest-of-local (form z0 ) 238 | (do ((l 1)(result nil)) 239 | ((= l (- *number-of-terms* 1)) result) ;;;ha ha ha ha 240 | (setf result (append result (list (lth-local-term form z0 l)))) 241 | (setf l (+ l 1)))) 242 | 243 | (defun lth-local-term (form z0 l) 244 | (do ((result (coerce 0 c)) (k 1)) 245 | ((= k *number-of-terms*) result) 246 | (setf result (+ result (* (the-kthterm form k ) 247 | (expt (recip (- z0)) (+ k l)) 248 | (combinations (+ l (- k 1)) (- k 1))))) 249 | (setf k (+ k 1)))) 250 | 251 | 252 | 253 | 254 | 255 | 256 | 257 | 258 | 259 | 260 | 261 | 262 | 263 | 264 | -------------------------------------------------------------------------------- /new-domains.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Package:Weyli; Base:10; Lowercase:T; Syntax:Common-Lisp -*- 2 | ;;; =========================================================================== 3 | ;;; Algebraic Domains 4 | ;;; =========================================================================== 5 | ;;; (c) Copyright 1994 Cornell University 6 | ;;; new-domains.lisp,v 1.2 1995/05/24 17:42:06 rz Exp 7 | 8 | ;;; NB: initialization code moved to seperate file new-domains-init.lisp. 9 | ;;; This allows seperate compilation of files. 10 | 11 | (in-package "USER") 12 | 13 | (defconstant *math-operator-properties* 14 | '(identity unary-inverse binary-inverse)) 15 | 16 | ;;; Operators 17 | (defclass math-operator () 18 | ((name :initarg :name :accessor name-of) 19 | (nargs :initarg :nargs :accessor nargs-of) 20 | (identity :initarg :identity :accessor %identity-of) 21 | (unary-inverse :initarg :unary-inverse :accessor %unary-inverse-of) 22 | (binary-inverse :initarg :binary-inverse :accessor %binary-inverse-of))) 23 | 24 | (defmethod print-object ((op math-operator) stream) 25 | (format stream "#" (name-of op) (nargs-of op))) 26 | 27 | (defvar *math-operators* (make-hash-table) 28 | "Table of all know mathematical operators") 29 | 30 | (defmacro math-operator (name) 31 | `(gethash ,name *math-operators*)) 32 | 33 | (defmacro define-math-operator-accessors () 34 | (flet ((internal-name (op) 35 | (intern (format nil "%~A-OF" op))) 36 | (external-name (op) 37 | (intern (format nil "~A-OF" op)))) 38 | `(progn 39 | ,@(loop for op in *math-operator-properties* 40 | append 41 | `((defmacro ,(external-name op) (obj) 42 | `(name-of (,',(internal-name op) ,obj))) 43 | (defmethod ,(internal-name op) ((obj symbol)) 44 | (when (setq obj (math-operator obj)) 45 | (,(internal-name op) obj)))))))) 46 | 47 | (define-math-operator-accessors) 48 | 49 | 50 | (defmacro define-math-operator (name (nargs) &rest properties) 51 | `(let ((operator (make-instance 'math-operator :name ',name :nargs ,nargs)) 52 | temp1 temp2) 53 | 54 | ,@(loop for op in *math-operator-properties* 55 | collect 56 | `(when (setq temp1 ',(getf properties 57 | (intern (symbol-name op) "KEYWORD"))) 58 | (unless (setq temp2 (math-operator temp1)) 59 | (error "The ~S operator must be defined before it is used." 60 | temp1)) 61 | (setf (,(intern (format nil "%~A-OF" op)) operator) temp2))) 62 | 63 | (setf (math-operator ',name) operator) 64 | ',name)) 65 | 66 | 67 | ;; The PRETTY-NAME slot of a domain will be used by the print-object 68 | ;; method. The CREATOR and CREATOR-ARGS slots of a domain are used 69 | ;; when the domain is creator from other domains. There is no 70 | ;; overwhelming reason why these should have been split into two 71 | ;; slots, but I suspect that we may want to do some optimizations on 72 | ;; the CREATOR slot at some point in the future. 73 | 74 | ; For testing purposes, remove dependence on anything in WEYL. 75 | ;(defclass domain (weyli::has-property-list) 76 | 77 | (defclass domain () 78 | ((pretty-name :initform nil 79 | :initarg :pretty-name 80 | :accessor pretty-name-of) 81 | (creator :initform :primitive 82 | :initarg :creator 83 | :accessor creator-of) 84 | (creator-args :initform nil 85 | :initarg :creator-args 86 | :accessor creator-args-of))) 87 | 88 | (defmethod print-object ((obj domain) stream) 89 | (if (pretty-name-of obj) 90 | (princ (pretty-name-of obj) stream) 91 | (format stream "#" (creator-of obj)))) 92 | 93 | ;;; FIXME : This is an alternate definition from that in 94 | ;;; domain-support.lisp. 95 | (defmacro define-domain-creator (name (domain . args) &body body) 96 | (let ((create-function (intern (format nil "MAKE-~A" name))) 97 | (predicate (intern (format nil "~A?" name))) 98 | arguments) 99 | (loop for arg in args 100 | do (cond ((member arg '(&optional &key))) 101 | ((atom arg) (push arg arguments)) 102 | (t (push (first arg) arguments)))) 103 | (setq arguments (nreverse arguments)) 104 | 105 | `(progn 106 | (defun ,create-function ,args 107 | (let ((,domain 108 | (make-instance 'domain 109 | :creator ',name 110 | :creator-args (list ,@arguments)))) 111 | ,@body 112 | ,domain)) 113 | (defun ,predicate (domain) 114 | (eql (creator-of domain) ',name)) 115 | ',name))) 116 | 117 | 118 | (define-domain-creator rational-integers (domain) 119 | (setf (pretty-name-of domain) "Z")) 120 | 121 | 122 | 123 | 124 | 125 | ;; This is the basic table of all properties of domains. It is 126 | ;; indexed by property name. (It could be made into a simple array, 127 | ;; but a hash table gives us a bit more flexibility now.) 128 | (defvar *domain-property-table* (make-hash-table)) 129 | 130 | (defun compare-pterm-lists (term1 term2) 131 | (loop for a in term1 132 | for b in term2 133 | do (unless (eql a b) ;; FIXTHIS: This predicate may need to be improved! 134 | (return nil)) 135 | finally (return t))) 136 | 137 | (defun assert-property (property terms) 138 | (let ((table (gethash property *domain-property-table*))) 139 | (loop for prop in table 140 | do (when (compare-pterm-lists prop terms) 141 | (return t)) 142 | finally (setf (gethash property *domain-property-table*) 143 | (cons terms table))))) 144 | 145 | (defun test-property (property terms) 146 | (let ((table (gethash property *domain-property-table*))) 147 | (loop for prop in table 148 | do (when (compare-pterm-lists prop terms) 149 | (return prop))))) 150 | 151 | ;; This version of delete expects an exact match before deleteing a 152 | ;; property. This is probably OK, buts its worth thinking about. 153 | (defun delete-property (property terms) 154 | (setf (gethash property *domain-property-table*) 155 | (delete terms (gethash property *domain-property-table*)))) 156 | 157 | ;; The function will be passed two arguments, the name of the property 158 | ;; and the list terms of the property. 159 | (defmethod %map-over-properties ((domain domain) function) 160 | (maphash #'(lambda (key value) 161 | (loop for term in value 162 | do (when (eql (car term) domain) 163 | (funcall function key term) 164 | (return t)))) 165 | *domain-property-table*)) 166 | 167 | (defmacro map-over-properties (domain (property terms) &body body) 168 | `(%map-over-properties ,domain #'(lambda (,property ,terms) ,@body))) 169 | 170 | (defmethod show-properties 171 | ((domain domain) &optional (stream *standard-output*)) 172 | (map-over-properties domain (prop val) 173 | (print (list prop '= val) stream))) 174 | 175 | ;; NEEDS FIXING: 176 | ;; Bad idea to destructively modify a data structure while 177 | ;; mapping over it. 178 | (defmethod delete-domain ((domain domain)) 179 | (map-over-properties domain (property terms) 180 | (delete-property property terms))) 181 | 182 | (defvar *math-properties* nil) 183 | (defvar *primitive-properties* nil) 184 | 185 | (defmacro define-primitive-property (property-name args) 186 | (when (member property-name *math-properties*) 187 | (error "~A has already been used as a non-primitive property!" 188 | property-name)) 189 | (let ((assert-function-name (intern (format nil "~A!" property-name))) 190 | (predicate-function-name (intern (format nil "~A?" property-name))) 191 | req-args opt-args) 192 | (labels ((make-predicate (args body) 193 | (if (null args) body 194 | `(if (null ,(first args)) ,body 195 | ,(make-predicate (rest args) 196 | (append body (list (first args)))))))) 197 | (loop for prop in args 198 | with req = t 199 | do (cond ((eql prop '&optional) 200 | (setq req nil)) 201 | ((null req) 202 | (if (atom prop) 203 | (push (list prop :true) opt-args) 204 | (push prop opt-args))) 205 | (t (push prop req-args)))) 206 | (setq req-args (reverse req-args)) 207 | (setq opt-args (reverse opt-args)) 208 | 209 | `(progn 210 | (defun ,assert-function-name (,@req-args 211 | ,@(when opt-args 212 | '(&optional)) 213 | ,@opt-args) 214 | (assert-property ',property-name 215 | (list ,@req-args 216 | ,@(loop for arg in opt-args 217 | collect (first arg))))) 218 | (defun ,predicate-function-name (,@req-args 219 | ,@(when opt-args 220 | '(&optional)) 221 | ,@(loop for arg in opt-args 222 | collect (first arg))) 223 | (test-property ',property-name 224 | ,(make-predicate (mapcar #'first opt-args) 225 | `(list . ,req-args)))) 226 | (pushnew ',property-name *primitive-properties*) 227 | 228 | ',property-name)))) 229 | 230 | (defun assert-function-name (name) 231 | (unless (or (member name *primitive-properties*) 232 | (member name *math-properties*)) 233 | (error "The property ~S is not yet defined" 234 | name)) 235 | (intern (format nil "~A!" name))) 236 | 237 | (defun predicate-function-name (name) 238 | (unless (or (member name *primitive-properties*) 239 | (member name *math-properties*)) 240 | (error "The property ~S is not yet defined" 241 | name)) 242 | (intern (format nil "~A?" name))) 243 | 244 | ;; The predicate is a form that must evaluate to true to assert this 245 | ;; property. 246 | (defmacro define-math-property (property-name args &body body) 247 | (when (member property-name *primitive-properties*) 248 | (error "~A has already been used as a primitive property!" 249 | property-name)) 250 | (when (null body) 251 | (error "~S should probably be a primitive property" property-name)) 252 | (let ((assert-name (intern (format nil "~A!" property-name))) 253 | (predicate-name (intern (format nil "~A?" property-name))) 254 | opt-args req-args) 255 | (loop for prop in args 256 | with req = t 257 | do (cond ((eql prop '&optional) 258 | (setq req nil)) 259 | ((null req) 260 | (if (atom prop) 261 | (push (list prop :true) opt-args) 262 | (push prop opt-args))) 263 | (t (push prop req-args)))) 264 | (setq req-args (reverse req-args)) 265 | (setq opt-args (reverse opt-args)) 266 | 267 | `(progn 268 | (defun ,assert-name (,@req-args 269 | ,@(when opt-args 270 | '(&optional)) 271 | ,@opt-args) 272 | ,@(loop for property in body 273 | collect `(,(assert-function-name (first property)) 274 | ,@(rest property)))) 275 | 276 | (defun ,predicate-name (,@req-args 277 | ,@(when opt-args 278 | '(&optional)) 279 | ,@(loop for arg in opt-args 280 | collect (first arg))) 281 | (and 282 | ,@(loop for property in body 283 | collect `(,(predicate-function-name (first property)) 284 | ,@(rest property))))) 285 | 286 | (pushnew ',property-name *math-properties*) 287 | ',property-name))) 288 | -------------------------------------------------------------------------------- /packages.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Package:CL-USER; Base:10; Lowercase:T; Syntax:Common-Lisp -*- 2 | ;;; =========================================================================== 3 | ;;; Package Definitions 4 | ;;; =========================================================================== 5 | ;;; (c) Copyright 1989, 1993 Cornell University 6 | 7 | ;;; packages.lisp,v 1.19 1995/04/05 21:39:44 chew Exp 8 | 9 | (in-package :common-lisp-user) 10 | 11 | (defvar *weyli-exported-symbols* 12 | '("*" "+" "-" "/" "=" ">" "<" ">=" "<=" "0?" "1?" 13 | 14 | "%MAX" 15 | "%MIN" 16 | "%PLUS" 17 | "%DIFFERENCE" 18 | "%TIMES" 19 | "%QUOTIENT" 20 | 21 | "*COERCE-WHERE-POSSIBLE*" 22 | "*DEFAULT-RANDOM-HEIGHT*" 23 | "*DOMAINS*" 24 | "*GENERAL*" 25 | "*MORPHISMS*" 26 | "*NEGATIVE-INFINITY*" 27 | "*POSITIVE-INFINITY*" 28 | "*PRINT-MODULUS*" 29 | 30 | "ABELIAN-GROUP" 31 | "ABELIAN-MONOID" 32 | "ABELIAN-SEMIGROUP" 33 | "ABSTRACT-POINT" 34 | "ABSTRACT-SPACE" 35 | "ADD-NEW-VARIABLE" 36 | "ADD-RELATION" 37 | "ADD-SUBSCRIPTS" 38 | "ADJACENCIES" 39 | "ALGEBRA" 40 | "ALGEBRAIC-EXTENSION" 41 | "ALL-NAMES" 42 | "ANGLES" 43 | "ARGS-OF" 44 | "ARGUMENT-OF" 45 | "BANACH-SPACE" 46 | "BASE-OF" 47 | "BIGFLOAT" 48 | "BOUNDARY" 49 | "BOUNDARY-COMPLEX-OF" 50 | "BOUNDARY-DOMAIN" 51 | "BOUND-VARS-OF" 52 | "CHARACTERISTIC" 53 | "CHOOSE" 54 | "COEFFICIENT" 55 | "COEFFICIENT-DOMAIN-OF" 56 | "COERCE" 57 | "COERCIBLE?" 58 | "COMBINATIONS" 59 | "COMPLEX-NUMBER" 60 | "COMPLEX-NUMBERS" 61 | "COMPOSE" 62 | "CONVERT-TO-LISP-NUMBER" 63 | "CREATE-MESH" 64 | "CROSS-PRODUCT" 65 | "DECLARE-DEPENDENCIES" 66 | "DEFINE-OPERATIONS" 67 | "DEGREE" 68 | "DELETE" 69 | "DEPENDS-ON?" 70 | "DERIV" 71 | "DERIVS-OF" 72 | "DESCRIBE-OPERATIONS" 73 | "DIFFERENT-KERNELS" 74 | "DIFFERENTIAL-RING" 75 | "DIMENSION-OF" 76 | "DIMENSIONAL-SPACE" 77 | "DIMENSIONS" 78 | "DIRECT-SUM" 79 | "DISPLAY" 80 | "DOMAIN-OF" 81 | "DOT-PRODUCT" 82 | "DRAW" 83 | "EQN=" 84 | "EQN>" 85 | "EQN>=" 86 | "EVEN?" 87 | "EUCLIDEAN-DOMAIN" 88 | "EVALUATE-AT" 89 | "EXPONENT-OF" 90 | "EXPR-OF" 91 | "EXPRS-OF" 92 | "EXPAND" 93 | "EXPT" 94 | "FACTOR" 95 | "FACTORIAL" 96 | "FIELD" 97 | "FINITE-FIELD" 98 | "FINITE-SET" 99 | "FOURIER" 100 | "FUNCT" 101 | "FUNCT-DOMAIN-OF" 102 | "FUNCT-OF" 103 | "FUNCT-RANGE-OF" 104 | "FUNCTION-SPACE" 105 | "GCD" 106 | "GCD-DOMAIN" 107 | "GE-ABS?" 108 | "GE-APPLICATION?" 109 | "GE-COS?" 110 | "GE-DERIV?" 111 | "GE-EQN=?" 112 | "GE-EQN>?" 113 | "GE-EQN>=?" 114 | "GE-EQUAL" 115 | "GE-EXPT?" 116 | "GE-FOURIER?" 117 | "GE-FUNCTION?" 118 | "GE-FUNCTION-DERIV?" 119 | "GE-IFOURIER?" 120 | "GE-LOG?" 121 | "GE-NARY?" 122 | "GE-PLUS?" 123 | "GE-SIN?" 124 | "GE-TAN?" 125 | "GE-TIMES?" 126 | "GE-VARIABLE?" 127 | "GENERATORS-OF" 128 | "GET-ABSTRACT-SPACE" 129 | "GET-ALGEBRAIC-EXTENSION" 130 | "GET-AUTOMORPHISMS" 131 | "GET-CHAIN-MODULE" 132 | "GET-COMPLEX-NUMBERS" 133 | "GET-DIFFERENTIAL-RING" 134 | "GET-DIRECT-SUM" 135 | "GET-EUCLIDEAN-SPACE" 136 | "GET-FACTOR-GROUP" 137 | "GET-FACTOR-MODULE" 138 | "GET-FACTOR-RING" 139 | "GET-FINITE-FIELD" 140 | "GET-FREE-MODULE" 141 | "GET-FUNCTION" 142 | "GET-GL-N" 143 | "GET-HILBERT-SPACE" 144 | "GET-HOMOMORPHISMS" 145 | "GET-LISP-NUMBERS" 146 | "GET-MATRIX-SPACE" 147 | "GET-MORPHISMS" 148 | "GET-O-N" 149 | "GET-POLYNOMIAL-RING" 150 | "GET-PSL-N" 151 | "GET-QUATERNION-DOMAIN" 152 | "GET-QUOTIENT-FIELD" 153 | "GET-RATIONAL-INTEGERS" 154 | "GET-RATIONAL-NUMBERS" 155 | "GET-REAL-NUMBERS" 156 | "GET-SL-N" 157 | "GET-SO-N" 158 | "GET-TPOWER-SERIES-DOMAIN" 159 | "GET-UNIT-QUATERNION-DOMAIN" 160 | "GET-VARIABLE-PROPERTY" 161 | "GET-VARIABLE-NAME" 162 | "GET-VECTOR-SPACE" 163 | "GREATER-FUNCTION" 164 | "GFM" 165 | "GFP" 166 | "GROUP" 167 | "HEIGHT" 168 | "HILBERT-SPACE" 169 | "HOME-OF" 170 | "HOMOMORPHISM" 171 | "IFOURIER" 172 | "INNER-PRODUCT" 173 | "INSERT" 174 | "INSERT-BOUNDARY" 175 | "INTEGRAL" 176 | "INTEGRAL-DOMAIN" 177 | "INTERPOLATE" 178 | "JACOBIAN" 179 | "LEXICAL-<" 180 | "LEXICAL->" 181 | "LHS-OF" 182 | "LIST-OF-ELEMENTS" 183 | "LIST-OF-VARIABLES" 184 | "LIST-OPERATIONS" 185 | "LOCATE" 186 | "MAKE-APP-FUNCTION" 187 | "MAKE-CURVED-SEGMENT" 188 | "MAKE-GE-FUNCTION" 189 | "MAKE-GE-DERIV" 190 | "MAKE-GE-EXPT" 191 | "MAKE-GE-FUNCTION" 192 | "MAKE-GE-PLUS" 193 | "MAKE-GE-TIMES" 194 | "MAKE-GENERATOR" 195 | "MAKE-IDEAL" 196 | "MAKE-MESH" 197 | "MAKE-MESH-FROM-FILE" 198 | "MAKE-POINT" 199 | "MAKE-SAMPLED-FUNCTION" 200 | "MAKE-SIMPLEX" 201 | "MAKE-UNION" 202 | "MAKE-UNIVERSAL-QUANTIFIED-SET" 203 | "MAKE-GE-VARIABLE" 204 | "MAP" 205 | "MAP-OVER-CELLS" 206 | "MAP-OVER-MAXIMAL-CELLS" 207 | "MAP-OVER-ELEMENTS" 208 | "MAP-OVER-EXPRESSIONS" 209 | "MAP-OVER-FACES" 210 | "MAP-WITH-DOMAIN" 211 | "MATRIX-DIMENSIONS" 212 | "MAX" 213 | "MEMBER" 214 | "MEMOIZE" 215 | "MESH" 216 | "MIN" 217 | "MINIMAL-POLYNOMIAL" 218 | "MINUS?" 219 | "MONOID" 220 | "MORPHISM" 221 | "MULTIPLICATIVE-ORDER" 222 | "MUTABLE-SET" 223 | "NAME" 224 | "NAME-OF" 225 | "NAME-REGION" 226 | "NARGS-OF" 227 | "NORM" 228 | "NUMBER-OF-ELEMENTS" 229 | "NUMBER?" 230 | "ODD?" 231 | "ONE" 232 | "ONE-MATRIX" 233 | "OPERATION-ARGUMENTS" 234 | "OPERATION-VALUES" 235 | "OPPOSITE" 236 | "ORDERED-ABELIAN-GROUP" 237 | "ORDERED-RING" 238 | "ORDERED-SET" 239 | "ORDERED-SET-OF-PAIRS" 240 | "ORDERED-SIMPLE-SET" 241 | "PARTIAL-DERIV" 242 | "PARTITION" 243 | "PERMUTE" 244 | "PLUS?" 245 | "POCHHAMMER" 246 | "POINT" 247 | "POLYNOMIAL" 248 | "POWER-OF?" 249 | "PRIME?" 250 | "PROJECTIVE-SPACE" 251 | "QUOTIENT-FIELD" 252 | "QUOTIENT-RING" 253 | "RATIONAL-INTEGER" 254 | "RATIONAL-INTEGERS" 255 | "RATIONAL-NUMBER" 256 | "RATIONAL-NUMBERS" 257 | "READ-MESH" 258 | "REAL-NUMBER" 259 | "REAL-NUMBERS" 260 | "RECIP" 261 | "REDUCE-BASIS" 262 | "REF" 263 | "REFINE-MESH" 264 | "RELATIONS" 265 | "REMAINDER" 266 | "REPLACE" 267 | "REQUIRED-OPERATIONS" 268 | "RESET-DOMAINS" 269 | "RESULTANT" 270 | "REVERSION" 271 | "REVLEX->" 272 | "RHS-OF" 273 | "RING" 274 | "RING-VARIABLES" 275 | "RNG" 276 | "SCALAR?" 277 | "SEGMENT?" 278 | "SEMIGROUP" 279 | "SET" 280 | "SET-ELEMENTS" 281 | "SET-OF-PAIRS" 282 | "SIMPLE-FIELD-EXTENSION" 283 | "SIMPLE-RING" 284 | "SIMPLE-SET" 285 | "SIMPLEX" 286 | "SIMPLEX-SIZE" 287 | "SIMPLICIAL-COMPLEX" 288 | "SIMPLIFY" 289 | "SKEW-FIELD" 290 | "SPLIT" 291 | "SQUARE-FREE" 292 | "STRING-OF" 293 | "SUBFACE?" 294 | "SUBSTITUTE" 295 | "TAYLOR" 296 | "TERMS-OF" 297 | "TETRAHEDRON?" 298 | "TILDE" 299 | "TOTAL->" 300 | "TOTIENT" 301 | "TRANSPOSE" 302 | "TRIANGLE?" 303 | "TRUNCATE-ORDER" 304 | "TUPLE" 305 | "UNIQUE-FACTORIZATION-DOMAIN" 306 | "UNIVERSAL-QUANTIFIED-SET" 307 | "VAR-OF" 308 | "VAR-DOMAIN-OF" 309 | "VARIABLE-DERIVATION" 310 | "VARIABLE-INDEX" 311 | "VARLIST-OF" 312 | "VECTOR-SPACE" 313 | "VERTICES-OF" 314 | "WITH-MATRIX-DIMENSIONS" 315 | "WITH-NUMERATOR-AND-DENOMINATOR" 316 | "WRITE-MESH" 317 | "ZERO" 318 | "ZERO-MATRIX") 319 | "Symbols exported from the internal WEYL package.") 320 | 321 | (defvar *weyli-shadowed-symbols* 322 | '(coerce set + - * / = > < >= <= minus expt abs random 323 | gcd lcm floor ceiling truncate round max min 324 | complex conjugate realpart imagpart 325 | sqrt exp log phase signum minusp zerop plusp 326 | sin cos tan asin acos atan sinh cosh tanh asinh acosh atanh 327 | numerator denominator reduce 328 | map delete member replace substitute getf union intersection 329 | apply funcall variable 330 | type-of) 331 | "Common lisp symbols shadowed in the internal WEYL package.") 332 | 333 | (defvar *weyl-exported-symbols* 334 | '("MAKE-ELEMENT" 335 | "MAKE-UPOLYNOMIAL") 336 | "The WEYL package export these symbols in addition to those exported 337 | form WEYLI.") 338 | 339 | ;; This should probably only be used to create the WEYL package 340 | (defun use-weyli-package (package) 341 | "Shadow import the shadowed symbols in the WEYLI package and then 342 | use it." 343 | (declare (special *weyli-shadowed-symbols*)) 344 | (shadowing-import (loop for sym in *weyli-shadowed-symbols* 345 | collect (intern (symbol-name sym) 'weyli)) 346 | package) 347 | (use-package (find-package 'weyli) package)) 348 | 349 | (defun use-weyl-package (package) 350 | "Shadow import the shadowed symbols in the WEYL package and then use 351 | it." 352 | (declare (special *weyli-shadowed-symbols*)) 353 | (shadowing-import (loop for sym in *weyli-shadowed-symbols* 354 | collect (intern (symbol-name sym) 'weyl)) 355 | package) 356 | (use-package (find-package 'weyl) package)) 357 | 358 | (defun intern-in-package (package-name symbols) 359 | (loop for sym in symbols 360 | with package = (find-package package-name) 361 | collect (intern sym package))) 362 | 363 | (defpackage "WEYLI" 364 | (:use :common-lisp)) 365 | 366 | (shadow *weyli-shadowed-symbols* 'weyli) 367 | (export (intern-in-package "WEYLI" *weyli-exported-symbols*) 'weyli) 368 | 369 | (defpackage "WEYL" 370 | (:use :common-lisp)) 371 | 372 | (use-weyli-package 'weyl) 373 | 374 | (export (intern-in-package "WEYL" *weyli-exported-symbols*) 'weyl) 375 | (export (intern-in-package "WEYL" *weyl-exported-symbols*) 'weyl) 376 | 377 | ;; Create the basic-graphics package. This is package is needed if 378 | ;; the system Mesh-Draw is loaded. 379 | #-(and) 380 | (unless (find-package "BASIC-GRAPHICS") 381 | #-Genera 382 | (make-package "BASIC-GRAPHICS" :nicknames '(BG) 383 | :use '(#-MCL LISP #+MCL CL #+PCL PCL 384 | #+(and CLOS (not MCL)) CLOS)) 385 | #+Genera 386 | (make-package "BASIC-GRAPHICS" :nicknames '(BG) 387 | :use '(#-Rel8 LISP #+Rel8 FUTURE-COMMON-LISP 388 | #+PCL PCL #+CLOS CLOS) 389 | :colon-mode :external)) 390 | -------------------------------------------------------------------------------- /polynomials/grobner.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Package:Weyli; Base:10; Lowercase:T; Syntax:Common-Lisp -*- 2 | ;;; =========================================================================== 3 | ;;; Expanded Polynomials 4 | ;;; =========================================================================== 5 | ;;; (c) Copyright 1989, 1993 Cornell University 6 | 7 | ;;; grobner.lisp,v 1.8 1995/05/24 17:42:02 rz Exp 8 | 9 | (in-package :weyli) 10 | 11 | ;;; DELETE (make::adjust-version-numbers Weyl "1.8") 12 | 13 | (defmethod initialize-instance :after ((id ideal) &rest ignore) 14 | (declare (ignore ignore)) 15 | (let ((ring (ring-of id))) 16 | (with-slots (coefficient-domain print-function) id 17 | (unless coefficient-domain 18 | (setf coefficient-domain (ring-of id))) 19 | 20 | (setf print-function 'ideal-print-object)) 21 | (unless (super-domains-of id) 22 | (setf (super-domains-of id) (cons ring (super-domains-of ring)))))) 23 | 24 | (defun ideal-print-object (id stream) 25 | (let ((gens (generators-of id))) 26 | (format stream "#Id(~S~{, ~S~})" (first gens) (rest gens)))) 27 | 28 | (defgeneric make-ideal (ring &rest generators) 29 | (:documentation 30 | "The purpose of this function is unknown.")) 31 | 32 | (defmethod make-ideal ((ring ring) &rest generators) 33 | (make-instance 'ideal 34 | :ring ring 35 | :generators (loop for g in generators 36 | collect (coerce g ring)))) 37 | 38 | (defmethod make-ideal ((ring field) &rest generators) 39 | (declare (ignore generators)) 40 | (make-instance 'ideal :ring ring :generators (list (one ring)))) 41 | 42 | ;;FIXTHIS: The following assumes that PID are GCD domains, which isn't true. 43 | (defmethod make-ideal ((ring rational-integers) &rest generators) 44 | (make-instance 'PID-ideal :ring ring 45 | :generators (list 46 | (loop with g = (coerce (first generators) ring) 47 | for e in (rest generators) 48 | do (setq g (gcd g (coerce e ring))) 49 | finally (return g))))) 50 | 51 | (defmethod reduce-basis ((id PID-ideal)) 52 | id) 53 | 54 | (defmethod plus ((id1 ideal) (id2 ideal)) 55 | (cond ((and (eql (ring-of id1) (ring-of id2)) 56 | (eql (coefficient-domain-of id1) (coefficient-domain-of id2))) 57 | (apply #'make-ideal (ring-of id1) 58 | (append (generators-of id1) (generators-of id2)))) 59 | (t (call-next-method)))) 60 | 61 | (defmethod times ((id1 ideal) (id2 ideal)) 62 | (cond ((and (eql (ring-of id1) (ring-of id2)) 63 | (eql (coefficient-domain-of id1) (coefficient-domain-of id2))) 64 | (apply #'make-ideal (ring-of id1) 65 | (loop for e1 in (generators-of id1) 66 | append (loop for e2 in (generators-of id2) 67 | collect (* e1 e2))))) 68 | (t (call-next-method)))) 69 | 70 | (defmethod binary= ((id1 ideal) (id2 ideal)) 71 | (or (eql id1 id2) 72 | (loop with id2-gen = (generators-of id2) 73 | for p in (generators-of id1) 74 | do (unless (member p id2-gen :test #'binary=) 75 | (return nil)) 76 | finally (return t)))) 77 | 78 | 79 | (defmacro with-grobner-operations (grobner-basis &body body) 80 | `(with-slots (greater-function ring generators undones reducibles possibles) 81 | ,grobner-basis 82 | (let ((dim (cl:1+ (length (ring-variables ring))))) 83 | (macrolet ((e> (a b) `(%funcall greater-function ,a ,b)) 84 | (e< (a b) `(%funcall greater-function ,b ,a))) 85 | ,@body)))) 86 | 87 | ;; Grobner calculations are done within the context of an instance of 88 | ;; the Grobner-Basis flavor. Each instance has its own variable list 89 | ;; and flags sets. At any time the user can add polynomials or 90 | ;; extract information from the structure. 91 | 92 | #| ;; The following is actually in algebraic-domains.lisp | 93 | (defclass grobner-basis (ideal has-comparison) 94 | (;; The exponent comparison function is managed by HAS-COMPARISON 95 | 96 | (undones :initform ()) 97 | ;; A list of triples pairs (lt f g), lt(f)<=lt(g), of elements of 98 | ;; GENERATORS such that if any pair is not in the list, its s-poly 99 | ;; is guaranteed to be writable as a linear combination of 100 | ;; GENERATORS, with smaller s-degs 101 | 102 | (reducibles :initform nil :accessor reducibles-of) 103 | (possibles :initform nil) 104 | )) 105 | ||# 106 | 107 | (defmethod initialize-instance :after ((gb grobner-basis) &rest ignore) 108 | (declare (ignore ignore)) 109 | (with-slots (greater-function ring) gb 110 | (setq greater-function 111 | (get-comparison-fun (length (ring-variables ring)) 112 | greater-function)))) 113 | 114 | (defun check-same-domain (exprs) 115 | (let ((domain (domain-of (first exprs)))) 116 | (loop for exp in (rest exprs) 117 | do (unless (eql domain (domain-of exp)) 118 | (return nil)) 119 | finally (return domain)))) 120 | 121 | 122 | (defmethod make-ideal ((ring polynomial-ring) &rest polys) 123 | (let (ideal) 124 | (cond ((field? (coefficient-domain-of ring)) 125 | (setq ideal (make-instance 'grobner-basis :ring ring 126 | :greater-function :lexical))) 127 | (t (error "Can't deal with polynomials not over fields: ~S" 128 | ring))) 129 | (loop for p in polys 130 | do (add-relation ideal (coerce p ring))) 131 | ideal)) 132 | 133 | (defmethod (setf greater-function) (new-function (grob grobner-basis)) 134 | (with-slots (ring greater-function generators reducibles possibles) grob 135 | (unless (eql greater-function new-function) 136 | (flet ((convert-list (list) 137 | (loop for poly in list 138 | collect (sort poly new-function)))) 139 | (unless (functionp new-function) 140 | (setq new-function 141 | (get-comparison-fun (length (ring-variables ring)) 142 | new-function))) 143 | (setq generators (convert-list generators)) 144 | (setq reducibles (convert-list reducibles)) 145 | (setq possibles (convert-list possibles)) 146 | (setq greater-function new-function))) 147 | grob)) 148 | 149 | (defgeneric add-relation (basis poly) 150 | (:documentation 151 | "The purpose of this function is unknown.")) 152 | 153 | (defmethod add-relation ((grob-struct grobner-basis) (relation mpolynomial)) 154 | (let ((ring (ring-of grob-struct))) 155 | (if (not (eql ring (domain-of relation))) 156 | (add-relation grob-struct (coerce relation ring))) 157 | (let ((poly (make-epolynomial ring (greater-function-of grob-struct) 158 | relation))) 159 | (push (poly-form poly) (reducibles-of grob-struct)) 160 | poly))) 161 | 162 | (defmethod add-relation ((grob-struct grobner-basis) (relation epolynomial)) 163 | (let ((ring (ring-of grob-struct))) 164 | (if (not (eql ring (domain-of relation))) 165 | (add-relation grob-struct (coerce relation ring))) 166 | (let ((poly (make-epolynomial ring (greater-function-of grob-struct) 167 | relation))) 168 | (push (poly-form poly) (reducibles-of grob-struct)) 169 | poly))) 170 | 171 | (defmethod generators-of ((grob-struct grobner-basis)) 172 | (with-slots (generators reducibles greater-function ring) grob-struct 173 | (append 174 | (loop for g in generators 175 | collect (make-instance 'epolynomial 176 | :domain ring 177 | :greater-function greater-function 178 | :form g)) 179 | (loop for g in reducibles 180 | collect (make-instance 'epolynomial 181 | :domain ring 182 | :greater-function greater-function 183 | :form g))))) 184 | 185 | (defmethod reset-grobner-basis ((grob-struct grobner-basis)) 186 | (with-slots (generators undones possibles reducibles) grob-struct 187 | (setq generators nil undones nil 188 | possibles nil reducibles nil))) 189 | 190 | #+Ignore 191 | (defun terms-s-poly (greater-function terms1 terms2) 192 | (let ((m (max (le terms1) (le terms2)))) 193 | (gterms-difference greater-function 194 | (gterms-mon-times terms1 (- m (le terms1)) (lc terms2)) 195 | (gterms-mon-times terms2 (- m (le terms2)) (lc terms1))))) 196 | 197 | ;; The following saves a bunch of consing, but not as much as I would expect 198 | (defun terms-s-poly (greater-function terms1 terms2) 199 | #+Lucid 200 | (declare (optimize (safety 0))) 201 | (let* ((dim (length (first terms1))) 202 | (m (gterm-lcm (lt terms1) (lt terms2) dim)) 203 | (ans-terms (list nil)) 204 | (terms ans-terms) 205 | (x (red terms1)) 206 | (y (red terms2)) 207 | (xe (gterm-quot m (lt terms1) dim)) 208 | (xc (svref (lt terms2) 0)) 209 | (ye (gterm-quot m (lt terms2) dim)) 210 | (yc (- (svref (lt terms1) 0))) 211 | temp sum new-xe new-ye) 212 | (loop 213 | (cond ((terms0? x) 214 | (cond ((terms0? y) (return (rest ans-terms))) 215 | (t (setq temp (gterm-times ye (lt y) dim)) 216 | (setf (svref temp 0) (* yc (svref (lt y) 0))) 217 | (setf (rest terms) (list temp)) 218 | (setf terms (rest terms)) 219 | (setq y (red y))))) 220 | ((or (terms0? y) 221 | (%funcall greater-function 222 | (setq new-xe (gterm-times xe (lt x) dim)) 223 | (setq new-ye (gterm-times ye (lt y) dim)))) 224 | (setq temp (gterm-times xe (lt x) dim)) 225 | (setf (svref temp 0) (* xc (svref (lt x) 0))) 226 | (setf (rest terms) (list temp)) 227 | (setf terms (rest terms)) 228 | (setq x (red x))) 229 | ((%funcall greater-function new-ye new-xe) 230 | (setf (svref new-ye 0) (* yc (svref (lt y) 0))) 231 | (setf (rest terms) (list new-ye)) 232 | (setf terms (rest terms)) 233 | (setq y (red y))) 234 | (t (setq sum (+ (* xc (svref (lt x) 0)) 235 | (* yc (svref (lt y) 0)))) 236 | (unless (0? sum) 237 | (setf (svref new-xe 0) sum) 238 | (setf (rest terms) (list new-xe)) 239 | (setf terms (rest terms))) 240 | (setq x (red x) y (red y))))))) 241 | 242 | (defmethod reduce-basis ((grob-struct grobner-basis)) 243 | (with-grobner-operations grob-struct 244 | (flet ((criterion1 (degree f1 f2) 245 | (loop for p in generators do 246 | (when (and (not (eql p f1)) 247 | (not (eql p f2)) 248 | (gterm-dominates degree (lt p) dim)) 249 | (unless (member nil undones 250 | :test 251 | #'(lambda (x prod) 252 | (declare (ignore x)) 253 | (let ((b1 (second prod)) 254 | (b2 (third prod))) 255 | (or (and (eql f1 b1) (eql p b2)) 256 | (and (eql f1 b2) (eql p b1)) 257 | (and (eql p b1) (eql f2 b2)) 258 | (and (eql p b2) (eql f2 b1)))))) 259 | (return-from criterion1 t)))))) 260 | (let (temp f1 f2 h) 261 | (reduce-all grob-struct) 262 | (new-basis grob-struct) 263 | (loop while undones do 264 | (setq temp (pop undones)) 265 | (setq f1 (second temp) f2 (third temp)) 266 | (when (and (null (criterion1 (first temp) f1 f2)) 267 | (not (gterm-disjoint (lt f1) (lt f2) dim))) 268 | (setq h (terms-reduce greater-function 269 | (gterms-prim* 270 | (terms-s-poly greater-function f1 f2)) 271 | generators)) 272 | (when (not (terms0? h)) 273 | (setq reducibles nil) 274 | (setq possibles (list h)) 275 | (setq generators 276 | (loop for g in generators 277 | when (gterm-dominates (lt g) (lt h) dim) 278 | do (push g reducibles) 279 | else collect g)) 280 | (setq undones 281 | (loop for undone in undones 282 | unless (or (member (second undone) reducibles) 283 | (member (third undone) reducibles)) 284 | collect undone)) 285 | (reduce-all grob-struct) 286 | (new-basis grob-struct))))))) 287 | grob-struct) 288 | 289 | (defgeneric reduce-all (basis) 290 | (:documentation 291 | "The purpose of this function is unknown.")) 292 | 293 | ;; This makes sure that all of the polynomials in generators and 294 | ;; possibles are AUTOREDUCED. 295 | (defmethod reduce-all ((grob-struct grobner-basis)) 296 | (with-grobner-operations grob-struct 297 | (let (h g0) 298 | (loop while (not (null reducibles)) do 299 | (setq h (terms-reduce greater-function 300 | (pop reducibles) 301 | (append generators possibles))) 302 | (unless (terms0? h) 303 | (setq generators (loop for elt in generators 304 | when (gterm-dominates (lt elt) (lt h) dim) 305 | do (push elt reducibles) 306 | (push elt g0) 307 | else collect elt)) 308 | (setq possibles (loop for elt in possibles 309 | when (gterm-dominates (lt elt) (lt h) dim) 310 | do (push elt reducibles) 311 | else collect elt)) 312 | (setq undones (loop for (nil f1 f2) in undones 313 | when (and (not (member f1 g0)) 314 | (not (member f2 g0))) 315 | collect (list (gterm-lcm (lt f1) (lt f2) dim) 316 | f1 f2))) 317 | (push h possibles)))))) 318 | 319 | (defgeneric new-basis (basis) 320 | (:documentation 321 | "The purpose of this function is unknown.")) 322 | 323 | (defmethod new-basis ((grob-struct grobner-basis)) 324 | (with-grobner-operations grob-struct 325 | (flet ((add-undone (f g) 326 | (when (e> (lt f) (lt g)) 327 | (rotatef f g)) 328 | (loop for (nil ff gg) in undones 329 | do (when (and (eql ff f) (eq gg g)) 330 | (return t)) 331 | finally (push (list (gterm-lcm (lt f) (lt g) dim) f g) 332 | undones)))) 333 | (setq generators (append generators possibles)) 334 | (loop for g in generators do 335 | (loop for elt in possibles do 336 | (when (not (eql elt g)) 337 | (add-undone elt g)))) 338 | (setq possibles nil) 339 | (setq undones (sort undones #'(lambda (a b) (e< (first a) (first b))))) 340 | #+ignore 341 | (setq generators 342 | (loop for g in generators 343 | for h = (terms-reduce greater-function g (remove g generators)) 344 | when (not (terms0? h)) 345 | collect h))))) 346 | 347 | ;; Reduce terms modulo the current basis 348 | (defun terms-reduce (greater-function terms basis) 349 | (let ((dim (length (first terms)))) 350 | #+ignore 351 | (format t "~&~%Poly = ~S~%Basis: " 352 | (le terms)) 353 | #+ignore 354 | (princ (mapcar #'(lambda (f) (le f)) basis)) 355 | (let ((again t)) 356 | (loop while again do 357 | (when (terms0? terms) 358 | (return nil)) 359 | #+ignore 360 | (format t "~&Terms = ~S" 361 | (make-instance 'epolynomial 362 | :domain (slot-value grob-struct 'ring) 363 | :greater-function greater-function 364 | :form terms)) 365 | (loop for g in basis 366 | do (when (gterm-dominates (lt terms) (lt g) dim) 367 | (setq terms (gterms-prim* 368 | (terms-s-poly greater-function terms g))) 369 | (return t)) 370 | finally (setq again nil)))) 371 | #+ignore 372 | (format t "~&Result = ~S~%" (le terms)) 373 | terms)) 374 | 375 | ;; Make poly primitive. 376 | ;; This isn't really well defined since coefs are in a field. Idea is 377 | ;; to make the coefficients smaller. Its really worth avoiding 378 | ;; dividing out a content of 1!!! 379 | #+ignore ;; Use for integral domains 380 | (defun gterms-prim* (poly) 381 | (unless (terms0? poly) 382 | (let ((coef-domain (domain-of (lc poly))) 383 | (num-gcd (numerator (lc poly))) 384 | (den-gcd (denominator (lc poly))) 385 | 1/content) 386 | ;; Should really use a probabilistic algorithm content algorithm 387 | ;; here 388 | (map-over-each-term (red poly) (nil c) 389 | (if (1? num-gcd) 390 | (if (1? den-gcd) (return t) 391 | (setq den-gcd (gcd den-gcd (denominator c)))) 392 | (if (1? den-gcd) 393 | (setq num-gcd (gcd num-gcd (numerator c))) 394 | (setq num-gcd (gcd num-gcd (numerator c)) 395 | den-gcd (gcd den-gcd (denominator c)))))) 396 | (unless (and (1? num-gcd) (1? den-gcd)) 397 | (setq 1/content (make-quotient-element coef-domain den-gcd num-gcd)) 398 | (map-over-each-term poly (e c) 399 | (update-term e (* c 1/content)))))) 400 | poly) 401 | 402 | ;; Use for fields 403 | (defun gterms-prim* (poly) 404 | (unless (terms0? poly) 405 | (let ((1/lc (/ (svref (lt poly) 0)))) 406 | (unless (1? 1/lc) 407 | (loop for term in poly 408 | do (setf (svref term 0) (* (svref term 0) 1/lc)))))) 409 | poly) 410 | -------------------------------------------------------------------------------- /polynomials/poly-tools.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Package:Weyli; Base:10; Lowercase:T; Syntax:Common-Lisp -*- 2 | ;;; =========================================================================== 3 | ;;; Polynomial Domain Tools 4 | ;;; =========================================================================== 5 | ;;; (c) Copyright 1989, 1993 Cornell University 6 | 7 | ;;; poly-tools.lisp,v 1.4 1995/05/24 17:42:08 rz Exp 8 | 9 | (in-package :weyli) 10 | 11 | ;;; DELETE (make::adjust-version-numbers Weyl "1.4") 12 | 13 | ;; Things conditionalized by GEHASH would require hash tables that 14 | ;; work with GE-EQUAL. 15 | 16 | (defmethod initialize-instance :after 17 | ((domain variable-hash-table) &rest plist) 18 | (declare (ignore plist)) 19 | (with-slots (variable-hash-table variable-table variables) domain 20 | #+GEHASH 21 | (setq variable-hash-table (make-hash-table :test #'equal)) 22 | (setq variable-table (make-array (list (max (length variables) 1) 2))) 23 | (setq variable-hash-table 24 | (loop for var in variables 25 | for i upfrom 0 26 | collect (list var i) 27 | do (setf (aref variable-table i 0) var))))) 28 | 29 | (defgeneric variable-index (domain variable) 30 | (:documentation 31 | "The purpose of this method is unknown.")) 32 | 33 | (defmethod variable-index ((domain variable-hash-table) (variable symbol)) 34 | (setq variable (coerce variable *general*)) 35 | (loop for (var index) in (variable-hash-table domain) 36 | do (when (ge-equal variable var) 37 | (return index))) 38 | #+GEHASH 39 | (gethash variable (variable-hash-table domain))) 40 | 41 | (defmethod variable-index 42 | ((domain variable-hash-table) (variable general-expression)) 43 | (loop for (var index) in (variable-hash-table domain) 44 | do (when (ge-equal variable var) 45 | (return index))) 46 | #+GEHASH 47 | (gethash variable (variable-hash-table domain))) 48 | 49 | (defgeneric variable-symbol (domain order) 50 | (:documentation 51 | "The purpose of this method is unknown.")) 52 | 53 | (defmethod variable-symbol ((domain variable-hash-table) (order-number number)) 54 | (aref (variable-index-table domain) order-number 0)) 55 | 56 | ;;(defmethod variable-symbol ((domain variable-hash-table) (poly polynomial)) 57 | ;; (aref (variable-index-table domain) (poly-order-number (poly-form poly)) 0)) 58 | 59 | (defgeneric get-variable-number-property (domain order property) 60 | (:documentation 61 | "The purpose of this method is unknown.")) 62 | 63 | (defmethod get-variable-number-property 64 | ((domain variable-hash-table) order-number property) 65 | (%getf (aref (variable-index-table domain) order-number 1) property)) 66 | 67 | (defgeneric set-variable-number-property (domain order property value) 68 | (:documentation 69 | "The purpose of this method is unknown.")) 70 | 71 | (defmethod set-variable-number-property 72 | ((domain variable-hash-table) order-number property value) 73 | (setf (%getf (aref (variable-index-table domain) order-number 1) property) 74 | value)) 75 | 76 | (defsetf get-variable-number-property set-variable-number-property) 77 | 78 | (defmethod get-variable-property 79 | ((domain variable-hash-table) variable property) 80 | (setq variable (coerce variable *general*)) 81 | (get-variable-number-property domain (variable-index domain variable) 82 | property)) 83 | 84 | (defmethod set-variable-property 85 | ((domain variable-hash-table) variable property value) 86 | (setq variable (coerce variable *general*)) 87 | (set-variable-number-property domain (variable-index domain variable) 88 | property value)) 89 | 90 | ;; Defined in general, which is loaded first. 91 | ;;(defsetf get-variable-property set-variable-property) 92 | 93 | (defgeneric add-new-variable (ring variable) 94 | (:documentation 95 | "The purpose of this method is unknown.")) 96 | 97 | (defmethod add-new-variable ((ring variable-hash-table) variable) 98 | (with-slots (variables variable-hash-table variable-table) ring 99 | (let ((vars (different-kernels (coerce variable *general*) 100 | variables))) 101 | (setq vars 102 | (loop for var in vars 103 | unless (member var variables :test #'ge-equal) 104 | collect var)) 105 | (unless (null vars) 106 | (let* ((count (length variables)) 107 | (array (make-array (list (cl:+ count (length vars)) 2)))) 108 | (setq variables (append variables vars)) 109 | (copy-array-contents variable-table array) 110 | (setq variable-table array) 111 | #-GEHASH 112 | (setq variable-hash-table 113 | (nconc variable-hash-table 114 | (loop for var in vars 115 | for cnt upfrom count 116 | do (setf (aref variable-table cnt 0) var) 117 | collect (list var cnt)))) 118 | #+GEHASH ;; If we had General expression hash tables 119 | (loop for var in vars 120 | for cnt upfrom count 121 | do (setf (gethash var variable-table) cnt))))) 122 | ring)) 123 | 124 | (defmethod zero ((domain caching-zero-and-one)) 125 | (with-slots (zero) domain 126 | zero)) 127 | 128 | (defmethod one ((domain caching-zero-and-one)) 129 | (with-slots (one) domain 130 | one)) 131 | -------------------------------------------------------------------------------- /quotient-fields.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Package:Weyli; Base:10; Lowercase:T; Syntax:Common-Lisp -*- 2 | ;;; =========================================================================== 3 | ;;; Quotient Field Routines 4 | ;;; =========================================================================== 5 | ;;; (c) Copyright 1989, 1993 Cornell University 6 | 7 | ;;; quotient-fields.lisp,v 1.10 1995/05/24 17:42:10 rz Exp 8 | 9 | (in-package :weyli) 10 | 11 | ;;; DELETE (make::adjust-version-numbers Weyl "1.10") 12 | 13 | (defgeneric make-quotient-field (field) 14 | (:documentation 15 | "The purpose of this method is unknown.") 16 | (:method ((ring field)) ring)) 17 | 18 | (defgeneric get-quotient-field (field) 19 | (:documentation 20 | "The purpose of this method is unknown.") 21 | (:method ((ring field)) ring)) 22 | 23 | ;;; These two methods are actually given in rational-numbers.lisp when 24 | ;;; the functions they call are defined. 25 | 26 | ;;;(defmethod make-quotient-field ((ring rational-integers)) 27 | ;;; (make-rational-numbers)) 28 | 29 | ;;;(defmethod get-quotient-field ((ring rational-integers)) 30 | ;;; (get-rational-numbers)) 31 | 32 | (defgeneric make-quotient-element (domain numerator denominator) 33 | (:documentation 34 | "The purpose of this method is unknown.")) 35 | 36 | (defmethod make-quotient-element 37 | ((domain quotient-field) numerator denominator) 38 | (make-instance 'quotient-element :domain domain 39 | :numerator numerator :denominator denominator)) 40 | 41 | (define-domain-creator quotient-field ((ring ring)) 42 | (progn 43 | (unless (gcd-domain? ring) 44 | (error "Can only create quotient fields of GCD domains: ~S" 45 | ring)) 46 | (let ((qf (make-instance 'quotient-field :ring ring 47 | :print-function 'quotient-field-print-object))) 48 | (with-slots (zero one) qf 49 | (setq zero (make-quotient-element qf (zero ring) (one ring))) 50 | (setq one (make-quotient-element qf (one ring) (one ring)))) 51 | (make-homomorphism ring #'(lambda (x) 52 | (make-quotient-element qf x (one ring))) 53 | qf) 54 | qf)) 55 | :predicate #'(lambda (d) 56 | (and (typep d 'quotient-field) (eql (qf-ring d) ring)))) 57 | 58 | (defun quotient-field-print-object (qf stream) 59 | (with-slots (ring) qf 60 | (format stream "QF(~S)" ring))) 61 | 62 | (defmethod coerce ((qe quotient-element) (d general-expressions)) 63 | (let ((num (coerce (numerator qe) d)) 64 | (den (coerce (denominator qe) d))) 65 | (setq den (if (number? den) (recip den) 66 | (make-ge-expt d den (make-element d -1)))) 67 | (cond ((1? num) den) 68 | ((1? den) num) 69 | (t (simplify (make-ge-times d (list num den))))))) 70 | 71 | (defmethod print-object ((ratfun quotient-element) stream) 72 | (with-numerator-and-denominator (numerator denominator) ratfun 73 | (cond ((1? denominator) 74 | (prin1 numerator stream)) 75 | (t (princ "(" stream) 76 | (prin1 numerator stream) 77 | (princ ")/(" stream) 78 | (prin1 denominator stream) 79 | (princ ")" stream))))) 80 | 81 | (defmethod numerator ((r quotient-element)) 82 | (qo-numerator r)) 83 | 84 | (defmethod denominator ((r quotient-element)) 85 | (qo-denominator r)) 86 | 87 | (defmethod zero ((qf quotient-field)) 88 | (with-slots (zero) qf 89 | zero)) 90 | 91 | (defmethod one ((qf quotient-field)) 92 | (with-slots (one) qf 93 | one)) 94 | 95 | (defmethod 0? ((r quotient-element)) 96 | (with-slots (numerator) r 97 | (0? numerator))) 98 | 99 | (defmethod 1? ((r quotient-element)) 100 | (with-slots (numerator denominator) r 101 | (and (1? numerator) 102 | (1? denominator)))) 103 | 104 | (defgeneric height (object) 105 | (:documentation 106 | "The purpose of this method is unknown.")) 107 | 108 | (defmethod height ((r quotient-element)) 109 | (max (height (numerator r)) (height (denominator r)))) 110 | 111 | (defmethod minus ((r quotient-element)) 112 | (let ((domain (domain-of r))) 113 | (with-numerator-and-denominator (numerator denominator) r 114 | (make-quotient-element domain (minus numerator) denominator)))) 115 | 116 | (defgeneric minus? (object) 117 | (:documentation 118 | "Return true if the object is negative.")) 119 | 120 | (defmethod minus? ((r quotient-element)) 121 | (minus? (qo-numerator r))) 122 | 123 | (defun quotient-reduce* (qf num &optional den) 124 | (with-slots (ring) qf 125 | (when (null den) 126 | (setq den (one ring)))) 127 | (if (0? num) (zero qf) 128 | (let ((common-gcd (gcd num den))) 129 | (unless (1? common-gcd) 130 | (setq num (/ num common-gcd) 131 | den (/ den common-gcd))) 132 | (when (minus? den) 133 | (setq num (minus num) 134 | den (minus den))) 135 | (make-quotient-element qf num den)))) 136 | 137 | (defgeneric quotient-reduce (field numerator &optional denominator) 138 | (:documentation 139 | "The purpose of this method is unknown.")) 140 | 141 | (defmethod quotient-reduce ((qf quotient-field) num &optional den) 142 | (with-slots (ring) qf 143 | (when (not (eql (domain-of num) ring)) 144 | (error "The numerator's domain, ~S, is not the ring of the quotient field ~S" 145 | (domain-of num) ring)) 146 | (when (not (eql (domain-of den) ring)) 147 | (error "The denominator's domain, ~S, is not the ring of the quotient field ~S" 148 | (domain-of den) ring)) 149 | (quotient-reduce* qf num den))) 150 | 151 | (defmethod-sd plus ((r1 quotient-element) (r2 quotient-element)) 152 | (with-numerator-and-denominator (n1 d1) r1 153 | (with-numerator-and-denominator (n2 d2) r2 154 | (cond ((0? n1) r2) 155 | ((0? n2) r1) 156 | (t (quotient-reduce* domain 157 | (+ (* n1 d2) (* n2 d1)) 158 | (* d1 d2))))))) 159 | 160 | (defmethod-sd difference ((r1 quotient-element) (r2 quotient-element)) 161 | (with-numerator-and-denominator (n1 d1) r1 162 | (with-numerator-and-denominator (n2 d2) r2 163 | (cond ((0? n1) 164 | (make-quotient-element domain (- n2) d1)) 165 | ((0? n2) r1) 166 | (t (quotient-reduce* domain 167 | (- (* n1 d2) (* n2 d1)) 168 | (* d1 d2))))))) 169 | 170 | (defmethod-sd times ((r1 quotient-element) (r2 quotient-element)) 171 | (with-numerator-and-denominator (n1 d1) r1 172 | (with-numerator-and-denominator (n2 d2) r2 173 | (let (common-gcd) 174 | (cond ((and (1? n1) (1? d1)) 175 | r2) 176 | ((and (1? n2) (1? d2)) 177 | r1) 178 | (t (setq common-gcd (gcd n1 d2)) 179 | (if (not (1? common-gcd)) 180 | (setq n1 (/ n1 common-gcd) 181 | d2 (/ d2 common-gcd))) 182 | (setq common-gcd (gcd n2 d1)) 183 | (if (not (1? common-gcd)) 184 | (setq n2 (/ n2 common-gcd) 185 | d1 (/ d1 common-gcd))) 186 | (setq d1 (* d1 d2) 187 | n1 (* n1 n2)) 188 | (if (minus? d1) 189 | (setq d1 (minus d1) n1 (minus n1))) 190 | (make-quotient-element domain n1 d1))))))) 191 | 192 | (defmethod-sd quotient ((r1 quotient-element) (r2 quotient-element)) 193 | (with-numerator-and-denominator (n1 d1) r1 194 | (with-numerator-and-denominator (n2 d2) r2 195 | (let (common-gcd) 196 | (cond ((and (1? n1) (1? d1)) 197 | (make-quotient-element domain d2 n2)) 198 | ((and (1? n2) (1? d2)) 199 | r1) 200 | (t (setq common-gcd (gcd n1 n2)) 201 | (if (not (1? common-gcd)) 202 | (setq n1 (/ n1 common-gcd) 203 | n2 (/ n2 common-gcd))) 204 | (setq common-gcd (gcd d1 d2)) 205 | (if (not (1? common-gcd)) 206 | (setq d2 (/ d2 common-gcd) 207 | d1 (/ d1 common-gcd))) 208 | (setq n1 (* n1 d2) 209 | d1 (* d1 n2)) 210 | (if (minus? d1) 211 | (setq d1 (minus d1) n1 (minus n1))) 212 | (make-quotient-element domain n1 d1))))))) 213 | 214 | (defmethod recip ((r1 quotient-element)) 215 | (with-numerator-and-denominator (n1 d1) r1 216 | (if (minus? n1) 217 | (setq n1 (minus n1) d1 (minus d1))) 218 | (make-quotient-element (domain-of r1) d1 n1))) 219 | 220 | (defun expt-quotient (domain quo exp) 221 | (with-numerator-and-denominator (n1 d1) quo 222 | (if (minus? exp) 223 | (if (minus? n1) 224 | (make-quotient-element 225 | domain (expt (minus d1) (- exp)) (expt (minus n1) (- exp))) 226 | (make-quotient-element 227 | domain (expt d1 (- exp)) (expt n1 (- exp)))) 228 | (make-quotient-element domain (expt n1 exp) (expt d1 exp))))) 229 | 230 | (defmethod expt ((r1 quotient-element) (exp integer)) 231 | (expt-quotient (domain-of r1) r1 exp)) 232 | 233 | (defmethod expt ((r1 quotient-element) (exp rational-integer)) 234 | (expt-quotient (domain-of r1) r1 (integer-value exp))) 235 | 236 | (defmethod-sd binary-gcd ((r1 quotient-element) (r2 quotient-element)) 237 | (with-numerator-and-denominator (n1 d1) r1 238 | (with-numerator-and-denominator (n2 d2) r2 239 | (make-quotient-element domain (gcd n1 n2) (lcm d1 d2))))) 240 | 241 | (defmethod coerce (x (domain quotient-field)) 242 | (let ((temp (coercible? x (qf-ring domain)))) 243 | (if temp (make-quotient-element domain temp (one (qf-ring domain))) 244 | (call-next-method)))) 245 | 246 | (defmethod coerce ((x quotient-element) (domain field)) 247 | (let ((num (coercible? (numerator x) domain))) 248 | (if num (/ num (coerce (denominator x) domain)) 249 | (call-next-method)))) 250 | -------------------------------------------------------------------------------- /rational-functions.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Package:Weyli; Base:10; Lowercase:T; Syntax:Common-Lisp -*- 2 | ;;; =========================================================================== 3 | ;;; Rational Function Fields 4 | ;;; =========================================================================== 5 | ;;; (c) Copyright 1989, 1993 Cornell University 6 | 7 | ;;; rational-functions.lisp,v 1.9 1995/05/24 17:42:10 rz Exp 8 | 9 | (in-package :weyli) 10 | 11 | ;;; DELETE (make::adjust-version-numbers Weyl "1.9") 12 | 13 | (defmethod initialize-instance :after ((qf rational-function-field) &rest plist) 14 | (declare (ignore plist)) 15 | (with-slots (print-function) qf 16 | (setf print-function 'ratfun-field-print-object))) 17 | 18 | (defun ratfun-field-print-object (qf stream) 19 | (format stream "~A(" (coefficient-domain-of (QF-ring qf))) 20 | (display-list (ring-variables (QF-ring qf)) stream) 21 | (princ ")" stream)) 22 | 23 | (defmethod ring-variables ((qf rational-function-field)) 24 | (ring-variables (qf-ring qf))) 25 | 26 | ;; The general GET-Q... in quotient-field.lisp is good enough 27 | (define-domain-creator quotient-field ((ring multivariate-polynomial-ring)) 28 | (let* ((coefs (coefficient-domain-of ring)) 29 | (qf (make-instance 'rational-function-field 30 | :ring ring))) 31 | (with-slots (zero one) qf 32 | (setq zero (make-rational-function qf (zero coefs) (one coefs))) 33 | (setq one (make-rational-function qf (one coefs) (one coefs)))) 34 | (make-homomorphism ring #'(lambda (x) 35 | (make-quotient-element qf x (one ring))) 36 | qf) 37 | qf)) 38 | 39 | (defsubst make-rational-function (domain numerator denominator) 40 | (make-instance 'rational-function :domain domain 41 | :numerator numerator 42 | :denominator denominator)) 43 | 44 | (defgeneric make-rational-function* (domain num den) 45 | (:documentation 46 | "The purpose of this function is unknown.")) 47 | 48 | (defmethod make-rational-function* (domain num den) 49 | (let* ((poly-domain (qf-ring domain)) 50 | (coef-domain (coefficient-domain-of poly-domain))) 51 | (bind-domain-context poly-domain 52 | (cond ((and (typep coef-domain 'field) 53 | (poly-coef? den)) 54 | (setq num (poly-times (recip den) num)) 55 | (setq den (one coef-domain))) 56 | ((poly-minus? den) 57 | (setq num (poly-minus num) den (poly-minus den))))) 58 | (make-rational-function domain num den))) 59 | 60 | (defmethod make-quotient-element 61 | ((domain rational-function-field) numerator denominator) 62 | (make-rational-function domain 63 | (poly-form (coerce numerator (qf-ring domain))) 64 | (poly-form (coerce denominator (qf-ring domain))))) 65 | 66 | (defmethod print-object ((ratfun rational-function) stream) 67 | (with-numerator-and-denominator (numerator denominator) ratfun 68 | (cond ((poly-1? denominator) 69 | (print-mpolynomial-form (QF-ring (domain-of ratfun)) numerator stream)) 70 | (t (princ "(" stream) 71 | (print-mpolynomial-form (QF-ring (domain-of ratfun)) numerator stream) 72 | (princ ")/(" stream) 73 | (print-mpolynomial-form (QF-ring (domain-of ratfun)) denominator stream) 74 | (princ ")" stream))))) 75 | 76 | (defmethod numerator ((r rational-function)) 77 | (let ((domain (domain-of r))) 78 | (make-polynomial (QF-ring domain) (qo-numerator r)))) 79 | 80 | (defmethod denominator ((r rational-function)) 81 | (let ((domain (domain-of r))) 82 | (make-polynomial (QF-ring domain) (qo-denominator r)))) 83 | 84 | (defmethod 0? ((r rational-function)) 85 | (poly-0? (qo-numerator r))) 86 | 87 | (defmethod 1? ((r rational-function)) 88 | (and (poly-1? (qo-numerator r)) 89 | (poly-1? (qo-denominator r)))) 90 | 91 | (defmethod minus ((r rational-function)) 92 | (let ((domain (domain-of r))) 93 | (with-numerator-and-denominator (numerator denominator) r 94 | (bind-domain-context (qf-ring domain) 95 | (make-rational-function domain (poly-minus numerator) denominator))))) 96 | 97 | (defmethod quotient-reduce ((qf rational-function-field) num &optional den) 98 | (with-slots (ring) qf 99 | (when (not (eql (domain-of num) ring)) 100 | (error "The numerator's domain, ~S, is not the ring of the quotient field ~S" 101 | (domain-of num) ring)) 102 | (when (not (eql (domain-of den) ring)) 103 | (error "The denominator's domain, ~S, is not the ring of the quotient field ~S" 104 | (domain-of den) ring)) 105 | (ratfun-reduce qf (poly-form num) (poly-form den)))) 106 | 107 | ;; The arguments to ratfun-reduce are poly-forms not polynomials!!! 108 | (defun ratfun-reduce (qf num &optional den) 109 | (when (null den) 110 | (setq den (one (QF-ring qf)))) 111 | (if (poly-0? num) (zero qf) 112 | (let ((common-gcd (poly-gcd num den))) 113 | (unless (poly-1? common-gcd) 114 | (setq num (poly-quotient num common-gcd) 115 | den (poly-quotient den common-gcd))) 116 | (make-rational-function* qf num den)))) 117 | 118 | (defmethod-sd plus ((r1 rational-function) (r2 rational-function)) 119 | (with-numerator-and-denominator (n1 d1) r1 120 | (with-numerator-and-denominator (n2 d2) r2 121 | (bind-domain-context (qf-ring domain) 122 | (ratfun-reduce domain 123 | (poly-plus (poly-times n1 d2) (poly-times n2 d1)) 124 | (poly-times d1 d2)))))) 125 | 126 | (defmethod-sd difference ((r1 rational-function) (r2 rational-function)) 127 | (with-numerator-and-denominator (n1 d1) r1 128 | (with-numerator-and-denominator (n2 d2) r2 129 | (bind-domain-context (qf-ring domain) 130 | (ratfun-reduce domain 131 | (poly-difference (poly-times n1 d2) (poly-times n2 d1)) 132 | (poly-times d1 d2)))))) 133 | 134 | (defmethod-sd times ((r1 rational-function) (r2 rational-function)) 135 | (with-numerator-and-denominator (n1 d1) r1 136 | (with-numerator-and-denominator (n2 d2) r2 137 | (bind-domain-context (qf-ring domain) 138 | (let (common-gcd) 139 | (setq common-gcd (poly-gcd n1 d2)) 140 | (if (not (poly-1? common-gcd)) 141 | (setq n1 (poly-quotient n1 common-gcd) 142 | d2 (poly-quotient d2 common-gcd))) 143 | (setq common-gcd (poly-gcd n2 d1)) 144 | (if (not (poly-1? common-gcd)) 145 | (setq n2 (poly-quotient n2 common-gcd) 146 | d1 (poly-quotient d1 common-gcd))) 147 | (setq d1 (poly-times d1 d2) 148 | n1 (poly-times n1 n2)) 149 | (make-rational-function* domain n1 d1)))))) 150 | 151 | (defmethod-sd quotient ((r1 rational-function) (r2 rational-function)) 152 | (with-numerator-and-denominator (n1 d1) r1 153 | (with-numerator-and-denominator (n2 d2) r2 154 | (bind-domain-context (qf-ring domain) 155 | (let (common-gcd) 156 | (setq common-gcd (poly-gcd n1 n2)) 157 | (if (not (poly-1? common-gcd)) 158 | (setq n1 (poly-quotient n1 common-gcd) 159 | n2 (poly-quotient n2 common-gcd))) 160 | (setq common-gcd (poly-gcd d1 d2)) 161 | (if (not (poly-1? common-gcd)) 162 | (setq d2 (poly-quotient d2 common-gcd) 163 | d1 (poly-quotient d1 common-gcd))) 164 | (setq n1 (poly-times n1 d2) 165 | d1 (poly-times d1 n2)) 166 | (make-rational-function* domain n1 d1)))))) 167 | 168 | (defmethod recip ((r1 rational-function)) 169 | (with-numerator-and-denominator (num den) r1 170 | (make-rational-function* (domain-of r1) den num))) 171 | 172 | (defmethod expt ((r1 rational-function) (exp integer)) 173 | (let ((domain (domain-of r1))) 174 | (with-numerator-and-denominator (n1 d1) r1 175 | (bind-domain-context (qf-ring domain) 176 | (if (minusp exp) 177 | (make-rational-function domain 178 | (poly-expt d1 (cl:- exp)) 179 | (poly-expt n1 (cl:- exp))) 180 | (make-rational-function domain 181 | (poly-expt n1 exp) (poly-expt d1 exp))))))) 182 | 183 | (defmethod expt ((r1 rational-function) (exp rational-integer)) 184 | (expt r1 (integer-value exp))) 185 | 186 | (defmethod-sd binary-gcd ((r1 rational-function) (r2 rational-function)) 187 | (with-numerator-and-denominator (n1 d1) r1 188 | (with-numerator-and-denominator (n2 d2) r2 189 | (bind-domain-context (qf-ring domain) 190 | (make-rational-function domain (poly-gcd n1 n2) (poly-lcm d1 d2)))))) 191 | 192 | 193 | (defmethod list-of-variables 194 | ((x rational-function) &optional list-of-variables) 195 | (let* ((domain (domain-of x)) 196 | (ring-domain (qf-ring domain))) 197 | (with-numerator-and-denominator (num-x den-x) x 198 | (loop for order-number in (poly-list-of-variables 199 | den-x (poly-list-of-variables num-x)) 200 | do (pushnew (get-variable-name order-number ring-domain) 201 | list-of-variables :test #'ge-equal))) 202 | list-of-variables)) 203 | 204 | ;; This is just like poly-subst, but its result is a rational function 205 | ;; and thus the values being substituted can be rational functions. 206 | (defun rational-poly-subst (poly var-value) 207 | (let ((temp nil)) 208 | (cond ((null var-value) 209 | poly) 210 | ((poly-coef? poly) (coerce poly *domain*)) 211 | (t (setq temp (or (second (assoc (poly-order-number poly) var-value 212 | :test #'eql)))) 213 | (when (null temp) 214 | (error "This variable can't be mapped into the domain ~S" 215 | *domain*)) 216 | (rational-terms-horners-rule (poly-terms poly) temp var-value))))) 217 | 218 | (defun rational-terms-horners-rule (terms value &optional var-value) 219 | (let ((old-e (le terms)) 220 | (ans (rational-poly-subst (lc terms) var-value))) 221 | (map-over-each-term (red terms) (e c) 222 | (setq ans (+ (* (expt value (e- old-e e)) ans) 223 | (rational-poly-subst c var-value))) 224 | (setq old-e e)) 225 | (* ans (expt value old-e)))) 226 | 227 | (defmethod substitute 228 | ((value rational-function) (variable rational-function) 229 | (p rational-function) &rest ignore) 230 | (declare (ignore ignore)) 231 | (substitute (list value) (list variable) p)) 232 | 233 | (defmethod substitute ((values list) (variables list) (p rational-function) 234 | &rest ignore) 235 | (declare (ignore ignore)) 236 | (let* ((domain (domain-of p)) 237 | (ring (qf-ring domain)) 238 | (new-domain (domain-of (first values))) 239 | subst-list) 240 | (loop for var in variables 241 | unless (eql (domain-of var) domain) 242 | do (error "Domain of ~S was expected to be ~S" var domain)) 243 | (loop for val in values 244 | unless (eql (domain-of val) new-domain) 245 | do (error "Domain of ~S was expected to be ~S" val new-domain)) 246 | (loop for var in (ring-variables ring) 247 | do (unless (find var variables 248 | :test #'(lambda (a b) 249 | (eql a (variable-symbol 250 | ring (numerator b))))) 251 | (push (coerce var domain) variables) 252 | (push (if (coercible? var new-domain) 253 | (coerce var new-domain) 254 | nil) 255 | values))) 256 | (setq subst-list (loop for var in variables 257 | for val in values 258 | collect (list (variable-index ring (numerator var)) 259 | val))) 260 | (with-numerator-and-denominator (num den) p 261 | (bind-domain-context new-domain 262 | (/ (rational-poly-subst num subst-list) 263 | (rational-poly-subst den subst-list)))))) 264 | 265 | (defmethod partial-deriv ((p rational-function) x) 266 | (error "Don't know how to compute the partial deriv with respect to ~S" 267 | x)) 268 | 269 | (defmethod partial-deriv ((p rational-function) (x symbol)) 270 | (partial-deriv p (coerce x *general*))) 271 | 272 | (defmethod partial-deriv ((p rational-function) (x list)) 273 | (partial-deriv p (coerce x *general*))) 274 | 275 | (defmethod partial-deriv ((p rational-function) (x general-expression)) 276 | (let ((domain (domain-of p))) 277 | (with-slots (variables) (qf-ring domain) 278 | (if (member x variables :test #'ge-equal) 279 | (partial-deriv p (coerce x domain)) 280 | (call-next-method))))) 281 | 282 | (defmethod partial-deriv ((p rational-function) (x rational-function)) 283 | (with-numerator-and-denominator (num-x den-x) x 284 | (with-numerator-and-denominator (num-p den-p) p 285 | (let ((domain (domain-of p)) 286 | terms) 287 | (unless (and (eql domain (domain-of x)) 288 | (1? den-x) 289 | (null (red (setq terms (poly-terms num-x)))) 290 | (e1? (le terms)) 291 | (poly-1? (lc terms))) 292 | (error "~S is not a variable in ~S" x domain)) 293 | (bind-domain-context (qf-ring domain) 294 | (ratfun-reduce domain 295 | (poly-difference 296 | (poly-times (poly-derivative num-p num-x) den-p) 297 | (poly-times (poly-derivative den-p num-x) num-p)) 298 | (poly-times den-p den-p))))))) 299 | 300 | (defmethod deriv ((poly rational-function) &rest vars) 301 | (let* ((domain (domain-of poly)) 302 | deriv diff) 303 | (bind-domain-context domain 304 | (loop for var in vars do 305 | (setq var (coerce var *general*)) 306 | (setq deriv (zero domain)) 307 | (loop with variables = (list-of-variables poly) 308 | for kernel in variables do 309 | (when (depends-on? kernel var) 310 | (setq diff (deriv kernel var)) 311 | (loop for new in (different-kernels diff variables) do 312 | (add-new-variable (qf-ring domain) new)) 313 | (setq deriv 314 | (+ deriv (* (partial-deriv poly kernel) 315 | (coerce diff domain)))))) 316 | (setq poly deriv))) 317 | poly)) 318 | 319 | (defmethod coerce ((x ge-expt) (domain rational-function-field)) 320 | (if (ge-minus? (exponent-of x)) 321 | (recip (coerce (expt (base-of x) (- (exponent-of x))) 322 | domain)) 323 | (call-next-method))) 324 | -------------------------------------------------------------------------------- /reference/AITR-2001-006.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/OdonataResearchLLC/weyl/299898c075795a7fb0b06907e6db13158e06b686/reference/AITR-2001-006.pdf -------------------------------------------------------------------------------- /reference/Weyl Manual.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/OdonataResearchLLC/weyl/299898c075795a7fb0b06907e6db13158e06b686/reference/Weyl Manual.pdf -------------------------------------------------------------------------------- /sets.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Package:Weyli; Base:10; Lowercase:T; Syntax:Common-Lisp -*- 2 | ;;; =========================================================================== 3 | ;;; Sets 4 | ;;; =========================================================================== 5 | ;;; (c) Copyright 1989, 1991 Cornell University 6 | 7 | ;;; sets.lisp,v 1.6 1995/05/24 17:42:11 rz Exp 8 | 9 | (in-package :weyli) 10 | 11 | ;;; DELETE (make::adjust-version-numbers Weyl "1.6") 12 | 13 | ;; Tuples are just indexed lists. 14 | (defclass tuple () 15 | ((value 16 | :initarg :values 17 | :initform () 18 | :reader value-of))) 19 | 20 | ;;; DELETE : This is a major update, so we're not concerned with 21 | ;;; backward compatibility. 22 | (defgeneric tuple-value (tuple) 23 | (:documentation 24 | "A wrapper function for value-of for backward compatibility.") 25 | (:method ((tuple tuple)) (value-of tuple))) 26 | 27 | (defmethod initialize-instance :after ((object tuple) &rest plist) 28 | (declare (ignore plist)) 29 | (with-slots (value) object 30 | (cond ((null value) 31 | (error "Values need to be provided for ~A" 32 | (class-name (class-of object)))) 33 | ((listp value) 34 | (setq value (%apply #'vector value)))))) 35 | 36 | (defmethod print-object ((tuple tuple) stream) 37 | (%apply #'format stream "<~S~@{, ~S~}>" 38 | (loop with v = (value-of tuple) 39 | for i below (array-dimension v 0) 40 | collect (aref v i)))) 41 | 42 | (defgeneric ref (tuple &rest args) 43 | (:documentation 44 | "Refernce the item of tuple specified by the first arg.") 45 | (:method ((tuple tuple) &rest args) 46 | (aref (value-of tuple) (first args)))) 47 | 48 | ;;; FIXME : Merge set-ref and (defsetf ref). 49 | (defgeneric set-ref (tuple new-value &rest args) 50 | (:documentation 51 | "Set the element specified by args to new-value.")) 52 | 53 | (defmethod set-ref ((tuple tuple) new-value &rest args) 54 | (setf (aref (value-of tuple) (first args)) new-value)) 55 | 56 | (defsetf ref (vect &rest indices) (new-value) 57 | `(set-ref ,vect ,new-value ,@indices)) 58 | 59 | (defgeneric list-of-elements (tuple) 60 | (:documentation 61 | "Return a list of the tuple elements.")) 62 | 63 | (defmethod list-of-elements ((tuple tuple)) 64 | (let ((array (value-of tuple))) 65 | (loop for i fixnum below (array-dimension array 0) 66 | collect (aref array i)))) 67 | 68 | (defmethod map (type function (seq tuple) &rest sequences) 69 | (setq type (cond ((null type) (class-of seq)) 70 | ((typep type 'class) type) 71 | ((typep type 'symbol) (find-class type)) 72 | (t (error "Bad type specifier: ~S" type)))) 73 | (let ((values (loop with v = (value-of seq) 74 | for i below (array-dimension v 0) 75 | collect (%apply function (aref v i) 76 | (loop for seq in sequences 77 | collect (ref seq i)))))) 78 | (if (subclass-of? 'domain-element type) 79 | (if (typep seq 'domain-element) 80 | (make-instance type :domain (domain-of seq) 81 | :values values) 82 | (error "Can't determine domain of resulting sequence")) 83 | (make-instance type :values values)))) 84 | 85 | (defgeneric map-with-domain (type domain function sequence &rest sequences) 86 | (:documentation 87 | "Map the values of the sequences into the domain.")) 88 | 89 | (defmethod map-with-domain (type domain function (seq tuple) &rest sequences) 90 | (make-instance 91 | type :domain domain 92 | :values 93 | (loop with v = (value-of seq) 94 | for i below (array-dimension v 0) 95 | collect (%apply function (aref v i) 96 | (loop for seq in sequences 97 | collect (ref seq i)))))) 98 | 99 | ;; (empty? set) 100 | ;; (insert key set &rest args) 101 | ;; (delete item set &rest args) 102 | ;; (member item set &rest args) 103 | ;; (map-over-elements set function) 104 | ;; (make-generator set) -> function 105 | 106 | (define-operations set 107 | (= (element self) (element self)) -> Boolean 108 | (coerce default self) -> (element self) 109 | (member (element self) self) -> Boolean 110 | (make-generator self) -> (-> (element self)) 111 | (print-object (element self) stream) -> Null 112 | (number-of-elements self) -> integer) 113 | 114 | ;; Default version of this... 115 | #+ignore 116 | (defmethod binary= (x y) (equal x y)) 117 | 118 | (define-operations mutable-set 119 | (insert (element self) self) -> Null 120 | (delete (element self) self) -> Null) 121 | 122 | #+IGNORE 123 | (define-operations ordered-set 124 | (< (element self) (element self)) -> Boolean 125 | (> (element self) (element self)) -> Boolean 126 | (max (element self) (element self)) -> (element self) 127 | (min (element self) (element self)) -> (element self)) 128 | 129 | #+IGNORE 130 | (defmethod initialize-method :after ((set ordered-set) &rest plist) 131 | (unless (%getf plist :compare-function) 132 | (error "Must provide a comparison function for ordered sets"))) 133 | 134 | (define-operations finite-set 135 | (size self) -> Integer 136 | (random self) -> (element self)) 137 | 138 | ;; Set elements are also objects in Weyl. They behave like 139 | ;; domain-elements (they are domain-elements). The function 140 | ;; (element-key ..) gets their key. They are two basic types of 141 | ;; set-elements. SET-ELEMENT1 is a class where the elements are the 142 | ;; keys themselves. There are many applications where we want to have 143 | ;; sets of pairs (key, value). The class SET-ELEMENT2 is used for this 144 | ;; purpose. Set-elements can be compared with =, and > in which case 145 | ;; the comparison will use the comparision function of the set. 146 | 147 | ;;When building more complex structures, (AVL trees etc.) the nodes of 148 | ;;the datastructures should be built out of these classes. 149 | 150 | (defmethod print-object ((element set-element) stream) 151 | (format stream "~S" (element-key element))) 152 | 153 | ;; This is used for sets whose elements are associated with a value. 154 | 155 | (defmethod print-object ((element set-element2) stream) 156 | (format stream "(~S, ~S)" (element-key element) (element-value element))) 157 | 158 | (defmethod-sd binary= ((e1 set-element) (e2 set-element)) 159 | (%funcall (equal-function-of domain) (element-key e1) (element-key e2))) 160 | 161 | (defmethod binary= ((e1 set-element) e2) 162 | (%funcall (equal-function-of (domain-of e1)) (element-key e1) e2)) 163 | 164 | ;; The following needs to be an around method so that it doesn't come 165 | ;; at the end of the precidence list (after (number domain-element) 166 | ;; defined in morphisms). 167 | (defmethod binary= :around (e1 (e2 set-element)) 168 | (%funcall (equal-function-of (domain-of e2)) e1 (element-key e2))) 169 | 170 | (defmethod-sd binary> ((e1 set-element) (e2 set-element)) 171 | (%funcall (greater-function-of domain) (element-key e1) (element-key e2))) 172 | 173 | (defmethod binary> ((e1 set-element) e2) 174 | (%funcall (greater-function-of (domain-of e1)) (element-key e1) e2)) 175 | 176 | ;; The following needs to be an around method so that it doesn't come 177 | ;; at the end of the precidence list (after (number domain-element) 178 | ;; defined in morphisms). 179 | (defmethod binary> :around (e1 (e2 set-element)) 180 | (%funcall (greater-function-of (domain-of e2)) e1 (element-key e2))) 181 | 182 | ;; In building real sets one should include one of these classes to 183 | ;; indicate how elements of the set will be represented. 184 | 185 | (defmethod make-element ((set set-elements-as-singletons) key &rest rest) 186 | (declare (ignore rest)) 187 | (make-instance 'set-element1 :domain set :key key)) 188 | 189 | (defmethod make-element ((set set-elements-as-pairs) key &rest rest) 190 | (make-instance 'set-element2 :domain set 191 | :key key :value (first rest))) 192 | 193 | ;; Here are some simple sets that we might use in a program. 194 | 195 | (defgeneric set-elements (set) 196 | (:documentation 197 | "The purpose of this method is unknown.") 198 | (:method ((set set-with-element-list)) 199 | (rest (set-element-list set)))) 200 | 201 | (defun set-with-element-list-print-object (set stream) 202 | (let ((elts (set-elements set))) 203 | (if (null elts) (princ "{}" stream) 204 | (format stream "{~S~{, ~S~}}" (first elts) (rest elts))))) 205 | 206 | (defmethod initialize-instance :after ((set set-with-element-list) &rest plist) 207 | (let ((initial-elements (loop for (item . args) in (%getf plist :initial-elements) 208 | collect (%apply #'make-element set item args)))) 209 | #+IGNORE 210 | (if (typep set 'ordered-set) 211 | (setf initial-elements (sort initial-elements #'binary>))) 212 | (setf (rest (set-element-list set)) initial-elements) 213 | (with-slots (print-function) set 214 | (setf print-function 'set-with-element-list-print-object)))) 215 | 216 | (defmethod insert (key (set mutable-set-with-element-list) &rest rest) 217 | (let ((list (set-element-list set))) 218 | (loop for elt in (rest list) 219 | when (= key elt) 220 | do (return set) 221 | finally (push (%apply #'make-element set key rest) (rest list)) 222 | (return set)))) 223 | 224 | (defmethod delete (item (set mutable-set-with-element-list) &rest args) 225 | (declare (ignore args)) 226 | (flet ((not-an-element () 227 | (error "~S is not an element of ~S" item set))) 228 | (loop for elts on (set-element-list set) 229 | when (null (rest elts)) 230 | do (not-an-element) 231 | when (= item (second elts)) 232 | do (setf (rest elts) (rest (rest elts))) 233 | (return set) 234 | finally (not-an-element)))) 235 | 236 | (defmethod member (key (set set-with-element-list) &rest args) 237 | (declare (ignore args)) 238 | (loop for elt in (set-elements set) 239 | when (= key elt) 240 | do (return elt) 241 | finally (return nil))) 242 | 243 | (defgeneric map-over-elements (set function) 244 | (:documentation 245 | "Map over the elements of the set applying the function.")) 246 | 247 | (defmethod map-over-elements ((set set-with-element-list) function) 248 | (loop for elt in (set-elements set) do 249 | (%funcall function elt))) 250 | 251 | (defmethod make-generator ((set set-with-element-list)) 252 | (let ((list (set-elements set))) 253 | (lambda () (pop list)))) 254 | 255 | ;; This is just a variant on the previous class. The inclusion of the 256 | ;; ordered-set class causes the initialize-instance method to put the 257 | ;; elements in the set ordered. 258 | 259 | (defmethod insert (key (set mutable-set-with-sorted-element-list) &rest rest) 260 | (loop for elts on (set-element-list set) do 261 | (cond ((or (null (rest elts)) (> key (second elts))) 262 | (setf (rest elts) (cons (%apply #'make-element set key rest) (rest elts))) 263 | (return set)) 264 | ((= key (second elts)) 265 | (return set))))) 266 | 267 | (defmethod delete (item (set mutable-set-with-sorted-element-list) &rest args) 268 | (declare (ignore args)) 269 | (flet ((not-an-element () 270 | (error "~S is not an element of ~S" item set))) 271 | (loop for elts on (set-element-list set) 272 | when (null (rest elts)) 273 | do (not-an-element) 274 | when (= item (second elts)) 275 | do (setf (rest elts) (rest (rest elts))) 276 | (return set) 277 | when (> item (second elts)) 278 | do (not-an-element) 279 | finally (not-an-element)))) 280 | 281 | (defmethod member (key (set set-with-sorted-element-list) &rest args) 282 | (declare (ignore args)) 283 | (loop for elt in (set-elements set) 284 | when (= key elt) 285 | do (return elt) 286 | when (> key elt) 287 | do (return nil) 288 | finally (return nil))) 289 | 290 | ;;; FIXME : It would be better to define this as length. 291 | (defgeneric size (set) 292 | (:documentation 293 | "Return the length of the set.") 294 | (:method ((set set-with-element-list)) 295 | (common-lisp:length (set-elements set)))) 296 | 297 | (defgeneric random (set &optional height) 298 | (:documentation 299 | "Return a random element of the list.")) 300 | 301 | (defmethod random ((set set-with-element-list) &optional height) 302 | (declare (ignore height)) 303 | (let ((l (set-elements set))) 304 | (nth (cl:random (length l)) l))) 305 | -------------------------------------------------------------------------------- /test/combinatorial-tools.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Weyl Unit Testing 2 | 3 | (in-package :weyl-test) 4 | 5 | (lisp-unit:define-test permute 6 | (let ((seq '())) 7 | (permute '(a b c) (var) (push var seq)) 8 | (lisp-unit:assert-equal '(a b c) (first seq)) 9 | (lisp-unit:assert-equal '(b a c) (second seq)) 10 | (lisp-unit:assert-equal '(a c b) (third seq)) 11 | (lisp-unit:assert-equal '(c a b) (fourth seq)) 12 | (lisp-unit:assert-equal '(b c a) (fifth seq)) 13 | (lisp-unit:assert-equal '(c b a) (sixth seq)))) 14 | 15 | (lisp-unit:define-test choose 16 | ;; 1 element subset 17 | (let ((seq '())) 18 | (choose '(a b c d) (var 1) (push var seq)) 19 | (lisp-unit:assert-equal '(d) (first seq)) 20 | (lisp-unit:assert-equal '(c) (second seq)) 21 | (lisp-unit:assert-equal '(b) (third seq)) 22 | (lisp-unit:assert-equal '(a) (fourth seq))) 23 | ;; 2 element subset 24 | (let ((seq '())) 25 | (choose '(a b c d) (var 2) (push var seq)) 26 | (lisp-unit:assert-equal '(d c) (first seq)) 27 | (lisp-unit:assert-equal '(d b) (second seq)) 28 | (lisp-unit:assert-equal '(c b) (third seq)) 29 | (lisp-unit:assert-equal '(d a) (fourth seq)) 30 | (lisp-unit:assert-equal '(c a) (fifth seq)) 31 | (lisp-unit:assert-equal '(b a) (sixth seq))) 32 | ;; 3 element subset 33 | (let ((seq '())) 34 | (choose '(a b c d) (var 3) (push var seq)) 35 | (lisp-unit:assert-equal '(D C B) (first seq)) 36 | (lisp-unit:assert-equal '(D C A) (second seq)) 37 | (lisp-unit:assert-equal '(D B A) (third seq)) 38 | (lisp-unit:assert-equal '(C B A) (fourth seq))) 39 | ;; 4 element 40 | (lisp-unit:assert-equal 41 | '(a b c d) 42 | (choose '(a b c d) (var 4) var)) 43 | ;; Error 44 | (lisp-unit:assert-error 45 | 'error 46 | (choose '(a b c d) (var 5) var))) 47 | -------------------------------------------------------------------------------- /test/defpackage.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Unit Tests for weyl 2 | 3 | (defpackage :weyl-test 4 | (:use :common-lisp)) 5 | 6 | (cl-user::use-weyl-package :weyl-test) 7 | -------------------------------------------------------------------------------- /test/f-and-g-series.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Weyl Unit Testing 2 | 3 | (in-package :weyl-test) 4 | 5 | (lisp-unit:define-test f-and-g-series 6 | (let* ((Z (get-rational-integers)) 7 | (R (get-polynomial-ring Z '(mu eps sigma))) 8 | (sigma (coerce 'sigma R)) 9 | (mu (coerce 'mu R)) 10 | (eps (coerce 'eps R)) 11 | (x1 (* (- sigma) (+ mu (* 2 eps)))) 12 | (x2 (+ eps (* -2 (expt sigma 2)))) 13 | (x3 (* -3 mu sigma)) 14 | (x4 (- mu)) 15 | (f-array (make-array 6 :initial-element nil)) 16 | (g-array (make-array 6 :initial-element nil))) 17 | (labels ((compute-f (n) 18 | (or (aref f-array n) 19 | (setf (aref f-array n) 20 | (+ (* x4 (compute-g (1- n))) 21 | (* x1 (partial-deriv (compute-f (1- n)) eps)) 22 | (* x2 (partial-deriv (compute-f (1- n)) sigma)) 23 | (* x3 (partial-deriv (compute-f (1- n)) mu)))))) 24 | (compute-g (n) 25 | (or (aref g-array n) 26 | (setf (aref g-array n) 27 | (+ (compute-f (1- n)) 28 | (* x1 (partial-deriv (compute-g (1- n)) eps)) 29 | (* x2 (partial-deriv (compute-g (1- n)) sigma)) 30 | (* x3 (partial-deriv (compute-g (1- n)) mu))))))) 31 | (setf (aref f-array 0) (coerce 0 R)) 32 | (setf (aref g-array 0) (coerce 1 R)) 33 | ;; Initial values 34 | (lisp-unit:assert-true (= (compute-f 0) (coerce 0 R))) 35 | (lisp-unit:assert-true (= (compute-g 0) (coerce 1 R))) 36 | ;; n = 1 37 | (lisp-unit:assert-true (= (compute-f 1) (- mu))) 38 | (lisp-unit:assert-true (= (compute-g 1) (coerce 0 R))) 39 | ;; n = 2 40 | (lisp-unit:assert-true (= (compute-f 2) (* 3 sigma mu))) 41 | (lisp-unit:assert-true (= (compute-g 2) (- mu))) 42 | ;; n = 3 43 | (lisp-unit:assert-true 44 | (= (compute-f 3) 45 | (+ (* mu mu) (* (+ (* 3 eps) (* -15 sigma sigma)) mu)))) 46 | (lisp-unit:assert-true 47 | (= (compute-g 3) (* 6 sigma mu))) 48 | ;; n = 4 49 | (lisp-unit:assert-true 50 | (= (compute-f 4) 51 | (+ (* -15 sigma mu mu) 52 | (* (+ (* -45 sigma eps) (* 105 (expt sigma 3))) mu)))) 53 | (lisp-unit:assert-true 54 | (= (compute-g 4) 55 | (+ (* mu mu) (* (+ (* 9 eps) (* -45 sigma sigma)) mu)))) 56 | ;; n = 5 57 | (lisp-unit:assert-true 58 | (= (compute-f 5) 59 | (+ (* -1 mu mu mu) 60 | (* (+ (* -24 eps) (* 210 sigma sigma)) mu mu) 61 | (* (+ (* -45 eps eps) 62 | (* 630 sigma sigma eps) 63 | (* -945 (expt sigma 4))) 64 | mu)))) 65 | (lisp-unit:assert-true 66 | (= (compute-g 5) 67 | (+ (* -30 sigma mu mu) 68 | (* (+ (* -180 sigma eps) (* 420 (expt sigma 3))) mu))))))) 69 | -------------------------------------------------------------------------------- /test/weyl-test.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*- 2 | #| 3 | 4 | =========================================================================== 5 | Weyl ASDF Definition 6 | =========================================================================== 7 | (c) Copyright 1989, 1993 Cornell University 8 | 9 | |# 10 | 11 | (in-package :asdf) 12 | 13 | (defsystem :weyl-test 14 | :description "WEYL Unit Testing" 15 | :version "0.1.0" 16 | :license "Custom" 17 | :depends-on ("lisp-unit" "weyl") 18 | :components 19 | ((:file "defpackage") 20 | (:file "f-and-g-series" :depends-on ("defpackage")))) 21 | -------------------------------------------------------------------------------- /vector-spaces/projective-space.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Package:Weyli; Base:10; Lowercase:T; Syntax:Common-Lisp -*- 2 | ;;; =========================================================================== 3 | ;;; Projective Spaces 4 | ;;; =========================================================================== 5 | ;;; (c) Copyright 1989, 1993 Cornell University 6 | 7 | ;;; projective-space.lisp,v 1.5 1995/05/24 17:42:09 rz Exp 8 | 9 | (in-package :weyli) 10 | 11 | ;;; DELETE (make::adjust-version-numbers Weyl "1.5") 12 | 13 | (eval-when (:compile-toplevel :load-toplevel) 14 | (define-domain-creator projective-space ((domain field) dimension) 15 | (make-instance 'projective-space 16 | :coefficient-domain domain 17 | :dimension dimension 18 | :print-function 'projective-space-print-object) 19 | :predicate #'(lambda (d) 20 | (and (eql (class-name (class-of d)) 'projective-space) 21 | (eql (coefficient-domain-of d) domain) 22 | (eql (dimension-of d) dimension))))) 23 | 24 | (defun projective-space-print-object (domain stream) 25 | (format stream #+Genera "P ~D(~S)" #-Genera "P^~D(~S)" 26 | (dimension-of domain) 27 | (coefficient-domain-of domain))) 28 | 29 | (defun make-projective-space-element (domain value) 30 | (make-instance 'projective-space-element :domain domain :value value)) 31 | 32 | (defmethod make-element ((domain projective-space) value &rest values) 33 | (let ((dim (dimension-of domain)) 34 | (num-values (1+ (length values))) 35 | (coeff-domain (coefficient-domain-of domain)) 36 | array) 37 | (setq values (cons value values)) 38 | (cond ((eql dim num-values) 39 | (setq array (make-array (1+ dim))) 40 | (loop for i below dim 41 | for v in values do 42 | (setf (aref array i) (coerce v coeff-domain))) 43 | (setf (aref array dim) (one coeff-domain)) 44 | (make-projective-space-element domain array)) 45 | ((eql dim (1- num-values)) 46 | (setq array (make-array (1+ dim))) 47 | (loop for i below dim 48 | for v in values 49 | with denom = (coerce (first (last values)) coeff-domain) do 50 | (setf (aref array i) (/ (coerce v coeff-domain) denom))) 51 | (setf (aref array dim) (one coeff-domain)) 52 | (make-projective-space-element domain array)) 53 | (t (error "Wrong number of vector elements in ~S" domain))))) 54 | 55 | (defmethod ref ((vect projective-space-element) &rest args) 56 | (aref (tuple-value vect) (first args))) 57 | 58 | (defmethod vector-set-ref 59 | ((vect projective-space-element) new-value &rest args) 60 | (setf (aref (tuple-value vect) (first args)) new-value)) 61 | 62 | ;; Create an affine space corresponding to 63 | (defmethod make-affine-space ((space projective-space) &optional n) 64 | (let* ((dim (dimension-of space)) 65 | (range-space (make-vector-space (coefficient-domain-of space) dim)) 66 | homo) 67 | (when (null n) 68 | (setf n dim)) 69 | (labels ((project (vector) 70 | (loop with denom = (ref vector n) 71 | for i below (1+ dim) 72 | unless (= i n) 73 | collect (/ (ref vector i) denom))) 74 | (map-fun (vector) 75 | (%apply #'make-element range-space (project vector)))) 76 | (setq homo (make-morphism space #'map-fun range-space)) 77 | (values (morphism-range homo) 78 | (morphism-map homo))))) 79 | 80 | -------------------------------------------------------------------------------- /vector-spaces/quaternions.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Package: WEYLI; Base:10; Lowercase:T; Syntax:Common-Lisp -*- 2 | ;;; =========================================================================== 3 | ;;; Quaternions 4 | ;;; 5 | ;;; 6 | ;;; based on "Applications of quaternions to computations with rotation", 7 | ;;; Eugene Salamin. 8 | ;;; Contains quaternions over a field and unit quaternions. 9 | ;;; 10 | ;;; Not yet implemented: homomorphism between unit quaternions and SO(3) 11 | ;;; 12 | ;;; =========================================================================== 13 | 14 | ;;; (c) Copyright 1989, 1993 Cornell University 15 | 16 | ;;; quaternions.lisp,v 1.9 1995/05/24 17:42:09 rz Exp 17 | 18 | (in-package :weyli) 19 | 20 | ;;; DELETE (make::adjust-version-numbers Weyl "1.9") 21 | 22 | (eval-when (:compile-toplevel :load-toplevel) 23 | (define-domain-creator quaternion-domain ((domain field)) 24 | (make-instance 'quaternion-domain 25 | :coefficient-domain domain 26 | :dimension 4 27 | :print-function 'quaternion-domain-print-object) 28 | :predicate #'(lambda (d) 29 | (and (eql (class-name (class-of d)) 'quaternion-domain) 30 | (eql (coefficient-domain-of d) domain))))) 31 | 32 | (defun quaternion-domain-print-object (domain stream) 33 | (format stream "Quat(~S)" (coefficient-domain-of domain))) 34 | 35 | (eval-when (:compile-toplevel :load-toplevel) 36 | (define-domain-creator unit-quaternion-domain ((domain field)) 37 | (make-instance 'unit-quaternion-domain 38 | :coefficient-domain domain 39 | :dimension 4 40 | :print-function 'unit-quaternion-domain-print-object) 41 | :predicate #'(lambda (d) 42 | (and (eql (class-name (class-of d)) 'unit-quaternion-domain) 43 | (eql (coefficient-domain-of d) domain))))) 44 | 45 | (defun unit-quaternion-domain-print-object (domain stream) 46 | (format stream "UQuat(~S)" (coefficient-domain-of domain))) 47 | 48 | 49 | ;;; Quaternion elements themselves 50 | 51 | 52 | (define-domain-element-classes quaternion-domain 53 | quaternion-domain-element) 54 | 55 | (define-domain-element-classes unit-quaternion-domain 56 | unit-quaternion-domain-element) 57 | 58 | (defmethod make-element ((domain quaternion-domain) (value vector) 59 | &rest values) 60 | (unless (and (eql (array-dimension value 0) 4) 61 | (null values)) 62 | (error "Wrong number of vector elements in ~S" domain)) 63 | (make-instance (first (domain-element-classes domain)) 64 | :domain domain :values value)) 65 | 66 | (defmethod weyl::make-element ((domain quaternion-domain) (value vector) 67 | &rest values) 68 | (unless (and (eql (array-dimension value 0) 4) 69 | (null values)) 70 | (error "Wrong number of vector elements in ~S" domain)) 71 | (let ((coef-domain (coefficient-domain-of domain)) 72 | (vector (make-array 4))) 73 | (loop for i below 4 do 74 | (setf (aref vector i) (coerce (aref value i) coef-domain))) 75 | (make-instance (first (domain-element-classes domain)) 76 | :domain domain :values vector))) 77 | 78 | (defmethod make-element ((domain quaternion-domain) value &rest values) 79 | (unless (eql 3 (length values)) 80 | (error "Wrong number of vector elements in ~S" domain)) 81 | (make-instance (first (domain-element-classes domain)) 82 | :domain domain 83 | :values (%apply #'vector value values))) 84 | 85 | (defmethod weyl::make-element ((domain quaternion-domain) value &rest values) 86 | (unless (eql 3 (length values)) 87 | (error "Wrong number of vector elements in ~S" domain)) 88 | (let ((coef-domain (coefficient-domain-of domain)) 89 | (vector (make-array 4))) 90 | (setf (aref vector 0) (coerce value coef-domain)) 91 | (setf (aref vector 1) (coerce (first values) coef-domain)) 92 | (setf (aref vector 2) (coerce (second values) coef-domain)) 93 | (setf (aref vector 3) (coerce (third values) coef-domain)) 94 | (make-instance (first (domain-element-classes domain)) 95 | :domain domain 96 | :values vector))) 97 | 98 | (defmethod make-element ((domain unit-quaternion-domain) (value vector) 99 | &rest values) 100 | (unless (and (eql (array-dimension value 0) 4) 101 | (null values)) 102 | (error "Wrong number of vector elements in ~S" domain)) 103 | (make-instance (first (domain-element-classes domain)) 104 | :domain domain :values value)) 105 | 106 | ;; FIXTHIS: Should check to make sure that quaternion is a unit 107 | (defmethod weyl::make-element ((domain unit-quaternion-domain) (value vector) 108 | &rest values) 109 | (unless (and (eql (array-dimension value 0) 4) 110 | (null values)) 111 | (error "Wrong number of vector elements in ~S" domain)) 112 | (let ((coef-domain (coefficient-domain-of domain)) 113 | (vector (make-array 4))) 114 | (loop for i below 4 do 115 | (setf (aref vector i) (coerce (aref value i) coef-domain))) 116 | (make-instance (first (domain-element-classes domain)) 117 | :domain domain :values vector))) 118 | 119 | (defmethod make-element ((domain unit-quaternion-domain) value &rest values) 120 | (unless (eql 3 (length values)) 121 | (error "Wrong number of vector elements in ~S" domain)) 122 | (make-instance (first (domain-element-classes domain)) 123 | :domain domain 124 | :values (%apply #'vector value values))) 125 | 126 | ;; FIXTHIS: Should check to make sure that quaternion is a unit 127 | (defmethod weyl::make-element ((domain unit-quaternion-domain) value 128 | &rest values) 129 | (unless (eql 3 (length values)) 130 | (error "Wrong number of vector elements in ~S" domain)) 131 | (let ((coef-domain (coefficient-domain-of domain)) 132 | (vector (make-array 4))) 133 | (setf (aref vector 0) (coerce value coef-domain)) 134 | (setf (aref vector 1) (coerce (first values) coef-domain)) 135 | (setf (aref vector 2) (coerce (second values) coef-domain)) 136 | (setf (aref vector 3) (coerce (third values) coef-domain)) 137 | (make-instance (first (domain-element-classes domain)) 138 | :domain domain 139 | :values vector))) 140 | 141 | (defmethod conjugate ((q quaternion-with-multiplication)) 142 | (let ((value (tuple-value q))) 143 | (make-element (domain-of q) 144 | (aref value 0) (- (aref value 1)) 145 | (- (aref value 2)) (- (aref value 3))))) 146 | 147 | (defmethod-sd dot-product 148 | ((q1 quaternion-with-multiplication) (q2 quaternion-with-multiplication)) 149 | (loop for i upfrom 1 below 4 150 | with ans = (* (ref q1 0) (ref q2 0)) 151 | do (setq ans (+ ans (* (ref q1 i) (ref q2 i)))) 152 | finally (return ans))) 153 | 154 | (defmethod-sd times 155 | ((p quaternion-with-multiplication) (q quaternion-with-multiplication)) 156 | (let* ((pp (tuple-value p)) 157 | (p0 (aref pp 0)) 158 | (p1 (aref pp 1)) 159 | (p2 (aref pp 2)) 160 | (p3 (aref pp 3)) 161 | (qq (tuple-value q)) 162 | (q0 (aref qq 0)) 163 | (q1 (aref qq 1)) 164 | (q2 (aref qq 2)) 165 | (q3 (aref qq 3))) 166 | (make-element domain 167 | (- (* p0 q0) (+ (+ (* p1 q1) (* p2 q2)) (* p3 q3))) 168 | (- (+ (+ (* p1 q0) (* p0 q1)) (* p2 q3)) (* p3 q2)) 169 | (- (+ (+ (* p2 q0) (* p0 q2)) (* p3 q1)) (* p1 q3)) 170 | (- (+ (+ (* p3 q0) (* p0 q3)) (* p1 q2)) (* p2 q1))))) 171 | 172 | #| For metricized fields| 173 | 174 | (defmethod norm ((q quaternion-domain-element)) 175 | (sqrt (dot-product q q))) 176 | 177 | (defmethod normalize ((q quaternion-domain-element)) 178 | (let ((l (norm q)) 179 | (v (tuple-value q))) 180 | (make-quaternion-domain-element 181 | (domain-of q) 182 | (make-array 4 :initial-contents (list (/ (aref v 0) l) 183 | (/ (aref v 1) l) 184 | (/ (aref v 2) l) 185 | (/ (aref v 3) l)))))) 186 | ||# 187 | 188 | (defmethod create-unit-quaternion 189 | ((domain unit-quaternion-domain) (v vector-space-element) (angle number)) 190 | (unless (= 3 (dimension-of (domain-of v))) 191 | (error "Illegal call to create-unit-quaternion: ~S" v)) 192 | ;; must coerce domains 193 | (make-element domain 194 | (cos (/ angle 2)) 195 | (* (sin (/ angle 2)) (ref v 0)) 196 | (* (sin (/ angle 2)) (ref v 1)) 197 | (* (sin (/ angle 2)) (ref v 2)))) 198 | 199 | ;; 200 | ;; homomorphism SO(3) --> Unit Quaternions 201 | ;; 202 | 203 | (defmethod coerce ((Q unit-quaternion-domain-element) (domain SO-n)) 204 | (if (eql (dimension-of domain) 3) 205 | (let* ((q0 (ref Q 0)) 206 | (q1 (ref Q 1)) 207 | (q2 (ref Q 2)) 208 | (q3 (ref Q 3)) 209 | (q0q0 (* q0 q0)) 210 | (q0q1 (* q0 q1)) 211 | (q0q2 (* q0 q2)) 212 | (q0q3 (* q0 q3)) 213 | (q1q1 (* q1 q1)) 214 | (q1q2 (* q1 q2)) ; 215 | (q1q3 (* q1 q3)) 216 | (q2q2 (* q2 q2)) 217 | (q2q3 (* q2 q3)) 218 | (q3q3 (* q3 q3)) 219 | (mat (make-array '(3 3)))) 220 | (setf (aref mat 0 0) (+ (* 2 q0q0) (* 2 q1q1) -1)) 221 | (setf (aref mat 1 1) (+ (* 2 q0q0) (* 2 q2q2) -1)) 222 | (setf (aref mat 2 2) (+ (* 2 q0q0) (* 2 q3q3) -1)) 223 | (setf (aref mat 0 1) (* 2 (- q1q2 q0q3))) 224 | (setf (aref mat 0 2) (* 2 (+ q1q3 q0q2))) 225 | (setf (aref mat 1 2) (* 2 (- q2q3 q0q1))) 226 | (setf (aref mat 1 0) (* 2 (+ q1q2 q0q3))) 227 | (setf (aref mat 2 0) (* 2 (- q1q3 q0q2))) 228 | (setf (aref mat 2 1) (* 2 (+ q0q1 q2q3))) 229 | (make-element domain mat)) 230 | (error "Cannot coerce a quaternion in SO(~D)" (dimension-of domain)))) 231 | 232 | -------------------------------------------------------------------------------- /vector-spaces/vector.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Package:Weyli; Base:10; Lowercase:T; Syntax:Common-Lisp -*- 2 | ;;; =========================================================================== 3 | ;;; Vector Space 4 | ;;; =========================================================================== 5 | ;;; (c) Copyright 1989, 1993 Cornell University 6 | 7 | ;;; vector.lisp,v 1.11 1995/06/05 20:38:00 rick Exp 8 | 9 | (in-package :weyli) 10 | 11 | ;;; DELETE (make::adjust-version-numbers Weyl "1.11") 12 | 13 | ;; Useful macro until everything is ANSI compliant 14 | (defmacro loop-vector-bind (index vars-vectors &body body) 15 | (let ((cnt 0) vectors limit var-bindings) 16 | (setq var-bindings 17 | (loop for (var vect) in vars-vectors 18 | for vector = (intern (format nil ".VV~D." (incf cnt))) 19 | do (push (list var vector) vectors) 20 | collect `(,vector ,vect) 21 | finally (setq vectors (nreverse vectors)))) 22 | (cond ((atom index) 23 | (when (null index) 24 | (setq index '.I.)) 25 | (setq limit `(min ,@(loop for (nil vect) in vectors 26 | collect `(array-dimension ,vect 0))))) 27 | (t (setq limit (second index)) 28 | (setq index (first index)))) 29 | `(let ,var-bindings 30 | (declare (optimize (safety 1))) 31 | (loop for ,index fixnum below ,limit 32 | ,@(loop for (var vect) in vectors 33 | append `(for ,var = (svref ,vect ,index))) 34 | do ,@body)))) 35 | 36 | (eval-when (:compile-toplevel :load-toplevel) 37 | (define-domain-creator free-module ((domain ring) dimension) 38 | (make-instance 'free-module 39 | :coefficient-domain domain 40 | :dimension dimension 41 | :print-function 'free-module-print-object) 42 | :predicate #'(lambda (d) 43 | (and (eql (class-name (class-of d)) 'free-module) 44 | (eql (coefficient-domain-of d) domain) 45 | (eql (dimension-of d) dimension))))) 46 | 47 | (eval-when (:compile-toplevel :load-toplevel) 48 | (define-domain-creator vector-space ((domain field) dimension) 49 | (make-instance 'vector-space 50 | :coefficient-domain domain 51 | :dimension dimension 52 | :print-function 'free-module-print-object) 53 | :predicate #'(lambda (d) 54 | (and (eql (class-name (class-of d)) 'vector-space) 55 | (eql (coefficient-domain-of d) domain) 56 | (eql (dimension-of d) dimension))))) 57 | 58 | (defun free-module-print-object (domain stream) 59 | (format stream #+Genera "~S ~D" #-Genera "~S^~D" 60 | (coefficient-domain-of domain) 61 | (dimension-of domain))) 62 | 63 | (define-domain-element-classes free-module free-module-element) 64 | (define-domain-element-classes vector-space vector-space-element) 65 | 66 | (defmethod make-element ((domain free-module) (value vector) &rest values) 67 | (declare (ignore values)) 68 | (make-element-free-module-vector domain value)) 69 | 70 | (defun make-element-free-module-vector (domain value) 71 | (let ((dim (dimension-of domain))) 72 | (unless (eql (array-dimension value 0) dim) 73 | (error "Wrong number of vector elements in ~S" domain)) 74 | (make-instance (first (domain-element-classes domain)) 75 | :domain domain :values value))) 76 | 77 | (defmethod make-element ((domain free-module) value &rest values) 78 | (let ((dim (dimension-of domain))) 79 | (unless (eql (1- dim) (length values)) 80 | (error "Wrong number of vector elements in ~S" domain)) 81 | (make-instance (first (domain-element-classes domain)) 82 | :domain domain 83 | :values (%apply #'vector value values)))) 84 | 85 | (defmethod weyl::make-element ((domain free-module) value &rest values) 86 | (let ((dim (dimension-of domain)) 87 | (coef-domain (coefficient-domain-of domain))) 88 | (cond ((typep value 'vector) 89 | (unless (and (eql (array-dimension value 0) dim) 90 | (null values)) 91 | (error "Wrong number of vector elements in ~S" domain)) 92 | (make-instance (first (domain-element-classes domain)) 93 | :domain domain 94 | :values (%apply #'vector 95 | (loop for i fixnum below (length value) 96 | collect (coerce (aref value i) coef-domain))))) 97 | (t (unless (eql (1- dim) (length values)) 98 | (error "Wrong number of vector elements in ~S" domain)) 99 | (make-instance (first (domain-element-classes domain)) 100 | :domain domain 101 | :values (%apply #'vector 102 | (coerce value coef-domain) 103 | (loop for v in values 104 | collect (coerce v coef-domain)))))))) 105 | 106 | (defmethod print-object ((elt free-module-element) stream) 107 | (print-free-module-element elt stream)) 108 | 109 | (defun print-free-module-element (elt stream) 110 | (let* ((domain (domain-of elt)) 111 | (dim (if (typep domain 'dimensional-domain) 112 | (dimension-of (domain-of elt)) 113 | (array-dimension (tuple-value elt) 0)))) 114 | (write-char #\< stream) 115 | (unless (0? dim) 116 | (print-object (ref elt 0) stream) 117 | (loop for i upfrom 1 below dim 118 | do (princ ", " stream) 119 | (print-object (ref elt i) stream))) 120 | (write-char #\> stream))) 121 | 122 | (defmethod dimensions ((v vector-space-element)) 123 | (list (dimension-of (domain-of v)))) 124 | 125 | (defmethod 0? ((v free-module-element)) 126 | (loop for i fixnum below (dimension-of (domain-of v)) 127 | do (unless (0? (ref v i)) 128 | (return nil)) 129 | finally (return t))) 130 | 131 | 132 | (defmethod zero ((domain free-module)) 133 | (let ((dim (dimension-of domain)) 134 | (zero (zero (coefficient-domain-of domain)))) 135 | (make-instance (first (domain-element-classes domain)) 136 | :domain domain 137 | :values (make-array dim :initial-element zero)))) 138 | 139 | (defmethod list-of-variables ((v free-module-element) &optional ignore) 140 | (declare (ignore ignore)) 141 | (loop for i fixnum below (dimension-of (domain-of v)) 142 | with list 143 | do (setq list (list-of-variables (ref v i) list)) 144 | finally (return list))) 145 | 146 | (defmethod-sd max-pair ((v1 free-module-element) (v2 free-module-element)) 147 | (let* ((dim (dimension-of domain)) 148 | (ans (make-array dim))) 149 | (loop-vector-bind (i dim) ((e1 (tuple-value v1)) 150 | (e2 (tuple-value v2))) 151 | (setf (svref ans i) (max e1 e2))) 152 | (make-element domain ans))) 153 | 154 | (defmethod-sd min-pair ((v1 free-module-element) (v2 free-module-element)) 155 | (let* ((dim (dimension-of domain)) 156 | (ans (make-array dim))) 157 | (loop-vector-bind (i dim) ((e1 (tuple-value v1)) 158 | (e2 (tuple-value v2))) 159 | (setf (svref ans i) (min e1 e2))) 160 | (make-element domain ans))) 161 | 162 | (defmethod-sd plus ((v1 free-module-element) (v2 free-module-element)) 163 | (let* ((dim (dimension-of domain)) 164 | (ans (make-array dim))) 165 | (loop-vector-bind (i dim) 166 | ((e1 (tuple-value v1)) 167 | (e2 (tuple-value v2))) 168 | (setf (svref ans i) (+ e1 e2))) 169 | (make-element domain ans))) 170 | 171 | (defmethod minus ((vector free-module-element)) 172 | (let* ((vector-space (domain-of vector)) 173 | (dim (dimension-of vector-space)) 174 | (ans (make-array dim))) 175 | (loop-vector-bind (i dim) ((e (tuple-value vector))) 176 | (setf (svref ans i) (minus e))) 177 | (make-element vector-space ans))) 178 | 179 | (defmethod-sd difference ((v1 free-module-element) (v2 free-module-element)) 180 | (let* ((dim (dimension-of domain)) 181 | (ans (make-array dim))) 182 | (loop-vector-bind (i dim) 183 | ((e1 (tuple-value v1)) 184 | (e2 (tuple-value v2))) 185 | (setf (svref ans i) (- e1 e2))) 186 | (make-element domain ans))) 187 | 188 | ;; The checks to see if the scalar is a free-module element are 189 | ;; necessary because we can multiple two quaternion's together. There 190 | ;; are some complications here. --RZ 11/2/94 191 | 192 | (defmethod times :around (scalar (vector free-module-element)) 193 | (let ((coeff-domain (coefficient-domain-of (domain-of vector))) 194 | (coerced-scalar nil)) 195 | (cond ((and *coerce-where-possible* 196 | ;; Don't clobber the arg, the next cluase needs it 197 | (setq coerced-scalar (coercible? scalar coeff-domain))) 198 | (multiply-vector-by-scalar vector coerced-scalar)) 199 | ((typep scalar 'free-module-element) 200 | (call-next-method)) 201 | (t (multiply-vector-by-scalar vector scalar))))) 202 | 203 | ;; The :around methods for this method and the next are not really 204 | ;; needed since they are chosen in preference other similar methods 205 | ;; since they have a more specialized first argument. Nonetheless, 206 | ;; I'm leaving the :around's here for symmetry and emphasis. 207 | ;; --RZ 7/12/94 208 | (defmethod times :around ((vector free-module-element) scalar) 209 | (let ((coeff-domain (coefficient-domain-of (domain-of vector))) 210 | (coerced-scalar nil)) 211 | (cond ((and *coerce-where-possible* 212 | ;; Don't clobber the arg, the next cluase needs it 213 | (setq coerced-scalar (coercible? scalar coeff-domain))) 214 | (multiply-vector-by-scalar vector coerced-scalar)) 215 | ((typep scalar 'free-module-element) 216 | (call-next-method)) 217 | (t (multiply-vector-by-scalar vector scalar))))) 218 | 219 | (defmethod quotient :around ((vector free-module-element) scalar) 220 | (let ((coeff-domain (coefficient-domain-of (domain-of vector))) 221 | (coerced-scalar nil)) 222 | (cond ((and (not (numberp scalar)) 223 | (eql (domain-of scalar) coeff-domain)) 224 | (multiply-vector-by-scalar vector (/ scalar))) 225 | ((and *coerce-where-possible* 226 | ;; Don't clobber the arg, the next cluase needs it 227 | (setq coerced-scalar (coercible? scalar coeff-domain))) 228 | (multiply-vector-by-scalar vector (/ coerced-scalar))) 229 | (t (call-next-method scalar vector))))) 230 | 231 | (defun multiply-vector-by-scalar (vector scalar) 232 | (let* ((vector-space (domain-of vector)) 233 | (dim (dimension-of vector-space)) 234 | (ans (make-array dim))) 235 | (loop-vector-bind (i dim) ((e (tuple-value vector))) 236 | (setf (svref ans i) (* e scalar))) 237 | (make-element vector-space ans))) 238 | 239 | (defmethod-sd dot-product ((v1 free-module-element) (v2 free-module-element)) 240 | (loop for i fixnum upfrom 1 below (dimension-of domain) 241 | with ans = (* (ref v1 0) (ref v2 0)) 242 | do (setq ans (+ ans (* (ref v1 i) (ref v2 i)))) 243 | finally (return ans))) 244 | 245 | (defmethod-sd inner-product ((v1 free-module-element) (v2 free-module-element)) 246 | (dot-product v1 v2)) 247 | 248 | (defmethod cross-product (v1 v2) 249 | (error "CROSS-PRODUCT product is not implemented for elements of ~S and ~S" 250 | (domain-of v1) (domain-of v2))) 251 | 252 | (defmethod cross-product ((v1 free-module-element) (v2 free-module-element)) 253 | (let ((domain (domain-of v1)) 254 | a b) 255 | (cond ((and (eql domain (domain-of v2)) 256 | (= 3 (dimension-of domain))) 257 | (setq a (tuple-value v1) 258 | b (tuple-value v2)) 259 | (make-element domain 260 | (- (* (aref a 1) (aref b 2)) 261 | (* (aref a 2) (aref b 1))) 262 | (- (* (aref a 2) (aref b 0)) 263 | (* (aref a 0) (aref b 2))) 264 | (- (* (aref a 0) (aref b 1)) 265 | (* (aref a 1) (aref b 0))))) 266 | (t (call-next-method))))) 267 | 268 | (defmethod tilde (vect) 269 | (error "TILDE is not implemented for elements of ~S" (domain-of vect))) 270 | 271 | (defmethod tilde ((vect free-module-element)) 272 | (cond ((= 3 (dimension-of (domain-of vect))) 273 | (let ((matrix-space (get-matrix-space 274 | (coefficient-domain-of (domain-of vect)))) 275 | (v1 (ref vect 0)) 276 | (v2 (ref vect 1)) 277 | (v3 (ref vect 2)) 278 | (zero (zero (coefficient-domain-of (domain-of vect))))) 279 | (make-element matrix-space 280 | (make-array (list 3 3) 281 | :initial-contents 282 | `((,zero ,(- v3) ,v2) 283 | (,v3 ,zero ,(- v1)) 284 | (,(- v2) ,v1 ,zero)))))) 285 | (t (call-next-method)))) 286 | 287 | (defmethod derivation ((vector free-module-element)) 288 | (let* ((vector-space (domain-of vector)) 289 | (coef-domain (coefficient-domain-of vector-space))) 290 | (cond ((member 'deriv (list-operations coef-domain)) 291 | (let* ((vector-space (domain-of vector)) 292 | (dim (dimension-of vector-space)) 293 | (ans (make-array dim))) 294 | (loop-vector-bind (i dim) ((e (tuple-value vector))) 295 | (setf (svref ans i) (deriv e))) 296 | (make-element vector-space ans))) 297 | (t (error "Derivation is not a legal operation for domain ~S~%" 298 | vector-space))))) 299 | 300 | (defmethod deriv ((vector free-module-element) &rest vars) 301 | (let* ((vector-space (domain-of vector)) 302 | (dim (dimension-of vector-space)) 303 | (ans (make-array dim))) 304 | (loop-vector-bind (i dim) ((e (tuple-value vector))) 305 | (setf (svref ans i) (%apply #'deriv e vars))) 306 | (make-element vector-space ans))) 307 | 308 | ;; v1 - v2 has no negative components 309 | (defmethod-sd dominates ((v1 lisp-vector) (v2 lisp-vector)) 310 | (loop with dimension = (dimension-of domain) 311 | and vect1 = (tuple-value v1) and vect2 = (tuple-value v2) 312 | for i below dimension 313 | when (< (aref vect1 i) (aref vect2 i)) 314 | do (return nil) 315 | finally (return t))) 316 | 317 | (defmethod-sd disjoint ((v1 lisp-vector) (v2 lisp-vector)) 318 | (loop with dimension = (dimension-of domain) 319 | and vect1 = (tuple-value v1) and vect2 = (tuple-value v2) 320 | for i below dimension 321 | when (not (or (0? (aref vect2 i)) (0? (aref vect1 i)))) 322 | do (return nil) 323 | finally (return t))) 324 | 325 | (defmethod substitute ((values list) (variables list) (v free-module-element) 326 | &rest ignore) 327 | (declare (ignore ignore)) 328 | (let* ((dim (dimension-of (domain-of v))) 329 | (ans (make-array dim))) 330 | (loop-vector-bind (i dim) ((e (tuple-value v))) 331 | (setf (svref ans i) (substitute values variables e))) 332 | (make-element (domain-of v) ans))) 333 | 334 | 335 | ;; Should the absolute value of a vector be defined? The phase? 336 | 337 | (defmethod conjugate ((vector free-module-element)) 338 | (let* ((vector-space (domain-of vector)) 339 | (dim (dimension-of vector-space)) 340 | (ans (make-array dim))) 341 | (loop-vector-bind (i dim) 342 | ((e (tuple-value vector))) 343 | (setf (aref ans i) (conjugate e))) 344 | (make-element vector-space ans))) 345 | 346 | (defmethod realpart ((vector free-module-element)) 347 | (let* ((vector-space (domain-of vector)) 348 | (dim (dimension-of vector-space)) 349 | (ans (make-array dim))) 350 | (loop-vector-bind (i dim) 351 | ((e (tuple-value vector))) 352 | (setf (aref ans i) (realpart e))) 353 | (make-element vector-space ans))) 354 | 355 | (defmethod imagpart ((vector free-module-element)) 356 | (let* ((vector-space (domain-of vector)) 357 | (dim (dimension-of vector-space)) 358 | (ans (make-array dim))) 359 | (loop-vector-bind (i dim) 360 | ((e (tuple-value vector))) 361 | (setf (aref ans i) (imagpart e))) 362 | (make-element vector-space ans))) 363 | 364 | 365 | ;;; the dimension of a vector is the dimension of it's domain 366 | (defmethod dimension-of ((v vector-space-element)) 367 | (dimension-of (domain-of v))) 368 | -------------------------------------------------------------------------------- /weyl.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*- 2 | #| 3 | 4 | =========================================================================== 5 | Weyl ASDF Definition 6 | =========================================================================== 7 | (c) Copyright 1989, 1993 Cornell University 8 | 9 | |# 10 | 11 | (in-package :asdf) 12 | 13 | (defsystem :weyl 14 | :description "WEYL: A computer algebra substrate." 15 | :version "0.1.0" 16 | :depends-on ("closer-mop") 17 | :license "Custom" 18 | :components 19 | ((:file "packages") 20 | (:file "lisp-support" :depends-on ("packages")) 21 | (:file "domain-support" 22 | :depends-on ("packages" "lisp-support")) 23 | (:module "classes" 24 | :pathname "classes" 25 | :depends-on ("domain-support") 26 | :components 27 | ((:file "algebraic-domains") 28 | (:file "space-classes") 29 | (:file "general-classes"))) 30 | (:file "avl" :depends-on ("classes")) 31 | (:file "lisp-numbers" :depends-on ("classes")) 32 | (:file "sets" :depends-on ("classes")) 33 | (:file "morphisms":depends-on ("classes" "avl")) 34 | (:file "quotient-fields" :depends-on ("classes")) 35 | (:file "general" :depends-on ("classes")) 36 | (:file "fourier" :depends-on ("classes")) 37 | (:file "functions" :depends-on ("classes" "general" "fourier")) 38 | (:file "direct-sums" :depends-on ("classes")) 39 | (:module "numbers" 40 | :pathname "numbers" 41 | :depends-on ("classes") 42 | :components 43 | ((:file "bigfloat") 44 | (:file "numbers" :depends-on ("bigfloat")) 45 | (:file "gfp"))) 46 | (:module "polynomials" 47 | :pathname "polynomials" 48 | :depends-on ("classes") 49 | :components 50 | ((:file "poly-tools") 51 | (:file "mpolynomial" :depends-on ("poly-tools")) 52 | (:file "upolynomial" :depends-on ("poly-tools")) 53 | (:file "epolynomial" :depends-on ("poly-tools")) 54 | (:file "sparsegcd" :depends-on ("mpolynomial")) 55 | (:file "grobner" :depends-on ("mpolynomial" "epolynomial")))) 56 | (:file "tpower" :depends-on ("polynomials")) 57 | (:file "taylor" :depends-on ("tpower")) 58 | (:file "rational-functions" :depends-on ("polynomials" "quotient-fields")) 59 | (:file "differential-domains" :depends-on ("polynomials")) 60 | (:file "algebraic-extension" :depends-on ("polynomials")) 61 | (:module "vector-spaces" 62 | :pathname "vector-spaces" 63 | :depends-on ("sets") 64 | :components 65 | ((:file "vector") 66 | (:file "projective-space" :depends-on ("vector")) 67 | (:file "quaternions" :depends-on ("vector")))) 68 | (:file "matrix" :depends-on ("morphisms")) 69 | (:file "topology" :depends-on ("avl" "polynomials" "vector-spaces")) 70 | (:file "funct-spaces" :depends-on ("classes" "vector-spaces")) 71 | (:file "mesh" :depends-on ("topology")))) 72 | 73 | (defmethod perform :after ((op load-op) (comp (eql (find-system "weyl")))) 74 | "Initialize and reset the contexts." 75 | (pushnew :weyl *features*) 76 | (funcall (intern "INITIALIZE-CONTEXTS" :weyli)) 77 | (funcall (intern "RESET-DOMAINS" :weyli))) 78 | --------------------------------------------------------------------------------