/[emacs]/emacs/lisp/calc/calc-units.el
ViewVC logotype

Diff of /emacs/lisp/calc/calc-units.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.9 by jpb, Wed Nov 17 19:23:41 2004 UTC revision 1.10 by jpb, Thu Nov 25 05:53:35 2004 UTC
# Line 313  Entries are (SYMBOL EXPR DOC-STRING TEMP Line 313  Entries are (SYMBOL EXPR DOC-STRING TEMP
313    (calc-slow-wrapper    (calc-slow-wrapper
314     (let ((expr (calc-top-n 1))     (let ((expr (calc-top-n 1))
315           (uoldname nil)           (uoldname nil)
316           unew)           unew
317             units)
318       (unless (math-units-in-expr-p expr t)       (unless (math-units-in-expr-p expr t)
319         (let ((uold (or old-units         (let ((uold (or old-units
320                         (progn                         (progn
# Line 409  Entries are (SYMBOL EXPR DOC-STRING TEMP Line 410  Entries are (SYMBOL EXPR DOC-STRING TEMP
410     (calc-enter-result 1 "rmun" (math-simplify-units     (calc-enter-result 1 "rmun" (math-simplify-units
411                                  (math-extract-units (calc-top-n 1))))))                                  (math-extract-units (calc-top-n 1))))))
412    
413    ;; The variables calc-num-units and calc-den-units are local to
414    ;; calc-explain-units, but are used by calc-explain-units-rec,
415    ;; which is called by calc-explain-units.
416    (defvar calc-num-units)
417    (defvar calc-den-units)
418    
419  (defun calc-explain-units ()  (defun calc-explain-units ()
420    (interactive)    (interactive)
421    (calc-wrapper    (calc-wrapper
422     (let ((num-units nil)     (let ((calc-num-units nil)
423           (den-units nil))           (calc-den-units nil))
424       (calc-explain-units-rec (calc-top-n 1) 1)       (calc-explain-units-rec (calc-top-n 1) 1)
425       (and den-units (string-match "^[^(].* .*[^)]$" den-units)       (and calc-den-units (string-match "^[^(].* .*[^)]$" calc-den-units)
426            (setq den-units (concat "(" den-units ")")))            (setq calc-den-units (concat "(" calc-den-units ")")))
427       (if num-units       (if calc-num-units
428           (if den-units           (if calc-den-units
429               (message "%s per %s" num-units den-units)               (message "%s per %s" calc-num-units calc-den-units)
430             (message "%s" num-units))             (message "%s" calc-num-units))
431         (if den-units         (if calc-den-units
432             (message "1 per %s" den-units)             (message "1 per %s" calc-den-units)
433           (message "No units in expression"))))))           (message "No units in expression"))))))
434    
435  (defun calc-explain-units-rec (expr pow)  (defun calc-explain-units-rec (expr pow)
# Line 463  Entries are (SYMBOL EXPR DOC-STRING TEMP Line 470  Entries are (SYMBOL EXPR DOC-STRING TEMP
470                   (setq name (concat name "^"                   (setq name (concat name "^"
471                                      (math-format-number (math-abs pow))))))                                      (math-format-number (math-abs pow))))))
472            (if (math-posp pow)            (if (math-posp pow)
473                (setq num-units (if num-units                (setq calc-num-units (if calc-num-units
474                                    (concat num-units " " name)                                    (concat calc-num-units " " name)
475                                  name))                                  name))
476              (setq den-units (if den-units              (setq calc-den-units (if calc-den-units
477                                  (concat den-units " " name)                                  (concat calc-den-units " " name)
478                                name))))                                name))))
479        (cond ((eq (car-safe expr) '*)        (cond ((eq (car-safe expr) '*)
480               (calc-explain-units-rec (nth 1 expr) pow)               (calc-explain-units-rec (nth 1 expr) pow)
# Line 615  Entries are (SYMBOL EXPR DOC-STRING TEMP Line 622  Entries are (SYMBOL EXPR DOC-STRING TEMP
622       (save-buffer))))       (save-buffer))))
623    
624    
625    ;; The variable math-cu-unit-list is local to math-build-units-table,
626    ;; but is used by math-compare-unit-names, which is called (indirectly)
627    ;; by math-build-units-table.
628    ;; math-cu-unit-list is also local to math-convert-units, but is used
629    ;; by math-convert-units-rec, which is called by math-convert-units.
630    (defvar math-cu-unit-list)
631    
632  (defun math-build-units-table ()  (defun math-build-units-table ()
633    (or math-units-table    (or math-units-table
634        (let* ((combined-units (append math-additional-units        (let* ((combined-units (append math-additional-units
635                                       math-standard-units))                                       math-standard-units))
636               (unit-list (mapcar 'car combined-units))               (math-cu-unit-list (mapcar 'car combined-units))
637               tab)               tab)
638          (message "Building units table...")          (message "Building units table...")
639          (setq math-units-table-buffer-valid nil)          (setq math-units-table-buffer-valid nil)
# Line 646  Entries are (SYMBOL EXPR DOC-STRING TEMP Line 659  Entries are (SYMBOL EXPR DOC-STRING TEMP
659          (message "Building units table...done")          (message "Building units table...done")
660          (setq math-units-table tab))))          (setq math-units-table tab))))
661    
662    ;; The variables math-fbu-base and math-fbu-entry are local to
663    ;; math-find-base-units, but are used by math-find-base-units-rec,
664    ;; which is called by math-find-base-units.
665    (defvar math-fbu-base)
666    (defvar math-fbu-entry)
667    
668  (defun math-find-base-units (entry)  (defun math-find-base-units (entry)
669    (if (eq (nth 4 entry) 'boom)    (if (eq (nth 4 entry) 'boom)
670        (error "Circular definition involving unit %s" (car entry)))        (error "Circular definition involving unit %s" (car entry)))
# Line 667  Entries are (SYMBOL EXPR DOC-STRING TEMP Line 686  Entries are (SYMBOL EXPR DOC-STRING TEMP
686          base)))          base)))
687    
688  (defun math-compare-unit-names (a b)  (defun math-compare-unit-names (a b)
689    (memq (car b) (cdr (memq (car a) unit-list))))    (memq (car b) (cdr (memq (car a) math-cu-unit-list))))
690    
691  (defun math-find-base-units-rec (expr pow)  (defun math-find-base-units-rec (expr pow)
692    (let ((u (math-check-unit-name expr)))    (let ((u (math-check-unit-name expr)))
# Line 751  Entries are (SYMBOL EXPR DOC-STRING TEMP Line 770  Entries are (SYMBOL EXPR DOC-STRING TEMP
770                             (assq (intern (substring name 3))                             (assq (intern (substring name 3))
771                                   math-units-table))))))))                                   math-units-table))))))))
772    
773    ;; The variable math-which-standard is local to math-to-standard-units,
774    ;; but is used by math-to-standard-rec, which is called by
775    ;; math-to-standard-units.
776    (defvar math-which-standard)
777    
778  (defun math-to-standard-units (expr which-standard)  (defun math-to-standard-units (expr math-which-standard)
779    (math-to-standard-rec expr))    (math-to-standard-rec expr))
780    
781  (defun math-to-standard-rec (expr)  (defun math-to-standard-rec (expr)
# Line 763  Entries are (SYMBOL EXPR DOC-STRING TEMP Line 786  Entries are (SYMBOL EXPR DOC-STRING TEMP
786              (progn              (progn
787                (if (nth 1 u)                (if (nth 1 u)
788                    (setq expr (math-to-standard-rec (nth 1 u)))                    (setq expr (math-to-standard-rec (nth 1 u)))
789                  (let ((st (assq (car u) which-standard)))                  (let ((st (assq (car u) math-which-standard)))
790                    (if st                    (if st
791                        (setq expr (nth 1 st))                        (setq expr (nth 1 st))
792                      (setq expr (list 'var (car u)                      (setq expr (list 'var (car u)
# Line 842  Entries are (SYMBOL EXPR DOC-STRING TEMP Line 865  Entries are (SYMBOL EXPR DOC-STRING TEMP
865                                                  unit nil))                                                  unit nil))
866                            t)))                            t)))
867    
868    ;; The variable math-fcu-u is local to math-find-compatible-unit,
869    ;; but is used by math-find-compatible-rec which is called by
870    ;; math-find-compatible-unit.
871    (defvar math-fcu-u)
872    
873  (defun math-find-compatible-unit (expr unit)  (defun math-find-compatible-unit (expr unit)
874    (let ((u (math-check-unit-name unit)))    (let ((math-fcu-u (math-check-unit-name unit)))
875      (if u      (if math-fcu-u
876          (math-find-compatible-unit-rec expr 1))))          (math-find-compatible-unit-rec expr 1))))
877    
878  (defun math-find-compatible-unit-rec (expr pow)  (defun math-find-compatible-unit-rec (expr pow)
# Line 859  Entries are (SYMBOL EXPR DOC-STRING TEMP Line 887  Entries are (SYMBOL EXPR DOC-STRING TEMP
887           (math-find-compatible-unit-rec (nth 1 expr) (* pow (nth 2 expr))))           (math-find-compatible-unit-rec (nth 1 expr) (* pow (nth 2 expr))))
888          (t          (t
889           (let ((u2 (math-check-unit-name expr)))           (let ((u2 (math-check-unit-name expr)))
890             (if (equal (nth 4 u) (nth 4 u2))             (if (equal (nth 4 math-fcu-u) (nth 4 u2))
891                 (cons expr pow))))))                 (cons expr pow))))))
892    
893  (defun math-convert-units (expr new-units &optional pure)  ;; The variables math-cu-new-units and math-cu-pure are local to
894    ;; math-convert-units, but are used by math-convert-units-rec,
895    ;; which is called by math-convert-units.
896    (defvar math-cu-new-units)
897    (defvar math-cu-pure)
898    
899    (defun math-convert-units (expr math-cu-new-units &optional math-cu-pure)
900    (math-with-extra-prec 2    (math-with-extra-prec 2
901      (let ((compat (and (not pure) (math-find-compatible-unit expr new-units)))      (let ((compat (and (not math-cu-pure)
902            (unit-list nil)                         (math-find-compatible-unit expr math-cu-new-units)))
903              (math-cu-unit-list nil)
904            (math-combining-units nil))            (math-combining-units nil))
905        (if compat        (if compat
906            (math-simplify-units            (math-simplify-units
907             (math-mul (math-mul (math-simplify-units             (math-mul (math-mul (math-simplify-units
908                                  (math-div expr (math-pow (car compat)                                  (math-div expr (math-pow (car compat)
909                                                           (cdr compat))))                                                           (cdr compat))))
910                                 (math-pow new-units (cdr compat)))                                 (math-pow math-cu-new-units (cdr compat)))
911                       (math-simplify-units                       (math-simplify-units
912                        (math-to-standard-units                        (math-to-standard-units
913                         (math-pow (math-div (car compat) new-units)                         (math-pow (math-div (car compat) math-cu-new-units)
914                                   (cdr compat))                                   (cdr compat))
915                         nil))))                         nil))))
916          (when (setq unit-list (math-decompose-units new-units))          (when (setq math-cu-unit-list (math-decompose-units math-cu-new-units))
917            (setq new-units (nth 2 (car unit-list))))            (setq math-cu-new-units (nth 2 (car math-cu-unit-list))))
918          (when (eq (car-safe expr) '+)          (when (eq (car-safe expr) '+)
919            (setq expr (math-simplify-units expr)))            (setq expr (math-simplify-units expr)))
920          (if (math-units-in-expr-p expr t)          (if (math-units-in-expr-p expr t)
921              (math-convert-units-rec expr)              (math-convert-units-rec expr)
922            (math-apply-units (math-to-standard-units            (math-apply-units (math-to-standard-units
923                               (list '/ expr new-units) nil)                               (list '/ expr math-cu-new-units) nil)
924                              new-units unit-list pure))))))                              math-cu-new-units math-cu-unit-list math-cu-pure))))))
925    
926  (defun math-convert-units-rec (expr)  (defun math-convert-units-rec (expr)
927    (if (math-units-in-expr-p expr nil)    (if (math-units-in-expr-p expr nil)
928        (math-apply-units (math-to-standard-units (list '/ expr new-units) nil)        (math-apply-units (math-to-standard-units
929                          new-units unit-list pure)                           (list '/ expr math-cu-new-units) nil)
930                            math-cu-new-units math-cu-unit-list math-cu-pure)
931      (if (Math-primp expr)      (if (Math-primp expr)
932          expr          expr
933        (cons (car expr)        (cons (car expr)
# Line 1026  Entries are (SYMBOL EXPR DOC-STRING TEMP Line 1062  Entries are (SYMBOL EXPR DOC-STRING TEMP
1062                         (setcar unitp pname)                         (setcar unitp pname)
1063                         math-simplify-expr)))))))                         math-simplify-expr)))))))
1064    
1065    (defvar math-try-cancel-units)
1066    
1067  (math-defsimplify /  (math-defsimplify /
1068    (and math-simplifying-units    (and math-simplifying-units
1069         (let ((np (cdr math-simplify-expr))         (let ((np (cdr math-simplify-expr))
1070               (try-cancel-units 0)               (math-try-cancel-units 0)
1071               n nn)               n nn)
1072           (setq n (if (eq (car-safe (nth 2 math-simplify-expr)) '*)           (setq n (if (eq (car-safe (nth 2 math-simplify-expr)) '*)
1073                       (cdr (nth 2 math-simplify-expr))                       (cdr (nth 2 math-simplify-expr))
# Line 1044  Entries are (SYMBOL EXPR DOC-STRING TEMP Line 1082  Entries are (SYMBOL EXPR DOC-STRING TEMP
1082             (math-simplify-units-divisor (cdr n) (cdr (cdr math-simplify-expr)))             (math-simplify-units-divisor (cdr n) (cdr (cdr math-simplify-expr)))
1083             (setq np (cdr (cdr n))))             (setq np (cdr (cdr n))))
1084           (math-simplify-units-divisor np (cdr (cdr math-simplify-expr)))           (math-simplify-units-divisor np (cdr (cdr math-simplify-expr)))
1085           (if (eq try-cancel-units 0)           (if (eq math-try-cancel-units 0)
1086               (let* ((math-simplifying-units nil)               (let* ((math-simplifying-units nil)
1087                      (base (math-simplify                      (base (math-simplify
1088                             (math-to-standard-units math-simplify-expr nil))))                             (math-to-standard-units math-simplify-expr nil))))
# Line 1089  Entries are (SYMBOL EXPR DOC-STRING TEMP Line 1127  Entries are (SYMBOL EXPR DOC-STRING TEMP
1127                   (setq ud1 ud)                   (setq ud1 ud)
1128                   (while ud1                   (while ud1
1129                     (and (eq (car (car un)) (car (car ud1)))                     (and (eq (car (car un)) (car (car ud1)))
1130                          (setq try-cancel-units                          (setq math-try-cancel-units
1131                                (+ try-cancel-units                                (+ math-try-cancel-units
1132                                   (- (* (cdr (car un)) pow1)                                   (- (* (cdr (car un)) pow1)
1133                                      (* (cdr (car ud)) pow2)))))                                      (* (cdr (car ud)) pow2)))))
1134                     (setq ud1 (cdr ud1)))                     (setq ud1 (cdr ud1)))

Legend:
Removed from v.1.9  
changed lines
  Added in v.1.10

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26