home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / misc / volume24 / gnucalc / part15 < prev    next >
Lisp/Scheme  |  1991-10-29  |  57KB  |  1,801 lines
  1. Newsgroups: comp.sources.misc
  2. From: daveg@synaptics.com (David Gillespie)
  3. Subject:  v24i063:  gnucalc - GNU Emacs Calculator, v2.00, Part15/56
  4. Message-ID: <1991Oct29.230249.20498@sparky.imd.sterling.com>
  5. X-Md4-Signature: f50ac648daab865903706eb51c2b4e86
  6. Date: Tue, 29 Oct 1991 23:02:49 GMT
  7. Approved: kent@sparky.imd.sterling.com
  8.  
  9. Submitted-by: daveg@synaptics.com (David Gillespie)
  10. Posting-number: Volume 24, Issue 63
  11. Archive-name: gnucalc/part15
  12. Environment: Emacs
  13. Supersedes: gmcalc: Volume 13, Issue 27-45
  14.  
  15. ---- Cut Here and unpack ----
  16. #!/bin/sh
  17. # do not concatenate these parts, unpack them in order with /bin/sh
  18. # file calc-ext.el continued
  19. #
  20. if test ! -r _shar_seq_.tmp; then
  21.     echo 'Please unpack part 1 first!'
  22.     exit 1
  23. fi
  24. (read Scheck
  25.  if test "$Scheck" != 15; then
  26.     echo Please unpack part "$Scheck" next!
  27.     exit 1
  28.  else
  29.     exit 0
  30.  fi
  31. ) < _shar_seq_.tmp || exit 1
  32. if test ! -f _shar_wnt_.tmp; then
  33.     echo 'x - still skipping calc-ext.el'
  34. else
  35. echo 'x - continuing file calc-ext.el'
  36. sed 's/^X//' << 'SHAR_EOF' >> 'calc-ext.el' &&
  37. X  (let* ((calc-language nil)
  38. X     (math-expr-opers math-standard-opers)
  39. X     (val (math-read-expr exp-str)))
  40. X    (and error-check
  41. X     (eq (car-safe val) 'error)
  42. X     (error "%s: %s" (nth 2 val) exp-str))
  43. X    val)
  44. )
  45. X
  46. X
  47. (defun math-read-string ()
  48. X  (let ((str (read-from-string (concat exp-data "\""))))
  49. X    (or (and (= (cdr str) (1+ (length exp-data)))
  50. X         (stringp (car str)))
  51. X    (throw 'syntax "Error in string constant"))
  52. X    (math-read-token)
  53. X    (append '(vec) (car str) nil))
  54. )
  55. X
  56. X
  57. X
  58. ;;; They said it couldn't be done...
  59. X
  60. (defun math-read-big-expr (str)
  61. X  (and (> (length calc-left-label) 0)
  62. X       (string-match (concat "^" (regexp-quote calc-left-label)) str)
  63. X       (setq str (concat (substring str 0 (match-beginning 0))
  64. X             (substring str (match-end 0)))))
  65. X  (and (> (length calc-right-label) 0)
  66. X       (string-match (concat (regexp-quote calc-right-label) " *$") str)
  67. X       (setq str (concat (substring str 0 (match-beginning 0))
  68. X             (substring str (match-end 0)))))
  69. X  (if (string-match "\\\\[^ \n|]" str)
  70. X      (if (eq calc-language 'tex)
  71. X      (math-read-expr str)
  72. X    (let ((calc-language 'tex)
  73. X          (calc-language-option nil)
  74. X          (math-expr-opers (get 'tex 'math-oper-table))
  75. X          (math-expr-function-mapping (get 'tex 'math-function-table))
  76. X          (math-expr-variable-mapping (get 'tex 'math-variable-table)))
  77. X      (math-read-expr str)))
  78. X    (let ((lines nil)
  79. X      (pos 0)
  80. X      (width 0)
  81. X      (err-msg nil)
  82. X      the-baseline the-h2
  83. X      new-pos p)
  84. X      (while (setq new-pos (string-match "\n" str pos))
  85. X    (setq lines (cons (substring str pos new-pos) lines)
  86. X          pos (1+ new-pos)))
  87. X      (setq lines (nreverse (cons (substring str pos) lines))
  88. X        p lines)
  89. X      (while p
  90. X    (setq width (max width (length (car p)))
  91. X          p (cdr p)))
  92. X      (if (math-read-big-bigp lines)
  93. X      (or (catch 'syntax
  94. X        (math-read-big-rec 0 0 width (length lines)))
  95. X          err-msg
  96. X          '(error 0 "Syntax error"))
  97. X    (math-read-expr str))))
  98. )
  99. X
  100. (defun math-read-big-bigp (lines)
  101. X  (and (cdr lines)
  102. X       (let ((matrix nil)
  103. X         (v 0)
  104. X         (height (if (> (length (car lines)) 0) 1 0)))
  105. X     (while (and (cdr lines)
  106. X             (let* ((i 0)
  107. X                j
  108. X                (l1 (car lines))
  109. X                (l2 (nth 1 lines))
  110. X                (len (min (length l1) (length l2))))
  111. X               (if (> (length l2) 0)
  112. X               (setq height (1+ height)))
  113. X               (while (and (< i len)
  114. X                   (or (memq (aref l1 i) '(?\  ?\- ?\_))
  115. X                       (memq (aref l2 i) '(?\  ?\-))
  116. X                       (and (memq (aref l1 i) '(?\| ?\,))
  117. X                        (= (aref l2 i) (aref l1 i)))
  118. X                       (and (eq (aref l1 i) ?\[)
  119. X                        (eq (aref l2 i) ?\[)
  120. X                        (let ((h2 (length l1)))
  121. X                          (setq j (math-read-big-balance
  122. X                               (1+ i) v "[")))
  123. X                        (setq i (1- j)))))
  124. X             (setq i (1+ i)))
  125. X               (or (= i len)
  126. X               (and (eq (aref l1 i) ?\[)
  127. X                (eq (aref l2 i) ?\[)
  128. X                (setq matrix t)
  129. X                nil))))
  130. X       (setq lines (cdr lines)
  131. X         v (1+ v)))
  132. X     (or (and (> height 1)
  133. X          (not (cdr lines)))
  134. X         matrix)))
  135. )
  136. X
  137. X
  138. X
  139. ;;; Nontrivial "flat" formatting.
  140. X
  141. (defun math-format-flat-expr-fancy (a prec)
  142. X  (cond
  143. X   ((eq (car a) 'incomplete)
  144. X    (format "<incomplete %s>" (nth 1 a)))
  145. X   ((eq (car a) 'vec)
  146. X    (if (or calc-full-trail-vectors (not calc-can-abbrev-vectors)
  147. X        (< (length a) 7))
  148. X    (concat "[" (math-format-flat-vector (cdr a) ", "
  149. X                         (if (cdr (cdr a)) 0 1000)) "]")
  150. X      (concat "["
  151. X          (math-format-flat-expr (nth 1 a) 0) ", "
  152. X          (math-format-flat-expr (nth 2 a) 0) ", "
  153. X          (math-format-flat-expr (nth 3 a) 0) ", ..., "
  154. X          (math-format-flat-expr (nth (1- (length a)) a) 0) "]")))
  155. X   ((eq (car a) 'intv)
  156. X    (concat (if (memq (nth 1 a) '(0 1)) "(" "[")
  157. X        (math-format-flat-expr (nth 2 a) 1000)
  158. X        " .. "
  159. X        (math-format-flat-expr (nth 3 a) 1000)
  160. X        (if (memq (nth 1 a) '(0 2)) ")" "]")))
  161. X   ((eq (car a) 'date)
  162. X    (concat "<" (math-format-date a) ">"))
  163. X   ((and (eq (car a) 'calcFunc-lambda) (> (length a) 2))
  164. X    (let ((p (cdr a))
  165. X      (ap calc-arg-values)
  166. X      (math-format-hash-args (if (= (length a) 3) 1 t)))
  167. X      (while (and (cdr p) (equal (car p) (car ap)))
  168. X    (setq p (cdr p) ap (cdr ap)))
  169. X      (concat "<"
  170. X          (if (cdr p)
  171. X          (concat (math-format-flat-vector
  172. X               (nreverse (cdr (reverse (cdr a)))) ", " 0)
  173. X              " : ")
  174. X        "")
  175. X          (math-format-flat-expr (nth (1- (length a)) a) 0)
  176. X          ">")))
  177. X   ((eq (car a) 'var)
  178. X    (or (and math-format-hash-args
  179. X         (let ((p calc-arg-values) (v 1))
  180. X           (while (and p (not (equal (car p) a)))
  181. X         (setq p (and (eq math-format-hash-args t) (cdr p))
  182. X               v (1+ v)))
  183. X           (and p
  184. X            (if (eq math-format-hash-args 1)
  185. X            "#"
  186. X              (format "#%d" v)))))
  187. X    (symbol-name (nth 1 a))))
  188. X   ((and (memq (car a) '(calcFunc-string calcFunc-bstring))
  189. X     (= (length a) 2)
  190. X     (math-vectorp (nth 1 a))
  191. X     (math-vector-is-string (nth 1 a)))
  192. X    (concat (substring (symbol-name (car a)) 9)
  193. X        "(" (math-vector-to-string (nth 1 a) t)) ")")
  194. X   (t
  195. X    (let ((op (math-assq2 (car a) math-standard-opers)))
  196. X      (cond ((and op (= (length a) 3))
  197. X         (if (> prec (min (nth 2 op) (nth 3 op)))
  198. X         (concat "(" (math-format-flat-expr a 0) ")")
  199. X           (let ((lhs (math-format-flat-expr (nth 1 a) (nth 2 op)))
  200. X             (rhs (math-format-flat-expr (nth 2 a) (nth 3 op))))
  201. X         (setq op (car op))
  202. X         (if (or (equal op "^") (equal op "_"))
  203. X             (if (= (aref lhs 0) ?-)
  204. X             (setq lhs (concat "(" lhs ")")))
  205. X           (setq op (concat " " op " ")))
  206. X         (concat lhs op rhs))))
  207. X        ((eq (car a) 'neg)
  208. X         (concat "-" (math-format-flat-expr (nth 1 a) 1000)))
  209. X        (t
  210. X         (concat (math-remove-dashes
  211. X              (if (string-match "\\`calcFunc-\\([a-zA-Z0-9']+\\)\\'"
  212. X                    (symbol-name (car a)))
  213. X              (math-match-substring (symbol-name (car a)) 1)
  214. X            (symbol-name (car a))))
  215. X             "("
  216. X             (math-format-flat-vector (cdr a) ", " 0)
  217. X             ")"))))))
  218. )
  219. (setq math-format-hash-args nil)
  220. X
  221. (defun math-format-flat-vector (vec sep prec)
  222. X  (if vec
  223. X      (let ((buf (math-format-flat-expr (car vec) prec)))
  224. X    (while (setq vec (cdr vec))
  225. X      (setq buf (concat buf sep (math-format-flat-expr (car vec) prec))))
  226. X    buf)
  227. X    "")
  228. )
  229. (setq calc-can-abbrev-vectors nil)
  230. X
  231. (defun math-format-nice-expr (x w)
  232. X  (cond ((and (eq (car-safe x) 'vec)
  233. X          (cdr (cdr x))
  234. X          (let ((ops '(vec calcFunc-assign calcFunc-condition
  235. X                   calcFunc-schedule calcFunc-iterations
  236. X                   calcFunc-phase)))
  237. X        (or (memq (car-safe (nth 1 x)) ops)
  238. X            (memq (car-safe (nth 2 x)) ops)
  239. X            (memq (car-safe (nth 3 x)) ops)
  240. X            calc-break-vectors)))
  241. X     (concat "[ " (math-format-flat-vector (cdr x) ",\n  " 0) " ]"))
  242. X    (t
  243. X     (let ((str (math-format-flat-expr x 0))
  244. X           (pos 0) p)
  245. X       (or (string-match "\"" str)
  246. X           (while (<= (setq p (+ pos w)) (length str))
  247. X         (while (and (> (setq p (1- p)) pos)
  248. X                 (not (= (aref str p) ? ))))
  249. X         (if (> p (+ pos 5))
  250. X             (setq str (concat (substring str 0 p)
  251. X                       "\n "
  252. X                       (substring str p))
  253. X               pos (1+ p))
  254. X           (setq pos (+ pos w)))))
  255. X       str)))
  256. )
  257. X
  258. (defun math-assq2 (v a)
  259. X  (while (and a (not (eq v (nth 1 (car a)))))
  260. X    (setq a (cdr a)))
  261. X  (car a)
  262. )
  263. X
  264. X
  265. (defun math-format-number-fancy (a prec)
  266. X  (cond
  267. X   ((eq (car a) 'float)    ; non-decimal radix
  268. X    (if (Math-integer-negp (nth 1 a))
  269. X    (concat "-" (math-format-number (math-neg a)))
  270. X      (let ((str (if (and calc-radix-formatter
  271. X              (not (memq calc-language '(c pascal))))
  272. X             (funcall calc-radix-formatter
  273. X                  calc-number-radix
  274. X                  (math-format-radix-float a prec))
  275. X           (format "%d#%s" calc-number-radix
  276. X               (math-format-radix-float a prec)))))
  277. X    (if (and prec (> prec 191) (string-match "\\*" str))
  278. X        (concat "(" str ")")
  279. X      str))))
  280. X   ((eq (car a) 'frac)
  281. X    (setq a (math-adjust-fraction a))
  282. X    (if (> (length (car calc-frac-format)) 1)
  283. X    (if (Math-integer-negp (nth 1 a))
  284. X        (concat "-" (math-format-number (math-neg a)))
  285. X      (let ((q (math-idivmod (nth 1 a) (nth 2 a))))
  286. X        (concat (let ((calc-frac-format nil))
  287. X              (math-format-number (car q)))
  288. X            (substring (car calc-frac-format) 0 1)
  289. X            (let ((math-radix-explicit-format nil)
  290. X              (calc-frac-format nil))
  291. X              (math-format-number (cdr q)))
  292. X            (substring (car calc-frac-format) 1 2)
  293. X            (let ((math-radix-explicit-format nil)
  294. X              (calc-frac-format nil))
  295. X              (math-format-number (nth 2 a))))))
  296. X      (concat (let ((calc-frac-format nil))
  297. X        (math-format-number (nth 1 a)))
  298. X          (car calc-frac-format)
  299. X          (let ((math-radix-explicit-format nil)
  300. X            (calc-frac-format nil))
  301. X        (math-format-number (nth 2 a))))))
  302. X   ((eq (car a) 'cplx)
  303. X    (if (math-zerop (nth 2 a))
  304. X    (math-format-number (nth 1 a))
  305. X      (if (null calc-complex-format)
  306. X      (concat "(" (math-format-number (nth 1 a))
  307. X          ", " (math-format-number (nth 2 a)) ")")
  308. X    (if (math-zerop (nth 1 a))
  309. X        (if (math-equal-int (nth 2 a) 1)
  310. X        (symbol-name calc-complex-format)
  311. X          (if prec
  312. X          (math-compose-expr (list '* (nth 2 a) '(cplx 0 1)) prec)
  313. X        (concat (math-format-number (nth 2 a)) " "
  314. X            (symbol-name calc-complex-format))))
  315. X      (if prec
  316. X          (math-compose-expr (list (if (math-negp (nth 2 a)) '- '+)
  317. X                       (nth 1 a)
  318. X                       (list 'cplx 0 (math-abs (nth 2 a))))
  319. X                 prec)
  320. X        (concat (math-format-number (nth 1 a))
  321. X            (if (math-negp (nth 2 a)) " - " " + ")
  322. X            (math-format-number (math-abs (nth 2 a))) " "
  323. X            (symbol-name calc-complex-format)))))))
  324. X   ((eq (car a) 'polar)
  325. X    (concat "(" (math-format-number (nth 1 a))
  326. X        "; " (math-format-number (nth 2 a)) ")"))
  327. X   ((eq (car a) 'hms)
  328. X    (if (math-negp a)
  329. X    (concat "-" (math-format-number (math-neg a)))
  330. X      (let ((calc-number-radix 10)
  331. X        (calc-leading-zeros nil)
  332. X        (calc-group-digits nil))
  333. X    (format calc-hms-format
  334. X        (let ((calc-frac-format '(":" nil)))
  335. X          (math-format-number (nth 1 a)))
  336. X        (let ((calc-frac-format '(":" nil)))
  337. X          (math-format-number (nth 2 a)))
  338. X        (math-format-number (nth 3 a))))))
  339. X   ((eq (car a) 'intv)
  340. X    (concat (if (memq (nth 1 a) '(0 1)) "(" "[")
  341. X        (math-format-number (nth 2 a))
  342. X        " .. "
  343. X        (math-format-number (nth 3 a))
  344. X        (if (memq (nth 1 a) '(0 2)) ")" "]")))
  345. X   ((eq (car a) 'sdev)
  346. X    (concat (math-format-number (nth 1 a))
  347. X        " +/- "
  348. X        (math-format-number (nth 2 a))))
  349. X   ((eq (car a) 'vec)
  350. X    (math-format-flat-expr a 0))
  351. X   (t (format "%s" a)))
  352. )
  353. X
  354. (defun math-adjust-fraction (a)
  355. X  (if (nth 1 calc-frac-format)
  356. X      (progn
  357. X    (if (Math-integerp a) (setq a (list 'frac a 1)))
  358. X    (let ((g (math-quotient (nth 1 calc-frac-format)
  359. X                (math-gcd (nth 2 a)
  360. X                      (nth 1 calc-frac-format)))))
  361. X      (list 'frac (math-mul (nth 1 a) g) (math-mul (nth 2 a) g))))
  362. X    a)
  363. )
  364. X
  365. (defun math-format-bignum-fancy (a)   ; [X L]
  366. X  (let ((str (cond ((= calc-number-radix 10)
  367. X            (math-format-bignum-decimal a))
  368. X           ((= calc-number-radix 2)
  369. X            (math-format-bignum-binary a))
  370. X           ((= calc-number-radix 8)
  371. X            (math-format-bignum-octal a))
  372. X           ((= calc-number-radix 16)
  373. X            (math-format-bignum-hex a))
  374. X           (t (math-format-bignum-radix a)))))
  375. X    (if calc-leading-zeros
  376. X    (let* ((calc-internal-prec 6)
  377. X           (digs (math-compute-max-digits (math-abs calc-word-size)
  378. X                          calc-number-radix))
  379. X           (len (length str)))
  380. X      (if (< len digs)
  381. X          (setq str (concat (make-string (- digs len) ?0) str)))))
  382. X    (if calc-group-digits
  383. X    (let ((i (length str))
  384. X          (g (if (integerp calc-group-digits)
  385. X             (math-abs calc-group-digits)
  386. X           (if (memq calc-number-radix '(2 16)) 4 3))))
  387. X      (while (> i g)
  388. X        (setq i (- i g)
  389. X          str (concat (substring str 0 i)
  390. X                  calc-group-char
  391. X                  (substring str i))))
  392. X      str))
  393. X    (if (and (/= calc-number-radix 10)
  394. X         math-radix-explicit-format)
  395. X    (if calc-radix-formatter
  396. X        (funcall calc-radix-formatter calc-number-radix str)
  397. X      (format "%d#%s" calc-number-radix str))
  398. X      str))
  399. )
  400. X
  401. X
  402. (defun math-group-float (str)   ; [X X]
  403. X  (let* ((pt (or (string-match "[^0-9a-zA-Z]" str) (length str)))
  404. X     (g (if (integerp calc-group-digits) (math-abs calc-group-digits) 3))
  405. X     (i pt))
  406. X    (if (and (integerp calc-group-digits) (< calc-group-digits 0))
  407. X    (while (< (setq i (+ (1+ i) g)) (length str))
  408. X      (setq str (concat (substring str 0 i)
  409. X                calc-group-char
  410. X                (substring str i))
  411. X        i (+ i (1- (length calc-group-char))))))
  412. X    (setq i pt)
  413. X    (while (> i g)
  414. X      (setq i (- i g)
  415. X        str (concat (substring str 0 i)
  416. X            calc-group-char
  417. X            (substring str i))))
  418. X    str)
  419. )
  420. X
  421. X
  422. X
  423. X
  424. X
  425. X
  426. X
  427. X
  428. (setq math-compose-level 0)
  429. (setq math-comp-selected nil)
  430. (setq math-comp-tagged nil)
  431. (setq math-comp-sel-hpos nil)
  432. (setq math-comp-sel-vpos nil)
  433. (setq math-comp-sel-cpos nil)
  434. (setq math-compose-hash-args nil)
  435. X
  436. X
  437. ;;; Users can redefine this in their .emacs files.
  438. (defvar calc-keypad-user-menu nil
  439. X  "If not NIL, this describes an additional menu for calc-keypad.
  440. It should contain a list of three rows.
  441. Each row should be a list of six keys.
  442. Each key should be a list of a label string, plus a Calc command name spec.
  443. A command spec is a command name symbol, a keyboard macro string, a
  444. list containing a numeric entry string, or nil.
  445. A key may contain additional specs for Inverse, Hyperbolic, and Inv+Hyp.")
  446. X
  447. X
  448. X
  449. X
  450. X
  451. (run-hooks 'calc-ext-load-hook)
  452. X
  453. X
  454. SHAR_EOF
  455. echo 'File calc-ext.el is complete' &&
  456. chmod 0644 calc-ext.el ||
  457. echo 'restore of calc-ext.el failed'
  458. Wc_c="`wc -c < 'calc-ext.el'`"
  459. test 118802 -eq "$Wc_c" ||
  460.     echo 'calc-ext.el: original size 118802, current size' "$Wc_c"
  461. rm -f _shar_wnt_.tmp
  462. fi
  463. # ============= calc-fin.el ==============
  464. if test -f 'calc-fin.el' -a X"$1" != X"-c"; then
  465.     echo 'x - skipping calc-fin.el (File already exists)'
  466.     rm -f _shar_wnt_.tmp
  467. else
  468. > _shar_wnt_.tmp
  469. echo 'x - extracting calc-fin.el (Text)'
  470. sed 's/^X//' << 'SHAR_EOF' > 'calc-fin.el' &&
  471. ;; Calculator for GNU Emacs, part II [calc-fin.el]
  472. ;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
  473. ;; Written by Dave Gillespie, daveg@csvax.cs.caltech.edu.
  474. X
  475. ;; This file is part of GNU Emacs.
  476. X
  477. ;; GNU Emacs is distributed in the hope that it will be useful,
  478. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  479. ;; accepts responsibility to anyone for the consequences of using it
  480. ;; or for whether it serves any particular purpose or works at all,
  481. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  482. ;; License for full details.
  483. X
  484. ;; Everyone is granted permission to copy, modify and redistribute
  485. ;; GNU Emacs, but only under the conditions described in the
  486. ;; GNU Emacs General Public License.   A copy of this license is
  487. ;; supposed to have been given to you along with GNU Emacs so you
  488. ;; can know your rights and responsibilities.  It should be in a
  489. ;; file named COPYING.  Among other things, the copyright notice
  490. ;; and this notice must be preserved on all copies.
  491. X
  492. X
  493. X
  494. ;; This file is autoloaded from calc-ext.el.
  495. (require 'calc-ext)
  496. X
  497. (require 'calc-macs)
  498. X
  499. (defun calc-Need-calc-fin () nil)
  500. X
  501. X
  502. ;;; Financial functions.
  503. X
  504. (defun calc-fin-pv ()
  505. X  (interactive)
  506. X  (calc-slow-wrapper
  507. X   (if (calc-is-hyperbolic)
  508. X       (calc-enter-result 3 "pvl" (cons 'calcFunc-pvl (calc-top-list-n 3)))
  509. X     (if (calc-is-inverse)
  510. X     (calc-enter-result 3 "pvb" (cons 'calcFunc-pvb (calc-top-list-n 3)))
  511. X       (calc-enter-result 3 "pv" (cons 'calcFunc-pv (calc-top-list-n 3))))))
  512. )
  513. X
  514. (defun calc-fin-npv (arg)
  515. X  (interactive "p")
  516. X  (calc-slow-wrapper
  517. X   (if (calc-is-inverse)
  518. X       (calc-vector-op "npvb" 'calcFunc-npvb (1+ arg))
  519. X     (calc-vector-op "npv" 'calcFunc-npv (1+ arg))))
  520. )
  521. X
  522. (defun calc-fin-fv ()
  523. X  (interactive)
  524. X  (calc-slow-wrapper
  525. X   (if (calc-is-hyperbolic)
  526. X       (calc-enter-result 3 "fvl" (cons 'calcFunc-fvl (calc-top-list-n 3)))
  527. X     (if (calc-is-inverse)
  528. X     (calc-enter-result 3 "fvb" (cons 'calcFunc-fvb (calc-top-list-n 3)))
  529. X       (calc-enter-result 3 "fv" (cons 'calcFunc-fv (calc-top-list-n 3))))))
  530. )
  531. X
  532. (defun calc-fin-pmt ()
  533. X  (interactive)
  534. X  (calc-slow-wrapper
  535. X   (if (calc-is-hyperbolic)
  536. X       (calc-enter-result 3 "fvl" (cons 'calcFunc-fvl (calc-top-list-n 3)))
  537. X     (if (calc-is-inverse)
  538. X     (calc-enter-result 3 "pmtb" (cons 'calcFunc-pmtb (calc-top-list-n 3)))
  539. X       (calc-enter-result 3 "pmt" (cons 'calcFunc-pmt (calc-top-list-n 3))))))
  540. )
  541. X
  542. (defun calc-fin-nper ()
  543. X  (interactive)
  544. X  (calc-slow-wrapper
  545. X   (if (calc-is-hyperbolic)
  546. X       (calc-enter-result 3 "nprl" (cons 'calcFunc-nperl (calc-top-list-n 3)))
  547. X     (if (calc-is-inverse)
  548. X     (calc-enter-result 3 "nprb" (cons 'calcFunc-nperb
  549. X                       (calc-top-list-n 3)))
  550. X       (calc-enter-result 3 "nper" (cons 'calcFunc-nper
  551. X                     (calc-top-list-n 3))))))
  552. )
  553. X
  554. (defun calc-fin-rate ()
  555. X  (interactive)
  556. X  (calc-slow-wrapper
  557. X   (if (calc-is-hyperbolic)
  558. X       (calc-enter-result 3 "ratl" (cons 'calcFunc-ratel
  559. X                     (calc-top-list-n 3)))
  560. X     (if (calc-is-inverse)
  561. X     (calc-enter-result 3 "ratb" (cons 'calcFunc-rateb
  562. X                       (calc-top-list-n 3)))
  563. X       (calc-enter-result 3 "rate" (cons 'calcFunc-rate
  564. X                     (calc-top-list-n 3))))))
  565. )
  566. X
  567. (defun calc-fin-irr (arg)
  568. X  (interactive "P")
  569. X  (calc-slow-wrapper
  570. X   (if (calc-is-inverse)
  571. X       (calc-vector-op "irrb" 'calcFunc-irrb arg)
  572. X     (calc-vector-op "irr" 'calcFunc-irr arg)))
  573. )
  574. X
  575. (defun calc-fin-sln ()
  576. X  (interactive)
  577. X  (calc-slow-wrapper
  578. X   (calc-enter-result 3 "sln" (cons 'calcFunc-sln (calc-top-list-n 3))))
  579. )
  580. X
  581. (defun calc-fin-syd ()
  582. X  (interactive)
  583. X  (calc-slow-wrapper
  584. X   (calc-enter-result 4 "syd" (cons 'calcFunc-syd (calc-top-list-n 4))))
  585. )
  586. X
  587. (defun calc-fin-ddb ()
  588. X  (interactive)
  589. X  (calc-slow-wrapper
  590. X   (calc-enter-result 4 "ddb" (cons 'calcFunc-ddb (calc-top-list-n 4))))
  591. )
  592. X
  593. X
  594. X
  595. X
  596. X
  597. X
  598. ;;; Financial functions.
  599. X
  600. (defun calcFunc-pv (rate num amount &optional lump)
  601. X  (math-check-financial rate num)
  602. X  (math-with-extra-prec 2
  603. X    (let ((p (math-pow (math-add 1 rate) num)))
  604. X      (math-add (math-mul amount
  605. X              (math-div (math-sub 1 (math-div 1 p))
  606. X                    rate))
  607. X        (math-div (or lump 0) p))))
  608. )
  609. (put 'calcFunc-pv 'math-expandable t)
  610. X
  611. (defun calcFunc-pvl (rate num amount)
  612. X  (calcFunc-pv rate num 0 amount)
  613. )
  614. (put 'calcFunc-pvl 'math-expandable t)
  615. X
  616. (defun calcFunc-pvb (rate num amount &optional lump)
  617. X  (math-check-financial rate num)
  618. X  (math-with-extra-prec 2
  619. X    (let* ((p (math-pow (math-add 1 rate) num)))
  620. X      (math-add (math-mul amount
  621. X              (math-div (math-mul (math-sub 1 (math-div 1 p))
  622. X                          (math-add 1 rate))
  623. X                    rate))
  624. X        (math-div (or lump 0) p))))
  625. )
  626. (put 'calcFunc-pvb 'math-expandable t)
  627. X
  628. (defun calcFunc-npv (rate &rest flows)
  629. X  (math-check-financial rate 1)
  630. X  (math-with-extra-prec 2
  631. X    (let* ((flat (math-flatten-many-vecs flows))
  632. X       (pp (math-add 1 rate))
  633. X       (p pp)
  634. X       (accum 0))
  635. X      (while (setq flat (cdr flat))
  636. X    (setq accum (math-add accum (math-div (car flat) p))
  637. X          p (math-mul p pp)))
  638. X      accum))
  639. )
  640. (put 'calcFunc-npv 'math-expandable t)
  641. X
  642. (defun calcFunc-npvb (rate &rest flows)
  643. X  (math-check-financial rate 1)
  644. X  (math-with-extra-prec 2
  645. X    (let* ((flat (math-flatten-many-vecs flows))
  646. X       (pp (math-add 1 rate))
  647. X       (p 1)
  648. X       (accum 0))
  649. X      (while (setq flat (cdr flat))
  650. X    (setq accum (math-add accum (math-div (car flat) p))
  651. X          p (math-mul p pp)))
  652. X      accum))
  653. )
  654. (put 'calcFunc-npvb 'math-expandable t)
  655. X
  656. (defun calcFunc-fv (rate num amount &optional initial)
  657. X  (math-check-financial rate num)
  658. X  (math-with-extra-prec 2
  659. X    (let ((p (math-pow (math-add 1 rate) num)))
  660. X      (math-add (math-mul amount
  661. X              (math-div (math-sub p 1)
  662. X                    rate))
  663. X        (math-mul (or initial 0) p))))
  664. )
  665. (put 'calcFunc-fv 'math-expandable t)
  666. X
  667. (defun calcFunc-fvl (rate num amount)
  668. X  (calcFunc-fv rate num 0 amount)
  669. )
  670. (put 'calcFunc-fvl 'math-expandable t)
  671. X
  672. (defun calcFunc-fvb (rate num amount &optional initial)
  673. X  (math-check-financial rate num)
  674. X  (math-with-extra-prec 2
  675. X    (let ((p (math-pow (math-add 1 rate) num)))
  676. X      (math-add (math-mul amount
  677. X              (math-div (math-mul (math-sub p 1)
  678. X                          (math-add 1 rate))
  679. X                    rate))
  680. X        (math-mul (or initial 0) p))))
  681. )
  682. (put 'calcFunc-fvb 'math-expandable t)
  683. X
  684. (defun calcFunc-pmt (rate num amount &optional lump)
  685. X  (math-check-financial rate num)
  686. X  (math-with-extra-prec 2
  687. X    (let ((p (math-pow (math-add 1 rate) num)))
  688. X      (math-div (math-mul (math-sub amount
  689. X                    (math-div (or lump 0) p))
  690. X              rate)
  691. X        (math-sub 1 (math-div 1 p)))))
  692. )
  693. (put 'calcFunc-pmt 'math-expandable t)
  694. X
  695. (defun calcFunc-pmtb (rate num amount &optional lump)
  696. X  (math-check-financial rate num)
  697. X  (math-with-extra-prec 2
  698. X    (let ((p (math-pow (math-add 1 rate) num)))
  699. X      (math-div (math-mul (math-sub amount (math-div (or lump 0) p)) rate)
  700. X        (math-mul (math-sub 1 (math-div 1 p))
  701. X              (math-add 1 rate)))))
  702. )
  703. (put 'calcFunc-pmtb 'math-expandable t)
  704. X
  705. (defun calcFunc-nper (rate pmt amount &optional lump)
  706. X  (math-compute-nper rate pmt amount lump nil)
  707. )
  708. (put 'calcFunc-nper 'math-expandable t)
  709. X
  710. (defun calcFunc-nperb (rate pmt amount &optional lump)
  711. X  (math-compute-nper rate pmt amount lump 'b)
  712. )
  713. (put 'calcFunc-nperb 'math-expandable t)
  714. X
  715. (defun calcFunc-nperl (rate pmt amount)
  716. X  (math-compute-nper rate pmt amount nil 'l)
  717. )
  718. (put 'calcFunc-nperl 'math-expandable t)
  719. X
  720. (defun math-compute-nper (rate pmt amount lump bflag)
  721. X  (and lump (math-zerop lump)
  722. X       (setq lump nil))
  723. X  (and lump (math-zerop pmt)
  724. X       (setq amount lump
  725. X         lump nil
  726. X         bflag 'l))
  727. X  (or (math-objectp rate) (and math-expand-formulas (null lump))
  728. X      (math-reject-arg rate 'numberp))
  729. X  (and (math-zerop rate)
  730. X       (math-reject-arg rate 'nonzerop))
  731. X  (or (math-objectp pmt) (and math-expand-formulas (null lump))
  732. X      (math-reject-arg pmt 'numberp))
  733. X  (or (math-objectp amount) (and math-expand-formulas (null lump))
  734. X      (math-reject-arg amount 'numberp))
  735. X  (if lump
  736. X      (progn
  737. X    (or (math-objectp lump)
  738. X        (math-reject-arg lump 'numberp))
  739. X    (let ((root (math-find-root (list 'calcFunc-eq
  740. X                      (list (if bflag
  741. X                            'calcFunc-pvb
  742. X                          'calcFunc-pv)
  743. X                        rate
  744. X                        '(var DUMMY var-DUMMY)
  745. X                        pmt
  746. X                        lump)
  747. X                      amount)
  748. X                    '(var DUMMY var-DUMMY)
  749. X                    '(intv 3 0 100)
  750. X                    t)))
  751. X      (if (math-vectorp root)
  752. X          (nth 1 root)
  753. X        root)))
  754. X    (math-with-extra-prec 2
  755. X      (let ((temp (if (eq bflag 'l)
  756. X              (math-div amount pmt)
  757. X            (math-sub 1 (math-div (math-mul amount rate)
  758. X                      (if bflag
  759. X                          (math-mul pmt (math-add 1 rate))
  760. X                        pmt))))))
  761. X    (if (or (math-posp temp) math-expand-formulas)
  762. X        (math-neg (calcFunc-log temp (math-add 1 rate)))
  763. X      (math-reject-arg pmt "*Payment too small to cover interest rate")))))
  764. )
  765. X
  766. (defun calcFunc-rate (num pmt amount &optional lump)
  767. X  (math-compute-rate num pmt amount lump 'calcFunc-pv)
  768. )
  769. X
  770. (defun calcFunc-rateb (num pmt amount &optional lump)
  771. X  (math-compute-rate num pmt amount lump 'calcFunc-pvb)
  772. )
  773. X
  774. (defun math-compute-rate (num pmt amount lump func)
  775. X  (or (math-objectp num)
  776. X      (math-reject-arg num 'numberp))
  777. X  (or (math-objectp pmt)
  778. X      (math-reject-arg pmt 'numberp))
  779. X  (or (math-objectp amount)
  780. X      (math-reject-arg amount 'numberp))
  781. X  (or (null lump)
  782. X      (math-objectp lump)
  783. X      (math-reject-arg lump 'numberp))
  784. X  (let ((root (math-find-root (list 'calcFunc-eq
  785. X                    (list func
  786. X                      '(var DUMMY var-DUMMY)
  787. X                      num
  788. X                      pmt
  789. X                      (or lump 0))
  790. X                    amount)
  791. X                  '(var DUMMY var-DUMMY)
  792. X                  '(intv 3 (float 1 -4) 1)
  793. X                  t)))
  794. X    (if (math-vectorp root)
  795. X    (nth 1 root)
  796. X      root))
  797. )
  798. X
  799. (defun calcFunc-ratel (num pmt amount)
  800. X  (or (math-objectp num) math-expand-formulas
  801. X      (math-reject-arg num 'numberp))
  802. X  (or (math-objectp pmt) math-expand-formulas
  803. X      (math-reject-arg pmt 'numberp))
  804. X  (or (math-objectp amount) math-expand-formulas
  805. X      (math-reject-arg amount 'numberp))
  806. X  (math-with-extra-prec 2
  807. X    (math-sub (math-pow (math-div pmt amount) (math-div 1 num)) 1))
  808. )
  809. X
  810. (defun calcFunc-irr (&rest vecs)
  811. X  (math-compute-irr vecs 'calcFunc-npv)
  812. )
  813. X
  814. (defun calcFunc-irrb (&rest vecs)
  815. X  (math-compute-irr vecs 'calcFunc-npvb)
  816. )
  817. X
  818. (defun math-compute-irr (vecs func)
  819. X  (let* ((flat (math-flatten-many-vecs vecs))
  820. X     (root (math-find-root (list func
  821. X                     '(var DUMMY var-DUMMY)
  822. X                     flat)
  823. X                   '(var DUMMY var-DUMMY)
  824. X                   '(intv 3 '(float 1 -4) 1)
  825. X                   t)))
  826. X    (if (math-vectorp root)
  827. X    (nth 1 root)
  828. X      root))
  829. )
  830. X
  831. (defun math-check-financial (rate num)
  832. X  (or (math-objectp rate) math-expand-formulas
  833. X      (math-reject-arg rate 'numberp))
  834. X  (and (math-zerop rate)
  835. X       (math-reject-arg rate 'nonzerop))
  836. X  (or (math-objectp num) math-expand-formulas
  837. X      (math-reject-arg num 'numberp))
  838. )
  839. X
  840. X
  841. (defun calcFunc-sln (cost salvage life &optional period)
  842. X  (or (math-realp cost) math-expand-formulas
  843. X      (math-reject-arg cost 'realp))
  844. X  (or (math-realp salvage) math-expand-formulas
  845. X      (math-reject-arg salvage 'realp))
  846. X  (or (math-realp life) math-expand-formulas
  847. X      (math-reject-arg life 'realp))
  848. X  (if (math-zerop life) (math-reject-arg life 'nonzerop))
  849. X  (if (and period
  850. X       (if (math-num-integerp period)
  851. X           (or (Math-lessp life period) (not (math-posp period)))
  852. X         (math-reject-arg period 'integerp)))
  853. X      0
  854. X    (math-div (math-sub cost salvage) life))
  855. )
  856. (put 'calcFunc-sln 'math-expandable t)
  857. X
  858. (defun calcFunc-syd (cost salvage life period)
  859. X  (or (math-realp cost) math-expand-formulas
  860. X      (math-reject-arg cost 'realp))
  861. X  (or (math-realp salvage) math-expand-formulas
  862. X      (math-reject-arg salvage 'realp))
  863. X  (or (math-realp life) math-expand-formulas
  864. X      (math-reject-arg life 'realp))
  865. X  (if (math-zerop life) (math-reject-arg life 'nonzerop))
  866. X  (or (math-realp period) math-expand-formulas
  867. X      (math-reject-arg period 'realp))
  868. X  (if (or (Math-lessp life period) (not (math-posp period)))
  869. X      0
  870. X    (math-div (math-mul (math-sub cost salvage)
  871. X            (math-add (math-sub life period) 1))
  872. X          (math-div (math-mul life (math-add life 1)) 2)))
  873. )
  874. (put 'calcFunc-syd 'math-expandable t)
  875. X
  876. (defun calcFunc-ddb (cost salvage life period)
  877. X  (if (math-messy-integerp period) (setq period (math-trunc period)))
  878. X  (or (integerp period) (math-reject-arg period 'fixnump))
  879. X  (or (math-realp cost) (math-reject-arg cost 'realp))
  880. X  (or (math-realp salvage) (math-reject-arg salvage 'realp))
  881. X  (or (math-realp life) (math-reject-arg life 'realp))
  882. X  (if (math-zerop life) (math-reject-arg life 'nonzerop))
  883. X  (if (or (Math-lessp life period) (<= period 0))
  884. X      0
  885. X    (let ((book cost)
  886. X      (res 0))
  887. X      (while (>= (setq period (1- period)) 0)
  888. X    (setq res (math-div (math-mul book 2) life)
  889. X          book (math-sub book res))
  890. X    (if (Math-lessp book salvage)
  891. X        (setq res (math-add res (math-sub book salvage))
  892. X          book salvage)))
  893. X      res))
  894. )
  895. X
  896. X
  897. X
  898. SHAR_EOF
  899. chmod 0644 calc-fin.el ||
  900. echo 'restore of calc-fin.el failed'
  901. Wc_c="`wc -c < 'calc-fin.el'`"
  902. test 12610 -eq "$Wc_c" ||
  903.     echo 'calc-fin.el: original size 12610, current size' "$Wc_c"
  904. rm -f _shar_wnt_.tmp
  905. fi
  906. # ============= calc-forms.el ==============
  907. if test -f 'calc-forms.el' -a X"$1" != X"-c"; then
  908.     echo 'x - skipping calc-forms.el (File already exists)'
  909.     rm -f _shar_wnt_.tmp
  910. else
  911. > _shar_wnt_.tmp
  912. echo 'x - extracting calc-forms.el (Text)'
  913. sed 's/^X//' << 'SHAR_EOF' > 'calc-forms.el' &&
  914. ;; Calculator for GNU Emacs, part II [calc-forms.el]
  915. ;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
  916. ;; Written by Dave Gillespie, daveg@csvax.cs.caltech.edu.
  917. X
  918. ;; This file is part of GNU Emacs.
  919. X
  920. ;; GNU Emacs is distributed in the hope that it will be useful,
  921. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  922. ;; accepts responsibility to anyone for the consequences of using it
  923. ;; or for whether it serves any particular purpose or works at all,
  924. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  925. ;; License for full details.
  926. X
  927. ;; Everyone is granted permission to copy, modify and redistribute
  928. ;; GNU Emacs, but only under the conditions described in the
  929. ;; GNU Emacs General Public License.   A copy of this license is
  930. ;; supposed to have been given to you along with GNU Emacs so you
  931. ;; can know your rights and responsibilities.  It should be in a
  932. ;; file named COPYING.  Among other things, the copyright notice
  933. ;; and this notice must be preserved on all copies.
  934. X
  935. X
  936. X
  937. ;; This file is autoloaded from calc-ext.el.
  938. (require 'calc-ext)
  939. X
  940. (require 'calc-macs)
  941. X
  942. (defun calc-Need-calc-forms () nil)
  943. X
  944. X
  945. (defun calc-time ()
  946. X  (interactive)
  947. X  (calc-wrapper
  948. X   (let ((time (current-time-string)))
  949. X     (calc-enter-result 0 "time"
  950. X            (list 'mod
  951. X                  (list 'hms
  952. X                    (string-to-int (substring time 11 13))
  953. X                    (string-to-int (substring time 14 16))
  954. X                    (string-to-int (substring time 17 19)))
  955. X                  (list 'hms 24 0 0)))))
  956. )
  957. X
  958. X
  959. X
  960. X
  961. (defun calc-to-hms (arg)
  962. X  (interactive "P")
  963. X  (calc-wrapper
  964. X   (if (calc-is-inverse)
  965. X       (if (eq calc-angle-mode 'rad)
  966. X       (calc-unary-op ">rad" 'calcFunc-rad arg)
  967. X     (calc-unary-op ">deg" 'calcFunc-deg arg))
  968. X     (calc-unary-op ">hms" 'calcFunc-hms arg)))
  969. )
  970. X
  971. (defun calc-from-hms (arg)
  972. X  (interactive "P")
  973. X  (calc-invert-func)
  974. X  (calc-to-hms arg)
  975. )
  976. X
  977. X
  978. (defun calc-hms-notation (fmt)
  979. X  (interactive "sHours-minutes-seconds format (hms, @ ' \", etc.): ")
  980. X  (calc-wrapper
  981. X   (if (string-match "\\`\\([^,; ]+\\)\\([,; ]*\\)\\([^,; ]\\)\\([,; ]*\\)\\([^,; ]\\)\\'" fmt)
  982. X       (progn
  983. X     (calc-change-mode 'calc-hms-format
  984. X               (concat "%s" (math-match-substring fmt 1)
  985. X                   (math-match-substring fmt 2)
  986. X                   "%s" (math-match-substring fmt 3)
  987. X                   (math-match-substring fmt 4)
  988. X                   "%s" (math-match-substring fmt 5))
  989. X               t)
  990. X     (setq-default calc-hms-format calc-hms-format))  ; for minibuffer
  991. X     (error "Bad hours-minutes-seconds format.")))
  992. )
  993. X
  994. (defun calc-date-notation (fmt arg)
  995. X  (interactive "sDate format (e.g., M/D/YY h:mm:ss): \nP")
  996. X  (calc-wrapper
  997. X   (if (equal fmt "")
  998. X       (setq fmt "1"))
  999. X   (if (string-match "\\` *[0-9] *\\'" fmt)
  1000. X       (setq fmt (nth (string-to-int fmt) calc-standard-date-formats)))
  1001. X   (or (string-match "[a-zA-Z]" fmt)
  1002. X       (error "Bad date format specifier"))
  1003. X   (and arg
  1004. X    (>= (setq arg (prefix-numeric-value arg)) 0)
  1005. X    (<= arg 9)
  1006. X    (setcar (nthcdr arg calc-standard-date-formats) fmt))
  1007. X   (let ((case-fold-search nil))
  1008. X     (and (not (string-match "<.*>" fmt))
  1009. X      (string-match "\\`[^hHspP]*\\([^ac-gi-lnoqrt-zAC-GI-OQRT-Z]*[bBhHmpPsS]+[^ac-gi-lnoqrt-zAC-GI-OQRT-Z]*\\)[^hHspP]*\\'" fmt)
  1010. X      (string-match (concat "[^ac-gi-lnoqrt-zAC-GI-OQRT-Z]*"
  1011. X                (regexp-quote (math-match-substring fmt 1))
  1012. X                "[^ac-gi-lnoqrt-zAC-GI-OQRT-Z]*") fmt)
  1013. X      (setq fmt (concat (substring fmt 0 (match-beginning 0))
  1014. X                "<"
  1015. X                (substring fmt (match-beginning 0) (match-end 0))
  1016. X                ">"
  1017. X                (substring fmt (match-end 0))))))
  1018. X   (let ((lfmt nil)
  1019. X     (fullfmt nil)
  1020. X     (time nil)
  1021. X     pos pos2 sym temp)
  1022. X     (let ((case-fold-search nil))
  1023. X       (and (setq temp (string-match ":[BS]S" fmt))
  1024. X        (aset fmt temp ?C)))
  1025. X     (while (setq pos (string-match "[<>a-zA-Z]" fmt))
  1026. X       (if (> pos 0)
  1027. X       (setq lfmt (cons (substring fmt 0 pos) lfmt)))
  1028. X       (setq pos2 (1+ pos))
  1029. X       (cond ((= (aref fmt pos) ?\<)
  1030. X          (and time (error "Nested <'s not allowed"))
  1031. X          (and lfmt (setq fullfmt (nconc lfmt fullfmt)
  1032. X                  lfmt nil))
  1033. X          (setq time t))
  1034. X         ((= (aref fmt pos) ?\>)
  1035. X          (or time (error "Misplaced > in format"))
  1036. X          (and lfmt (setq fullfmt (cons (nreverse lfmt) fullfmt)
  1037. X                  lfmt nil))
  1038. X          (setq time nil))
  1039. X         (t
  1040. X          (if (string-match "\\`[^a-zA-Z]*[bB][a-zA-Z]" fmt)
  1041. X          (setq pos2 (1+ pos2)))
  1042. X          (while (and (< pos2 (length fmt))
  1043. X              (= (upcase (aref fmt pos2))
  1044. X                 (upcase (aref fmt (1- pos2)))))
  1045. X        (setq pos2 (1+ pos2)))
  1046. X          (setq sym (intern (substring fmt pos pos2)))
  1047. X          (or (memq sym '(Y YY BY YYY YYYY
  1048. X                aa AA aaa AAA aaaa AAAA
  1049. X                bb BB bbb BBB bbbb BBBB
  1050. X                M MM BM Mmm Mmmm MMM MMMM
  1051. X                D DD BD d ddd bdd
  1052. X                W Www Wwww WWW WWWW
  1053. X                h hh bh H HH BH
  1054. X                p P pp PP pppp PPPP
  1055. X                m mm bm s ss bss SS BS C
  1056. X                N n J j U b))
  1057. X          (and (eq sym 'X) (not lfmt) (not fullfmt))
  1058. X          (error "Bad format code: %s" sym))
  1059. X          (and (memq sym '(bb BB bbb BBB bbbb BBBB))
  1060. X           (setq lfmt (cons 'b lfmt)))
  1061. X          (setq lfmt (cons sym lfmt))))
  1062. X       (setq fmt (substring fmt pos2)))
  1063. X     (or (equal fmt "")
  1064. X     (setq lfmt (cons fmt lfmt)))
  1065. X     (and lfmt (if time
  1066. X           (setq fullfmt (cons (nreverse lfmt) fullfmt))
  1067. X         (setq fullfmt (nconc lfmt fullfmt))))
  1068. X     (calc-change-mode 'calc-date-format (nreverse fullfmt) t)))
  1069. )
  1070. X
  1071. X
  1072. (defun calc-hms-mode ()
  1073. X  (interactive)
  1074. X  (calc-wrapper
  1075. X   (calc-change-mode 'calc-angle-mode 'hms)
  1076. X   (message "Angles measured in degrees-minutes-seconds."))
  1077. )
  1078. X
  1079. X
  1080. (defun calc-now (arg)
  1081. X  (interactive "P")
  1082. X  (calc-date-zero-args "now" 'calcFunc-now arg)
  1083. )
  1084. X
  1085. (defun calc-date-part (arg)
  1086. X  (interactive "NPart code (1-9 = Y,M,D,H,M,S,Wd,Yd,Hms): ")
  1087. X  (if (or (< arg 1) (> arg 9))
  1088. X      (error "Part code out of range"))
  1089. X  (calc-wrapper
  1090. X   (calc-enter-result 1
  1091. X              (nth arg '(nil "year" "mnth" "day" "hour" "minu"
  1092. X                      "sec" "wday" "yday" "hmst"))
  1093. X              (list (nth arg '(nil calcFunc-year calcFunc-month
  1094. X                       calcFunc-day calcFunc-hour
  1095. X                       calcFunc-minute calcFunc-second
  1096. X                       calcFunc-weekday calcFunc-yearday
  1097. X                       calcFunc-time))
  1098. X                (calc-top-n 1))))
  1099. )
  1100. X
  1101. (defun calc-date (arg)
  1102. X  (interactive "p")
  1103. X  (if (or (< arg 1) (> arg 6))
  1104. X      (error "Between one and six arguments are allowed"))
  1105. X  (calc-wrapper
  1106. X   (calc-enter-result arg "date" (cons 'calcFunc-date (calc-top-list-n arg))))
  1107. )
  1108. X
  1109. (defun calc-julian (arg)
  1110. X  (interactive "P")
  1111. X  (calc-date-one-arg "juln" 'calcFunc-julian arg)
  1112. )
  1113. X
  1114. (defun calc-unix-time (arg)
  1115. X  (interactive "P")
  1116. X  (calc-date-one-arg "unix" 'calcFunc-unixtime arg)
  1117. )
  1118. X
  1119. (defun calc-time-zone (arg)
  1120. X  (interactive "P")
  1121. X  (calc-date-zero-args "zone" 'calcFunc-tzone arg)
  1122. )
  1123. X
  1124. (defun calc-convert-time-zones (old &optional new)
  1125. X  (interactive "sFrom time zone: ")
  1126. X  (calc-wrapper
  1127. X   (if (equal old "$")
  1128. X       (calc-enter-result 3 "tzcv" (cons 'calcFunc-tzconv (calc-top-list-n 3)))
  1129. X     (if (equal old "") (setq old "local"))
  1130. X     (or new
  1131. X     (setq new (read-string (concat "From time zone: " old
  1132. X                    ", to zone: "))))
  1133. X     (if (stringp old) (setq old (math-read-expr old)))
  1134. X     (if (eq (car-safe old) 'error)
  1135. X     (error "Error in expression: " (nth 1 old)))
  1136. X     (if (equal new "") (setq new "local"))
  1137. X     (if (stringp new) (setq new (math-read-expr new)))
  1138. X     (if (eq (car-safe new) 'error)
  1139. X     (error "Error in expression: " (nth 1 new)))
  1140. X     (calc-enter-result 1 "tzcv" (list 'calcFunc-tzconv
  1141. X                       (calc-top-n 1) old new))))
  1142. )
  1143. X
  1144. (defun calc-new-week (arg)
  1145. X  (interactive "P")
  1146. X  (calc-date-one-arg "nwwk" 'calcFunc-newweek arg)
  1147. )
  1148. X
  1149. (defun calc-new-month (arg)
  1150. X  (interactive "P")
  1151. X  (calc-date-one-arg "nwmn" 'calcFunc-newmonth arg)
  1152. )
  1153. X
  1154. (defun calc-new-year (arg)
  1155. X  (interactive "P")
  1156. X  (calc-date-one-arg "nwyr" 'calcFunc-newyear arg)
  1157. )
  1158. X
  1159. (defun calc-inc-month (arg)
  1160. X  (interactive "p")
  1161. X  (calc-date-one-arg "incm" 'calcFunc-incmonth arg)
  1162. )
  1163. X
  1164. (defun calc-date-zero-args (prefix func arg)
  1165. X  (calc-wrapper
  1166. X   (if (consp arg)
  1167. X       (calc-enter-result 1 prefix (list func (calc-top-n 1)))
  1168. X     (calc-enter-result 0 prefix (if arg
  1169. X                     (list func (prefix-numeric-value arg))
  1170. X                   (list func)))))
  1171. )
  1172. X
  1173. (defun calc-date-one-arg (prefix func arg)
  1174. X  (calc-wrapper
  1175. X   (if (consp arg)
  1176. X       (calc-enter-result 2 prefix (cons func (calc-top-list-n 2)))
  1177. X     (calc-enter-result 1 prefix (if arg
  1178. X                     (list func (calc-top-n 1)
  1179. X                       (prefix-numeric-value arg))
  1180. X                   (list func (calc-top-n 1))))))
  1181. )
  1182. X
  1183. X
  1184. X
  1185. X
  1186. X
  1187. X
  1188. X
  1189. X
  1190. ;;;; Hours-minutes-seconds forms.
  1191. X
  1192. (defun math-normalize-hms (a)
  1193. X  (let ((h (math-normalize (nth 1 a)))
  1194. X    (m (math-normalize (nth 2 a)))
  1195. X    (s (let ((calc-internal-prec (max (- calc-internal-prec 4) 3)))
  1196. X         (math-normalize (nth 3 a)))))
  1197. X    (if (math-negp h)
  1198. X    (progn
  1199. X      (if (math-posp s)
  1200. X          (setq s (math-add s -60)
  1201. X            m (math-add m 1)))
  1202. X      (if (math-posp m)
  1203. X          (setq m (math-add m -60)
  1204. X            h (math-add h 1)))
  1205. X      (if (not (Math-lessp -60 s))
  1206. X          (setq s (math-add s 60)
  1207. X            m (math-add m -1)))
  1208. X      (if (not (Math-lessp -60 m))
  1209. X          (setq m (math-add m 60)
  1210. X            h (math-add h -1))))
  1211. X      (if (math-negp s)
  1212. X      (setq s (math-add s 60)
  1213. X        m (math-add m -1)))
  1214. X      (if (math-negp m)
  1215. X      (setq m (math-add m 60)
  1216. X        h (math-add h -1)))
  1217. X      (if (not (Math-lessp s 60))
  1218. X      (setq s (math-add s -60)
  1219. X        m (math-add m 1)))
  1220. X      (if (not (Math-lessp m 60))
  1221. X      (setq m (math-add m -60)
  1222. X        h (math-add h 1))))
  1223. X    (if (and (eq (car-safe s) 'float)
  1224. X         (<= (+ (math-numdigs (nth 1 s)) (nth 2 s))
  1225. X         (- 2 calc-internal-prec)))
  1226. X    (setq s 0))
  1227. X    (list 'hms h m s))
  1228. )
  1229. X
  1230. ;;; Convert A from ANG or current angular mode to HMS format.
  1231. (defun math-to-hms (a &optional ang)   ; [X R] [Public]
  1232. X  (cond ((eq (car-safe a) 'hms) a)
  1233. X    ((eq (car-safe a) 'sdev)
  1234. X     (math-make-sdev (math-to-hms (nth 1 a))
  1235. X             (math-to-hms (nth 2 a))))
  1236. X    ((not (Math-numberp a))
  1237. X     (list 'calcFunc-hms a))
  1238. X    ((math-negp a)
  1239. X     (math-neg (math-to-hms (math-neg a) ang)))
  1240. X    ((eq (or ang calc-angle-mode) 'rad)
  1241. X     (math-to-hms (math-div a (math-pi-over-180)) 'deg))
  1242. X    ((memq (car-safe a) '(cplx polar)) a)
  1243. X    (t
  1244. X     ;(setq a (let ((calc-internal-prec (max (1- calc-internal-prec) 3)))
  1245. X     ;        (math-normalize a)))
  1246. X     (math-normalize
  1247. X      (let* ((b (math-mul a 3600))
  1248. X         (hm (math-trunc (math-div b 60)))
  1249. X         (hmd (math-idivmod hm 60)))
  1250. X        (list 'hms
  1251. X          (car hmd)
  1252. X          (cdr hmd)
  1253. X          (math-sub b (math-mul hm 60)))))))
  1254. )
  1255. (defun calcFunc-hms (h &optional m s)
  1256. X  (or (Math-realp h) (math-reject-arg h 'realp))
  1257. X  (or m (setq m 0))
  1258. X  (or (Math-realp m) (math-reject-arg m 'realp))
  1259. X  (or s (setq s 0))
  1260. X  (or (Math-realp s) (math-reject-arg s 'realp))
  1261. X  (if (and (not (Math-lessp m 0)) (Math-lessp m 60)
  1262. X       (not (Math-lessp s 0)) (Math-lessp s 60))
  1263. X      (math-add (math-to-hms h)
  1264. X        (list 'hms 0 m s))
  1265. X    (math-to-hms (math-add h
  1266. X               (math-add (math-div (or m 0) 60)
  1267. X                     (math-div (or s 0) 3600)))
  1268. X         'deg))
  1269. )
  1270. X
  1271. ;;; Convert A from HMS format to ANG or current angular mode.
  1272. (defun math-from-hms (a &optional ang)   ; [R X] [Public]
  1273. X  (cond ((not (eq (car-safe a) 'hms))
  1274. X     (if (Math-numberp a)
  1275. X         a
  1276. X       (if (eq (car-safe a) 'sdev)
  1277. X           (math-make-sdev (math-from-hms (nth 1 a) ang)
  1278. X                   (math-from-hms (nth 2 a) ang))
  1279. X         (if (eq (or ang calc-angle-mode) 'rad)
  1280. X         (list 'calcFunc-rad a)
  1281. X           (list 'calcFunc-deg a)))))
  1282. X    ((math-negp a)
  1283. X     (math-neg (math-from-hms (math-neg a) ang)))
  1284. X    ((eq (or ang calc-angle-mode) 'rad)
  1285. X     (math-mul (math-from-hms a 'deg) (math-pi-over-180)))
  1286. X    (t
  1287. X     (math-add (math-div (math-add (math-div (nth 3 a)
  1288. X                         '(float 6 1))
  1289. X                       (nth 2 a))
  1290. X                 60)
  1291. X           (nth 1 a))))
  1292. )
  1293. X
  1294. X
  1295. X
  1296. ;;;; Date forms.
  1297. X
  1298. X
  1299. ;;; Some of these functions are adapted from Edward Reingold's "calendar.el".
  1300. ;;; These versions are rewritten to use arbitrary-size integers.
  1301. ;;; The Julian calendar is used up to 9/2/1752, after which the Gregorian
  1302. ;;; calendar is used; the first day after 9/2/1752 is 9/14/1752.
  1303. X
  1304. ;;; A numerical date is the number of days since midnight on
  1305. ;;; the morning of January 1, 1 A.D.  If the date is a non-integer,
  1306. ;;; it represents a specific date and time.
  1307. ;;; A "dt" is a list of the form, (year month day), corresponding to
  1308. ;;; an integer code, or (year month day hour minute second), corresponding
  1309. ;;; to a non-integer code.
  1310. X
  1311. (defun math-date-to-dt (value)
  1312. X  (if (eq (car-safe value) 'date)
  1313. X      (setq value (nth 1 value)))
  1314. X  (or (math-realp value)
  1315. X      (math-reject-arg value 'datep))
  1316. X  (let* ((parts (math-date-parts value))
  1317. X     (date (car parts))
  1318. X     (time (nth 1 parts))
  1319. X     (month 1)
  1320. X     day
  1321. X     (year (math-quotient (math-add date (if (Math-lessp date 711859)
  1322. X                         365  ; for speed, we take
  1323. X                           -108)) ; >1950 as a special case
  1324. X                  (if (math-negp value) 366 365)))
  1325. X                    ; this result may be an overestimate
  1326. X     temp)
  1327. X    (while (Math-lessp date (setq temp (math-absolute-from-date year 1 1)))
  1328. X      (setq year (math-add year -1)))
  1329. X    (if (eq year 0) (setq year -1))
  1330. X    (setq date (1+ (math-sub date temp)))
  1331. X    (and (eq year 1752) (>= date 247)
  1332. X     (setq date (+ date 11)))
  1333. X    (setq temp (if (math-leap-year-p year)
  1334. X           [1 32 61 92 122 153 183 214 245 275 306 336 999]
  1335. X         [1 32 60 91 121 152 182 213 244 274 305 335 999]))
  1336. X    (while (>= date (aref temp month))
  1337. X      (setq month (1+ month)))
  1338. X    (setq day (1+ (- date (aref temp (1- month)))))
  1339. X    (if (math-integerp value)
  1340. X    (list year month day)
  1341. X      (list year month day
  1342. X        (/ time 3600)
  1343. X        (% (/ time 60) 60)
  1344. X        (math-add (% time 60) (nth 2 parts)))))
  1345. )
  1346. X
  1347. (defun math-dt-to-date (dt)
  1348. X  (or (integerp (nth 1 dt))
  1349. X      (math-reject-arg (nth 1 dt) 'fixnump))
  1350. X  (if (or (< (nth 1 dt) 1) (> (nth 1 dt) 12))
  1351. X      (math-reject-arg (nth 1 dt) "Month value is out of range"))
  1352. X  (or (integerp (nth 2 dt))
  1353. X      (math-reject-arg (nth 2 dt) 'fixnump))
  1354. X  (if (or (< (nth 2 dt) 1) (> (nth 2 dt) 31))
  1355. X      (math-reject-arg (nth 2 dt) "Day value is out of range"))
  1356. X  (let ((date (math-absolute-from-date (car dt) (nth 1 dt) (nth 2 dt))))
  1357. X    (if (nth 3 dt)
  1358. X    (math-add (math-float date)
  1359. X          (math-div (math-add (+ (* (nth 3 dt) 3600)
  1360. X                     (* (nth 4 dt) 60))
  1361. X                      (nth 5 dt))
  1362. X                '(float 864 2)))
  1363. X      date))
  1364. )
  1365. X
  1366. (defun math-date-parts (value &optional offset)
  1367. X  (let* ((date (math-floor value))
  1368. X     (time (math-round (math-mul (math-sub value (or offset date)) 86400)
  1369. X               (and (> calc-internal-prec 12)
  1370. X                (- calc-internal-prec 12))))
  1371. X     (ftime (math-floor time)))
  1372. X    (list date
  1373. X      ftime
  1374. X      (math-sub time ftime)))
  1375. )
  1376. X
  1377. X
  1378. (defun math-this-year ()
  1379. X  (string-to-int (substring (current-time-string) -4))
  1380. )
  1381. X
  1382. (defun math-leap-year-p (year)
  1383. X  (if (Math-lessp year 1752)
  1384. X      (if (math-negp year)
  1385. X      (= (math-imod (math-neg year) 4) 1)
  1386. X    (= (math-imod year 4) 0))
  1387. X    (setq year (math-imod year 400))
  1388. X    (or (and (= (% year 4) 0) (/= (% year 100) 0))
  1389. X    (= year 0)))
  1390. )
  1391. X
  1392. (defun math-days-in-month (year month)
  1393. X  (if (and (= month 2) (math-leap-year-p year))
  1394. X      29
  1395. X    (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month)))
  1396. )
  1397. X
  1398. (defun math-day-number (year month day)
  1399. X  (let ((day-of-year (+ day (* 31 (1- month)))))
  1400. X    (if (> month 2)
  1401. X    (progn
  1402. X      (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10)))
  1403. X      (if (math-leap-year-p year)
  1404. X          (setq day-of-year (1+ day-of-year)))))
  1405. X    (and (eq year 1752)
  1406. X     (or (> month 9)
  1407. X         (and (= month 9) (>= day 14)))
  1408. X     (setq day-of-year (- day-of-year 11)))
  1409. X    day-of-year)
  1410. )
  1411. X
  1412. (defun math-absolute-from-date (year month day)
  1413. X  (if (eq year 0) (setq year -1))
  1414. X  (let ((yearm1 (math-sub year 1)))
  1415. X    (math-sub (math-add (math-day-number year month day)
  1416. X            (math-add (math-mul 365 yearm1)
  1417. X                  (if (math-posp year)
  1418. X                      (math-quotient yearm1 4)
  1419. X                    (math-sub 365
  1420. X                          (math-quotient (math-sub 3 year)
  1421. X                                 4)))))
  1422. X          (if (or (Math-lessp year 1753)
  1423. X              (and (eq year 1752) (<= month 9)))
  1424. X          1
  1425. X        (let ((correction (math-mul (math-quotient yearm1 100) 3)))
  1426. X          (let ((res (math-idivmod correction 4)))
  1427. X            (math-add (if (= (cdr res) 0)
  1428. X                  -1
  1429. X                0)
  1430. X                  (car res)))))))
  1431. )
  1432. X
  1433. X
  1434. ;;; It is safe to redefine these in your .emacs file to use a different
  1435. ;;; language.
  1436. X
  1437. (defvar math-long-weekday-names '( "Sunday" "Monday" "Tuesday" "Wednesday"
  1438. X                   "Thursday" "Friday" "Saturday" ))
  1439. (defvar math-short-weekday-names '( "Sun" "Mon" "Tue" "Wed"
  1440. X                    "Thu" "Fri" "Sat" ))
  1441. X
  1442. (defvar math-long-month-names '( "January" "February" "March" "April"
  1443. X                 "May" "June" "July" "August"
  1444. X                 "September" "October" "November" "December" ))
  1445. (defvar math-short-month-names '( "Jan" "Feb" "Mar" "Apr" "May" "Jun"
  1446. X                  "Jul" "Aug" "Sep" "Oct" "Nov" "Dec" ))
  1447. X
  1448. X
  1449. (defun math-format-date (date)
  1450. X  (if (eq (car-safe date) 'date)
  1451. X      (setq date (nth 1 date)))
  1452. X  (let ((entry (list date calc-internal-prec calc-date-format)))
  1453. X    (or (cdr (assoc entry math-format-date-cache))
  1454. X    (let* ((dt nil)
  1455. X           (calc-group-digits nil)
  1456. X           (calc-leading-zeros nil)
  1457. X           (calc-number-radix 10)
  1458. X           year month day weekday hour minute second
  1459. X           (bc-flag nil)
  1460. X           (fmt (apply 'concat (mapcar 'math-format-date-part
  1461. X                       calc-date-format))))
  1462. X      (setq math-format-date-cache (cons (cons entry fmt)
  1463. X                         math-format-date-cache))
  1464. X      (and (setq dt (nthcdr 10 math-format-date-cache))
  1465. X           (setcdr dt nil))
  1466. X      fmt)))
  1467. )
  1468. (setq math-format-date-cache nil)
  1469. X
  1470. (defun math-format-date-part (x)
  1471. X  (cond ((stringp x)
  1472. X     x)
  1473. X    ((listp x)
  1474. X     (if (math-integerp date)
  1475. X         ""
  1476. X       (apply 'concat (mapcar 'math-format-date-part x))))
  1477. X    ((eq x 'X)
  1478. X     "")
  1479. X    ((eq x 'N)
  1480. X     (math-format-number date))
  1481. X    ((eq x 'n)
  1482. X     (math-format-number (math-floor date)))
  1483. X    ((eq x 'J)
  1484. X     (math-format-number (math-add date '(float (bigpos 235 214 17) -1))))
  1485. X    ((eq x 'j)
  1486. X     (math-format-number (math-add (math-floor date) '(bigpos 424 721 1))))
  1487. X    ((eq x 'U)
  1488. X     (math-format-number (nth 1 (math-date-parts date 719164))))
  1489. X    ((progn
  1490. X       (or dt
  1491. X           (progn
  1492. X         (setq dt (math-date-to-dt date)
  1493. X               year (car dt)
  1494. X               month (nth 1 dt)
  1495. X               day (nth 2 dt)
  1496. X               weekday (math-mod (math-add (math-floor date) 6) 7)
  1497. X               hour (nth 3 dt)
  1498. X               minute (nth 4 dt)
  1499. X               second (nth 5 dt))
  1500. X         (and (memq 'b calc-date-format)
  1501. X              (math-negp year)
  1502. X              (setq year (math-neg year)
  1503. X                bc-flag t))))
  1504. X       (memq x '(Y YY BY)))
  1505. X     (if (and (integerp year) (> year 1940) (< year 2040))
  1506. X         (format (cond ((eq x 'YY) "%02d")
  1507. X               ((eq x 'BYY) "%2d")
  1508. X               (t "%d"))
  1509. X             (% year 100))
  1510. X       (if (and (natnump year) (< year 100))
  1511. X           (format "+%d" year)
  1512. X         (math-format-number year))))
  1513. X    ((eq x 'YYY)
  1514. X     (math-format-number year))
  1515. X    ((eq x 'YYYY)
  1516. X     (if (and (natnump year) (< year 100))
  1517. X         (format "+%d" year)
  1518. X       (math-format-number year)))
  1519. X    ((eq x 'b) "")
  1520. X    ((eq x 'aa)
  1521. X     (and (not bc-flag) "ad"))
  1522. X    ((eq x 'AA)
  1523. X     (and (not bc-flag) "AD"))
  1524. X    ((eq x 'aaa)
  1525. X     (and (not bc-flag) "ad "))
  1526. X    ((eq x 'AAA)
  1527. X     (and (not bc-flag) "AD "))
  1528. X    ((eq x 'aaaa)
  1529. X     (and (not bc-flag) "a.d."))
  1530. X    ((eq x 'AAAA)
  1531. X     (and (not bc-flag) "A.D."))
  1532. X    ((eq x 'bb)
  1533. X     (and bc-flag "bc"))
  1534. X    ((eq x 'BB)
  1535. X     (and bc-flag "BC"))
  1536. X    ((eq x 'bbb)
  1537. X     (and bc-flag " bc"))
  1538. X    ((eq x 'BBB)
  1539. X     (and bc-flag " BC"))
  1540. X    ((eq x 'bbbb)
  1541. X     (and bc-flag "b.c."))
  1542. X    ((eq x 'BBBB)
  1543. X     (and bc-flag "B.C."))
  1544. X    ((eq x 'M)
  1545. X     (format "%d" month))
  1546. X    ((eq x 'MM)
  1547. X     (format "%02d" month))
  1548. X    ((eq x 'BM)
  1549. X     (format "%2d" month))
  1550. X    ((eq x 'Mmm)
  1551. X     (nth (1- month) math-short-month-names))
  1552. X    ((eq x 'MMM)
  1553. X     (upcase (nth (1- month) math-short-month-names)))
  1554. X    ((eq x 'Mmmm)
  1555. X     (nth (1- month) math-long-month-names))
  1556. X    ((eq x 'MMMM)
  1557. X     (upcase (nth (1- month) math-long-month-names)))
  1558. X    ((eq x 'D)
  1559. X     (format "%d" day))
  1560. X    ((eq x 'DD)
  1561. X     (format "%02d" day))
  1562. X    ((eq x 'BD)
  1563. X     (format "%2d" day))
  1564. X    ((eq x 'W)
  1565. X     (format "%d" weekday))
  1566. X    ((eq x 'Www)
  1567. X     (nth weekday math-short-weekday-names))
  1568. X    ((eq x 'WWW)
  1569. X     (upcase (nth weekday math-short-weekday-names)))
  1570. X    ((eq x 'Wwww)
  1571. X     (nth weekday math-long-weekday-names))
  1572. X    ((eq x 'WWWW)
  1573. X     (upcase (nth weekday math-long-weekday-names)))
  1574. X    ((eq x 'd)
  1575. X     (format "%d" (math-day-number year month day)))
  1576. X    ((eq x 'ddd)
  1577. X     (format "%03d" (math-day-number year month day)))
  1578. X    ((eq x 'bdd)
  1579. X     (format "%3d" (math-day-number year month day)))
  1580. X    ((eq x 'h)
  1581. X     (and hour (format "%d" hour)))
  1582. X    ((eq x 'hh)
  1583. X     (and hour (format "%02d" hour)))
  1584. X    ((eq x 'bh)
  1585. X     (and hour (format "%2d" hour)))
  1586. X    ((eq x 'H)
  1587. X     (and hour (format "%d" (1+ (% (+ hour 11) 12)))))
  1588. X    ((eq x 'HH)
  1589. X     (and hour (format "%02d" (1+ (% (+ hour 11) 12)))))
  1590. X    ((eq x 'BH)
  1591. X     (and hour (format "%2d" (1+ (% (+ hour 11) 12)))))
  1592. X    ((eq x 'p)
  1593. X     (and hour (if (< hour 12) "a" "p")))
  1594. X    ((eq x 'P)
  1595. X     (and hour (if (< hour 12) "A" "P")))
  1596. X    ((eq x 'pp)
  1597. X     (and hour (if (< hour 12) "am" "pm")))
  1598. X    ((eq x 'PP)
  1599. X     (and hour (if (< hour 12) "AM" "PM")))
  1600. X    ((eq x 'pppp)
  1601. X     (and hour (if (< hour 12) "a.m." "p.m.")))
  1602. X    ((eq x 'PPPP)
  1603. X     (and hour (if (< hour 12) "A.M." "P.M.")))
  1604. X    ((eq x 'm)
  1605. X     (and minute (format "%d" minute)))
  1606. X    ((eq x 'mm)
  1607. X     (and minute (format "%02d" minute)))
  1608. X    ((eq x 'bm)
  1609. X     (and minute (format "%2d" minute)))
  1610. X    ((eq x 'C)
  1611. X     (and second (not (math-zerop second))
  1612. X          ":"))
  1613. X    ((memq x '(s ss bs SS BS))
  1614. X     (and second
  1615. X          (not (and (memq x '(SS BS)) (math-zerop second)))
  1616. X          (if (integerp second)
  1617. X          (format (cond ((memq x '(ss SS)) "%02d")
  1618. X                ((memq x '(bs BS)) "%2d")
  1619. X                (t "%d"))
  1620. X              second)
  1621. X        (concat (if (Math-lessp second 10)
  1622. X                (cond ((memq x '(ss SS)) "0")
  1623. X                  ((memq x '(bs BS)) " ")
  1624. X                  (t ""))
  1625. X              "")
  1626. X            (let ((calc-float-format
  1627. X                   (list 'fix (min (- 12 calc-internal-prec)
  1628. X                           0))))
  1629. X              (math-format-number second)))))))
  1630. )
  1631. X
  1632. X
  1633. (defun math-parse-date (str)
  1634. X  (catch 'syntax
  1635. X    (or (math-parse-standard-date str t)
  1636. X    (math-parse-standard-date str nil)
  1637. X    (and (string-match "\\`[^-+/0-9a-zA-Z]*\\([-+]?[0-9]+\\.?[0-9]*\\([eE][-+]?[0-9]+\\)?\\)[^-+/0-9a-zA-Z]*\\'" str)
  1638. X         (list 'date (math-read-number (math-match-substring str 1))))
  1639. X    (let ((case-fold-search t)
  1640. X          (year nil) (month nil) (day nil) (weekday nil)
  1641. X          (hour nil) (minute nil) (second nil) (bc-flag nil)
  1642. X          (a nil) (b nil) (c nil) (bigyear nil) temp)
  1643. X
  1644. X      ;; Extract the time, if any.
  1645. X      (if (or (string-match "\\([0-9][0-9]?\\):\\([0-9][0-9]?\\)\\(:\\([0-9][0-9]?\\(\\.[0-9]+\\)?\\)\\)? *\\([ap]m?\\|[ap]\\. *m\\.\\|noon\\|n\\>\\|midnight\\|mid\\>\\|m\\>\\)?" str)
  1646. X          (string-match "\\([0-9][0-9]?\\)\\(\\)\\(\\(\\(\\)\\)\\) *\\([ap]m?\\|[ap]\\. *m\\.\\|noon\\|n\\>\\|midnight\\|mid\\>\\|m\\>\\)" str))
  1647. X          (let ((ampm (math-match-substring str 6)))
  1648. X        (setq hour (string-to-int (math-match-substring str 1))
  1649. X              minute (math-match-substring str 2)
  1650. X              second (math-match-substring str 4)
  1651. X              str (concat (substring str 0 (match-beginning 0))
  1652. X                  (substring str (match-end 0))))
  1653. X        (if (equal minute "")
  1654. X            (setq minute 0)
  1655. X          (setq minute (string-to-int minute)))
  1656. X        (if (equal second "")
  1657. X            (setq second 0)
  1658. X          (setq second (math-read-number second)))
  1659. X        (if (equal ampm "")
  1660. X            (if (> hour 23)
  1661. X            (throw 'syntax "Hour value out of range"))
  1662. X          (setq ampm (upcase (aref ampm 0)))
  1663. X          (if (memq ampm '(?N ?M))
  1664. X              (if (and (= hour 12) (= minute 0) (eq second 0))
  1665. X              (if (eq ampm ?M) (setq hour 0))
  1666. X            (throw 'syntax
  1667. X                   "Time must be 12:00:00 in this context"))
  1668. X            (if (or (= hour 0) (> hour 12))
  1669. X            (throw 'syntax "Hour value out of range"))
  1670. X            (if (eq (= ampm ?A) (= hour 12))
  1671. X            (setq hour (% (+ hour 12) 24)))))))
  1672. X
  1673. X      ;; Rewrite xx-yy-zz to xx/yy/zz to avoid seeing "-" as a minus sign.
  1674. X      (while (string-match "[0-9a-zA-Z]\\(-\\)[0-9a-zA-Z]" str)
  1675. X        (progn
  1676. X          (setq str (copy-sequence str))
  1677. X          (aset str (match-beginning 1) ?\/)))
  1678. X
  1679. X      ;; Extract obvious month or weekday names.
  1680. X      (if (string-match "[a-zA-Z]" str)
  1681. X          (progn
  1682. X        (setq month (math-parse-date-word math-long-month-names))
  1683. X        (setq weekday (math-parse-date-word math-long-weekday-names))
  1684. X        (or month (setq month
  1685. X                (math-parse-date-word math-short-month-names)))
  1686. X        (or weekday (math-parse-date-word math-short-weekday-names))
  1687. X        (or hour
  1688. X            (if (setq temp (math-parse-date-word
  1689. X                    '( "noon" "midnight" "mid" )))
  1690. X            (setq hour (if (= temp 1) 12 0) minute 0 second 0)))
  1691. X        (or (math-parse-date-word '( "ad" "a.d." ))
  1692. X            (if (math-parse-date-word '( "bc" "b.c." ))
  1693. X            (setq bc-flag t)))
  1694. X        (if (string-match "[a-zA-Z]+" str)
  1695. X            (throw 'syntax (format "Bad word in date: \"%s\""
  1696. X                       (math-match-substring str 0))))))
  1697. X
  1698. X      ;; If there is a huge number other than the year, ignore it.
  1699. X      (while (and (string-match "[-+]?0*[1-9][0-9][0-9][0-9][0-9]+" str)
  1700. X              (setq temp (concat (substring str 0 (match-beginning 0))
  1701. X                     (substring str (match-end 0))))
  1702. X              (string-match "[4-9][0-9]\\|[0-9][0-9][0-9]\\|[-+][0-9]+[^-]*\\'" temp))
  1703. X        (setq str temp))
  1704. X
  1705. X      ;; If there is a number with a sign or a large number, it is a year.
  1706. X      (if (or (string-match "\\([-+][0-9]+\\)[^-]*\\'" str)
  1707. X          (string-match "\\(0*[1-9][0-9][0-9]+\\)" str))
  1708. X          (setq year (math-match-substring str 1)
  1709. X            str (concat (substring str 0 (match-beginning 1))
  1710. X                (substring str (match-end 1)))
  1711. X            year (math-read-number year)
  1712. X            bigyear t))
  1713. X
  1714. X      ;; Collect remaining numbers.
  1715. X      (setq temp 0)
  1716. X      (while (string-match "[0-9]+" str temp)
  1717. X        (and c (throw 'syntax "Too many numbers in date"))
  1718. X        (setq c (string-to-int (math-match-substring str 0)))
  1719. X        (or b (setq b c c nil))
  1720. X        (or a (setq a b b nil))
  1721. X        (setq temp (match-end 0)))
  1722. X
  1723. X      ;; Check that we have the right amount of information.
  1724. X      (setq temp (+ (if year 1 0) (if month 1 0) (if day 1 0)
  1725. X            (if a 1 0) (if b 1 0) (if c 1 0)))
  1726. X      (if (> temp 3)
  1727. X          (throw 'syntax "Too many numbers in date")
  1728. X        (if (or (< temp 2) (and year (= temp 2)))
  1729. X        (throw 'syntax "Not enough numbers in date")
  1730. X          (if (= temp 2)   ; if year omitted, assume current year
  1731. X          (setq year (math-this-year)))))
  1732. X
  1733. X      ;; A large number must be a year.
  1734. X      (or year
  1735. X          (if (and a (or (> a 31) (< a 1)))
  1736. X          (setq year a a b b c c nil)
  1737. X        (if (and b (or (> b 31) (< b 1)))
  1738. X            (setq year b b c c nil)
  1739. X          (if (and c (or (> c 31) (< c 1)))
  1740. X              (setq year c c nil)))))
  1741. X
  1742. X      ;; A medium-large number must be a day.
  1743. X      (if year
  1744. X          (if (and a (> a 12))
  1745. X          (setq day a a b b c c nil)
  1746. X        (if (and b (> b 12))
  1747. X            (setq day b b c c nil)
  1748. X          (if (and c (> c 12))
  1749. X              (setq day c c nil)))))
  1750. X
  1751. X      ;; We may know enough to sort it out now.
  1752. X      (if (and year day)
  1753. X          (or month (setq month a))
  1754. X        (if (and year month)
  1755. X        (setq day a)
  1756. X
  1757. X          ;; Interpret order of numbers as same as for display format.
  1758. X          (setq temp calc-date-format)
  1759. X          (while temp
  1760. X        (cond ((not (symbolp (car temp))))
  1761. X              ((memq (car temp) '(Y YY BY YYY YYYY))
  1762. X               (or year (setq year a a b b c)))
  1763. X              ((memq (car temp) '(M MM BM Mmm Mmmm MMM MMMM))
  1764. X               (or month (setq month a a b b c)))
  1765. X              ((memq (car temp) '(D DD BD))
  1766. X               (or day (setq day a a b b c))))
  1767. X        (setq temp (cdr temp)))
  1768. X
  1769. X          ;; If display format was not complete, assume American style.
  1770. X          (or month (setq month a a b b c))
  1771. X          (or day (setq day a a b b c))
  1772. X          (or year (setq year a a b b c))))
  1773. X
  1774. X      (if bc-flag
  1775. X          (setq year (math-neg (math-abs year))))
  1776. X
  1777. X      (math-parse-date-validate year bigyear month day
  1778. X                    hour minute second))))
  1779. )
  1780. X
  1781. (defun math-parse-date-validate (year bigyear month day hour minute second)
  1782. X  (and (not bigyear) (natnump year) (< year 100)
  1783. X       (setq year (+ year (if (< year 40) 2000 1900))))
  1784. X  (if (eq year 0)
  1785. X      (throw 'syntax "Year value is out of range"))
  1786. X  (if (or (< month 1) (> month 12))
  1787. X      (throw 'syntax "Month value is out of range"))
  1788. SHAR_EOF
  1789. true || echo 'restore of calc-forms.el failed'
  1790. fi
  1791. echo 'End of  part 15'
  1792. echo 'File calc-forms.el is continued in part 16'
  1793. echo 16 > _shar_seq_.tmp
  1794. exit 0
  1795. exit 0 # Just in case...
  1796. -- 
  1797. Kent Landfield                   INTERNET: kent@sparky.IMD.Sterling.COM
  1798. Sterling Software, IMD           UUCP:     uunet!sparky!kent
  1799. Phone:    (402) 291-8300         FAX:      (402) 291-4362
  1800. Please send comp.sources.misc-related mail to kent@uunet.uu.net.
  1801.