Mercurial > emacs
comparison lisp/calc/calc-units.el @ 58508:589dc235628a
(calc-convert-units): Make units a local variable.
(calc-num-units, calc-den-units): New variables.
(calc-explain-units, calc-explain-units-rec): Replace variables
num-units and den-units by declared variables.
(math-cu-unit-list): New variable.
(math-build-units-table, math-compare-unit-names)
(math-convert-units, math-convert-units-rec): Replace variable
unit-list by declared variable.
(math-fbu-base, math-fbu-entry): New variables.
(math-find-base-units, math-find-base-units-rec): Replace variables
base and entry by declared variables.
(math-which-standard): New variable.
(math-to-standard-units, math-to-standard-rec): Replace variable
which-standard by declared variable.
(math-fcu-u): New variable.
(math-find-compatible-unit, math-find-compatible-unit-rec):
Replace variable u by declared variable.
(math-cu-new-units, math-cu-pure): New variables.
(math-convert-units, math-convert-units-rec): Replace variables
new-units and pure by declared variables.
(math-try-cancel-units): New variable.
(math-simplify-units-quotient): Replace variable try-cancel-units by
declared variable.
author | Jay Belanger <jay.p.belanger@gmail.com> |
---|---|
date | Thu, 25 Nov 2004 05:53:35 +0000 |
parents | 6ae80af2f94b |
children | 0a3797785946 |
comparison
equal
deleted
inserted
replaced
58507:c8e117d0c5ff | 58508:589dc235628a |
---|---|
311 (defun calc-convert-units (&optional old-units new-units) | 311 (defun calc-convert-units (&optional old-units new-units) |
312 (interactive) | 312 (interactive) |
313 (calc-slow-wrapper | 313 (calc-slow-wrapper |
314 (let ((expr (calc-top-n 1)) | 314 (let ((expr (calc-top-n 1)) |
315 (uoldname nil) | 315 (uoldname nil) |
316 unew) | 316 unew |
317 units) | |
317 (unless (math-units-in-expr-p expr t) | 318 (unless (math-units-in-expr-p expr t) |
318 (let ((uold (or old-units | 319 (let ((uold (or old-units |
319 (progn | 320 (progn |
320 (setq uoldname (read-string "Old units: ")) | 321 (setq uoldname (read-string "Old units: ")) |
321 (if (equal uoldname "") | 322 (if (equal uoldname "") |
407 (interactive) | 408 (interactive) |
408 (calc-slow-wrapper | 409 (calc-slow-wrapper |
409 (calc-enter-result 1 "rmun" (math-simplify-units | 410 (calc-enter-result 1 "rmun" (math-simplify-units |
410 (math-extract-units (calc-top-n 1)))))) | 411 (math-extract-units (calc-top-n 1)))))) |
411 | 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 | |
412 (defun calc-explain-units () | 419 (defun calc-explain-units () |
413 (interactive) | 420 (interactive) |
414 (calc-wrapper | 421 (calc-wrapper |
415 (let ((num-units nil) | 422 (let ((calc-num-units nil) |
416 (den-units nil)) | 423 (calc-den-units nil)) |
417 (calc-explain-units-rec (calc-top-n 1) 1) | 424 (calc-explain-units-rec (calc-top-n 1) 1) |
418 (and den-units (string-match "^[^(].* .*[^)]$" den-units) | 425 (and calc-den-units (string-match "^[^(].* .*[^)]$" calc-den-units) |
419 (setq den-units (concat "(" den-units ")"))) | 426 (setq calc-den-units (concat "(" calc-den-units ")"))) |
420 (if num-units | 427 (if calc-num-units |
421 (if den-units | 428 (if calc-den-units |
422 (message "%s per %s" num-units den-units) | 429 (message "%s per %s" calc-num-units calc-den-units) |
423 (message "%s" num-units)) | 430 (message "%s" calc-num-units)) |
424 (if den-units | 431 (if calc-den-units |
425 (message "1 per %s" den-units) | 432 (message "1 per %s" calc-den-units) |
426 (message "No units in expression")))))) | 433 (message "No units in expression")))))) |
427 | 434 |
428 (defun calc-explain-units-rec (expr pow) | 435 (defun calc-explain-units-rec (expr pow) |
429 (let ((u (math-check-unit-name expr)) | 436 (let ((u (math-check-unit-name expr)) |
430 pos) | 437 pos) |
461 (setq name (concat name "-cubed")))) | 468 (setq name (concat name "-cubed")))) |
462 (t | 469 (t |
463 (setq name (concat name "^" | 470 (setq name (concat name "^" |
464 (math-format-number (math-abs pow)))))) | 471 (math-format-number (math-abs pow)))))) |
465 (if (math-posp pow) | 472 (if (math-posp pow) |
466 (setq num-units (if num-units | 473 (setq calc-num-units (if calc-num-units |
467 (concat num-units " " name) | 474 (concat calc-num-units " " name) |
468 name)) | 475 name)) |
469 (setq den-units (if den-units | 476 (setq calc-den-units (if calc-den-units |
470 (concat den-units " " name) | 477 (concat calc-den-units " " name) |
471 name)))) | 478 name)))) |
472 (cond ((eq (car-safe expr) '*) | 479 (cond ((eq (car-safe expr) '*) |
473 (calc-explain-units-rec (nth 1 expr) pow) | 480 (calc-explain-units-rec (nth 1 expr) pow) |
474 (calc-explain-units-rec (nth 2 expr) pow)) | 481 (calc-explain-units-rec (nth 2 expr) pow)) |
475 ((eq (car-safe expr) '/) | 482 ((eq (car-safe expr) '/) |
613 (insert ";;; (no custom units defined)\n")) | 620 (insert ";;; (no custom units defined)\n")) |
614 (insert ";;; End of custom units\n") | 621 (insert ";;; End of custom units\n") |
615 (save-buffer)))) | 622 (save-buffer)))) |
616 | 623 |
617 | 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) | |
618 | 631 |
619 (defun math-build-units-table () | 632 (defun math-build-units-table () |
620 (or math-units-table | 633 (or math-units-table |
621 (let* ((combined-units (append math-additional-units | 634 (let* ((combined-units (append math-additional-units |
622 math-standard-units)) | 635 math-standard-units)) |
623 (unit-list (mapcar 'car combined-units)) | 636 (math-cu-unit-list (mapcar 'car combined-units)) |
624 tab) | 637 tab) |
625 (message "Building units table...") | 638 (message "Building units table...") |
626 (setq math-units-table-buffer-valid nil) | 639 (setq math-units-table-buffer-valid nil) |
627 (setq tab (mapcar (function | 640 (setq tab (mapcar (function |
628 (lambda (x) | 641 (lambda (x) |
644 (let ((math-units-table tab)) | 657 (let ((math-units-table tab)) |
645 (mapcar 'math-find-base-units tab)) | 658 (mapcar 'math-find-base-units tab)) |
646 (message "Building units table...done") | 659 (message "Building units table...done") |
647 (setq math-units-table tab)))) | 660 (setq math-units-table tab)))) |
648 | 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 | |
649 (defun math-find-base-units (entry) | 668 (defun math-find-base-units (entry) |
650 (if (eq (nth 4 entry) 'boom) | 669 (if (eq (nth 4 entry) 'boom) |
651 (error "Circular definition involving unit %s" (car entry))) | 670 (error "Circular definition involving unit %s" (car entry))) |
652 (or (nth 4 entry) | 671 (or (nth 4 entry) |
653 (let (base) | 672 (let (base) |
665 (setq base (sort base 'math-compare-unit-names)) | 684 (setq base (sort base 'math-compare-unit-names)) |
666 (setcar (nthcdr 4 entry) base) | 685 (setcar (nthcdr 4 entry) base) |
667 base))) | 686 base))) |
668 | 687 |
669 (defun math-compare-unit-names (a b) | 688 (defun math-compare-unit-names (a b) |
670 (memq (car b) (cdr (memq (car a) unit-list)))) | 689 (memq (car b) (cdr (memq (car a) math-cu-unit-list)))) |
671 | 690 |
672 (defun math-find-base-units-rec (expr pow) | 691 (defun math-find-base-units-rec (expr pow) |
673 (let ((u (math-check-unit-name expr))) | 692 (let ((u (math-check-unit-name expr))) |
674 (cond (u | 693 (cond (u |
675 (let ((ulist (math-find-base-units u))) | 694 (let ((ulist (math-find-base-units u))) |
749 (eq (aref name 1) ?e) | 768 (eq (aref name 1) ?e) |
750 (eq (aref name 2) ?g) | 769 (eq (aref name 2) ?g) |
751 (assq (intern (substring name 3)) | 770 (assq (intern (substring name 3)) |
752 math-units-table)))))))) | 771 math-units-table)))))))) |
753 | 772 |
754 | 773 ;; The variable math-which-standard is local to math-to-standard-units, |
755 (defun math-to-standard-units (expr which-standard) | 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 math-which-standard) | |
756 (math-to-standard-rec expr)) | 779 (math-to-standard-rec expr)) |
757 | 780 |
758 (defun math-to-standard-rec (expr) | 781 (defun math-to-standard-rec (expr) |
759 (if (eq (car-safe expr) 'var) | 782 (if (eq (car-safe expr) 'var) |
760 (let ((u (math-check-unit-name expr)) | 783 (let ((u (math-check-unit-name expr)) |
761 (base (nth 1 expr))) | 784 (base (nth 1 expr))) |
762 (if u | 785 (if u |
763 (progn | 786 (progn |
764 (if (nth 1 u) | 787 (if (nth 1 u) |
765 (setq expr (math-to-standard-rec (nth 1 u))) | 788 (setq expr (math-to-standard-rec (nth 1 u))) |
766 (let ((st (assq (car u) which-standard))) | 789 (let ((st (assq (car u) math-which-standard))) |
767 (if st | 790 (if st |
768 (setq expr (nth 1 st)) | 791 (setq expr (nth 1 st)) |
769 (setq expr (list 'var (car u) | 792 (setq expr (list 'var (car u) |
770 (intern (concat "var-" | 793 (intern (concat "var-" |
771 (symbol-name | 794 (symbol-name |
840 (cons unit | 863 (cons unit |
841 (math-is-multiple (math-simplify-units (math-to-standard-units | 864 (math-is-multiple (math-simplify-units (math-to-standard-units |
842 unit nil)) | 865 unit nil)) |
843 t))) | 866 t))) |
844 | 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 | |
845 (defun math-find-compatible-unit (expr unit) | 873 (defun math-find-compatible-unit (expr unit) |
846 (let ((u (math-check-unit-name unit))) | 874 (let ((math-fcu-u (math-check-unit-name unit))) |
847 (if u | 875 (if math-fcu-u |
848 (math-find-compatible-unit-rec expr 1)))) | 876 (math-find-compatible-unit-rec expr 1)))) |
849 | 877 |
850 (defun math-find-compatible-unit-rec (expr pow) | 878 (defun math-find-compatible-unit-rec (expr pow) |
851 (cond ((eq (car-safe expr) '*) | 879 (cond ((eq (car-safe expr) '*) |
852 (or (math-find-compatible-unit-rec (nth 1 expr) pow) | 880 (or (math-find-compatible-unit-rec (nth 1 expr) pow) |
857 ((and (eq (car-safe expr) '^) | 885 ((and (eq (car-safe expr) '^) |
858 (integerp (nth 2 expr))) | 886 (integerp (nth 2 expr))) |
859 (math-find-compatible-unit-rec (nth 1 expr) (* pow (nth 2 expr)))) | 887 (math-find-compatible-unit-rec (nth 1 expr) (* pow (nth 2 expr)))) |
860 (t | 888 (t |
861 (let ((u2 (math-check-unit-name expr))) | 889 (let ((u2 (math-check-unit-name expr))) |
862 (if (equal (nth 4 u) (nth 4 u2)) | 890 (if (equal (nth 4 math-fcu-u) (nth 4 u2)) |
863 (cons expr pow)))))) | 891 (cons expr pow)))))) |
864 | 892 |
865 (defun math-convert-units (expr new-units &optional pure) | 893 ;; 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) | |
866 (math-with-extra-prec 2 | 900 (math-with-extra-prec 2 |
867 (let ((compat (and (not pure) (math-find-compatible-unit expr new-units))) | 901 (let ((compat (and (not math-cu-pure) |
868 (unit-list nil) | 902 (math-find-compatible-unit expr math-cu-new-units))) |
903 (math-cu-unit-list nil) | |
869 (math-combining-units nil)) | 904 (math-combining-units nil)) |
870 (if compat | 905 (if compat |
871 (math-simplify-units | 906 (math-simplify-units |
872 (math-mul (math-mul (math-simplify-units | 907 (math-mul (math-mul (math-simplify-units |
873 (math-div expr (math-pow (car compat) | 908 (math-div expr (math-pow (car compat) |
874 (cdr compat)))) | 909 (cdr compat)))) |
875 (math-pow new-units (cdr compat))) | 910 (math-pow math-cu-new-units (cdr compat))) |
876 (math-simplify-units | 911 (math-simplify-units |
877 (math-to-standard-units | 912 (math-to-standard-units |
878 (math-pow (math-div (car compat) new-units) | 913 (math-pow (math-div (car compat) math-cu-new-units) |
879 (cdr compat)) | 914 (cdr compat)) |
880 nil)))) | 915 nil)))) |
881 (when (setq unit-list (math-decompose-units new-units)) | 916 (when (setq math-cu-unit-list (math-decompose-units math-cu-new-units)) |
882 (setq new-units (nth 2 (car unit-list)))) | 917 (setq math-cu-new-units (nth 2 (car math-cu-unit-list)))) |
883 (when (eq (car-safe expr) '+) | 918 (when (eq (car-safe expr) '+) |
884 (setq expr (math-simplify-units expr))) | 919 (setq expr (math-simplify-units expr))) |
885 (if (math-units-in-expr-p expr t) | 920 (if (math-units-in-expr-p expr t) |
886 (math-convert-units-rec expr) | 921 (math-convert-units-rec expr) |
887 (math-apply-units (math-to-standard-units | 922 (math-apply-units (math-to-standard-units |
888 (list '/ expr new-units) nil) | 923 (list '/ expr math-cu-new-units) nil) |
889 new-units unit-list pure)))))) | 924 math-cu-new-units math-cu-unit-list math-cu-pure)))))) |
890 | 925 |
891 (defun math-convert-units-rec (expr) | 926 (defun math-convert-units-rec (expr) |
892 (if (math-units-in-expr-p expr nil) | 927 (if (math-units-in-expr-p expr nil) |
893 (math-apply-units (math-to-standard-units (list '/ expr new-units) nil) | 928 (math-apply-units (math-to-standard-units |
894 new-units unit-list pure) | 929 (list '/ expr math-cu-new-units) nil) |
930 math-cu-new-units math-cu-unit-list math-cu-pure) | |
895 (if (Math-primp expr) | 931 (if (Math-primp expr) |
896 expr | 932 expr |
897 (cons (car expr) | 933 (cons (car expr) |
898 (mapcar 'math-convert-units-rec (cdr expr)))))) | 934 (mapcar 'math-convert-units-rec (cdr expr)))))) |
899 | 935 |
1024 (calcFunc-scf (nth 1 math-simplify-expr) | 1060 (calcFunc-scf (nth 1 math-simplify-expr) |
1025 (- uxpon pxpon)))) | 1061 (- uxpon pxpon)))) |
1026 (setcar unitp pname) | 1062 (setcar unitp pname) |
1027 math-simplify-expr))))))) | 1063 math-simplify-expr))))))) |
1028 | 1064 |
1065 (defvar math-try-cancel-units) | |
1066 | |
1029 (math-defsimplify / | 1067 (math-defsimplify / |
1030 (and math-simplifying-units | 1068 (and math-simplifying-units |
1031 (let ((np (cdr math-simplify-expr)) | 1069 (let ((np (cdr math-simplify-expr)) |
1032 (try-cancel-units 0) | 1070 (math-try-cancel-units 0) |
1033 n nn) | 1071 n nn) |
1034 (setq n (if (eq (car-safe (nth 2 math-simplify-expr)) '*) | 1072 (setq n (if (eq (car-safe (nth 2 math-simplify-expr)) '*) |
1035 (cdr (nth 2 math-simplify-expr)) | 1073 (cdr (nth 2 math-simplify-expr)) |
1036 (nthcdr 2 math-simplify-expr))) | 1074 (nthcdr 2 math-simplify-expr))) |
1037 (if (math-realp (car n)) | 1075 (if (math-realp (car n)) |
1042 (setcar n 1))) | 1080 (setcar n 1))) |
1043 (while (eq (car-safe (setq n (car np))) '*) | 1081 (while (eq (car-safe (setq n (car np))) '*) |
1044 (math-simplify-units-divisor (cdr n) (cdr (cdr math-simplify-expr))) | 1082 (math-simplify-units-divisor (cdr n) (cdr (cdr math-simplify-expr))) |
1045 (setq np (cdr (cdr n)))) | 1083 (setq np (cdr (cdr n)))) |
1046 (math-simplify-units-divisor np (cdr (cdr math-simplify-expr))) | 1084 (math-simplify-units-divisor np (cdr (cdr math-simplify-expr))) |
1047 (if (eq try-cancel-units 0) | 1085 (if (eq math-try-cancel-units 0) |
1048 (let* ((math-simplifying-units nil) | 1086 (let* ((math-simplifying-units nil) |
1049 (base (math-simplify | 1087 (base (math-simplify |
1050 (math-to-standard-units math-simplify-expr nil)))) | 1088 (math-to-standard-units math-simplify-expr nil)))) |
1051 (if (Math-numberp base) | 1089 (if (Math-numberp base) |
1052 (setq math-simplify-expr base)))) | 1090 (setq math-simplify-expr base)))) |
1087 ud (nth 4 ud)) | 1125 ud (nth 4 ud)) |
1088 (while un | 1126 (while un |
1089 (setq ud1 ud) | 1127 (setq ud1 ud) |
1090 (while ud1 | 1128 (while ud1 |
1091 (and (eq (car (car un)) (car (car ud1))) | 1129 (and (eq (car (car un)) (car (car ud1))) |
1092 (setq try-cancel-units | 1130 (setq math-try-cancel-units |
1093 (+ try-cancel-units | 1131 (+ math-try-cancel-units |
1094 (- (* (cdr (car un)) pow1) | 1132 (- (* (cdr (car un)) pow1) |
1095 (* (cdr (car ud)) pow2))))) | 1133 (* (cdr (car ud)) pow2))))) |
1096 (setq ud1 (cdr ud1))) | 1134 (setq ud1 (cdr ud1))) |
1097 (setq un (cdr un))) | 1135 (setq un (cdr un))) |
1098 nil)))))) | 1136 nil)))))) |