X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/6664fc59a8f296117ea98b943f062c0cc0e907c1..771fc75ee915ce4cbf6f257a82e22ea49462df72:/lisp/calc/calc-units.el

diff --git a/lisp/calc/calc-units.el b/lisp/calc/calc-units.el
index a88e87dffb..e6a6fb0113 100644
--- a/lisp/calc/calc-units.el
+++ b/lisp/calc/calc-units.el
@@ -1,7 +1,6 @@
 ;;; calc-units.el --- unit conversion functions for Calc
 
-;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004, 2005,
-;;   2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1990-1993, 2001-2011  Free Software Foundation, Inc.
 
 ;; Author: David Gillespie <daveg@synaptics.com>
 ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
@@ -57,23 +56,23 @@
               "149597870691 m (*)")
               ;; (approx) NASA JPL (http://neo.jpl.nasa.gov/glossary/au.html)
     ( lyr     "c yr"                 "Light Year" )
-    ( pc      "3.0856775854*10^16 m" "Parsec" nil
+    ( pc      "3.0856775854*10^16 m" "Parsec  (**)" nil
               "3.0856775854 10^16 m (*)") ;; (approx) ESUWM
     ( nmi     "1852 m"               "Nautical Mile" )
     ( fath    "6 ft"                 "Fathom" )
     ( fur     "660 ft"               "Furlong")
     ( mu      "1 um"                 "Micron" )
     ( mil     "(1/1000) in"          "Mil" )
-    ( point   "(1/72) in"            "Point (1/72 inch)" )
+    ( point   "(1/72) in"            "Point  (PostScript convention)" )
     ( Ang     "10^(-10) m"           "Angstrom" )
     ( mfi     "mi+ft+in"             "Miles + feet + inches" )
     ;; TeX lengths
-    ( texpt   "(100/7227) in"        "Point (TeX conventions)" )
-    ( texpc   "12 texpt"             "Pica" )
-    ( texbp   "point"                "Big point (TeX conventions)" )
-    ( texdd   "(1238/1157) texpt"    "Didot point" )
-    ( texcc   "12 texdd"             "Cicero" )
-    ( texsp   "(1/65536) texpt"      "Scaled TeX point" )
+    ( texpt   "(100/7227) in"        "Point  (TeX convention) (**)" )
+    ( texpc   "12 texpt"             "Pica  (TeX convention) (**)" )
+    ( texbp   "point"                "Big point  (TeX convention) (**)" )
+    ( texdd   "(1238/1157) texpt"    "Didot point  (TeX convention) (**)" )
+    ( texcc   "12 texdd"             "Cicero  (TeX convention) (**)" )
+    ( texsp   "(1/65536) texpt"      "Scaled TeX point (TeX convention) (**)" )
 
     ;; Area
     ( hect    "10000 m^2"            "*Hectare" )
@@ -86,7 +85,7 @@
     ( l       "L"                    "Liter" )
     ( gal     "4 qt"                 "US Gallon" )
     ( qt      "2 pt"                 "Quart" )
-    ( pt      "2 cup"                "Pint" )
+    ( pt      "2 cup"                "Pint (**)" )
     ( cup     "8 ozfl"               "Cup" )
     ( ozfl    "2 tbsp"               "Fluid Ounce" )
     ( floz    "2 tbsp"               "Fluid Ounce" )
@@ -296,7 +295,10 @@
     ( R0      "8.314472 J/(mol K)"          "Molar gas constant" nil
               "8.314472 J/(mol K) (*)")
     ( V0      "22.710981*10^(-3) m^3/mol"   "Standard volume of ideal gas" nil
-              "22.710981 10^-3 m^3/mol (*)")))
+              "22.710981 10^-3 m^3/mol (*)")
+    ;; Logarithmic units
+    ( Np      nil    "*Neper")
+    ( dB      "(ln(10)/20) Np" "decibel")))
 
 
 (defvar math-additional-units nil
@@ -871,6 +873,7 @@ If EXPR is nil, return nil."
 	   (or (eq (nth 1 expr) 'pi)
 	       (error "Unknown name %s in defining expression for unit %s"
 		      (nth 1 expr) (car math-fbu-entry))))
+          ((equal expr '(calcFunc-ln 10)))
 	  (t (error "Malformed defining expression for unit %s" (car math-fbu-entry))))))
 
 
@@ -1531,7 +1534,12 @@ If EXPR is nil, return nil."
               (indent-to 15)
               (insert "   " (nth 2 u) "\n")
               (while (eq (car (car (setq uptr (cdr uptr)))) 0)))
