Mercurial > emacs
annotate lisp/calc/calc-frac.el @ 86933:553d66dcf5fd
(math-compose-var): Fix declaration.
author | Jay Belanger <jay.p.belanger@gmail.com> |
---|---|
date | Sun, 02 Dec 2007 03:45:14 +0000 |
parents | 095d08e7d6bb |
children | 9754bb0422ed f55f9811f5d7 |
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 |
64325
1db49616ce05
Update copyright information.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
62036
diff
changeset
|
3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004, |
75346 | 4 ;; 2005, 2006, 2007 Free Software Foundation, Inc. |
40785 | 5 |
41264
0759b2de09c1
(calc-over-notation): Use `completing-read'.
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
6 ;; Author: David Gillespie <daveg@synaptics.com> |
77465
1154f082efd9
Update maintainer's address.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
76595
diff
changeset
|
7 ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> |
40785 | 8 |
41384
5b80d417cf80
"This file is part of GNU Emacs." added.
Pavel Janík <Pavel@Janik.cz>
parents:
41264
diff
changeset
|
9 ;; 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
|
10 |
76595
497d17a80bb8
Change form of license text to match rest of Emacs.
Glenn Morris <rgm@gnu.org>
parents:
75346
diff
changeset
|
11 ;; GNU Emacs is free software; you can redistribute it and/or modify |
497d17a80bb8
Change form of license text to match rest of Emacs.
Glenn Morris <rgm@gnu.org>
parents:
75346
diff
changeset
|
12 ;; it under the terms of the GNU General Public License as published by |
78215
095d08e7d6bb
Switch license to GPLv3 or later.
Glenn Morris <rgm@gnu.org>
parents:
77465
diff
changeset
|
13 ;; the Free Software Foundation; either version 3, or (at your option) |
76595
497d17a80bb8
Change form of license text to match rest of Emacs.
Glenn Morris <rgm@gnu.org>
parents:
75346
diff
changeset
|
14 ;; any later version. |
40785 | 15 |
76595
497d17a80bb8
Change form of license text to match rest of Emacs.
Glenn Morris <rgm@gnu.org>
parents:
75346
diff
changeset
|
16 ;; GNU Emacs is distributed in the hope that it will be useful, |
497d17a80bb8
Change form of license text to match rest of Emacs.
Glenn Morris <rgm@gnu.org>
parents:
75346
diff
changeset
|
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
497d17a80bb8
Change form of license text to match rest of Emacs.
Glenn Morris <rgm@gnu.org>
parents:
75346
diff
changeset
|
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
497d17a80bb8
Change form of license text to match rest of Emacs.
Glenn Morris <rgm@gnu.org>
parents:
75346
diff
changeset
|
19 ;; GNU General Public License for more details. |
497d17a80bb8
Change form of license text to match rest of Emacs.
Glenn Morris <rgm@gnu.org>
parents:
75346
diff
changeset
|
20 |
497d17a80bb8
Change form of license text to match rest of Emacs.
Glenn Morris <rgm@gnu.org>
parents:
75346
diff
changeset
|
21 ;; You should have received a copy of the GNU General Public License |
497d17a80bb8
Change form of license text to match rest of Emacs.
Glenn Morris <rgm@gnu.org>
parents:
75346
diff
changeset
|
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the |
497d17a80bb8
Change form of license text to match rest of Emacs.
Glenn Morris <rgm@gnu.org>
parents:
75346
diff
changeset
|
23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
497d17a80bb8
Change form of license text to match rest of Emacs.
Glenn Morris <rgm@gnu.org>
parents:
75346
diff
changeset
|
24 ;; Boston, MA 02110-1301, USA. |
40785 | 25 |
41264
0759b2de09c1
(calc-over-notation): Use `completing-read'.
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
26 ;;; Commentary: |
40785 | 27 |
41264
0759b2de09c1
(calc-over-notation): Use `completing-read'.
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
28 ;;; Code: |
40785 | 29 |
30 ;; This file is autoloaded from calc-ext.el. | |
58655
4683e1bb5445
Add a provide statement.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
57848
diff
changeset
|
31 |
40785 | 32 (require 'calc-ext) |
33 (require 'calc-macs) | |
34 | |
35 (defun calc-fdiv (arg) | |
36 (interactive "P") | |
37 (calc-slow-wrapper | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
38 (calc-binary-op ":" 'calcFunc-fdiv arg 1))) |
40785 | 39 |
40 | |
41 (defun calc-fraction (arg) | |
42 (interactive "P") | |
43 (calc-slow-wrapper | |
44 (let ((func (if (calc-is-hyperbolic) 'calcFunc-frac 'calcFunc-pfrac))) | |
45 (if (eq arg 0) | |
46 (calc-enter-result 2 "frac" (list func | |
47 (calc-top-n 2) | |
48 (calc-top-n 1))) | |
49 (calc-enter-result 1 "frac" (list func | |
50 (calc-top-n 1) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
51 (prefix-numeric-value (or arg 0)))))))) |
40785 | 52 |
53 | |
54 (defun calc-over-notation (fmt) | |
57848
28443b8e3b48
(calc-over-notation): Replaced `completing-read' with
Jay Belanger <jay.p.belanger@gmail.com>
parents:
52401
diff
changeset
|
55 (interactive "sFraction separator: ") |
40785 | 56 (calc-wrapper |
57 (if (string-match "\\`\\([^ 0-9][^ 0-9]?\\)[0-9]*\\'" fmt) | |
58 (let ((n nil)) | |
59 (if (/= (match-end 0) (match-end 1)) | |
62036
e0224a91347d
(calc-over-notation): Replace string-to-int by string-to-number.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
58655
diff
changeset
|
60 (setq n (string-to-number (substring fmt (match-end 1))) |
40785 | 61 fmt (math-match-substring fmt 1))) |
62 (if (eq n 0) (error "Bad denominator")) | |
63 (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
|
64 (error "Bad fraction separator format")))) |
40785 | 65 |
66 (defun calc-slash-notation (n) | |
67 (interactive "P") | |
68 (calc-wrapper | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
69 (calc-change-mode 'calc-frac-format (if n '("//" nil) '("/" nil)) t))) |
40785 | 70 |
71 | |
72 (defun calc-frac-mode (n) | |
73 (interactive "P") | |
74 (calc-wrapper | |
75 (calc-change-mode 'calc-prefer-frac n nil t) | |
76 (message (if calc-prefer-frac | |
41264
0759b2de09c1
(calc-over-notation): Use `completing-read'.
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
77 "Integer division will now generate fractions" |
0759b2de09c1
(calc-over-notation): Use `completing-read'.
Colin Walters <walters@gnu.org>
parents:
41047
diff
changeset
|
78 "Integer division will now generate floating-point results")))) |
40785 | 79 |
80 | |
81 ;;;; Fractions. | |
82 | |
83 ;;; Build a normalized fraction. [R I I] | |
84 ;;; (This could probably be implemented more efficiently than using | |
85 ;;; the plain gcd algorithm.) | |
86 (defun math-make-frac (num den) | |
87 (if (Math-integer-negp den) | |
88 (setq num (math-neg num) | |
89 den (math-neg den))) | |
90 (let ((gcd (math-gcd num den))) | |
91 (if (eq gcd 1) | |
92 (if (eq den 1) | |
93 num | |
94 (list 'frac num den)) | |
95 (if (equal gcd den) | |
96 (math-quotient num gcd) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
97 (list 'frac (math-quotient num gcd) (math-quotient den gcd)))))) |
40785 | 98 |
99 (defun calc-add-fractions (a b) | |
100 (if (eq (car-safe a) 'frac) | |
101 (if (eq (car-safe b) 'frac) | |
102 (math-make-frac (math-add (math-mul (nth 1 a) (nth 2 b)) | |
103 (math-mul (nth 2 a) (nth 1 b))) | |
104 (math-mul (nth 2 a) (nth 2 b))) | |
105 (math-make-frac (math-add (nth 1 a) | |
106 (math-mul (nth 2 a) b)) | |
107 (nth 2 a))) | |
108 (math-make-frac (math-add (math-mul a (nth 2 b)) | |
109 (nth 1 b)) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
110 (nth 2 b)))) |
40785 | 111 |
112 (defun calc-mul-fractions (a b) | |
113 (if (eq (car-safe a) 'frac) | |
114 (if (eq (car-safe b) 'frac) | |
115 (math-make-frac (math-mul (nth 1 a) (nth 1 b)) | |
116 (math-mul (nth 2 a) (nth 2 b))) | |
117 (math-make-frac (math-mul (nth 1 a) b) | |
118 (nth 2 a))) | |
119 (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
|
120 (nth 2 b)))) |
40785 | 121 |
122 (defun calc-div-fractions (a b) | |
123 (if (eq (car-safe a) 'frac) | |
124 (if (eq (car-safe b) 'frac) | |
125 (math-make-frac (math-mul (nth 1 a) (nth 2 b)) | |
126 (math-mul (nth 2 a) (nth 1 b))) | |
127 (math-make-frac (nth 1 a) | |
128 (math-mul (nth 2 a) b))) | |
129 (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
|
130 (nth 1 b)))) |
40785 | 131 |
132 | |
133 ;;; Convert a real value to fractional form. [T R I; T R F] [Public] | |
134 (defun calcFunc-frac (a &optional tol) | |
135 (or tol (setq tol 0)) | |
136 (cond ((Math-ratp a) | |
137 a) | |
138 ((memq (car a) '(cplx polar vec hms date sdev intv mod)) | |
139 (cons (car a) (mapcar (function | |
140 (lambda (x) | |
141 (calcFunc-frac x tol))) | |
142 (cdr a)))) | |
143 ((Math-messy-integerp a) | |
144 (math-trunc a)) | |
145 ((Math-negp a) | |
146 (math-neg (calcFunc-frac (math-neg a) tol))) | |
147 ((not (eq (car a) 'float)) | |
148 (if (math-infinitep a) | |
149 a | |
150 (if (math-provably-integerp a) | |
151 a | |
152 (math-reject-arg a 'numberp)))) | |
153 ((integerp tol) | |
154 (if (<= tol 0) | |
155 (setq tol (+ tol calc-internal-prec))) | |
156 (calcFunc-frac a (list 'float 5 | |
157 (- (+ (math-numdigs (nth 1 a)) | |
158 (nth 2 a)) | |
159 (1+ tol))))) | |
160 ((not (eq (car tol) 'float)) | |
161 (if (Math-realp tol) | |
162 (calcFunc-frac a (math-float tol)) | |
163 (math-reject-arg tol 'realp))) | |
164 ((Math-negp tol) | |
165 (calcFunc-frac a (math-neg tol))) | |
166 ((Math-zerop tol) | |
167 (calcFunc-frac a 0)) | |
168 ((not (math-lessp-float tol '(float 1 0))) | |
169 (math-trunc a)) | |
170 ((Math-zerop a) | |
171 0) | |
172 (t | |
173 (let ((cfrac (math-continued-fraction a tol)) | |
174 (calc-prefer-frac t)) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
175 (math-eval-continued-fraction cfrac))))) |
40785 | 176 |
177 (defun math-continued-fraction (a tol) | |
178 (let ((calc-internal-prec (+ calc-internal-prec 2))) | |
179 (let ((cfrac nil) | |
180 (aa a) | |
181 (calc-prefer-frac nil) | |
182 int) | |
183 (while (or (null cfrac) | |
184 (and (not (Math-zerop aa)) | |
185 (not (math-lessp-float | |
186 (math-abs | |
187 (math-sub a | |
188 (let ((f (math-eval-continued-fraction | |
189 cfrac))) | |
190 (math-working "Fractionalize" f) | |
191 f))) | |
192 tol)))) | |
193 (setq int (math-trunc aa) | |
194 aa (math-sub aa int) | |
195 cfrac (cons int cfrac)) | |
196 (or (Math-zerop aa) | |
197 (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
|
198 cfrac))) |
40785 | 199 |
200 (defun math-eval-continued-fraction (cf) | |
201 (let ((n (car cf)) | |
202 (d 1) | |
203 temp) | |
204 (while (setq cf (cdr cf)) | |
205 (setq temp (math-add (math-mul (car cf) n) d) | |
206 d n | |
207 n temp)) | |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
208 (math-div n d))) |
40785 | 209 |
210 | |
211 | |
212 (defun calcFunc-fdiv (a b) ; [R I I] [Public] | |
213 (if (Math-num-integerp a) | |
214 (if (Math-num-integerp b) | |
215 (if (Math-zerop b) | |
216 (math-reject-arg a "*Division by zero") | |
217 (math-make-frac (math-trunc a) (math-trunc b))) | |
218 (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
|
219 (math-reject-arg a 'integerp))) |
40785 | 220 |
58655
4683e1bb5445
Add a provide statement.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
57848
diff
changeset
|
221 (provide 'calc-frac) |
4683e1bb5445
Add a provide statement.
Jay Belanger <jay.p.belanger@gmail.com>
parents:
57848
diff
changeset
|
222 |
52401 | 223 ;;; arch-tag: 89d65274-0b3b-42d8-aacd-eaf86da5b4ea |
41047
73f364fd8aaa
Style cleanup; don't put closing parens on their
Colin Walters <walters@gnu.org>
parents:
40785
diff
changeset
|
224 ;;; calc-frac.el ends here |