Mercurial > emacs
annotate lisp/calc/calc-frac.el @ 46533:701fdda31b83
*** empty log message ***
author | Juanma Barranquero <lekktu@gmail.com> |
---|---|
date | Fri, 19 Jul 2002 06:25:06 +0000 |
parents | 5b80d417cf80 |
children | f4d68f97221e |
rev | line source |
---|---|
41264
0759b2de09c1
(calc-over-notation): Use `completing-read'.
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
1 ;;; calc-frac.el --- fraction functions for Calc |
0759b2de09c1
(calc-over-notation): Use `completing-read'.
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
2 |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc. |
40785 | 4 |
41264
0759b2de09c1
(calc-over-notation): Use `completing-read'.
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
5 ;; Author: David Gillespie <daveg@synaptics.com> |
0759b2de09c1
(calc-over-notation): Use `completing-read'.
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
6 ;; Maintainer: Colin Walters <walters@debian.org> |
40785 | 7 |
41384
5b80d417cf80
"This file is part of GNU Emacs." added.
Pavel Janík <Pavel@Janik.cz>
parents:
41264
diff
changeset
|
8 ;; This file is part of GNU Emacs. |
5b80d417cf80
"This file is part of GNU Emacs." added.
Pavel Janík <Pavel@Janik.cz>
parents:
41264
diff
changeset
|
9 |
40785 | 10 ;; GNU Emacs is distributed in the hope that it will be useful, |
11 ;; but WITHOUT ANY WARRANTY. No author or distributor | |
12 ;; accepts responsibility to anyone for the consequences of using it | |
13 ;; or for whether it serves any particular purpose or works at all, | |
14 ;; unless he says so in writing. Refer to the GNU Emacs General Public | |
15 ;; License for full details. | |
16 | |
17 ;; Everyone is granted permission to copy, modify and redistribute | |
18 ;; GNU Emacs, but only under the conditions described in the | |
19 ;; GNU Emacs General Public License. A copy of this license is | |
20 ;; supposed to have been given to you along with GNU Emacs so you | |
21 ;; can know your rights and responsibilities. It should be in a | |
22 ;; file named COPYING. Among other things, the copyright notice | |
23 ;; and this notice must be preserved on all copies. | |
24 | |
41264
0759b2de09c1
(calc-over-notation): Use `completing-read'.
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
25 ;;; Commentary: |
40785 | 26 |
41264
0759b2de09c1
(calc-over-notation): Use `completing-read'.
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
27 ;;; Code: |
40785 | 28 |
29 ;; This file is autoloaded from calc-ext.el. | |
30 (require 'calc-ext) | |
31 | |
32 (require 'calc-macs) | |
33 | |
34 (defun calc-Need-calc-frac () nil) | |
35 | |
36 (defun calc-fdiv (arg) | |
37 (interactive "P") | |
38 (calc-slow-wrapper | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
39 (calc-binary-op ":" 'calcFunc-fdiv arg 1))) |
40785 | 40 |
41 | |
42 (defun calc-fraction (arg) | |
43 (interactive "P") | |
44 (calc-slow-wrapper | |
45 (let ((func (if (calc-is-hyperbolic) 'calcFunc-frac 'calcFunc-pfrac))) | |
46 (if (eq arg 0) | |
47 (calc-enter-result 2 "frac" (list func | |
48 (calc-top-n 2) | |
49 (calc-top-n 1))) | |
50 (calc-enter-result 1 "frac" (list func | |
51 (calc-top-n 1) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
52 (prefix-numeric-value (or arg 0)))))))) |
40785 | 53 |
54 | |
55 (defun calc-over-notation (fmt) | |
41264
0759b2de09c1
(calc-over-notation): Use `completing-read'.
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
56 (interactive |
0759b2de09c1
(calc-over-notation): Use `completing-read'.
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
57 (list |
0759b2de09c1
(calc-over-notation): Use `completing-read'.
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
58 (completing-read "Fraction separator: " (mapcar (lambda (s) |
0759b2de09c1
(calc-over-notation): Use `completing-read'.
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
59 (cons s 0)) |
0759b2de09c1
(calc-over-notation): Use `completing-read'.
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
60 '(":" "::" "/" "//" ":/")) |
0759b2de09c1
(calc-over-notation): Use `completing-read'.
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
61 nil t))) |
40785 | 62 (calc-wrapper |
63 (if (string-match "\\`\\([^ 0-9][^ 0-9]?\\)[0-9]*\\'" fmt) | |
64 (let ((n nil)) | |
65 (if (/= (match-end 0) (match-end 1)) | |
66 (setq n (string-to-int (substring fmt (match-end 1))) | |
67 fmt (math-match-substring fmt 1))) | |
68 (if (eq n 0) (error "Bad denominator")) | |
69 (calc-change-mode 'calc-frac-format (list fmt n) t)) | |
41264
0759b2de09c1
(calc-over-notation): Use `completing-read'.
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
70 (error "Bad fraction separator format")))) |
40785 | 71 |
72 (defun calc-slash-notation (n) | |
73 (interactive "P") | |
74 (calc-wrapper | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
75 (calc-change-mode 'calc-frac-format (if n '("//" nil) '("/" nil)) t))) |
40785 | 76 |
77 | |
78 (defun calc-frac-mode (n) | |
79 (interactive "P") | |
80 (calc-wrapper | |
81 (calc-change-mode 'calc-prefer-frac n nil t) | |
82 (message (if calc-prefer-frac | |
41264
0759b2de09c1
(calc-over-notation): Use `completing-read'.
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
83 "Integer division will now generate fractions" |
0759b2de09c1
(calc-over-notation): Use `completing-read'.
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
84 "Integer division will now generate floating-point results")))) |
40785 | 85 |
86 | |
87 ;;;; Fractions. | |
88 | |
89 ;;; Build a normalized fraction. [R I I] | |
90 ;;; (This could probably be implemented more efficiently than using | |
91 ;;; the plain gcd algorithm.) | |
92 (defun math-make-frac (num den) | |
93 (if (Math-integer-negp den) | |
94 (setq num (math-neg num) | |
95 den (math-neg den))) | |
96 (let ((gcd (math-gcd num den))) | |
97 (if (eq gcd 1) | |
98 (if (eq den 1) | |
99 num | |
100 (list 'frac num den)) | |
101 (if (equal gcd den) | |
102 (math-quotient num gcd) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
103 (list 'frac (math-quotient num gcd) (math-quotient den gcd)))))) |
40785 | 104 |
105 (defun calc-add-fractions (a b) | |
106 (if (eq (car-safe a) 'frac) | |
107 (if (eq (car-safe b) 'frac) | |
108 (math-make-frac (math-add (math-mul (nth 1 a) (nth 2 b)) | |
109 (math-mul (nth 2 a) (nth 1 b))) | |
110 (math-mul (nth 2 a) (nth 2 b))) | |
111 (math-make-frac (math-add (nth 1 a) | |
112 (math-mul (nth 2 a) b)) | |
113 (nth 2 a))) | |
114 (math-make-frac (math-add (math-mul a (nth 2 b)) | |
115 (nth 1 b)) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
116 (nth 2 b)))) |
40785 | 117 |
118 (defun calc-mul-fractions (a b) | |
119 (if (eq (car-safe a) 'frac) | |
120 (if (eq (car-safe b) 'frac) | |
121 (math-make-frac (math-mul (nth 1 a) (nth 1 b)) | |
122 (math-mul (nth 2 a) (nth 2 b))) | |
123 (math-make-frac (math-mul (nth 1 a) b) | |
124 (nth 2 a))) | |
125 (math-make-frac (math-mul a (nth 1 b)) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
126 (nth 2 b)))) |
40785 | 127 |
128 (defun calc-div-fractions (a b) | |
129 (if (eq (car-safe a) 'frac) | |
130 (if (eq (car-safe b) 'frac) | |
131 (math-make-frac (math-mul (nth 1 a) (nth 2 b)) | |
132 (math-mul (nth 2 a) (nth 1 b))) | |
133 (math-make-frac (nth 1 a) | |
134 (math-mul (nth 2 a) b))) | |
135 (math-make-frac (math-mul a (nth 2 b)) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
136 (nth 1 b)))) |
40785 | 137 |
138 | |
139 ;;; Convert a real value to fractional form. [T R I; T R F] [Public] | |
140 (defun calcFunc-frac (a &optional tol) | |
141 (or tol (setq tol 0)) | |
142 (cond ((Math-ratp a) | |
143 a) | |
144 ((memq (car a) '(cplx polar vec hms date sdev intv mod)) | |
145 (cons (car a) (mapcar (function | |
146 (lambda (x) | |
147 (calcFunc-frac x tol))) | |
148 (cdr a)))) | |
149 ((Math-messy-integerp a) | |
150 (math-trunc a)) | |
151 ((Math-negp a) | |
152 (math-neg (calcFunc-frac (math-neg a) tol))) | |
153 ((not (eq (car a) 'float)) | |
154 (if (math-infinitep a) | |
155 a | |
156 (if (math-provably-integerp a) | |
157 a | |
158 (math-reject-arg a 'numberp)))) | |
159 ((integerp tol) | |
160 (if (<= tol 0) | |
161 (setq tol (+ tol calc-internal-prec))) | |
162 (calcFunc-frac a (list 'float 5 | |
163 (- (+ (math-numdigs (nth 1 a)) | |
164 (nth 2 a)) | |
165 (1+ tol))))) | |
166 ((not (eq (car tol) 'float)) | |
167 (if (Math-realp tol) | |
168 (calcFunc-frac a (math-float tol)) | |
169 (math-reject-arg tol 'realp))) | |
170 ((Math-negp tol) | |
171 (calcFunc-frac a (math-neg tol))) | |
172 ((Math-zerop tol) | |
173 (calcFunc-frac a 0)) | |
174 ((not (math-lessp-float tol '(float 1 0))) | |
175 (math-trunc a)) | |
176 ((Math-zerop a) | |
177 0) | |
178 (t | |
179 (let ((cfrac (math-continued-fraction a tol)) | |
180 (calc-prefer-frac t)) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
181 (math-eval-continued-fraction cfrac))))) |
40785 | 182 |
183 (defun math-continued-fraction (a tol) | |
184 (let ((calc-internal-prec (+ calc-internal-prec 2))) | |
185 (let ((cfrac nil) | |
186 (aa a) | |
187 (calc-prefer-frac nil) | |
188 int) | |
189 (while (or (null cfrac) | |
190 (and (not (Math-zerop aa)) | |
191 (not (math-lessp-float | |
192 (math-abs | |
193 (math-sub a | |
194 (let ((f (math-eval-continued-fraction | |
195 cfrac))) | |
196 (math-working "Fractionalize" f) | |
197 f))) | |
198 tol)))) | |
199 (setq int (math-trunc aa) | |
200 aa (math-sub aa int) | |
201 cfrac (cons int cfrac)) | |
202 (or (Math-zerop aa) | |
203 (setq aa (math-div 1 aa)))) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
204 cfrac))) |
40785 | 205 |
206 (defun math-eval-continued-fraction (cf) | |
207 (let ((n (car cf)) | |
208 (d 1) | |
209 temp) | |
210 (while (setq cf (cdr cf)) | |
211 (setq temp (math-add (math-mul (car cf) n) d) | |
212 d n | |
213 n temp)) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
214 (math-div n d))) |
40785 | 215 |
216 | |
217 | |
218 (defun calcFunc-fdiv (a b) ; [R I I] [Public] | |
219 (if (Math-num-integerp a) | |
220 (if (Math-num-integerp b) | |
221 (if (Math-zerop b) | |
222 (math-reject-arg a "*Division by zero") | |
223 (math-make-frac (math-trunc a) (math-trunc b))) | |
224 (math-reject-arg b 'integerp)) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
225 (math-reject-arg a 'integerp))) |
40785 | 226 |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
227 ;;; calc-frac.el ends here |