home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / oper_sys / weyl / weyl_lsp.lha / coercions.lisp < prev    next >
Encoding:
Text File  |  1991-10-04  |  7.9 KB  |  258 lines
  1. ;;; -*- Mode:Lisp; Package:Weyli; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2. ;;; ===========================================================================
  3. ;;;                  Coercions
  4. ;;; ===========================================================================
  5. ;;; (c) Copyright 1989, 1991 Cornell University
  6.  
  7. ;;; $Id: coercions.lisp,v 2.9 1991/10/04 22:42:58 rz Exp $
  8.  
  9. (in-package "WEYLI")
  10.  
  11. ;; Scalars
  12.  
  13. (defmethod zero ((domain domain))
  14.   (coerce 0 domain))
  15.  
  16. (defmethod one ((domain domain))
  17.   (coerce 1 domain)) 
  18.  
  19. (defmethod-binary max-pair domain-element (x y)
  20.   (if (> x y) x y))
  21.  
  22. (defmethod-binary min-pair domain-element (x y)
  23.   (if (> x y) y x))
  24.  
  25.  
  26.  
  27. ;; Since we don't have an error system in Common Lisp yet, we use the
  28. ;; following flag to control whether an error is generated or NIL is
  29. ;; returned from COERCE.
  30.  
  31. (defvar *coercibility-checking* nil)
  32.  
  33. (defmethod coerce ((elt domain-element) (d domain))
  34.   (if (eql (domain-of elt) d) elt
  35.       (unless *coercibility-checking*
  36.     (error "Don't know how to coerce ~S to be an element of ~S" elt d))))
  37.  
  38. ;; This root method is here so we can always use :around methods with coerce.
  39. (defmethod coerce (elt (d domain))
  40.   (unless *coercibility-checking*
  41.     (error "Don't know how to coerce ~S to be an element of ~S" elt d)))
  42.  
  43. (defmethod coercible? (elt (d domain))
  44.   (let ((*coercibility-checking* t))
  45.     (coerce elt d)))
  46.  
  47. (defmethod coerce ((value number) (domain lisp-numbers))
  48.   value)
  49.  
  50. (defmethod coerce ((value integer) (domain rational-integers))
  51.   (make-element domain value))
  52.  
  53. (defmethod coerce ((value integer) (domain GFp))
  54.   (make-element domain value))
  55.  
  56. (defmethod coerce ((value integer) (domain GFm))
  57.   (make-element domain value 0))
  58.  
  59. (defmethod coerce ((value ratio) (domain GFp))
  60.   (make-element domain (lisp:* (lisp:numerator value)
  61.                    (compute-inverse (lisp:denominator value)
  62.                         (characteristic domain)))))
  63.  
  64. (defmethod coerce ((elt GFp-element) (domain GFm))
  65.   (with-slots (value d1) elt
  66.     (make-element domain value (characteristic d1))))
  67.  
  68. ;; Real number coercions
  69. (defmethod coerce ((number bigfloat) (domain real-numbers))
  70.   number)
  71.  
  72. ;;  This function converts an integer intgr to a BigFloat.
  73. (defmethod coerce ((int integer) (domain real-numbers))
  74.   (make-bigfloat domain int 0))
  75.  
  76. (defmethod coerce ((number float) (domain real-numbers))
  77.   (bind-domain-context domain
  78.     (read!num (format nil "~E" number))))
  79.  
  80. (defmethod coerce ((r ratio) (domain real-numbers))
  81.   (/ (make-bigfloat domain (lisp::numerator r) 0)
  82.      (make-bigfloat domain (lisp::denominator r) 0)))
  83.  
  84. (defmethod coerce ((number float) (domain floating-point-numbers))
  85.   number)
  86.  
  87. (defmethod coerce ((number quotient-element) (domain floating-point-numbers))
  88.   (let ((num (coerce (numerator number) domain))
  89.     (den (coerce (denominator number) domain)))
  90.     (if (or (null num) (null den))
  91.     (unless *coercibility-checking*
  92.       (error "Can't coerce ~S into ~D" number domain))
  93.     (/ num den))))
  94.  
  95. (defmethod coerce ((int integer) (domain floating-point-numbers))
  96.   (float int 1.0d0))
  97.  
  98. (defmethod coerce ((number string) (domain real-numbers))
  99.   (read!num number))
  100.  
  101. (defmethod coerce ((number bigfloat) (domain rational-integers))
  102.   (with-slots (mantissa exponent) (cut!ep number 0)
  103.     (if (0? exponent) mantissa
  104.     (lisp:* mantissa (lisp:expt 10 exponent)))))
  105.  
  106.  
  107. ;; Modules We assume that Lisp numbers can always be coerced into
  108. ;; modules.  The generic function embed-coefficient* is used to embed a
  109. ;; domain-element into the the coefficient domain of a module.  The *
  110. ;; indicates that it doesn't bother checking to see if the elt is
  111. ;; actually an element of the coefficient.  embed-coefficient does the checking.
  112.  
  113. (defmacro define-module-coercions (&rest types)
  114.   `(progn
  115.      ,@(loop for type in types
  116.          collect
  117.            `(defmethod coerce :around ((number ,type) (domain module))
  118.           (let* ((coefficient-domain (coefficient-domain domain))
  119.              coef)
  120.             (if (and coefficient-domain
  121.                  (setq coef (coercible? number coefficient-domain)))
  122.             (embed-coefficient* coef domain)
  123.             (call-next-method number domain)))))))
  124.  
  125. (define-module-coercions integer float ratio rational-number)
  126.  
  127. (defmethod embed-coefficient (elt (domain module))
  128.   (if (eql (domain-of elt) (coefficient-domain domain))
  129.       (embed-coefficient* elt domain)
  130.       (error "~S is not an element of the coefficient domain of ~S"
  131.          elt domain)))
  132.  
  133. ;; Derivatives
  134.  
  135. (defmethod coerce ((variable list) (domain differential-polynomial-ring))
  136.   (cond ((member variable (ring-variables domain))
  137.      (make-polynomial domain
  138.               (cons (variable-index domain variable)
  139.                 (make-terms 1 (one (coefficient-domain domain))))))
  140.     ((and (not (atom variable))
  141.           (eql (first variable) 'deriv))
  142.      (loop for i below (third variable)
  143.            for p = (deriv (coerce (second variable) domain)) then (deriv p)
  144.            finally (return p)))
  145.     ((coercible? variable (coefficient-domain domain)))
  146.     (t (call-next-method variable domain))))
  147.  
  148. ;; Quotient fields
  149.  
  150. (defmethod coerce ((int integer) (qf quotient-field))
  151.   (make-instance 'rational-function :domain qf
  152.          :numerator (coerce int (QF-ring qf))
  153.          :denominator (coerce 1 (QF-ring qf))))
  154.  
  155. ;; Rational numbers
  156.  
  157. (defmethod coerce ((int integer) (Q rational-numbers))
  158.   (make-instance 'rational-number :domain q :numerator int :denominator 1))
  159.  
  160. (defmethod coerce ((r ratio) (Q rational-numbers))
  161.   (make-instance 'rational-number :domain q
  162.          :numerator (lisp:numerator r)
  163.          :denominator (lisp:denominator r)))
  164.  
  165.  
  166. ;; This code provides primary methods for those situations when all
  167. ;; applicable methods are :around methods.
  168.  
  169. (defvar *coerce-where-possible* nil)
  170.  
  171. (defmacro def-binary-coercion (op illegal-mess ambig-mess)
  172.   `(defmethod ,op (x y)
  173.      (when (null *coerce-where-possible*)
  174.        (error ,illegal-mess x y))
  175.      (let ((domain-x (domain-of x))
  176.        (domain-y (domain-of y))
  177.        temp-x temp-y)
  178.        (when (eql domain-x domain-y)
  179.      (error ,illegal-mess x y))
  180.        (setq temp-x (coercible? x domain-y))
  181.        (setq temp-y (coercible? y domain-x))
  182.        (cond ((and temp-x temp-y)
  183.           (error ,ambig-mess  x y))
  184.          (temp-x
  185.           (,op temp-x y))
  186.          (temp-y
  187.           (,op x temp-y))
  188.          (t 
  189.           (error ,illegal-mess x y))))))
  190.  
  191. (def-binary-coercion plus
  192.   "No way to add ~S and ~S"
  193.   "Ambiguous coercion for addition ( ~S, ~S)")
  194.  
  195. (def-binary-coercion difference
  196.   "No way to subtract ~S and ~S"
  197.   "Ambiguous coercion for subtraction ( ~S, ~S)")
  198.  
  199. (def-binary-coercion times
  200.   "No way to multiply ~S and ~S"
  201.   "Ambiguous coercion for multiplication ( ~S, ~S)")
  202.  
  203. (def-binary-coercion quotient
  204.   "No way to compute the quotient of  ~S and ~S"
  205.   "Ambiguous coercion for division ( ~S, ~S)")
  206.  
  207. ;; There is always a canonical map of the integers into any domain.  The
  208. ;; following methods indicate that we should use that map for the common
  209. ;; operations.
  210.  
  211. (defmethod plus ((x integer) y)
  212.   (let ((xx (coerce x (domain-of y))))
  213.     (if (eql xx x)
  214.     (error "Infinite recursion in PLUS ~S ~S" x y)
  215.     (plus xx y))))
  216.  
  217. (defmethod plus (x (y integer))
  218.   (let ((yy (coerce y (domain-of x))))
  219.     (if (eql yy y)
  220.     (error "Infinite recursion in PLUS ~S ~S" x y)
  221.     (plus x yy))))
  222.  
  223. (defmethod difference ((x integer) y)
  224.   (let ((xx (coerce x (domain-of y))))
  225.     (if (eql xx x)
  226.     (error "Infinite recursion in DIFFERENCE ~S ~S" x y)
  227.     (difference xx y))))
  228.  
  229. (defmethod difference (x (y integer))
  230.   (let ((yy (coerce y (domain-of x))))
  231.     (if (eql yy y)
  232.     (error "Infinite recursion in DIFFERENCE ~S ~S" x y)
  233.     (difference x yy))))
  234.  
  235. (defmethod times ((x integer) y)
  236.   (let ((xx (coerce x (domain-of y))))
  237.     (if (eql xx x)
  238.     (error "Infinite recursion in TIMES ~S ~S" x y)
  239.     (times xx y))))
  240.  
  241. (defmethod times (x (y integer))
  242.   (let ((yy (coerce y (domain-of x))))
  243.     (if (eql yy y)
  244.     (error "Infinite recursion in TIMES ~S ~S" x y)
  245.     (times x yy))))
  246.  
  247. (defmethod quotient ((x integer) y)
  248.   (let ((xx (coerce x (domain-of y))))
  249.     (if (eql xx x)
  250.     (error "Infinite recursion in QUOTIENT ~S ~S" x y)
  251.     (quotient xx y))))
  252.  
  253. (defmethod quotient (x (y integer))
  254.   (let ((yy (coerce y (domain-of x))))
  255.     (if (eql yy y)
  256.     (error "Infinite recursion in QUOTIENT ~S ~S" x y)
  257.     (quotient x yy))))
  258.