-            (insert "\n"))
+            (insert "\n\n")
+            (insert "(**) When in TeX or LaTeX display mode, the TeX specific unit\n"
+                     "names will not use the `tex' prefix; the unit name for a\n"
+                     "TeX point will be `pt' instead of `texpt', for example.\n"
+                     "To avoid conflicts, the unit names for pint and parsec will\n"
+                     "be `pint' and `parsec' instead of `pt' and `pc'."))
 	  (view-mode)
 	  (message "Formatting units table...done"))
 	(setq math-units-table-buffer-valid t)
@@ -1546,11 +1554,312 @@ If EXPR is nil, return nil."
 	(pop-to-buffer (get-buffer "*Units Table*"))
       (display-buffer (get-buffer "*Units Table*")))))
 
+;;; Logarithmic units functions
+
+(defvar math-logunits '((var dB var-dB)
+                        (var Np var-Np)))
+
+(defun math-conditional-apply (fn &rest args)
+  "Evaluate f(args) unless in symbolic mode.
+In symbolic mode, return the list (fn args)."
+  (if calc-symbolic-mode
+      (cons fn args)
+    (apply fn args)))
+
+(defun math-conditional-pow (a b)
+  "Evaluate a^b unless in symbolic mode.
+In symbolic mode, return the list (^ a b)."
+  (if calc-symbolic-mode
+      (list '^ a b)
+    (math-pow a b)))
+
+(defun math-extract-logunits (expr)
+  (if (memq (car-safe expr) '(* /))
+      (cons (car expr)
+	    (mapcar 'math-extract-logunits (cdr expr)))
+    (if (memq (car-safe expr) '(^))
+        (list '^ (math-extract-logunits (nth 1 expr)) (nth 2 expr))
+      (if (member expr math-logunits) expr 1))))
+
+(defun math-logunits-add (a b neg power)
+  (let ((aunit (math-simplify (math-extract-logunits a))))
+    (if (not (eq (car-safe aunit) 'var))
+        (calc-record-why "*Improper logarithmic unit" aunit)
+      (let* ((units (math-extract-units a))
+            (acoeff (math-simplify (math-remove-units a)))
+            (bcoeff (math-simplify (math-to-standard-units
+                                    (list '/ b units) nil))))
+        (if (math-units-in-expr-p bcoeff nil)
+            (calc-record-why "*Inconsistent units" nil)
+          (if (and neg
+                   (or (math-lessp acoeff bcoeff)
+                       (math-equal acoeff bcoeff)))
+              (calc-record-why "*Improper coefficients" nil)
+            (math-mul 
+             (if (equal aunit '(var dB var-dB))
+                 (let ((coef (if power 10 20)))
+                   (math-mul coef
+                             (math-conditional-apply 'calcFunc-log10
+                              (if neg
+                                  (math-sub
+                                   (math-conditional-pow 10 (math-div acoeff coef))
+                                   (math-conditional-pow 10 (math-div bcoeff coef)))
+                                (math-add
+                                 (math-conditional-pow 10 (math-div acoeff coef))
+                                 (math-conditional-pow 10 (math-div bcoeff coef)))))))
+               (let ((coef (if power 2 1)))
+                 (math-div
+                  (math-conditional-apply 'calcFunc-ln
+                   (if neg
+                       (math-sub
+                        (math-conditional-apply 'calcFunc-exp (math-mul coef acoeff))
+                        (math-conditional-apply 'calcFunc-exp (math-mul coef bcoeff)))
+                     (math-add
+                      (math-conditional-apply 'calcFunc-exp (math-mul coef acoeff))
+                      (math-conditional-apply 'calcFunc-exp (math-mul coef bcoeff)))))
+                  coef)))
+             units)))))))
+
+(defun calcFunc-lufieldplus (a b)
+  (math-logunits-add a b nil nil))
+
+(defun calcFunc-lupowerplus (a b)
+  (math-logunits-add a b nil t))
+
+(defun calcFunc-lufieldminus (a b)
+  (math-logunits-add a b t nil))
+
+(defun calcFunc-lupowerminus (a b)
+  (math-logunits-add a b t t))
+
+(defun calc-logunits-add (arg)
+  (interactive "P")
+  (calc-slow-wrapper
+   (if (calc-is-inverse)
+       (if (calc-is-hyperbolic)
+           (calc-binary-op "lu-" 'calcFunc-lufieldminus arg)
+         (calc-binary-op "lu-" 'calcFunc-lupowerminus arg))
+     (if (calc-is-hyperbolic)
+         (calc-binary-op "lu+" 'calcFunc-lufieldplus arg)
+       (calc-binary-op "lu+" 'calcFunc-lupowerplus arg)))))
+
+(defun calc-logunits-sub (arg)
+  (interactive "P")
+  (calc-slow-wrapper
+   (if (calc-is-inverse)
+       (if (calc-is-hyperbolic)
+           (calc-binary-op "lu+" 'calcFunc-lufieldplus arg)
+         (calc-binary-op "lu+" 'calcFunc-lupowerplus arg))
+     (if (calc-is-hyperbolic)
+         (calc-binary-op "lu-" 'calcFunc-lufieldminus arg)
+       (calc-binary-op "lu-" 'calcFunc-lupowerminus arg)))))
+
+(defun math-logunits-mul (a b power)
+  (let (logunit coef units number)
+    (cond
+     ((and
+       (setq logunit (math-simplify (math-extract-logunits a)))
+       (eq (car-safe logunit) 'var)
+       (eq (math-simplify (math-extract-units b)) 1))
+      (setq coef (math-simplify (math-remove-units a))
+            units (math-extract-units a)
+            number b))
+     ((and
+       (setq logunit (math-simplify (math-extract-logunits b)))
+       (eq (car-safe logunit) 'var)
+       (eq (math-simplify (math-extract-units a)) 1))
+      (setq coef (math-simplify (math-remove-units b))
+            units (math-extract-units b)
+            number a))
+     (t (setq logunit nil)))
+    (if logunit
+        (cond
+         ((equal logunit '(var dB var-dB))
+          (math-simplify
+           (math-mul
+            (math-add
+             coef 
+             (math-mul (if power 10 20)
+                       (math-conditional-apply 'calcFunc-log10 number)))
+            units)))
+         (t
+          (math-simplify
+           (math-mul
+            (math-add
+             coef 
+             (math-div (math-conditional-apply 'calcFunc-ln number) (if power 2 1)))
+            units))))
+      (calc-record-why "*Improper units" nil))))
+
+(defun math-logunits-divide (a b power)
+  (let ((logunit (math-simplify (math-extract-logunits a))))
+    (if (not (eq (car-safe logunit) 'var))
+        (calc-record-why "*Improper logarithmic unit" logunit)
+      (if (math-units-in-expr-p b nil)
+          (calc-record-why "*Improper units quantity" b)
+        (let* ((units (math-extract-units a))
+               (coef (math-simplify (math-remove-units a))))
+          (cond
+           ((equal logunit '(var dB var-dB))
+            (math-simplify
+             (math-mul
+              (math-sub
+               coef 
+               (math-mul (if power 10 20)
+                         (math-conditional-apply 'calcFunc-log10 b)))
+              units)))
+         (t
+          (math-simplify
+           (math-mul
+            (math-sub
+             coef 
+             (math-div (math-conditional-apply 'calcFunc-ln b) (if power 2 1)))
+            units)))))))))
+
+(defun calcFunc-lufieldtimes (a b)
+  (math-logunits-mul a b nil))
+
+(defun calcFunc-lupowertimes (a b)
+  (math-logunits-mul a b t))
+
+(defun calc-logunits-mul (arg)
+  (interactive "P")
+  (calc-slow-wrapper
+   (if (calc-is-inverse)
+       (if (calc-is-hyperbolic)
+           (calc-binary-op "lu/" 'calcFunc-lufielddiv arg)
+         (calc-binary-op "lu/" 'calcFunc-lupowerdiv arg))
+     (if (calc-is-hyperbolic)
+         (calc-binary-op "lu*" 'calcFunc-lufieldtimes arg)
+       (calc-binary-op "lu*" 'calcFunc-lupowertimes arg)))))
+
+(defun calcFunc-lufielddiv (a b)
+  (math-logunits-divide a b nil))
+
+(defun calcFunc-lupowerdiv (a b)
+  (math-logunits-divide a b t))
+
+(defun calc-logunits-divide (arg)
+  (interactive "P")
+  (calc-slow-wrapper
+   (if (calc-is-inverse)
+       (if (calc-is-hyperbolic)
+           (calc-binary-op "lu*" 'calcFunc-lufieldtimes arg)
+         (calc-binary-op "lu*" 'calcFunc-lupowertimes arg))
+     (if (calc-is-hyperbolic)
+         (calc-binary-op "lu/" 'calcFunc-lufielddiv arg)
+       (calc-binary-op "lu/" 'calcFunc-lupowerdiv arg)))))
+
+(defun math-logunits-quant (val ref power)
+  (let* ((units (math-simplify (math-extract-units val)))
+         (lunit (math-simplify (math-extract-logunits units))))
+    (if (not (eq (car-safe lunit) 'var))
+        (calc-record-why "*Improper logarithmic unit" lunit)
+      (let ((runits (math-simplify (math-div units lunit)))
+            (coeff (math-simplify (math-div val units))))
+        (math-mul
+         (if (equal lunit '(var dB var-dB))
+             (math-mul 
+              ref
+              (math-conditional-pow 
+               10
+               (math-div
+                coeff
+                (if power 10 20))))
+           (math-mul 
+            ref
+            (math-conditional-apply 'calcFunc-exp
+             (if power 
+                 (math-mul 2 coeff)
+               coeff))))
+         runits)))))
+
+(defvar calc-logunits-field-reference)
+(defvar calc-logunits-power-reference)
+
+(defun calcFunc-fieldquant (val &optional ref)
+  (unless ref
+    (setq ref (math-read-expr calc-logunits-field-reference)))
+  (math-logunits-quant val ref nil))
+
+(defun calcFunc-powerquant (val &optional ref)
+  (unless ref
+    (setq ref (math-read-expr calc-logunits-power-reference)))
+  (math-logunits-quant val ref t))
+
+(defun calc-logunits-quantity (arg)
+  (interactive "P")
+  (calc-slow-wrapper
+   (if (calc-is-hyperbolic)
+       (if (calc-is-option)
+           (calc-binary-op "lupq" 'calcFunc-fieldquant arg)
+         (calc-unary-op "lupq" 'calcFunc-fieldquant arg))
+     (if (calc-is-option)
+         (calc-binary-op "lufq" 'calcFunc-powerquant arg)
+       (calc-unary-op "lufq" 'calcFunc-powerquant arg)))))
+
+(defun math-logunits-level (val ref db power)
+  "Compute the value of VAL in decibels or nepers."
+      (let* ((ratio (math-simplify-units (math-div val ref)))
+             (ratiou (math-simplify-units (math-remove-units ratio)))
+             (units (math-simplify (math-extract-units ratio))))
+        (math-mul
+         (if db
+             (math-mul
+              (math-mul (if power 10 20)
+                        (math-conditional-apply 'calcFunc-log10 ratiou))
+              '(var dB var-dB))
+           (math-mul
+            (math-div (math-conditional-apply 'calcFunc-ln ratiou) (if power 2 1))
+            '(var Np var-Np)))
+         units)))
+
+(defun calcFunc-dbfieldlevel (val &optional ref)
+  (unless ref
+    (setq ref (math-read-expr calc-logunits-field-reference)))
+  (math-logunits-level val ref t nil))
+
+(defun calcFunc-dbpowerlevel (val &optional ref)
+  (unless ref
+    (setq ref (math-read-expr calc-logunits-power-reference)))
+  (math-logunits-level val ref t t))
+
+(defun calcFunc-npfieldlevel (val &optional ref)
+  (unless ref
+    (setq ref (math-read-expr calc-logunits-field-reference)))
+  (math-logunits-level val ref nil nil))
+
+(defun calcFunc-nppowerlevel (val &optional ref)
+  (unless ref
+    (setq ref (math-read-expr calc-logunits-power-reference)))
+  (math-logunits-level val ref nil t))
+
+(defun calc-logunits-dblevel (arg)
+  (interactive "P")
+  (calc-slow-wrapper
+   (if (calc-is-hyperbolic)
+       (if (calc-is-option)
+           (calc-binary-op "ludb" 'calcFunc-dbfieldlevel arg)
+         (calc-unary-op "ludb" 'calcFunc-dbfieldlevel arg))
+     (if (calc-is-option)
+         (calc-binary-op "ludb" 'calcFunc-dbpowerlevel arg)
+       (calc-unary-op "ludb" 'calcFunc-dbpowerlevel arg)))))
+
+(defun calc-logunits-nplevel (arg)
+  (interactive "P")
+  (calc-slow-wrapper
+   (if (calc-is-hyperbolic)
+       (if (calc-is-option)
+           (calc-binary-op "lunp" 'calcFunc-npfieldlevel arg)
+         (calc-unary-op "lunp" 'calcFunc-npfieldlevel arg))
+     (if (calc-is-option)
+         (calc-binary-op "lunp" 'calcFunc-nppowerlevel arg)
+       (calc-unary-op "lunp" 'calcFunc-nppowerlevel arg)))))
+
 (provide 'calc-units)
 
 ;; Local variables:
 ;; coding: utf-8
 ;; End:
 
-;; arch-tag: e993314f-3adc-4191-be61-4ef8874881c4
 ;;; calc-units.el ends here