| 1 | ;;; calc-bin.el --- binary functions for Calc |
| 2 | |
| 3 | ;; Copyright (C) 1990, 1991, 1992, 1993, 2001 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: David Gillespie <daveg@synaptics.com> |
| 6 | ;; Maintainer: Jay Belanger <belanger@truman.edu> |
| 7 | |
| 8 | ;; This file is part of GNU Emacs. |
| 9 | |
| 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 | |
| 25 | ;;; Commentary: |
| 26 | |
| 27 | ;;; Code: |
| 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-bin () nil) |
| 35 | |
| 36 | |
| 37 | ;;; b-prefix binary commands. |
| 38 | |
| 39 | (defun calc-and (n) |
| 40 | (interactive "P") |
| 41 | (calc-slow-wrapper |
| 42 | (calc-enter-result 2 "and" |
| 43 | (append '(calcFunc-and) |
| 44 | (calc-top-list-n 2) |
| 45 | (and n (list (prefix-numeric-value n))))))) |
| 46 | |
| 47 | (defun calc-or (n) |
| 48 | (interactive "P") |
| 49 | (calc-slow-wrapper |
| 50 | (calc-enter-result 2 "or" |
| 51 | (append '(calcFunc-or) |
| 52 | (calc-top-list-n 2) |
| 53 | (and n (list (prefix-numeric-value n))))))) |
| 54 | |
| 55 | (defun calc-xor (n) |
| 56 | (interactive "P") |
| 57 | (calc-slow-wrapper |
| 58 | (calc-enter-result 2 "xor" |
| 59 | (append '(calcFunc-xor) |
| 60 | (calc-top-list-n 2) |
| 61 | (and n (list (prefix-numeric-value n))))))) |
| 62 | |
| 63 | (defun calc-diff (n) |
| 64 | (interactive "P") |
| 65 | (calc-slow-wrapper |
| 66 | (calc-enter-result 2 "diff" |
| 67 | (append '(calcFunc-diff) |
| 68 | (calc-top-list-n 2) |
| 69 | (and n (list (prefix-numeric-value n))))))) |
| 70 | |
| 71 | (defun calc-not (n) |
| 72 | (interactive "P") |
| 73 | (calc-slow-wrapper |
| 74 | (calc-enter-result 1 "not" |
| 75 | (append '(calcFunc-not) |
| 76 | (calc-top-list-n 1) |
| 77 | (and n (list (prefix-numeric-value n))))))) |
| 78 | |
| 79 | (defun calc-lshift-binary (n) |
| 80 | (interactive "P") |
| 81 | (calc-slow-wrapper |
| 82 | (let ((hyp (if (calc-is-hyperbolic) 2 1))) |
| 83 | (calc-enter-result hyp "lsh" |
| 84 | (append '(calcFunc-lsh) |
| 85 | (calc-top-list-n hyp) |
| 86 | (and n (list (prefix-numeric-value n)))))))) |
| 87 | |
| 88 | (defun calc-rshift-binary (n) |
| 89 | (interactive "P") |
| 90 | (calc-slow-wrapper |
| 91 | (let ((hyp (if (calc-is-hyperbolic) 2 1))) |
| 92 | (calc-enter-result hyp "rsh" |
| 93 | (append '(calcFunc-rsh) |
| 94 | (calc-top-list-n hyp) |
| 95 | (and n (list (prefix-numeric-value n)))))))) |
| 96 | |
| 97 | (defun calc-lshift-arith (n) |
| 98 | (interactive "P") |
| 99 | (calc-slow-wrapper |
| 100 | (let ((hyp (if (calc-is-hyperbolic) 2 1))) |
| 101 | (calc-enter-result hyp "ash" |
| 102 | (append '(calcFunc-ash) |
| 103 | (calc-top-list-n hyp) |
| 104 | (and n (list (prefix-numeric-value n)))))))) |
| 105 | |
| 106 | (defun calc-rshift-arith (n) |
| 107 | (interactive "P") |
| 108 | (calc-slow-wrapper |
| 109 | (let ((hyp (if (calc-is-hyperbolic) 2 1))) |
| 110 | (calc-enter-result hyp "rash" |
| 111 | (append '(calcFunc-rash) |
| 112 | (calc-top-list-n hyp) |
| 113 | (and n (list (prefix-numeric-value n)))))))) |
| 114 | |
| 115 | (defun calc-rotate-binary (n) |
| 116 | (interactive "P") |
| 117 | (calc-slow-wrapper |
| 118 | (let ((hyp (if (calc-is-hyperbolic) 2 1))) |
| 119 | (calc-enter-result hyp "rot" |
| 120 | (append '(calcFunc-rot) |
| 121 | (calc-top-list-n hyp) |
| 122 | (and n (list (prefix-numeric-value n)))))))) |
| 123 | |
| 124 | (defun calc-clip (n) |
| 125 | (interactive "P") |
| 126 | (calc-slow-wrapper |
| 127 | (calc-enter-result 1 "clip" |
| 128 | (append '(calcFunc-clip) |
| 129 | (calc-top-list-n 1) |
| 130 | (and n (list (prefix-numeric-value n))))))) |
| 131 | |
| 132 | (defun calc-word-size (n) |
| 133 | (interactive "P") |
| 134 | (calc-wrapper |
| 135 | (or n (setq n (read-string (format "Binary word size: (default %d) " |
| 136 | calc-word-size)))) |
| 137 | (setq n (if (stringp n) |
| 138 | (if (equal n "") |
| 139 | calc-word-size |
| 140 | (if (string-match "\\`[-+]?[0-9]+\\'" n) |
| 141 | (string-to-int n) |
| 142 | (error "Expected an integer"))) |
| 143 | (prefix-numeric-value n))) |
| 144 | (or (= n calc-word-size) |
| 145 | (if (> (math-abs n) 100) |
| 146 | (calc-change-mode 'calc-word-size n calc-leading-zeros) |
| 147 | (calc-change-mode '(calc-word-size calc-previous-modulo) |
| 148 | (list n (math-power-of-2 (math-abs n))) |
| 149 | calc-leading-zeros))) |
| 150 | (if (< n 0) |
| 151 | (message "Binary word size is %d bits (2's complement)" (- n)) |
| 152 | (message "Binary word size is %d bits" n)))) |
| 153 | |
| 154 | |
| 155 | |
| 156 | |
| 157 | |
| 158 | ;;; d-prefix mode commands. |
| 159 | |
| 160 | (defun calc-radix (n) |
| 161 | (interactive "NDisplay radix (2-36): ") |
| 162 | (calc-wrapper |
| 163 | (if (and (>= n 2) (<= n 36)) |
| 164 | (progn |
| 165 | (calc-change-mode 'calc-number-radix n t) |
| 166 | ;; also change global value so minibuffer sees it |
| 167 | (setq-default calc-number-radix calc-number-radix)) |
| 168 | (setq n calc-number-radix)) |
| 169 | (message "Number radix is %d" n))) |
| 170 | |
| 171 | (defun calc-decimal-radix () |
| 172 | (interactive) |
| 173 | (calc-radix 10)) |
| 174 | |
| 175 | (defun calc-binary-radix () |
| 176 | (interactive) |
| 177 | (calc-radix 2)) |
| 178 | |
| 179 | (defun calc-octal-radix () |
| 180 | (interactive) |
| 181 | (calc-radix 8)) |
| 182 | |
| 183 | (defun calc-hex-radix () |
| 184 | (interactive) |
| 185 | (calc-radix 16)) |
| 186 | |
| 187 | (defun calc-leading-zeros (n) |
| 188 | (interactive "P") |
| 189 | (calc-wrapper |
| 190 | (if (calc-change-mode 'calc-leading-zeros n t t) |
| 191 | (message "Zero-padding integers to %d digits (assuming radix %d)" |
| 192 | (let* ((calc-internal-prec 6)) |
| 193 | (math-compute-max-digits (math-abs calc-word-size) |
| 194 | calc-number-radix)) |
| 195 | calc-number-radix) |
| 196 | (message "Omitting leading zeros on integers")))) |
| 197 | |
| 198 | |
| 199 | (defvar math-power-of-2-cache (list 1 2 4 8 16 32 64 128 256 512 1024)) |
| 200 | (defvar math-big-power-of-2-cache nil) |
| 201 | (defun math-power-of-2 (n) ; [I I] [Public] |
| 202 | (if (and (natnump n) (<= n 100)) |
| 203 | (or (nth n math-power-of-2-cache) |
| 204 | (let* ((i (length math-power-of-2-cache)) |
| 205 | (val (nth (1- i) math-power-of-2-cache))) |
| 206 | (while (<= i n) |
| 207 | (setq val (math-mul val 2) |
| 208 | math-power-of-2-cache (nconc math-power-of-2-cache |
| 209 | (list val)) |
| 210 | i (1+ i))) |
| 211 | val)) |
| 212 | (let ((found (assq n math-big-power-of-2-cache))) |
| 213 | (if found |
| 214 | (cdr found) |
| 215 | (let ((po2 (math-ipow 2 n))) |
| 216 | (setq math-big-power-of-2-cache |
| 217 | (cons (cons n po2) math-big-power-of-2-cache)) |
| 218 | po2))))) |
| 219 | |
| 220 | (defun math-integer-log2 (n) ; [I I] [Public] |
| 221 | (let ((i 0) |
| 222 | (p math-power-of-2-cache) |
| 223 | val) |
| 224 | (while (and p (Math-natnum-lessp (setq val (car p)) n)) |
| 225 | (setq p (cdr p) |
| 226 | i (1+ i))) |
| 227 | (if p |
| 228 | (and (equal val n) |
| 229 | i) |
| 230 | (while (Math-natnum-lessp |
| 231 | (prog1 |
| 232 | (setq val (math-mul val 2)) |
| 233 | (setq math-power-of-2-cache (nconc math-power-of-2-cache |
| 234 | (list val)))) |
| 235 | n) |
| 236 | (setq i (1+ i))) |
| 237 | (and (equal val n) |
| 238 | i)))) |
| 239 | |
| 240 | |
| 241 | |
| 242 | |
| 243 | ;;; Bitwise operations. |
| 244 | |
| 245 | (defun calcFunc-and (a b &optional w) ; [I I I] [Public] |
| 246 | (cond ((Math-messy-integerp w) |
| 247 | (calcFunc-and a b (math-trunc w))) |
| 248 | ((and w (not (integerp w))) |
| 249 | (math-reject-arg w 'fixnump)) |
| 250 | ((and (integerp a) (integerp b)) |
| 251 | (math-clip (logand a b) w)) |
| 252 | ((or (eq (car-safe a) 'mod) (eq (car-safe b) 'mod)) |
| 253 | (math-binary-modulo-args 'calcFunc-and a b w)) |
| 254 | ((not (Math-num-integerp a)) |
| 255 | (math-reject-arg a 'integerp)) |
| 256 | ((not (Math-num-integerp b)) |
| 257 | (math-reject-arg b 'integerp)) |
| 258 | (t (math-clip (cons 'bigpos |
| 259 | (math-and-bignum (math-binary-arg a w) |
| 260 | (math-binary-arg b w))) |
| 261 | w)))) |
| 262 | |
| 263 | (defun math-binary-arg (a w) |
| 264 | (if (not (Math-integerp a)) |
| 265 | (setq a (math-trunc a))) |
| 266 | (if (Math-integer-negp a) |
| 267 | (math-not-bignum (cdr (math-bignum-test (math-sub -1 a))) |
| 268 | (math-abs (if w (math-trunc w) calc-word-size))) |
| 269 | (cdr (Math-bignum-test a)))) |
| 270 | |
| 271 | (defun math-binary-modulo-args (f a b w) |
| 272 | (let (mod) |
| 273 | (if (eq (car-safe a) 'mod) |
| 274 | (progn |
| 275 | (setq mod (nth 2 a) |
| 276 | a (nth 1 a)) |
| 277 | (if (eq (car-safe b) 'mod) |
| 278 | (if (equal mod (nth 2 b)) |
| 279 | (setq b (nth 1 b)) |
| 280 | (math-reject-arg b "*Inconsistent modulos")))) |
| 281 | (setq mod (nth 2 b) |
| 282 | b (nth 1 b))) |
| 283 | (if (Math-messy-integerp mod) |
| 284 | (setq mod (math-trunc mod)) |
| 285 | (or (Math-integerp mod) |
| 286 | (math-reject-arg mod 'integerp))) |
| 287 | (let ((bits (math-integer-log2 mod))) |
| 288 | (if bits |
| 289 | (if w |
| 290 | (if (/= w bits) |
| 291 | (calc-record-why |
| 292 | "*Warning: Modulo inconsistent with word size")) |
| 293 | (setq w bits)) |
| 294 | (calc-record-why "*Warning: Modulo is not a power of 2")) |
| 295 | (math-make-mod (if b |
| 296 | (funcall f a b w) |
| 297 | (funcall f a w)) |
| 298 | mod)))) |
| 299 | |
| 300 | (defun math-and-bignum (a b) ; [l l l] |
| 301 | (and a b |
| 302 | (let ((qa (math-div-bignum-digit a 512)) |
| 303 | (qb (math-div-bignum-digit b 512))) |
| 304 | (math-mul-bignum-digit (math-and-bignum (math-norm-bignum (car qa)) |
| 305 | (math-norm-bignum (car qb))) |
| 306 | 512 |
| 307 | (logand (cdr qa) (cdr qb)))))) |
| 308 | |
| 309 | (defun calcFunc-or (a b &optional w) ; [I I I] [Public] |
| 310 | (cond ((Math-messy-integerp w) |
| 311 | (calcFunc-or a b (math-trunc w))) |
| 312 | ((and w (not (integerp w))) |
| 313 | (math-reject-arg w 'fixnump)) |
| 314 | ((and (integerp a) (integerp b)) |
| 315 | (math-clip (logior a b) w)) |
| 316 | ((or (eq (car-safe a) 'mod) (eq (car-safe b) 'mod)) |
| 317 | (math-binary-modulo-args 'calcFunc-or a b w)) |
| 318 | ((not (Math-num-integerp a)) |
| 319 | (math-reject-arg a 'integerp)) |
| 320 | ((not (Math-num-integerp b)) |
| 321 | (math-reject-arg b 'integerp)) |
| 322 | (t (math-clip (cons 'bigpos |
| 323 | (math-or-bignum (math-binary-arg a w) |
| 324 | (math-binary-arg b w))) |
| 325 | w)))) |
| 326 | |
| 327 | (defun math-or-bignum (a b) ; [l l l] |
| 328 | (and (or a b) |
| 329 | (let ((qa (math-div-bignum-digit a 512)) |
| 330 | (qb (math-div-bignum-digit b 512))) |
| 331 | (math-mul-bignum-digit (math-or-bignum (math-norm-bignum (car qa)) |
| 332 | (math-norm-bignum (car qb))) |
| 333 | 512 |
| 334 | (logior (cdr qa) (cdr qb)))))) |
| 335 | |
| 336 | (defun calcFunc-xor (a b &optional w) ; [I I I] [Public] |
| 337 | (cond ((Math-messy-integerp w) |
| 338 | (calcFunc-xor a b (math-trunc w))) |
| 339 | ((and w (not (integerp w))) |
| 340 | (math-reject-arg w 'fixnump)) |
| 341 | ((and (integerp a) (integerp b)) |
| 342 | (math-clip (logxor a b) w)) |
| 343 | ((or (eq (car-safe a) 'mod) (eq (car-safe b) 'mod)) |
| 344 | (math-binary-modulo-args 'calcFunc-xor a b w)) |
| 345 | ((not (Math-num-integerp a)) |
| 346 | (math-reject-arg a 'integerp)) |
| 347 | ((not (Math-num-integerp b)) |
| 348 | (math-reject-arg b 'integerp)) |
| 349 | (t (math-clip (cons 'bigpos |
| 350 | (math-xor-bignum (math-binary-arg a w) |
| 351 | (math-binary-arg b w))) |
| 352 | w)))) |
| 353 | |
| 354 | (defun math-xor-bignum (a b) ; [l l l] |
| 355 | (and (or a b) |
| 356 | (let ((qa (math-div-bignum-digit a 512)) |
| 357 | (qb (math-div-bignum-digit b 512))) |
| 358 | (math-mul-bignum-digit (math-xor-bignum (math-norm-bignum (car qa)) |
| 359 | (math-norm-bignum (car qb))) |
| 360 | 512 |
| 361 | (logxor (cdr qa) (cdr qb)))))) |
| 362 | |
| 363 | (defun calcFunc-diff (a b &optional w) ; [I I I] [Public] |
| 364 | (cond ((Math-messy-integerp w) |
| 365 | (calcFunc-diff a b (math-trunc w))) |
| 366 | ((and w (not (integerp w))) |
| 367 | (math-reject-arg w 'fixnump)) |
| 368 | ((and (integerp a) (integerp b)) |
| 369 | (math-clip (logand a (lognot b)) w)) |
| 370 | ((or (eq (car-safe a) 'mod) (eq (car-safe b) 'mod)) |
| 371 | (math-binary-modulo-args 'calcFunc-diff a b w)) |
| 372 | ((not (Math-num-integerp a)) |
| 373 | (math-reject-arg a 'integerp)) |
| 374 | ((not (Math-num-integerp b)) |
| 375 | (math-reject-arg b 'integerp)) |
| 376 | (t (math-clip (cons 'bigpos |
| 377 | (math-diff-bignum (math-binary-arg a w) |
| 378 | (math-binary-arg b w))) |
| 379 | w)))) |
| 380 | |
| 381 | (defun math-diff-bignum (a b) ; [l l l] |
| 382 | (and a |
| 383 | (let ((qa (math-div-bignum-digit a 512)) |
| 384 | (qb (math-div-bignum-digit b 512))) |
| 385 | (math-mul-bignum-digit (math-diff-bignum (math-norm-bignum (car qa)) |
| 386 | (math-norm-bignum (car qb))) |
| 387 | 512 |
| 388 | (logand (cdr qa) (lognot (cdr qb))))))) |
| 389 | |
| 390 | (defun calcFunc-not (a &optional w) ; [I I] [Public] |
| 391 | (cond ((Math-messy-integerp w) |
| 392 | (calcFunc-not a (math-trunc w))) |
| 393 | ((eq (car-safe a) 'mod) |
| 394 | (math-binary-modulo-args 'calcFunc-not a nil w)) |
| 395 | ((and w (not (integerp w))) |
| 396 | (math-reject-arg w 'fixnump)) |
| 397 | ((not (Math-num-integerp a)) |
| 398 | (math-reject-arg a 'integerp)) |
| 399 | ((< (or w (setq w calc-word-size)) 0) |
| 400 | (math-clip (calcFunc-not a (- w)) w)) |
| 401 | (t (math-normalize |
| 402 | (cons 'bigpos |
| 403 | (math-not-bignum (math-binary-arg a w) |
| 404 | w)))))) |
| 405 | |
| 406 | (defun math-not-bignum (a w) ; [l l] |
| 407 | (let ((q (math-div-bignum-digit a 512))) |
| 408 | (if (<= w 9) |
| 409 | (list (logand (lognot (cdr q)) |
| 410 | (1- (lsh 1 w)))) |
| 411 | (math-mul-bignum-digit (math-not-bignum (math-norm-bignum (car q)) |
| 412 | (- w 9)) |
| 413 | 512 |
| 414 | (logxor (cdr q) 511))))) |
| 415 | |
| 416 | (defun calcFunc-lsh (a &optional n w) ; [I I] [Public] |
| 417 | (setq a (math-trunc a) |
| 418 | n (if n (math-trunc n) 1)) |
| 419 | (if (eq (car-safe a) 'mod) |
| 420 | (math-binary-modulo-args 'calcFunc-lsh a n w) |
| 421 | (setq w (if w (math-trunc w) calc-word-size)) |
| 422 | (or (integerp w) |
| 423 | (math-reject-arg w 'fixnump)) |
| 424 | (or (Math-integerp a) |
| 425 | (math-reject-arg a 'integerp)) |
| 426 | (or (Math-integerp n) |
| 427 | (math-reject-arg n 'integerp)) |
| 428 | (if (< w 0) |
| 429 | (math-clip (calcFunc-lsh a n (- w)) w) |
| 430 | (if (Math-integer-negp a) |
| 431 | (setq a (math-clip a w))) |
| 432 | (cond ((or (Math-lessp n (- w)) |
| 433 | (Math-lessp w n)) |
| 434 | 0) |
| 435 | ((< n 0) |
| 436 | (math-quotient (math-clip a w) (math-power-of-2 (- n)))) |
| 437 | (t |
| 438 | (math-clip (math-mul a (math-power-of-2 n)) w)))))) |
| 439 | |
| 440 | (defun calcFunc-rsh (a &optional n w) ; [I I] [Public] |
| 441 | (calcFunc-lsh a (math-neg (or n 1)) w)) |
| 442 | |
| 443 | (defun calcFunc-ash (a &optional n w) ; [I I] [Public] |
| 444 | (if (or (null n) |
| 445 | (not (Math-negp n))) |
| 446 | (calcFunc-lsh a n w) |
| 447 | (setq a (math-trunc a) |
| 448 | n (if n (math-trunc n) 1)) |
| 449 | (if (eq (car-safe a) 'mod) |
| 450 | (math-binary-modulo-args 'calcFunc-ash a n w) |
| 451 | (setq w (if w (math-trunc w) calc-word-size)) |
| 452 | (or (integerp w) |
| 453 | (math-reject-arg w 'fixnump)) |
| 454 | (or (Math-integerp a) |
| 455 | (math-reject-arg a 'integerp)) |
| 456 | (or (Math-integerp n) |
| 457 | (math-reject-arg n 'integerp)) |
| 458 | (if (< w 0) |
| 459 | (math-clip (calcFunc-ash a n (- w)) w) |
| 460 | (if (Math-integer-negp a) |
| 461 | (setq a (math-clip a w))) |
| 462 | (let ((two-to-sizem1 (math-power-of-2 (1- w))) |
| 463 | (sh (calcFunc-lsh a n w))) |
| 464 | (cond ((Math-natnum-lessp a two-to-sizem1) |
| 465 | sh) |
| 466 | ((Math-lessp n (- 1 w)) |
| 467 | (math-add (math-mul two-to-sizem1 2) -1)) |
| 468 | (t (let ((two-to-n (math-power-of-2 (- n)))) |
| 469 | (math-add (calcFunc-lsh (math-add two-to-n -1) |
| 470 | (+ w n) w) |
| 471 | sh))))))))) |
| 472 | |
| 473 | (defun calcFunc-rash (a &optional n w) ; [I I] [Public] |
| 474 | (calcFunc-ash a (math-neg (or n 1)) w)) |
| 475 | |
| 476 | (defun calcFunc-rot (a &optional n w) ; [I I] [Public] |
| 477 | (setq a (math-trunc a) |
| 478 | n (if n (math-trunc n) 1)) |
| 479 | (if (eq (car-safe a) 'mod) |
| 480 | (math-binary-modulo-args 'calcFunc-rot a n w) |
| 481 | (setq w (if w (math-trunc w) calc-word-size)) |
| 482 | (or (integerp w) |
| 483 | (math-reject-arg w 'fixnump)) |
| 484 | (or (Math-integerp a) |
| 485 | (math-reject-arg a 'integerp)) |
| 486 | (or (Math-integerp n) |
| 487 | (math-reject-arg n 'integerp)) |
| 488 | (if (< w 0) |
| 489 | (math-clip (calcFunc-rot a n (- w)) w) |
| 490 | (if (Math-integer-negp a) |
| 491 | (setq a (math-clip a w))) |
| 492 | (cond ((or (Math-integer-negp n) |
| 493 | (not (Math-natnum-lessp n w))) |
| 494 | (calcFunc-rot a (math-mod n w) w)) |
| 495 | (t |
| 496 | (math-add (calcFunc-lsh a (- n w) w) |
| 497 | (calcFunc-lsh a n w))))))) |
| 498 | |
| 499 | (defun math-clip (a &optional w) ; [I I] [Public] |
| 500 | (cond ((Math-messy-integerp w) |
| 501 | (math-clip a (math-trunc w))) |
| 502 | ((eq (car-safe a) 'mod) |
| 503 | (math-binary-modulo-args 'math-clip a nil w)) |
| 504 | ((and w (not (integerp w))) |
| 505 | (math-reject-arg w 'fixnump)) |
| 506 | ((not (Math-num-integerp a)) |
| 507 | (math-reject-arg a 'integerp)) |
| 508 | ((< (or w (setq w calc-word-size)) 0) |
| 509 | (setq a (math-clip a (- w))) |
| 510 | (if (Math-natnum-lessp a (math-power-of-2 (- -1 w))) |
| 511 | a |
| 512 | (math-sub a (math-power-of-2 (- w))))) |
| 513 | ((Math-negp a) |
| 514 | (math-normalize (cons 'bigpos (math-binary-arg a w)))) |
| 515 | ((and (integerp a) (< a 1000000)) |
| 516 | (if (>= w 20) |
| 517 | a |
| 518 | (logand a (1- (lsh 1 w))))) |
| 519 | (t |
| 520 | (math-normalize |
| 521 | (cons 'bigpos |
| 522 | (math-clip-bignum (cdr (math-bignum-test (math-trunc a))) |
| 523 | w)))))) |
| 524 | |
| 525 | (defalias 'calcFunc-clip 'math-clip) |
| 526 | |
| 527 | (defun math-clip-bignum (a w) ; [l l] |
| 528 | (let ((q (math-div-bignum-digit a 512))) |
| 529 | (if (<= w 9) |
| 530 | (list (logand (cdr q) |
| 531 | (1- (lsh 1 w)))) |
| 532 | (math-mul-bignum-digit (math-clip-bignum (math-norm-bignum (car q)) |
| 533 | (- w 9)) |
| 534 | 512 |
| 535 | (cdr q))))) |
| 536 | |
| 537 | (defvar math-max-digits-cache nil) |
| 538 | (defun math-compute-max-digits (w r) |
| 539 | (let* ((pair (+ (* r 100000) w)) |
| 540 | (res (assq pair math-max-digits-cache))) |
| 541 | (if res |
| 542 | (cdr res) |
| 543 | (let* ((calc-command-flags nil) |
| 544 | (digs (math-ceiling (math-div w (math-real-log2 r))))) |
| 545 | (setq math-max-digits-cache (cons (cons pair digs) |
| 546 | math-max-digits-cache)) |
| 547 | digs)))) |
| 548 | |
| 549 | (defvar math-log2-cache (list '(2 . 1) |
| 550 | '(4 . 2) |
| 551 | '(8 . 3) |
| 552 | '(10 . (float 332193 -5)) |
| 553 | '(16 . 4) |
| 554 | '(32 . 5))) |
| 555 | (defun math-real-log2 (x) ;;; calc-internal-prec must be 6 |
| 556 | (let ((res (assq x math-log2-cache))) |
| 557 | (if res |
| 558 | (cdr res) |
| 559 | (let* ((calc-symbolic-mode nil) |
| 560 | (calc-display-working-message nil) |
| 561 | (log (calcFunc-log x 2))) |
| 562 | (setq math-log2-cache (cons (cons x log) math-log2-cache)) |
| 563 | log)))) |
| 564 | |
| 565 | (defconst math-radix-digits ["0" "1" "2" "3" "4" "5" "6" "7" "8" "9" |
| 566 | "A" "B" "C" "D" "E" "F" "G" "H" "I" "J" |
| 567 | "K" "L" "M" "N" "O" "P" "Q" "R" "S" "T" |
| 568 | "U" "V" "W" "X" "Y" "Z"]) |
| 569 | |
| 570 | (defsubst math-format-radix-digit (a) ; [X D] |
| 571 | (aref math-radix-digits a)) |
| 572 | |
| 573 | (defun math-format-radix (a) ; [X S] |
| 574 | (if (< a calc-number-radix) |
| 575 | (if (< a 0) |
| 576 | (concat "-" (math-format-radix (- a))) |
| 577 | (math-format-radix-digit a)) |
| 578 | (let ((s "")) |
| 579 | (while (> a 0) |
| 580 | (setq s (concat (math-format-radix-digit (% a calc-number-radix)) s) |
| 581 | a (/ a calc-number-radix))) |
| 582 | s))) |
| 583 | |
| 584 | (defconst math-binary-digits ["000" "001" "010" "011" |
| 585 | "100" "101" "110" "111"]) |
| 586 | (defun math-format-binary (a) ; [X S] |
| 587 | (if (< a 8) |
| 588 | (if (< a 0) |
| 589 | (concat "-" (math-format-binary (- a))) |
| 590 | (math-format-radix a)) |
| 591 | (let ((s "")) |
| 592 | (while (> a 7) |
| 593 | (setq s (concat (aref math-binary-digits (% a 8)) s) |
| 594 | a (/ a 8))) |
| 595 | (concat (math-format-radix a) s)))) |
| 596 | |
| 597 | (defun math-format-bignum-radix (a) ; [X L] |
| 598 | (cond ((null a) "0") |
| 599 | ((and (null (cdr a)) |
| 600 | (< (car a) calc-number-radix)) |
| 601 | (math-format-radix-digit (car a))) |
| 602 | (t |
| 603 | (let ((q (math-div-bignum-digit a calc-number-radix))) |
| 604 | (concat (math-format-bignum-radix (math-norm-bignum (car q))) |
| 605 | (math-format-radix-digit (cdr q))))))) |
| 606 | |
| 607 | (defun math-format-bignum-binary (a) ; [X L] |
| 608 | (cond ((null a) "0") |
| 609 | ((null (cdr a)) |
| 610 | (math-format-binary (car a))) |
| 611 | (t |
| 612 | (let ((q (math-div-bignum-digit a 512))) |
| 613 | (concat (math-format-bignum-binary (math-norm-bignum (car q))) |
| 614 | (aref math-binary-digits (/ (cdr q) 64)) |
| 615 | (aref math-binary-digits (% (/ (cdr q) 8) 8)) |
| 616 | (aref math-binary-digits (% (cdr q) 8))))))) |
| 617 | |
| 618 | (defun math-format-bignum-octal (a) ; [X L] |
| 619 | (cond ((null a) "0") |
| 620 | ((null (cdr a)) |
| 621 | (math-format-radix (car a))) |
| 622 | (t |
| 623 | (let ((q (math-div-bignum-digit a 512))) |
| 624 | (concat (math-format-bignum-octal (math-norm-bignum (car q))) |
| 625 | (math-format-radix-digit (/ (cdr q) 64)) |
| 626 | (math-format-radix-digit (% (/ (cdr q) 8) 8)) |
| 627 | (math-format-radix-digit (% (cdr q) 8))))))) |
| 628 | |
| 629 | (defun math-format-bignum-hex (a) ; [X L] |
| 630 | (cond ((null a) "0") |
| 631 | ((null (cdr a)) |
| 632 | (math-format-radix (car a))) |
| 633 | (t |
| 634 | (let ((q (math-div-bignum-digit a 256))) |
| 635 | (concat (math-format-bignum-hex (math-norm-bignum (car q))) |
| 636 | (math-format-radix-digit (/ (cdr q) 16)) |
| 637 | (math-format-radix-digit (% (cdr q) 16))))))) |
| 638 | |
| 639 | ;;; Decompose into integer and fractional parts, without depending |
| 640 | ;;; on calc-internal-prec. |
| 641 | (defun math-float-parts (a need-frac) ; returns ( int frac fracdigs ) |
| 642 | (if (>= (nth 2 a) 0) |
| 643 | (list (math-scale-rounding (nth 1 a) (nth 2 a)) '(float 0 0) 0) |
| 644 | (let* ((d (math-numdigs (nth 1 a))) |
| 645 | (n (- (nth 2 a)))) |
| 646 | (if need-frac |
| 647 | (if (>= n d) |
| 648 | (list 0 a n) |
| 649 | (let ((qr (math-idivmod (nth 1 a) (math-scale-int 1 n)))) |
| 650 | (list (car qr) (math-make-float (cdr qr) (- n)) n))) |
| 651 | (list (math-scale-rounding (nth 1 a) (nth 2 a)) |
| 652 | '(float 0 0) 0))))) |
| 653 | |
| 654 | (defun math-format-radix-float (a prec) |
| 655 | (let ((fmt (car calc-float-format)) |
| 656 | (figs (nth 1 calc-float-format)) |
| 657 | (point calc-point-char) |
| 658 | (str nil) |
| 659 | pos) |
| 660 | (if (eq fmt 'fix) |
| 661 | (let* ((afigs (math-abs figs)) |
| 662 | (fp (math-float-parts a (> afigs 0))) |
| 663 | (calc-internal-prec (+ 3 (max (nth 2 fp) |
| 664 | (math-convert-radix-digits |
| 665 | afigs t)))) |
| 666 | (int (car fp)) |
| 667 | (frac (math-round (math-mul (math-normalize (nth 1 fp)) |
| 668 | (math-radix-float-power afigs))))) |
| 669 | (if (not (and (math-zerop frac) (math-zerop int) (< figs 0))) |
| 670 | (let ((math-radix-explicit-format nil)) |
| 671 | (let ((calc-group-digits nil)) |
| 672 | (setq str (if (> afigs 0) (math-format-number frac) "")) |
| 673 | (if (< (length str) afigs) |
| 674 | (setq str (concat (make-string (- afigs (length str)) ?0) |
| 675 | str)) |
| 676 | (if (> (length str) afigs) |
| 677 | (setq str (substring str 1) |
| 678 | int (math-add int 1)))) |
| 679 | (setq str (concat (math-format-number int) point str))) |
| 680 | (when calc-group-digits |
| 681 | (setq str (math-group-float str)))) |
| 682 | (setq figs 0)))) |
| 683 | (or str |
| 684 | (let* ((prec calc-internal-prec) |
| 685 | (afigs (if (> figs 0) |
| 686 | figs |
| 687 | (max 1 (+ figs |
| 688 | (1- (math-convert-radix-digits |
| 689 | (max prec |
| 690 | (math-numdigs (nth 1 a))))))))) |
| 691 | (calc-internal-prec (+ 3 (math-convert-radix-digits afigs t))) |
| 692 | (explo -1) (vlo (math-radix-float-power explo)) |
| 693 | (exphi 1) (vhi (math-radix-float-power exphi)) |
| 694 | expmid vmid eadj) |
| 695 | (setq a (math-normalize a)) |
| 696 | (if (Math-zerop a) |
| 697 | (setq explo 0) |
| 698 | (if (math-lessp-float '(float 1 0) a) |
| 699 | (while (not (math-lessp-float a vhi)) |
| 700 | (setq explo exphi vlo vhi |
| 701 | exphi (math-mul exphi 2) |
| 702 | vhi (math-radix-float-power exphi))) |
| 703 | (while (math-lessp-float a vlo) |
| 704 | (setq exphi explo vhi vlo |
| 705 | explo (math-mul explo 2) |
| 706 | vlo (math-radix-float-power explo)))) |
| 707 | (while (not (eq (math-sub exphi explo) 1)) |
| 708 | (setq expmid (math-div2 (math-add explo exphi)) |
| 709 | vmid (math-radix-float-power expmid)) |
| 710 | (if (math-lessp-float a vmid) |
| 711 | (setq exphi expmid vhi vmid) |
| 712 | (setq explo expmid vlo vmid))) |
| 713 | (setq a (math-div-float a vlo))) |
| 714 | (let* ((sc (math-round (math-mul a (math-radix-float-power |
| 715 | (1- afigs))))) |
| 716 | (math-radix-explicit-format nil)) |
| 717 | (let ((calc-group-digits nil)) |
| 718 | (setq str (math-format-number sc)))) |
| 719 | (if (> (length str) afigs) |
| 720 | (setq str (substring str 0 -1) |
| 721 | explo (1+ explo))) |
| 722 | (if (and (eq fmt 'float) |
| 723 | (math-lessp explo (+ (if (= figs 0) |
| 724 | (1- (math-convert-radix-digits |
| 725 | prec)) |
| 726 | afigs) |
| 727 | calc-display-sci-high 1)) |
| 728 | (math-lessp calc-display-sci-low explo)) |
| 729 | (let ((dpos (1+ explo))) |
| 730 | (cond ((<= dpos 0) |
| 731 | (setq str (concat "0" point (make-string (- dpos) ?0) |
| 732 | str))) |
| 733 | ((> dpos (length str)) |
| 734 | (setq str (concat str (make-string (- dpos (length str)) |
| 735 | ?0) point))) |
| 736 | (t |
| 737 | (setq str (concat (substring str 0 dpos) point |
| 738 | (substring str dpos))))) |
| 739 | (setq explo nil)) |
| 740 | (setq eadj (if (eq fmt 'eng) |
| 741 | (min (math-mod explo 3) (length str)) |
| 742 | 0) |
| 743 | str (concat (substring str 0 (1+ eadj)) point |
| 744 | (substring str (1+ eadj))))) |
| 745 | (setq pos (length str)) |
| 746 | (while (eq (aref str (1- pos)) ?0) (setq pos (1- pos))) |
| 747 | (and explo (eq (aref str (1- pos)) ?.) (setq pos (1- pos))) |
| 748 | (setq str (substring str 0 pos)) |
| 749 | (when calc-group-digits |
| 750 | (setq str (math-group-float str))) |
| 751 | (if explo |
| 752 | (let ((estr (let ((calc-number-radix 10) |
| 753 | (calc-group-digits nil)) |
| 754 | (math-format-number |
| 755 | (math-sub explo eadj))))) |
| 756 | (setq str (if (or (memq calc-language '(math maple)) |
| 757 | (> calc-number-radix 14)) |
| 758 | (format "%s*%d.^%s" str calc-number-radix estr) |
| 759 | (format "%se%s" str estr))))))) |
| 760 | str)) |
| 761 | |
| 762 | (defvar math-radix-digits-cache nil) |
| 763 | |
| 764 | (defun math-convert-radix-digits (n &optional to-dec) |
| 765 | (let ((key (cons n (cons to-dec calc-number-radix)))) |
| 766 | (or (cdr (assoc key math-radix-digits-cache)) |
| 767 | (let* ((calc-internal-prec 6) |
| 768 | (log (math-div (math-real-log2 calc-number-radix) |
| 769 | '(float 332193 -5)))) |
| 770 | (cdr (car (setq math-radix-digits-cache |
| 771 | (cons (cons key (math-ceiling (if to-dec |
| 772 | (math-mul n log) |
| 773 | (math-div n log)))) |
| 774 | math-radix-digits-cache)))))))) |
| 775 | |
| 776 | (defvar math-radix-float-cache-tag nil) |
| 777 | (defvar math-radix-float-cache) |
| 778 | |
| 779 | (defun math-radix-float-power (n) |
| 780 | (if (eq n 0) |
| 781 | '(float 1 0) |
| 782 | (or (and (eq calc-number-radix (car math-radix-float-cache-tag)) |
| 783 | (<= calc-internal-prec (cdr math-radix-float-cache-tag))) |
| 784 | (setq math-radix-float-cache-tag (cons calc-number-radix |
| 785 | calc-internal-prec) |
| 786 | math-radix-float-cache nil)) |
| 787 | (math-normalize |
| 788 | (or (cdr (assoc n math-radix-float-cache)) |
| 789 | (cdr (car (setq math-radix-float-cache |
| 790 | (cons (cons |
| 791 | n |
| 792 | (let ((calc-internal-prec |
| 793 | (cdr math-radix-float-cache-tag))) |
| 794 | (if (math-negp n) |
| 795 | (math-div-float '(float 1 0) |
| 796 | (math-radix-float-power |
| 797 | (math-neg n))) |
| 798 | (math-mul-float (math-sqr-float |
| 799 | (math-radix-float-power |
| 800 | (math-div2 n))) |
| 801 | (if (math-evenp n) |
| 802 | '(float 1 0) |
| 803 | (math-float |
| 804 | calc-number-radix)))))) |
| 805 | math-radix-float-cache)))))))) |
| 806 | |
| 807 | |
| 808 | ;;; arch-tag: f6dba7bc-53b2-41ae-919c-c266ab0ca8b3 |
| 809 | ;;; calc-bin.el ends here |