[bpt/emacs.git] / lisp / calc / calc-frac.el

;;; calc-frac.el --- fraction functions for Calc

;; Copyright (C) 1990-1993, 2001-2013 Free Software Foundation, Inc.

;; Author: David Gillespie <daveg@synaptics.com>
;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; Code:

;; This file is autoloaded from calc-ext.el.

(require 'calc-ext)
(require 'calc-macs)

(defun calc-fdiv (arg)
  (interactive "P")
  (calc-slow-wrapper
   (calc-binary-op ":" 'calcFunc-fdiv arg 1)))


(defun calc-fraction (arg)
  (interactive "P")
  (calc-slow-wrapper
   (let ((func (if (calc-is-hyperbolic) 'calcFunc-frac 'calcFunc-pfrac)))
     (if (eq arg 0)
	 (calc-enter-result 2 "frac" (list func
					   (calc-top-n 2)
					   (calc-top-n 1)))
       (calc-enter-result 1 "frac" (list func
					 (calc-top-n 1)
					 (prefix-numeric-value (or arg 0))))))))


(defun calc-over-notation (fmt)
  (interactive "sFraction separator: ")
  (calc-wrapper
   (if (string-match "\\`\\([^ 0-9][^ 0-9]?\\)[0-9]*\\'" fmt)
       (let ((n nil))
	 (if (/= (match-end 0) (match-end 1))
	     (setq n (string-to-number (substring fmt (match-end 1)))
		   fmt (math-match-substring fmt 1)))
	 (if (eq n 0) (error "Bad denominator"))
	 (calc-change-mode 'calc-frac-format (list fmt n) t))
     (error "Bad fraction separator format"))))

(defun calc-slash-notation (n)
  (interactive "P")
  (calc-wrapper
   (calc-change-mode 'calc-frac-format (if n '("//" nil) '("/" nil)) t)))


(defun calc-frac-mode (n)
  (interactive "P")
  (calc-wrapper
   (calc-change-mode 'calc-prefer-frac n nil t)
   (message (if calc-prefer-frac
		"Integer division will now generate fractions"
	      "Integer division will now generate floating-point results"))))


;;;; Fractions.

;;; Build a normalized fraction.  [R I I]
;;; (This could probably be implemented more efficiently than using
;;;  the plain gcd algorithm.)
(defun math-make-frac (num den)
  (if (Math-integer-negp den)
      (setq num (math-neg num)
	    den (math-neg den)))
  (let ((gcd (math-gcd num den)))
    (if (eq gcd 1)
	(if (eq den 1)
	    num
	  (list 'frac num den))
      (if (equal gcd den)
	  (math-quotient num gcd)
	(list 'frac (math-quotient num gcd) (math-quotient den gcd))))))

(defun calc-add-fractions (a b)
  (if (eq (car-safe a) 'frac)
      (if (eq (car-safe b) 'frac)
	  (math-make-frac (math-add (math-mul (nth 1 a) (nth 2 b))
				    (math-mul (nth 2 a) (nth 1 b)))
			  (math-mul (nth 2 a) (nth 2 b)))
	(math-make-frac (math-add (nth 1 a)
				  (math-mul (nth 2 a) b))
			(nth 2 a)))
    (math-make-frac (math-add (math-mul a (nth 2 b))
			      (nth 1 b))
		    (nth 2 b))))

(defun calc-mul-fractions (a b)
  (if (eq (car-safe a) 'frac)
      (if (eq (car-safe b) 'frac)
	  (math-make-frac (math-mul (nth 1 a) (nth 1 b))
			  (math-mul (nth 2 a) (nth 2 b)))
	(math-make-frac (math-mul (nth 1 a) b)
			(nth 2 a)))
    (math-make-frac (math-mul a (nth 1 b))
		    (nth 2 b))))

(defun calc-div-fractions (a b)
  (if (eq (car-safe a) 'frac)
      (if (eq (car-safe b) 'frac)
	  (math-make-frac (math-mul (nth 1 a) (nth 2 b))
			  (math-mul (nth 2 a) (nth 1 b)))
	(math-make-frac (nth 1 a)
			(math-mul (nth 2 a) b)))
    (math-make-frac (math-mul a (nth 2 b))
		    (nth 1 b))))


;;; Convert a real value to fractional form.  [T R I; T R F] [Public]
(defun calcFunc-frac (a &optional tol)
  (or tol (setq tol 0))
  (cond ((Math-ratp a)
	 a)
	((memq (car a) '(cplx polar vec hms date sdev intv mod))
	 (cons (car a) (mapcar (function
				(lambda (x)
				  (calcFunc-frac x tol)))
			       (cdr a))))
	((Math-messy-integerp a)
	 (math-trunc a))
	((Math-negp a)
	 (math-neg (calcFunc-frac (math-neg a) tol)))
	((not (eq (car a) 'float))
	 (if (math-infinitep a)
	     a
	   (if (math-provably-integerp a)
	       a
	     (math-reject-arg a 'numberp))))
	((integerp tol)
	 (if (<= tol 0)
	     (setq tol (+ tol calc-internal-prec)))
	 (calcFunc-frac a (list 'float 5
				(- (+ (math-numdigs (nth 1 a))
				      (nth 2 a))
				   (1+ tol)))))
	((not (eq (car tol) 'float))
	 (if (Math-realp tol)
	     (calcFunc-frac a (math-float tol))
	   (math-reject-arg tol 'realp)))
	((Math-negp tol)
	 (calcFunc-frac a (math-neg tol)))
	((Math-zerop tol)
	 (calcFunc-frac a 0))
	((not (math-lessp-float tol '(float 1 0)))
	 (math-trunc a))
	((Math-zerop a)
	 0)
	(t
	 (let ((cfrac (math-continued-fraction a tol))
	       (calc-prefer-frac t))
	   (math-eval-continued-fraction cfrac)))))

(defun math-continued-fraction (a tol)
  (let ((calc-internal-prec (+ calc-internal-prec 2)))
    (let ((cfrac nil)
	  (aa a)
	  (calc-prefer-frac nil)
	  int)
      (while (or (null cfrac)
		 (and (not (Math-zerop aa))
		      (not (math-lessp-float
			    (math-abs
			     (math-sub a
				       (let ((f (math-eval-continued-fraction
						 cfrac)))
					 (math-working "Fractionalize" f)
					 f)))
			    tol))))
	(setq int (math-trunc aa)
	      aa (math-sub aa int)
	      cfrac (cons int cfrac))
	(or (Math-zerop aa)
	    (setq aa (math-div 1 aa))))
      cfrac)))

(defun math-eval-continued-fraction (cf)
  (let ((n (car cf))
	(d 1)
	temp)
    (while (setq cf (cdr cf))
      (setq temp (math-add (math-mul (car cf) n) d)
	    d n
	    n temp))
    (math-div n d)))

(defun calcFunc-fdiv (a b)   ; [R I I] [Public]
  (cond
   ((Math-num-integerp a)
    (cond 
     ((Math-num-integerp b)
      (if (Math-zerop b)
	  (math-reject-arg a "*Division by zero")
	(math-make-frac (math-trunc a) (math-trunc b))))
     ((eq (car-safe b) 'frac)
      (if (Math-zerop (nth 1 b))
	  (math-reject-arg a "*Division by zero")
	(math-make-frac (math-mul (math-trunc a) (nth 2 b)) (nth 1 b))))
     (t (math-reject-arg b 'integerp))))
   ((eq (car-safe a) 'frac)
    (cond 
     ((Math-num-integerp b)
      (if (Math-zerop b)
	  (math-reject-arg a "*Division by zero")
	(math-make-frac (cadr a) (math-mul (nth 2 a) (math-trunc b)))))
     ((eq (car-safe b) 'frac)
      (if (Math-zerop (nth 1 b))
	  (math-reject-arg a "*Division by zero")
	(math-make-frac (math-mul (nth 1 a) (nth 2 b)) (math-mul (nth 2 a) (nth 1 b)))))
     (t (math-reject-arg b 'integerp))))
   (t 
    (math-reject-arg a 'integerp))))

(provide 'calc-frac)

;;; calc-frac.el ends here
Commit	Line	Data
12f1951a CW	1	;;; calc-frac.el --- fraction functions for Calc
12f1951a CW	2
ab422c4d	3	;; Copyright (C) 1990-1993, 2001-2013 Free Software Foundation, Inc.
136211a9	4
12f1951a	5	;; Author: David Gillespie <daveg@synaptics.com>
e8fff8ed	6	;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
136211a9	7
a2cdc7f9 PJ	8	;; This file is part of GNU Emacs.
a2cdc7f9 PJ	9
662c9c64	10	;; GNU Emacs is free software: you can redistribute it and/or modify
7c671b23	11	;; it under the terms of the GNU General Public License as published by
662c9c64 GM	12	;; the Free Software Foundation, either version 3 of the License, or
662c9c64 GM	13	;; (at your option) any later version.
7c671b23	14
136211a9	15	;; GNU Emacs is distributed in the hope that it will be useful,
7c671b23 GM	16	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	17	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	18	;; GNU General Public License for more details.
	19
	20	;; You should have received a copy of the GNU General Public License
662c9c64	21	;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
136211a9	22
12f1951a	23	;;; Commentary:
136211a9	24
12f1951a	25	;;; Code:
136211a9 EZ	26
136211a9 EZ	27	;; This file is autoloaded from calc-ext.el.
136211a9	28
3ccef44f	29	(require 'calc-ext)
136211a9 EZ	30	(require 'calc-macs)
136211a9 EZ	31
136211a9 EZ	32	(defun calc-fdiv (arg)
	33	(interactive "P")
	34	(calc-slow-wrapper
bf77c646	35	(calc-binary-op ":" 'calcFunc-fdiv arg 1)))
136211a9 EZ	36
	37
	38	(defun calc-fraction (arg)
	39	(interactive "P")
	40	(calc-slow-wrapper
	41	(let ((func (if (calc-is-hyperbolic) 'calcFunc-frac 'calcFunc-pfrac)))
	42	(if (eq arg 0)
	43	(calc-enter-result 2 "frac" (list func
	44	(calc-top-n 2)
	45	(calc-top-n 1)))
	46	(calc-enter-result 1 "frac" (list func
	47	(calc-top-n 1)
bf77c646	48	(prefix-numeric-value (or arg 0))))))))
136211a9 EZ	49
	50
	51	(defun calc-over-notation (fmt)
97d83988	52	(interactive "sFraction separator: ")
136211a9 EZ	53	(calc-wrapper
	54	(if (string-match "\\`\\([^ 0-9][^ 0-9]?\\)[0-9]*\\'" fmt)
	55	(let ((n nil))
	56	(if (/= (match-end 0) (match-end 1))
d227f871	57	(setq n (string-to-number (substring fmt (match-end 1)))
136211a9 EZ	58	fmt (math-match-substring fmt 1)))
	59	(if (eq n 0) (error "Bad denominator"))
	60	(calc-change-mode 'calc-frac-format (list fmt n) t))
12f1951a	61	(error "Bad fraction separator format"))))
136211a9 EZ	62
	63	(defun calc-slash-notation (n)
	64	(interactive "P")
	65	(calc-wrapper
bf77c646	66	(calc-change-mode 'calc-frac-format (if n '("//" nil) '("/" nil)) t)))
136211a9 EZ	67
	68
	69	(defun calc-frac-mode (n)
	70	(interactive "P")
	71	(calc-wrapper
	72	(calc-change-mode 'calc-prefer-frac n nil t)
	73	(message (if calc-prefer-frac
12f1951a CW	74	"Integer division will now generate fractions"
12f1951a CW	75	"Integer division will now generate floating-point results"))))
136211a9 EZ	76
	77
	78	;;;; Fractions.
	79
	80	;;; Build a normalized fraction. [R I I]
	81	;;; (This could probably be implemented more efficiently than using
	82	;;; the plain gcd algorithm.)
	83	(defun math-make-frac (num den)
	84	(if (Math-integer-negp den)
	85	(setq num (math-neg num)
	86	den (math-neg den)))
	87	(let ((gcd (math-gcd num den)))
	88	(if (eq gcd 1)
	89	(if (eq den 1)
	90	num
	91	(list 'frac num den))
	92	(if (equal gcd den)
	93	(math-quotient num gcd)
bf77c646	94	(list 'frac (math-quotient num gcd) (math-quotient den gcd))))))
136211a9 EZ	95
	96	(defun calc-add-fractions (a b)
	97	(if (eq (car-safe a) 'frac)
	98	(if (eq (car-safe b) 'frac)
	99	(math-make-frac (math-add (math-mul (nth 1 a) (nth 2 b))
	100	(math-mul (nth 2 a) (nth 1 b)))
	101	(math-mul (nth 2 a) (nth 2 b)))
	102	(math-make-frac (math-add (nth 1 a)
	103	(math-mul (nth 2 a) b))
	104	(nth 2 a)))
	105	(math-make-frac (math-add (math-mul a (nth 2 b))
	106	(nth 1 b))
bf77c646	107	(nth 2 b))))
136211a9 EZ	108
	109	(defun calc-mul-fractions (a b)
	110	(if (eq (car-safe a) 'frac)
	111	(if (eq (car-safe b) 'frac)
	112	(math-make-frac (math-mul (nth 1 a) (nth 1 b))
	113	(math-mul (nth 2 a) (nth 2 b)))
	114	(math-make-frac (math-mul (nth 1 a) b)
	115	(nth 2 a)))
	116	(math-make-frac (math-mul a (nth 1 b))
bf77c646	117	(nth 2 b))))
136211a9 EZ	118
	119	(defun calc-div-fractions (a b)
	120	(if (eq (car-safe a) 'frac)
	121	(if (eq (car-safe b) 'frac)
	122	(math-make-frac (math-mul (nth 1 a) (nth 2 b))
	123	(math-mul (nth 2 a) (nth 1 b)))
	124	(math-make-frac (nth 1 a)
	125	(math-mul (nth 2 a) b)))
	126	(math-make-frac (math-mul a (nth 2 b))
bf77c646	127	(nth 1 b))))
136211a9 EZ	128
136211a9 EZ	129
136211a9 EZ	130	;;; Convert a real value to fractional form. [T R I; T R F] [Public]
	131	(defun calcFunc-frac (a &optional tol)
	132	(or tol (setq tol 0))
	133	(cond ((Math-ratp a)
	134	a)
	135	((memq (car a) '(cplx polar vec hms date sdev intv mod))
	136	(cons (car a) (mapcar (function
	137	(lambda (x)
	138	(calcFunc-frac x tol)))
	139	(cdr a))))
	140	((Math-messy-integerp a)
	141	(math-trunc a))
	142	((Math-negp a)
	143	(math-neg (calcFunc-frac (math-neg a) tol)))
	144	((not (eq (car a) 'float))
	145	(if (math-infinitep a)
	146	a
	147	(if (math-provably-integerp a)
	148	a
	149	(math-reject-arg a 'numberp))))
	150	((integerp tol)
	151	(if (<= tol 0)
	152	(setq tol (+ tol calc-internal-prec)))
	153	(calcFunc-frac a (list 'float 5
	154	(- (+ (math-numdigs (nth 1 a))
	155	(nth 2 a))
	156	(1+ tol)))))
	157	((not (eq (car tol) 'float))
	158	(if (Math-realp tol)
	159	(calcFunc-frac a (math-float tol))
	160	(math-reject-arg tol 'realp)))
	161	((Math-negp tol)
	162	(calcFunc-frac a (math-neg tol)))
	163	((Math-zerop tol)
	164	(calcFunc-frac a 0))
	165	((not (math-lessp-float tol '(float 1 0)))
	166	(math-trunc a))
	167	((Math-zerop a)
	168	0)
	169	(t
	170	(let ((cfrac (math-continued-fraction a tol))
	171	(calc-prefer-frac t))
bf77c646	172	(math-eval-continued-fraction cfrac)))))
136211a9 EZ	173
	174	(defun math-continued-fraction (a tol)
	175	(let ((calc-internal-prec (+ calc-internal-prec 2)))
	176	(let ((cfrac nil)
	177	(aa a)
	178	(calc-prefer-frac nil)
	179	int)
	180	(while (or (null cfrac)
	181	(and (not (Math-zerop aa))
	182	(not (math-lessp-float
	183	(math-abs
	184	(math-sub a
	185	(let ((f (math-eval-continued-fraction
	186	cfrac)))
	187	(math-working "Fractionalize" f)
	188	f)))
	189	tol))))
	190	(setq int (math-trunc aa)
	191	aa (math-sub aa int)
	192	cfrac (cons int cfrac))
	193	(or (Math-zerop aa)
	194	(setq aa (math-div 1 aa))))
bf77c646	195	cfrac)))
136211a9 EZ	196
	197	(defun math-eval-continued-fraction (cf)
	198	(let ((n (car cf))
	199	(d 1)
	200	temp)
	201	(while (setq cf (cdr cf))
	202	(setq temp (math-add (math-mul (car cf) n) d)
	203	d n
	204	n temp))
bf77c646	205	(math-div n d)))
136211a9	206
136211a9	207	(defun calcFunc-fdiv (a b) ; [R I I] [Public]
317a26be VB	208	(cond
	209	((Math-num-integerp a)
	210	(cond
	211	((Math-num-integerp b)
	212	(if (Math-zerop b)
	213	(math-reject-arg a "*Division by zero")
	214	(math-make-frac (math-trunc a) (math-trunc b))))
	215	((eq (car-safe b) 'frac)
cfd4160d	216	(if (Math-zerop (nth 1 b))
317a26be	217	(math-reject-arg a "*Division by zero")
cfd4160d	218	(math-make-frac (math-mul (math-trunc a) (nth 2 b)) (nth 1 b))))
317a26be VB	219	(t (math-reject-arg b 'integerp))))
	220	((eq (car-safe a) 'frac)
	221	(cond
	222	((Math-num-integerp b)
	223	(if (Math-zerop b)
	224	(math-reject-arg a "*Division by zero")
cfd4160d	225	(math-make-frac (cadr a) (math-mul (nth 2 a) (math-trunc b)))))
317a26be	226	((eq (car-safe b) 'frac)
cfd4160d	227	(if (Math-zerop (nth 1 b))
317a26be	228	(math-reject-arg a "*Division by zero")
cfd4160d	229	(math-make-frac (math-mul (nth 1 a) (nth 2 b)) (math-mul (nth 2 a) (nth 1 b)))))
317a26be VB	230	(t (math-reject-arg b 'integerp))))
	231	(t
	232	(math-reject-arg a 'integerp))))
136211a9	233
3ccef44f JB	234	(provide 'calc-frac)
3ccef44f JB	235
bf77c646	236	;;; calc-frac.el ends here