1;;; calc-frac.el --- fraction functions for Calc 2 3;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004, 4;; 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Author: David Gillespie <daveg@synaptics.com> 7;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> 8 9;; This file is part of GNU Emacs. 10 11;; GNU Emacs is free software; you can redistribute it and/or modify 12;; it under the terms of the GNU General Public License as published by 13;; the Free Software Foundation; either version 2, or (at your option) 14;; any later version. 15 16;; GNU Emacs is distributed in the hope that it will be useful, 17;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19;; GNU General Public License for more details. 20 21;; You should have received a copy of the GNU General Public License 22;; along with GNU Emacs; see the file COPYING. If not, write to the 23;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 24;; Boston, MA 02110-1301, USA. 25 26;;; Commentary: 27 28;;; Code: 29 30;; This file is autoloaded from calc-ext.el. 31 32(require 'calc-ext) 33(require 'calc-macs) 34 35(defun calc-fdiv (arg) 36 (interactive "P") 37 (calc-slow-wrapper 38 (calc-binary-op ":" 'calcFunc-fdiv arg 1))) 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) 51 (prefix-numeric-value (or arg 0)))))))) 52 53 54(defun calc-over-notation (fmt) 55 (interactive "sFraction separator: ") 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)) 60 (setq n (string-to-number (substring fmt (match-end 1))) 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)) 64 (error "Bad fraction separator format")))) 65 66(defun calc-slash-notation (n) 67 (interactive "P") 68 (calc-wrapper 69 (calc-change-mode 'calc-frac-format (if n '("//" nil) '("/" nil)) t))) 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 77 "Integer division will now generate fractions" 78 "Integer division will now generate floating-point results")))) 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) 97 (list 'frac (math-quotient num gcd) (math-quotient den gcd)))))) 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)) 110 (nth 2 b)))) 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)) 120 (nth 2 b)))) 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)) 130 (nth 1 b)))) 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)) 175 (math-eval-continued-fraction cfrac))))) 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)))) 198 cfrac))) 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)) 208 (math-div n d))) 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)) 219 (math-reject-arg a 'integerp))) 220 221(provide 'calc-frac) 222 223;;; arch-tag: 89d65274-0b3b-42d8-aacd-eaf86da5b4ea 224;;; calc-frac.el ends here 225