home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / oper_sys / weyl / weyl_lsp.lha / differential-domains.lisp < prev    next >
Encoding:
Text File  |  1991-10-24  |  5.7 KB  |  160 lines
  1. ;;; -*- Mode:Lisp; Package:Weyli; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2. ;;; ===========================================================================
  3. ;;;                 Differential Rings
  4. ;;; ===========================================================================
  5. ;;; (c) Copyright 1989, 1991 Cornell University
  6.  
  7. ;;; $Id: differential-domains.lisp,v 2.13 1991/10/24 19:12:11 rz Exp $
  8.  
  9. (in-package "WEYLI")
  10.  
  11. (defmethod ring-variables ((domain differential-polynomial-ring))
  12.   (with-slots ((vars variables)) domain
  13.     (loop for v in vars
  14.       when (or (atom v) (not (eql (first v) 'derivation)))
  15.         collect v)))
  16.  
  17. (defsetf variable-derivation set-variable-derivation)
  18.  
  19. (define-domain-creator differential-ring ((coefficient-domain ring) variables) 
  20.   (progn
  21.     (setq variables (loop for var in variables
  22.               collect (coerce var *general*)))
  23.     (let ((ring (make-instance 'differential-polynomial-ring 
  24.                    :variables variables
  25.                    :coefficient-domain coefficient-domain)))
  26.       (loop for var in variables do
  27.     (setf (variable-derivation ring var) :generate))
  28.       ring))
  29.   :predicate 
  30.    (lambda (d)  
  31.      (and (eql (class-name (class-of d)) 'differential-polynomial-ring) 
  32.       (eql (coefficient-domain d) coefficient-domain)
  33.       (eql (ring-variables d) variables)
  34.       ;; And check that the derivations are the same.
  35.       )))
  36.  
  37. (defmethod print-object ((d differential-polynomial-ring) stream)
  38.   (with-slots (coefficient-domain) d
  39.     (format stream "~A<" coefficient-domain)
  40.     (display-list (ring-variables d))
  41.     (princ ">" stream)))
  42.  
  43. ;; Derivations are more complex than differentation.
  44. ;; This returns the derivation of the main variable of the polynomial.
  45. ;; In general this polynomial is expected to be of degree 1 with
  46. ;; coefficient 1.
  47. (defmacro variable-derivation (domain var)
  48.   `(get-variable-number-property ,domain (poly-order-number ,var)
  49.                  :derivation))
  50.  
  51. (defmacro variable-derivative-order (domain var)
  52.   `(get-variable-number-property ,domain (poly-order-number ,var)
  53.                  :derivative-order))
  54.  
  55. (defmethod set-variable-derivation ((domain differential-polynomial-ring)
  56.                     (variable (or symbol list)) derivation)
  57.   (setq variable (coerce variable *general*))
  58.   (with-slots (variables) domain
  59.     (unless (member variable variables :test #'ge-equal)
  60.       #+Genera
  61.       (error "~'i~A~ is not a variable of ~S" variable domain)
  62.       #-Genera      
  63.       (error "~A is not a variable of ~S" variable domain)))
  64.   (cond ((eql derivation :generate)
  65.      (setf (get-variable-number-property domain
  66.                          (variable-index domain variable)
  67.                          :derivation)
  68.            :generate))
  69.     (t (cond ((eql (domain-of derivation) *general*)
  70.           (setq derivation (coerce derivation domain)))
  71.          ((not (eql (domain-of derivation) domain))
  72.           (error "The derivation ~S is not an element of ~S" 
  73.              derivation domain)))
  74.        (setf (get-variable-number-property domain 
  75.                            (variable-index domain variable)
  76.                            :derivation)
  77.          (poly-form derivation)))))
  78.  
  79. (defmethod add-new-variable :around ((domain differential-ring) variable)
  80.   (prog1
  81.     (call-next-method domain variable)
  82.     (setq variable (coerce variable *general*))
  83.     (setf (variable-derivation domain variable) :generate)))
  84.  
  85. (defun standard-derivation (p)
  86.   (let ((deriv (variable-derivation *domain* p)))
  87.     (cond ((null deriv) (zero *coefficient-domain*))
  88.       ((eql deriv :generate)
  89.        (let* ((old-var (variable-symbol *domain* (poly-order-number p)))
  90.           (new-order
  91.            (cond ((ge-variable? old-var) 1)
  92.              ((eql (first old-var) 'derivation)
  93.               (1+ (third old-var)))
  94.              (t 1)))
  95.           (new-var `(derivation
  96.                  ,(if (or (ge-variable? old-var)
  97.                       (not (eql (first old-var) 'derivation)))
  98.                   old-var
  99.                   (second old-var))
  100.                  ,new-order))
  101.           (new-var-num (add-new-variable *domain* new-var)))
  102.          (setf (variable-derivation *domain* old-var) new-var)
  103.          #+ignore
  104.          (setf (variable-derivative-order *domain* new-var) new-order)
  105.          (cons new-var-num (make-terms 1 (one *coefficient-domain*)))))
  106.        (t deriv))))
  107.  
  108. (defun poly-derivation (p &optional (derivation #'standard-derivation))
  109.   (let ((deriv nil) (temp nil))
  110.     (cond ((poly-coef? p) (zero *coefficient-domain*))
  111.       (t (setq deriv (%funcall derivation p))
  112.          (poly-plus
  113.            (if (poly-0? deriv) deriv
  114.            (poly-times
  115.              (make-poly-form
  116.                p
  117.                (map-over-each-term (poly-terms p) (e c)
  118.              (unless (e0? e)
  119.                (unless (poly-0?
  120.                      (setq temp
  121.                        (poly-times
  122.                         (coerce e *coefficient-domain*)
  123.                         c)))
  124.                  (collect-term (e1- e) temp)))))
  125.              deriv))
  126.            (poly-differentiate-coefs p derivation))))))
  127.  
  128. (defun poly-differentiate-coefs (p derivation)
  129.   (let* ((dc nil)
  130.      (one (one *coefficient-domain*))
  131.      (terms (poly-terms p))
  132.      (sum (poly-times (make-poly-form p (make-terms (le terms) one))
  133.               (poly-derivation (lc terms) derivation))))
  134.     (map-over-each-term (red terms) (e c)
  135.       (setq dc (poly-derivation c derivation))
  136.       (setq sum (poly-plus sum 
  137.                (poly-times dc
  138.                        (make-poly-form p 
  139.                                (make-terms e one))))))
  140.     sum))
  141.  
  142. (defmethod derivation ((poly polynomial))
  143.   (let ((domain (domain-of poly)))
  144.     (unless (typep domain 'differential-ring)
  145.       (error "No derivation operator for ~S" domain))
  146.     (bind-domain-context domain
  147.       (make-polynomial domain (poly-derivation (poly-form poly))))))
  148.  
  149. (defmethod derivation ((rat rational-function))
  150.   (let ((domain (domain-of rat)))    
  151.     (unless (typep (qf-ring domain) 'differential-ring)
  152.       (error "No derivation operator for ~S" domain))
  153.     (with-numerator-and-denominator (n d) rat
  154.       (bind-domain-context (qf-ring domain)
  155.     (ratfun-reduce domain
  156.                (poly-difference
  157.             (poly-times (poly-derivation n) d)
  158.             (poly-times (poly-derivation d) n))
  159.                (poly-times d d))))))
  160.