home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / misc / volume24 / gnucalc / part26 < prev    next >
Encoding:
Text File  |  1991-10-31  |  55.2 KB  |  1,723 lines
  1. Newsgroups: comp.sources.misc
  2. From: daveg@synaptics.com (David Gillespie)
  3. Subject:  v24i074:  gnucalc - GNU Emacs Calculator, v2.00, Part26/56
  4. Message-ID: <1991Oct31.072817.18326@sparky.imd.sterling.com>
  5. X-Md4-Signature: 84c2fdc7279e8cdd578cc5b3fc54658f
  6. Date: Thu, 31 Oct 1991 07:28:17 GMT
  7. Approved: kent@sparky.imd.sterling.com
  8.  
  9. Submitted-by: daveg@synaptics.com (David Gillespie)
  10. Posting-number: Volume 24, Issue 74
  11. Archive-name: gnucalc/part26
  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-rewr.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" != 26; 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-rewr.el'
  34. else
  35. echo 'x - continuing file calc-rewr.el'
  36. sed 's/^X//' << 'SHAR_EOF' >> 'calc-rewr.el' &&
  37. X    (if (and (eq (car-safe varval) 'vec)
  38. X         (not (memq (car-safe old) '(nil schedule + -)))
  39. X         rules)
  40. X    (progn
  41. X      (setcdr varval (cons (list 'calcFunc-assign
  42. X                     (if (math-rwcomp-no-vars old)
  43. X                     old
  44. X                       (list 'calcFunc-quote old))
  45. X                     new)
  46. X                   (cdr varval)))
  47. X      (setcdr rules (cons (list (vector nil old)
  48. X                    (list (list 'same 0 1)
  49. X                      (list 'done new nil))
  50. X                    nil nil)
  51. X                  (cdr rules))))))
  52. )
  53. X
  54. X
  55. X
  56. X
  57. SHAR_EOF
  58. echo 'File calc-rewr.el is complete' &&
  59. chmod 0644 calc-rewr.el ||
  60. echo 'restore of calc-rewr.el failed'
  61. Wc_c="`wc -c < 'calc-rewr.el'`"
  62. test 69210 -eq "$Wc_c" ||
  63.     echo 'calc-rewr.el: original size 69210, current size' "$Wc_c"
  64. rm -f _shar_wnt_.tmp
  65. fi
  66. # ============= calc-rules.el ==============
  67. if test -f 'calc-rules.el' -a X"$1" != X"-c"; then
  68.     echo 'x - skipping calc-rules.el (File already exists)'
  69.     rm -f _shar_wnt_.tmp
  70. else
  71. > _shar_wnt_.tmp
  72. echo 'x - extracting calc-rules.el (Text)'
  73. sed 's/^X//' << 'SHAR_EOF' > 'calc-rules.el' &&
  74. ;; Calculator for GNU Emacs, part II [calc-rules.el]
  75. ;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
  76. ;; Written by Dave Gillespie, daveg@csvax.cs.caltech.edu.
  77. X
  78. ;; This file is part of GNU Emacs.
  79. X
  80. ;; GNU Emacs is distributed in the hope that it will be useful,
  81. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  82. ;; accepts responsibility to anyone for the consequences of using it
  83. ;; or for whether it serves any particular purpose or works at all,
  84. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  85. ;; License for full details.
  86. X
  87. ;; Everyone is granted permission to copy, modify and redistribute
  88. ;; GNU Emacs, but only under the conditions described in the
  89. ;; GNU Emacs General Public License.   A copy of this license is
  90. ;; supposed to have been given to you along with GNU Emacs so you
  91. ;; can know your rights and responsibilities.  It should be in a
  92. ;; file named COPYING.  Among other things, the copyright notice
  93. ;; and this notice must be preserved on all copies.
  94. X
  95. X
  96. X
  97. ;; This file is autoloaded from calc-ext.el.
  98. (require 'calc-ext)
  99. X
  100. (require 'calc-macs)
  101. X
  102. (defun calc-Need-calc-rules () nil)
  103. X
  104. X
  105. (defun calc-compile-rule-set (name rules)
  106. X  (prog2
  107. X   (message "Preparing rule set %s..." name)
  108. X   (math-read-plain-expr rules t)
  109. X   (message "Preparing rule set %s...done" name))
  110. )
  111. X
  112. (defun calc-CommuteRules ()
  113. X  "CommuteRules"
  114. X  (calc-compile-rule-set
  115. X   "CommuteRules" "[
  116. iterations(1),
  117. select(plain(a + b))        :=  select(plain(b + a)),
  118. select(plain(a - b))        :=  select(plain((-b) + a)),
  119. select(plain((1/a) * b))    :=  select(b / a),
  120. select(plain(a * b))        :=  select(b * a),
  121. select((1/a) / b)        :=  select((1/b) / a),
  122. select(a / b)            :=  select((1/b) * a),
  123. select((a^b) ^ c)        :=  select((a^c) ^ b),
  124. select(log(a, b))        :=  select(1 / log(b, a)),
  125. select(plain(a && b))        :=  select(b && a),
  126. select(plain(a || b))        :=  select(b || a),
  127. select(plain(a = b))        :=  select(b = a),
  128. select(plain(a != b))        :=  select(b != a),
  129. select(a < b)            :=  select(b > a),
  130. select(a > b)            :=  select(b < a),
  131. select(a <= b)            :=  select(b >= a),
  132. select(a >= b)            :=  select(b <= a) ]")
  133. )
  134. X
  135. (defun calc-JumpRules ()
  136. X  "JumpRules"
  137. X  (calc-compile-rule-set
  138. X   "JumpRules" "[
  139. iterations(1),
  140. plain(select(x) = y)        :=  0 = select(-x) + y,
  141. plain(a + select(x) = y)    :=  a = select(-x) + y,
  142. plain(a - select(x) = y)    :=  a = select(x) + y,
  143. plain(select(x) + a = y)    :=  a = select(-x) + y,
  144. plain(a * select(x) = y)    :=  a = y / select(x),
  145. plain(a / select(x) = y)    :=  a = select(x) * y,
  146. plain(select(x) / a = y)    :=  1/a = y / select(x),
  147. plain(a ^ select(2) = y)    :=  a = select(sqrt(y)),
  148. plain(a ^ select(x) = y)    :=  a = y ^ select(1/x),
  149. plain(select(x) ^ a = y)    :=  a = log(y, select(x)),
  150. plain(log(a, select(x)) = y)    :=  a = select(x) ^ y,
  151. plain(log(select(x), a) = y)    :=  a = select(x) ^ (1/y),
  152. plain(y = select(x))        :=  y - select(x) = 0,
  153. plain(y = a + select(x))    :=  y - select(x) = a,
  154. plain(y = a - select(x))    :=  y + select(x) = a,
  155. plain(y = select(x) + a)    :=  y - select(x) = a,
  156. plain(y = a * select(x))    :=  y / select(x) = a,
  157. plain(y = a / select(x))    :=  y * select(x) = a,
  158. plain(y = select(x) / a)    :=  y / select(x) = 1/a,
  159. plain(y = a ^ select(2))    :=  select(sqrt(y)) = a,
  160. plain(y = a ^ select(x))    :=  y ^ select(1/x) = a,
  161. plain(y = select(x) ^ a)    :=  log(y, select(x)) = a,
  162. plain(y = log(a, select(x)))    :=  select(x) ^ y = a,
  163. plain(y = log(select(x), a))    :=  select(x) ^ (1/y) = a ]")
  164. )
  165. X
  166. (defun calc-DistribRules ()
  167. X  "DistribRules"
  168. X  (calc-compile-rule-set
  169. X   "DistribRules" "[
  170. iterations(1),
  171. x * select(a + b)        :=  x*select(a) + x*b,
  172. x * select(sum(a,b,c,d))    :=  sum(x*select(a),b,c,d),
  173. x / select(a + b)        :=  1 / (select(a)/x + b/x),
  174. select(a + b) / x        :=  select(a)/x + b/x,
  175. sum(select(a),b,c,d) / x    :=  sum(select(a)/x,b,c,d),
  176. x ^ select(a + b)        :=  x^select(a) * x^b,
  177. x ^ select(sum(a,b,c,d))    :=  prod(x^select(a),b,c,d),
  178. x ^ select(a * b)        :=  (x^a)^select(b),
  179. x ^ select(a / b)        :=  (x^a)^select(1/b),
  180. select(a + b) ^ n        :=  select(x)
  181. X                    :: integer(n) :: n >= 2
  182. X                    :: let(x, expandpow(a+b,n))
  183. X                    :: quote(matches(x,y+z)),
  184. select(a + b) ^ x        :=  a*select(a+b)^(x-1) + b*select(a+b)^(x-1),
  185. select(a * b) ^ x        :=  a^x * select(b)^x,
  186. select(prod(a,b,c,d)) ^ x    :=  prod(select(a)^x,b,c,d),
  187. select(a / b) ^ x        :=  select(a)^x / b^x,
  188. select(- a) ^ x            :=  (-1)^x * select(a)^x,
  189. plain(-select(a + b))        :=  select(-a) - b,
  190. plain(-select(sum(a,b,c,d)))    :=  sum(select(-a),b,c,d),
  191. plain(-select(a * b))            :=  select(-a) * b,
  192. plain(-select(a / b))            :=  select(-a) / b,
  193. sqrt(select(a * b))        :=  sqrt(select(a)) * sqrt(b),
  194. sqrt(select(prod(a,b,c,d)))    :=  prod(sqrt(select(a)),b,c,d),
  195. sqrt(select(a / b))        :=  sqrt(select(a)) / sqrt(b),
  196. sqrt(select(- a))        :=  sqrt(-1) sqrt(select(a)),
  197. exp(select(a + b))        :=  exp(select(a)) / exp(-b) :: negative(b),
  198. exp(select(a + b))        :=  exp(select(a)) * exp(b),
  199. exp(select(sum(a,b,c,d)))    :=  prod(exp(select(a)),b,c,d),
  200. exp(select(a * b))        :=  exp(select(a)) ^ b :: constant(b),
  201. exp(select(a * b))        :=  exp(select(a)) ^ b,
  202. exp(select(a / b))        :=  exp(select(a)) ^ (1/b),
  203. ln(select(a * b))        :=  ln(select(a)) + ln(b),
  204. ln(select(prod(a,b,c,d)))    :=  sum(ln(select(a)),b,c,d),
  205. ln(select(a / b))        :=  ln(select(a)) - ln(b),
  206. ln(select(a ^ b))        :=  ln(select(a)) * b,
  207. log10(select(a * b))        :=  log10(select(a)) + log10(b),
  208. log10(select(prod(a,b,c,d)))    :=  sum(log10(select(a)),b,c,d),
  209. log10(select(a / b))        :=  log10(select(a)) - log10(b),
  210. log10(select(a ^ b))        :=  log10(select(a)) * b,
  211. log(select(a * b), x)        :=  log(select(a), x) + log(b,x),
  212. log(select(prod(a,b,c,d)),x)    :=  sum(log(select(a),x),b,c,d),
  213. log(select(a / b), x)        :=  log(select(a), x) - log(b,x),
  214. log(select(a ^ b), x)        :=  log(select(a), x) * b,
  215. log(a, select(b))        :=  ln(a) / select(ln(b)),
  216. sin(select(a + b))        :=  sin(select(a)) cos(b) + cos(a) sin(b),
  217. sin(select(2 a))        :=  2 sin(select(a)) cos(a),
  218. sin(select(n a))        :=  2sin((n-1) select(a)) cos(a) - sin((n-2) a)
  219. X                    :: integer(n) :: n > 2,
  220. cos(select(a + b))        :=  cos(select(a)) cos(b) - sin(a) sin(b),
  221. cos(select(2 a))        :=  2 cos(select(a))^2 - 1,
  222. cos(select(n a))        :=  2cos((n-1) select(a)) cos(a) - cos((n-2) a)
  223. X                    :: integer(n) :: n > 2,
  224. tan(select(a + b))        :=  (tan(select(a)) + tan(b)) /
  225. X                    (1 - tan(a) tan(b)),
  226. tan(select(2 a))        :=  2 tan(select(a)) / (1 - tan(a)^2),
  227. tan(select(n a))        :=  (tan((n-1) select(a)) + tan(a)) /
  228. X                    (1 - tan((n-1) a) tan(a))
  229. X                    :: integer(n) :: n > 2,
  230. sinh(select(a + b))        :=  sinh(select(a)) cosh(b) + cosh(a) sinh(b),
  231. cosh(select(a + b))        :=  cosh(select(a)) cosh(b) + sinh(a) sinh(b),
  232. tanh(select(a + b))        :=  (tanh(select(a)) + tanh(b)) /
  233. X                    (1 + tanh(a) tanh(b)),
  234. x && select(a || b)        :=  (x && select(a)) || (x && b),
  235. select(a || b) && x        :=  (select(a) && x) || (b && x),
  236. ! select(a && b)        :=  (!a) || (!b),
  237. ! select(a || b)        :=  (!a) && (!b) ]")
  238. )
  239. X
  240. (defun calc-MergeRules ()
  241. X  "MergeRules"
  242. X  (calc-compile-rule-set
  243. X   "MergeRules" "[
  244. iterations(1),
  245. X (x*opt(a)) + select(x*b)    :=  x * (a + select(b)),
  246. X (x*opt(a)) - select(x*b)    :=  x * (a - select(b)),
  247. sum(select(x)*a,b,c,d)        :=  x * sum(select(a),b,c,d),
  248. X (a/x) + select(b/x)        :=  (a + select(b)) / x,
  249. X (a/x) - select(b/x)        :=  (a - select(b)) / x,
  250. sum(a/select(x),b,c,d)        :=  sum(select(a),b,c,d) / x,
  251. X (a/opt(b)) + select(c/d)    :=  ((select(a)*d) + (b*c)) / (b*d),
  252. X (a/opt(b)) - select(c/d)    :=  ((select(a)*d) - (b*c)) / (b*d),
  253. X (x^opt(a)) * select(x^b)    :=  x ^ (a + select(b)),
  254. X (x^opt(a)) / select(x^b)    :=  x ^ (a - select(b)),
  255. select(x^a) / (x^opt(b))    :=  x ^ (select(a) - b),
  256. prod(select(x)^a,b,c,d)        :=  x ^ sum(select(a),b,c,d),
  257. select(x^a) / (x^opt(b))    :=  x ^ (select(a) - b),
  258. X (a^x) * select(b^x)        :=  select((a * b) ^x),
  259. X (a^x) / select(b^x)        :=  select((b / b) ^ x),
  260. select(a^x) / (b^x)        :=  select((a / b) ^ x),
  261. prod(a^select(x),b,c,d)        :=  select(prod(a,b,c,d) ^ x),
  262. X (a^x) * select(b^y)        :=  select((a * b^(y-x)) ^x),
  263. X (a^x) / select(b^y)        :=  select((b / b^(y-x)) ^ x),
  264. select(a^x) / (b^y)        :=  select((a / b^(y-x)) ^ x),
  265. select(x^a) ^ b            :=  x ^ select(a * b),
  266. X (x^a) ^ select(b)        :=  x ^ select(a * b),
  267. select(sqrt(a)) ^ b        :=  select(a ^ (b / 2)),
  268. sqrt(a) ^ select(b)        :=  select(a ^ (b / 2)),
  269. sqrt(select(a) ^ b)        :=  select(a ^ (b / 2)),
  270. sqrt(a ^ select(b))        :=  select(a ^ (b / 2)),
  271. sqrt(a) * select(sqrt(b))    :=  select(sqrt(a * b)),
  272. sqrt(a) / select(sqrt(b))    :=  select(sqrt(a / b)),
  273. select(sqrt(a)) / sqrt(b)    :=  select(sqrt(a / b)),
  274. prod(select(sqrt(a)),b,c,d)    :=  select(sqrt(prod(a,b,c,d))),
  275. exp(a) * select(exp(b))        :=  select(exp(a + b)),
  276. exp(a) / select(exp(b))        :=  select(exp(a - b)),
  277. select(exp(a)) / exp(b)        :=  select(exp(a - b)),
  278. prod(select(exp(a)),b,c,d)    :=  select(exp(sum(a,b,c,d))),
  279. select(exp(a)) ^ b        :=  select(exp(a * b)),
  280. exp(a) ^ select(b)        :=  select(exp(a * b)),
  281. ln(a) + select(ln(b))        :=  select(ln(a * b)),
  282. ln(a) - select(ln(b))        :=  select(ln(a / b)),
  283. select(ln(a)) - ln(b)        :=  select(ln(a / b)),
  284. sum(select(ln(a)),b,c,d)    :=  select(ln(prod(a,b,c,d))),
  285. b * select(ln(a))        :=  select(ln(a ^ b)),
  286. select(b) * ln(a)        :=  select(ln(a ^ b)),
  287. select(ln(a)) / ln(b)        :=  select(log(a, b)),
  288. ln(a) / select(ln(b))        :=  select(log(a, b)),
  289. select(ln(a)) / b        :=  select(ln(a ^ (1/b))),
  290. ln(a) / select(b)        :=  select(ln(a ^ (1/b))),
  291. log10(a) + select(log10(b))    :=  select(log10(a * b)),
  292. log10(a) - select(log10(b))    :=  select(log10(a / b)),
  293. select(log10(a)) - log10(b)    :=  select(log10(a / b)),
  294. sum(select(log10(a)),b,c,d)    :=  select(log10(prod(a,b,c,d))),
  295. b * select(log10(a))        :=  select(log10(a ^ b)),
  296. select(b) * log10(a)        :=  select(log10(a ^ b)),
  297. select(log10(a)) / log10(b)    :=  select(log(a, b)),
  298. log10(a) / select(log10(b))    :=  select(log(a, b)),
  299. select(log10(a)) / b        :=  select(log10(a ^ (1/b))),
  300. log10(a) / select(b)        :=  select(log10(a ^ (1/b))),
  301. log(a,x) + select(log(b,x))    :=  select(log(a * b,x)),
  302. log(a,x) - select(log(b,x))    :=  select(log(a / b,x)),
  303. select(log(a,x)) - log(b,x)    :=  select(log(a / b,x)),
  304. sum(select(log(a,x)),b,c,d)    :=  select(log(prod(a,b,c,d),x)),
  305. b * select(log(a,x))        :=  select(log(a ^ b,x)),
  306. select(b) * log(a,x)        :=  select(log(a ^ b,x)),
  307. select(log(a,x)) / log(b,x)    :=  select(log(a, b)),
  308. log(a,x) / select(log(b,x))    :=  select(log(a, b)),
  309. select(log(a,x)) / b        :=  select(log(a ^ (1/b),x)),
  310. log(a,x) / select(b)        :=  select(log(a ^ (1/b),x)),
  311. select(x && a) || (x && opt(b)) :=  x && (select(a) || b) ]")
  312. )
  313. X
  314. (defun calc-NegateRules ()
  315. X  "NegateRules"
  316. X  (calc-compile-rule-set
  317. X   "NegateRules" "[
  318. iterations(1),
  319. a + select(x)            :=  a - select(-x),
  320. a - select(x)            :=  a + select(-x),
  321. sum(select(x),b,c,d)        :=  -sum(select(-x),b,c,d),
  322. a * select(x)            :=  -a * select(-x),
  323. a / select(x)            :=  -a / select(-x),
  324. select(x) / a            :=  -select(-x) / a,
  325. prod(select(x),b,c,d)        :=  (-1)^(d-c+1) * prod(select(-x),b,c,d),
  326. select(x) ^ n            :=  select(-x) ^ a :: integer(n) :: n%2 = 0,
  327. select(x) ^ n            :=  -(select(-x) ^ a) :: integer(n) :: n%2 = 1,
  328. select(x) ^ a            :=  (-select(-x)) ^ a,
  329. a ^ select(x)            :=  (1 / a)^select(-x),
  330. abs(select(x))            :=  abs(select(-x)),
  331. i sqrt(select(x))        :=  -sqrt(select(-x)),
  332. sqrt(select(x))            :=  i sqrt(select(-x)),
  333. re(select(x))            :=  -re(select(-x)),
  334. im(select(x))            :=  -im(select(-x)),
  335. conj(select(x))            :=  -conj(select(-x)),
  336. trunc(select(x))        :=  -trunc(select(-x)),
  337. round(select(x))        :=  -round(select(-x)),
  338. floor(select(x))        :=  -ceil(select(-x)),
  339. ceil(select(x))            :=  -floor(select(-x)),
  340. ftrunc(select(x))        :=  -ftrunc(select(-x)),
  341. fround(select(x))        :=  -fround(select(-x)),
  342. ffloor(select(x))        :=  -fceil(select(-x)),
  343. fceil(select(x))        :=  -ffloor(select(-x)),
  344. exp(select(x))            :=  1 / exp(select(-x)),
  345. sin(select(x))            :=  -sin(select(-x)),
  346. cos(select(x))            :=  cos(select(-x)),
  347. tan(select(x))            :=  -tan(select(-x)),
  348. arcsin(select(x))        :=  -arcsin(select(-x)),
  349. arccos(select(x))        :=  4 arctan(1) - arccos(select(-x)),
  350. arctan(select(x))        :=  -arctan(select(-x)),
  351. sinh(select(x))            :=  -sinh(select(-x)),
  352. cosh(select(x))            :=  cosh(select(-x)),
  353. tanh(select(x))            :=  -tanh(select(-x)),
  354. arcsinh(select(x))        :=  -arcsinh(select(-x)),
  355. arctanh(select(x))        :=  -arctanh(select(-x)),
  356. select(x) = a            :=  select(-x) = -a,
  357. select(x) != a            :=  select(-x) != -a,
  358. select(x) < a            :=  select(-x) > -a,
  359. select(x) > a            :=  select(-x) < -a,
  360. select(x) <= a            :=  select(-x) >= -a,
  361. select(x) >= a            :=  select(-x) <= -a,
  362. a < select(x)            :=  -a > select(-x),
  363. a > select(x)            :=  -a < select(-x),
  364. a <= select(x)            :=  -a >= select(-x),
  365. a >= select(x)            :=  -a <= select(-x),
  366. select(x)            :=  -select(-x) ]")
  367. )
  368. X
  369. (defun calc-InvertRules ()
  370. X  "InvertRules"
  371. X  (calc-compile-rule-set
  372. X   "InvertRules" "[
  373. iterations(1),
  374. a * select(x)            :=  a / select(1/x),
  375. a / select(x)            :=  a * select(1/x),
  376. select(x) / a            :=  1 / (select(1/x) a),
  377. prod(select(x),b,c,d)        :=  1 / prod(select(1/x),b,c,d),
  378. abs(select(x))            :=  1 / abs(select(1/x)),
  379. sqrt(select(x))            :=  1 / sqrt(select(1/x)),
  380. ln(select(x))            :=  -ln(select(1/x)),
  381. log10(select(x))        :=  -log10(select(1/x)),
  382. log(select(x), a)        :=  -log(select(1/x), a),
  383. log(a, select(x))        :=  -log(a, select(1/x)),
  384. arctan(select(x))               :=  simplify(2 arctan(1))-arctan(select(1/x)),
  385. select(x) = a            :=  select(1/x) = 1/a,
  386. select(x) != a            :=  select(1/x) != 1/a,
  387. select(x) < a            :=  select(1/x) > 1/a,
  388. select(x) > a            :=  select(1/x) < 1/a,
  389. select(x) <= a            :=  select(1/x) >= 1/a,
  390. select(x) >= a            :=  select(1/x) <= 1/a,
  391. a < select(x)            :=  1/a > select(1/x),
  392. a > select(x)            :=  1/a < select(1/x),
  393. a <= select(x)            :=  1/a >= select(1/x),
  394. a >= select(x)            :=  1/a <= select(1/x),
  395. select(x)            :=  1 / select(1/x) ]")
  396. )
  397. X
  398. X
  399. (defun calc-FactorRules ()
  400. X  "FactorRules"
  401. X  (calc-compile-rule-set
  402. X   "FactorRules" "[
  403. thecoefs(x, [z, a+b, c]) := thefactors(x, [d x + d a/c, (c/d) x + (b/d)])
  404. X        :: z = a b/c :: let(d := pgcd(pcont(c), pcont(b))),
  405. thecoefs(x, [z, a, c]) := thefactors(x, [(r x + a/(2 r))^2])
  406. X        :: z = (a/2)^2/c :: let(r := esimplify(sqrt(c)))
  407. X        :: !matches(r, sqrt(rr)),
  408. thecoefs(x, [z, 0, c]) := thefactors(x, [rc x + rz, rc x - rz])
  409. X        :: negative(z)
  410. X        :: let(rz := esimplify(sqrt(-z))) :: !matches(rz, sqrt(rzz))
  411. X        :: let(rc := esimplify(sqrt(c))) :: !matches(rc, sqrt(rcc)),
  412. thecoefs(x, [z, 0, c]) := thefactors(x, [rz + rc x, rz - rc x])
  413. X        :: negative(c)
  414. X        :: let(rz := esimplify(sqrt(z))) :: !matches(rz, sqrt(rzz))
  415. X        :: let(rc := esimplify(sqrt(-c))) :: !matches(rc, sqrt(rcc))
  416. X ]")
  417. )
  418. ;;(setq var-FactorRules 'calc-FactorRules)
  419. X
  420. X
  421. (defun calc-IntegAfterRules ()
  422. X  "IntegAfterRules"
  423. X  (calc-compile-rule-set
  424. X   "IntegAfterRules" "[
  425. X opt(a) ln(x) + opt(b) ln(y) := 2 a esimplify(arctanh(x-1))
  426. X     :: a + b = 0 :: nrat(x + y) = 2 || nrat(x - y) = 2,
  427. X a * (b + c) := a b + a c :: constant(a)
  428. X ]")
  429. )
  430. X
  431. ;;(setq var-IntegAfterRules 'calc-IntegAfterRules)
  432. X
  433. X
  434. (defun calc-FitRules ()
  435. X  "FitRules"
  436. X  (calc-compile-rule-set
  437. X   "FitRules" "[
  438. X
  439. schedule(1,2,3,4),
  440. iterations(inf),
  441. X
  442. phase(1),
  443. e^x          :=  exp(x),
  444. x^y        :=  exp(y ln(x))  :: !istrue(constant(y)),
  445. x/y        :=  x fitinv(y),
  446. fitinv(x y)    :=  fitinv(x) fitinv(y),
  447. exp(a) exp(b)    :=  exp(a + b),
  448. a exp(b)    :=  exp(ln(a) + b)  :: !hasfitvars(a),
  449. fitinv(exp(a))  :=  exp(-a),
  450. ln(a b)        :=  ln(a) + ln(b),
  451. ln(fitinv(a))    :=  -ln(a),
  452. log10(a b)    :=  log10(a) + log10(b),
  453. log10(fitinv(a)) := -log10(a),
  454. log(a,b)    :=  ln(a)/ln(b),
  455. ln(exp(a))    :=  a,
  456. a*(b+c)        :=  a*b + a*c,
  457. (a+b)^n        :=  x  :: integer(n) :: n >= 2
  458. X               :: let(x, expandpow(a+b,n))
  459. X               :: quote(matches(x,y+z)),
  460. X
  461. phase(1,2),
  462. fitmodel(y = x)   :=  fitmodel(0, y - x),
  463. fitmodel(y, x+c)  :=  fitmodel(y-c, x)  :: !hasfitparams(c),
  464. fitmodel(y, x c)  :=  fitmodel(y/c, x)  :: !hasfitparams(c),
  465. fitmodel(y, x/(c opt(d)))  :=  fitmodel(y c, x/d)  :: !hasfitparams(c),
  466. fitmodel(y, apply(f,[x]))  :=  fitmodel(yy, x)
  467. X                   :: hasfitparams(x)
  468. X                   :: let(FTemp() = yy,
  469. X                          solve(apply(f,[FTemp()]) = y,
  470. X                        FTemp())),
  471. fitmodel(y, apply(f,[x,c]))  :=  fitmodel(yy, x)
  472. X                 :: !hasfitparams(c)
  473. X                 :: let(FTemp() = yy,
  474. X                        solve(apply(f,[FTemp(),c]) = y,
  475. X                          FTemp())),
  476. fitmodel(y, apply(f,[c,x]))  :=  fitmodel(yy, x)
  477. X                 :: !hasfitparams(c)
  478. X                 :: let(FTemp() = yy,
  479. X                        solve(apply(f,[c,FTemp()]) = y,
  480. X                          FTemp())),
  481. X
  482. phase(2,3),
  483. fitmodel(y, x)              :=  fitsystem(y, [], [], fitpart(1,1,x)),
  484. fitpart(a,b,plain(x + y))   :=  fitpart(a,b,x) + fitpart(a,b,y),
  485. fitpart(a,b,plain(x - y))   :=  fitpart(a,b,x) + fitpart(-a,b,y),
  486. fitpart(a,b,plain(-x))        :=  fitpart(-a,b,x),
  487. fitpart(a,b,x opt(c))        :=  fitpart(a,x b,c)  :: !hasfitvars(x),
  488. fitpart(a,x opt(b),c)        :=  fitpart(x a,b,c)  :: !hasfitparams(x),
  489. fitpart(a,x y + x opt(z),c) :=    fitpart(a,x*(y+z),c),
  490. fitpart(a,b,c)            :=  fitpart2(a,b,c),
  491. X
  492. phase(3),
  493. fitpart2(a1,b1,x) + fitpart2(a2,b2,x)  :=  fitpart(1, a1 b1 + a2 b2, x),
  494. fitpart2(a1,x,c1) + fitpart2(a2,x,c2)  :=  fitpart2(1, x, a1 c1 + a2 c2),
  495. X
  496. phase(4),
  497. fitinv(x)      :=  1 / x,
  498. exp(x + ln(y))  :=  y exp(x),
  499. exp(x ln(y))    :=  y^x,
  500. ln(x) + ln(y)    :=  ln(x y),
  501. ln(x) - ln(y)    :=  ln(x/y),
  502. x*y + x*z    :=  x*(y+z),
  503. fitsystem(y, xv, pv, fitpart2(a,fitparam(b),c) + opt(d))
  504. X        :=  fitsystem(y, rcons(xv, a c),
  505. X                            rcons(pv, fitdummy(b) = fitparam(b)), d)
  506. X            :: b = vlen(pv)+1,
  507. fitsystem(y, xv, pv, fitpart2(a,b,c) + opt(d))
  508. X        :=  fitsystem(y, rcons(xv, a c),
  509. X                  rcons(pv, fitdummy(vlen(pv)+1) = b), d),
  510. fitsystem(y, xv, pv, 0)  :=  fitsystem(y, xv, cons(fvh,fvt))
  511. X                 :: !hasfitparams(xv)
  512. X                 :: let(cons(fvh,fvt),
  513. X                    solve(pv, table(fitparam(j), j, 1,
  514. X                            hasfitparams(pv)))),
  515. fitparam(n) = x  :=  x ]")
  516. )
  517. X
  518. SHAR_EOF
  519. chmod 0644 calc-rules.el ||
  520. echo 'restore of calc-rules.el failed'
  521. Wc_c="`wc -c < 'calc-rules.el'`"
  522. test 17425 -eq "$Wc_c" ||
  523.     echo 'calc-rules.el: original size 17425, current size' "$Wc_c"
  524. rm -f _shar_wnt_.tmp
  525. fi
  526. # ============= calc-sel-2.el ==============
  527. if test -f 'calc-sel-2.el' -a X"$1" != X"-c"; then
  528.     echo 'x - skipping calc-sel-2.el (File already exists)'
  529.     rm -f _shar_wnt_.tmp
  530. else
  531. > _shar_wnt_.tmp
  532. echo 'x - extracting calc-sel-2.el (Text)'
  533. sed 's/^X//' << 'SHAR_EOF' > 'calc-sel-2.el' &&
  534. ;; Calculator for GNU Emacs, part II [calc-sel-2.el]
  535. ;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
  536. ;; Written by Dave Gillespie, daveg@csvax.cs.caltech.edu.
  537. X
  538. ;; This file is part of GNU Emacs.
  539. X
  540. ;; GNU Emacs is distributed in the hope that it will be useful,
  541. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  542. ;; accepts responsibility to anyone for the consequences of using it
  543. ;; or for whether it serves any particular purpose or works at all,
  544. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  545. ;; License for full details.
  546. X
  547. ;; Everyone is granted permission to copy, modify and redistribute
  548. ;; GNU Emacs, but only under the conditions described in the
  549. ;; GNU Emacs General Public License.   A copy of this license is
  550. ;; supposed to have been given to you along with GNU Emacs so you
  551. ;; can know your rights and responsibilities.  It should be in a
  552. ;; file named COPYING.  Among other things, the copyright notice
  553. ;; and this notice must be preserved on all copies.
  554. X
  555. X
  556. X
  557. ;; This file is autoloaded from calc-ext.el.
  558. (require 'calc-ext)
  559. X
  560. (require 'calc-macs)
  561. X
  562. (defun calc-Need-calc-sel-2 () nil)
  563. X
  564. X
  565. (defun calc-commute-left (arg)
  566. X  (interactive "p")
  567. X  (if (< arg 0)
  568. X      (calc-commute-right (- arg))
  569. X    (calc-wrapper
  570. X     (calc-preserve-point)
  571. X     (let ((num (max 1 (calc-locate-cursor-element (point))))
  572. X       (reselect calc-keep-selection))
  573. X       (if (= arg 0) (setq arg nil))
  574. X       (while (or (null arg) (>= (setq arg (1- arg)) 0))
  575. X     (let* ((entry (calc-top num 'entry))
  576. X        (expr (car entry))
  577. X        (sel (calc-auto-selection entry))
  578. X        parent new)
  579. X       (or (and sel
  580. X            (consp (setq parent (calc-find-assoc-parent-formula
  581. X                     expr sel))))
  582. X           (error "No term is selected"))
  583. X       (if (and calc-assoc-selections
  584. X            (assq (car parent) calc-assoc-ops))
  585. X           (let ((outer (calc-find-parent-formula parent sel)))
  586. X         (if (eq sel (nth 2 outer))
  587. X             (setq new (calc-replace-sub-formula
  588. X                parent outer
  589. X                (cond
  590. X                 ((memq (car outer)
  591. X                    (nth 1 (assq (car-safe (nth 1 outer))
  592. X                             calc-assoc-ops)))
  593. X                  (let* ((other (nth 2 (nth 1 outer)))
  594. X                     (new (calc-build-assoc-term
  595. X                           (car (nth 1 outer))
  596. X                           (calc-build-assoc-term
  597. X                        (car outer)
  598. X                        (nth 1 (nth 1 outer))
  599. X                        sel)
  600. X                           other)))
  601. X                    (setq sel (nth 2 (nth 1 new)))
  602. X                    new))
  603. X                 ((eq (car outer) '-)
  604. X                  (calc-build-assoc-term
  605. X                   '+
  606. X                   (setq sel (math-neg sel))
  607. X                   (nth 1 outer)))
  608. X                 ((eq (car outer) '/)
  609. X                  (calc-build-assoc-term
  610. X                   '*
  611. X                   (setq sel (calcFunc-div 1 sel))
  612. X                   (nth 1 outer)))
  613. X                 (t (calc-build-assoc-term
  614. X                     (car outer) sel (nth 1 outer))))))
  615. X           (let ((next (calc-find-parent-formula parent outer)))
  616. X             (if (not (and (consp next)
  617. X                   (eq outer (nth 2 next))
  618. X                   (eq (car next) (car outer))))
  619. X             (setq new nil)
  620. X               (setq new (calc-build-assoc-term
  621. X                  (car next)
  622. X                  sel
  623. X                  (calc-build-assoc-term
  624. X                   (car next) (nth 1 next) (nth 2 outer)))
  625. X                 sel (nth 1 new)
  626. X                 new (calc-replace-sub-formula
  627. X                  parent next new))))))
  628. X         (if (eq (nth 1 parent) sel)
  629. X         (setq new nil)
  630. X           (let ((p (nthcdr (1- (calc-find-sub-formula parent sel))
  631. X                (setq new (copy-sequence parent)))))
  632. X         (setcar (cdr p) (car p))
  633. X         (setcar p sel))))
  634. X       (if (null new)
  635. X           (if arg
  636. X           (error "Term is already leftmost")
  637. X         (or reselect
  638. X             (calc-pop-push-list 1 (list expr) num '(nil)))
  639. X         (setq arg 0))
  640. X         (calc-pop-push-record-list
  641. X          1 "left"
  642. X          (list (calc-replace-sub-formula expr parent new))
  643. X          num
  644. X          (list (and (or (not (eq arg 0)) reselect)
  645. X             sel)))))))))
  646. )
  647. X
  648. (defun calc-commute-right (arg)
  649. X  (interactive "p")
  650. X  (if (< arg 0)
  651. X      (calc-commute-left (- arg))
  652. X    (calc-wrapper
  653. X     (calc-preserve-point)
  654. X     (let ((num (max 1 (calc-locate-cursor-element (point))))
  655. X       (reselect calc-keep-selection))
  656. X       (if (= arg 0) (setq arg nil))
  657. X       (while (or (null arg) (>= (setq arg (1- arg)) 0))
  658. X     (let* ((entry (calc-top num 'entry))
  659. X        (expr (car entry))
  660. X        (sel (calc-auto-selection entry))
  661. X        parent new)
  662. X       (or (and sel
  663. X            (consp (setq parent (calc-find-assoc-parent-formula
  664. X                     expr sel))))
  665. X           (error "No term is selected"))
  666. X       (if (and calc-assoc-selections
  667. X            (assq (car parent) calc-assoc-ops))
  668. X           (let ((outer (calc-find-parent-formula parent sel)))
  669. X         (if (eq sel (nth 1 outer))
  670. X             (setq new (calc-replace-sub-formula
  671. X                parent outer
  672. X                (if (memq (car outer)
  673. X                      (nth 2 (assq (car-safe (nth 2 outer))
  674. X                               calc-assoc-ops)))
  675. X                    (let ((other (nth 1 (nth 2 outer))))
  676. X                      (calc-build-assoc-term
  677. X                       (car outer)
  678. X                       other
  679. X                       (calc-build-assoc-term
  680. X                    (car (nth 2 outer))
  681. X                    sel
  682. X                    (nth 2 (nth 2 outer)))))
  683. X                  (let ((new (cond
  684. X                          ((eq (car outer) '-)
  685. X                           (calc-build-assoc-term
  686. X                        '+
  687. X                        (math-neg (nth 2 outer))
  688. X                        sel))
  689. X                          ((eq (car outer) '/)
  690. X                           (calc-build-assoc-term
  691. X                        '*
  692. X                        (calcFunc-div 1 (nth 2 outer))
  693. X                        sel))
  694. X                          (t (calc-build-assoc-term
  695. X                          (car outer)
  696. X                          (nth 2 outer)
  697. X                          sel)))))
  698. X                    (setq sel (nth 2 new))
  699. X                    new))))
  700. X           (let ((next (calc-find-parent-formula parent outer)))
  701. X             (if (not (and (consp next)
  702. X                   (eq outer (nth 1 next))))
  703. X             (setq new nil)
  704. X               (setq new (calc-build-assoc-term
  705. X                  (car outer)
  706. X                  (calc-build-assoc-term
  707. X                   (car next) (nth 1 outer) (nth 2 next))
  708. X                  sel)
  709. X                 sel (nth 2 new)
  710. X                 new (calc-replace-sub-formula
  711. X                  parent next new))))))
  712. X         (if (eq (nth (1- (length parent)) parent) sel)
  713. X         (setq new nil)
  714. X           (let ((p (nthcdr (calc-find-sub-formula parent sel)
  715. X                (setq new (copy-sequence parent)))))
  716. X         (setcar p (nth 1 p))
  717. X         (setcar (cdr p) sel))))
  718. X       (if (null new)
  719. X           (if arg
  720. X           (error "Term is already rightmost")
  721. X         (or reselect
  722. X             (calc-pop-push-list 1 (list expr) num '(nil)))
  723. X         (setq arg 0))
  724. X         (calc-pop-push-record-list
  725. X          1 "rght"
  726. X          (list (calc-replace-sub-formula expr parent new))
  727. X          num
  728. X          (list (and (or (not (eq arg 0)) reselect)
  729. X             sel)))))))))
  730. )
  731. X
  732. (defun calc-build-assoc-term (op lhs rhs)
  733. X  (cond ((and (eq op '+) (or (math-looks-negp rhs)
  734. X                 (and (eq (car-safe rhs) 'cplx)
  735. X                  (math-negp (nth 1 rhs))
  736. X                  (eq (nth 2 rhs) 0))))
  737. X     (list '- lhs (math-neg rhs)))
  738. X    ((and (eq op '-) (or (math-looks-negp rhs)
  739. X                 (and (eq (car-safe rhs) 'cplx)
  740. X                  (math-negp (nth 1 rhs))
  741. X                  (eq (nth 2 rhs) 0))))
  742. X     (list '+ lhs (math-neg rhs)))
  743. X    ((and (eq op '*) (and (eq (car-safe rhs) '/)
  744. X                  (or (math-equal-int (nth 1 rhs) 1)
  745. X                  (equal (nth 1 rhs) '(cplx 1 0)))))
  746. X     (list '/ lhs (nth 2 rhs)))
  747. X    ((and (eq op '/) (and (eq (car-safe rhs) '/)
  748. X                  (or (math-equal-int (nth 1 rhs) 1)
  749. X                  (equal (nth 1 rhs) '(cplx 1 0)))))
  750. X     (list '/ lhs (nth 2 rhs)))
  751. X    (t (list op lhs rhs)))
  752. )
  753. X
  754. (defun calc-sel-unpack ()
  755. X  (interactive)
  756. X  (calc-wrapper
  757. X   (calc-preserve-point)
  758. X   (let* ((num (max 1 (calc-locate-cursor-element (point))))
  759. X      (reselect calc-keep-selection)
  760. X      (entry (calc-top num 'entry))
  761. X      (expr (car entry))
  762. X      (sel (or (calc-auto-selection entry) expr)))
  763. X     (or (and (not (math-primp sel))
  764. X          (= (length sel) 2))
  765. X     (error "Selection must be a function of one argument"))
  766. X     (calc-pop-push-record-list 1 "unpk"
  767. X                (list (calc-replace-sub-formula
  768. X                       expr sel (nth 1 sel)))
  769. X                num
  770. X                (list (and reselect (nth 1 sel))))))
  771. )
  772. X
  773. (defun calc-sel-isolate ()
  774. X  (interactive)
  775. X  (calc-slow-wrapper
  776. X   (calc-preserve-point)
  777. X   (let* ((num (max 1 (calc-locate-cursor-element (point))))
  778. X      (reselect calc-keep-selection)
  779. X      (entry (calc-top num 'entry))
  780. X      (expr (car entry))
  781. X      (sel (or (calc-auto-selection entry) (error "No selection")))
  782. X      (eqn sel)
  783. X      soln)
  784. X     (while (and (or (consp (setq eqn (calc-find-parent-formula expr eqn)))
  785. X             (error "Selection must be a member of an equation"))
  786. X         (not (assq (car eqn) calc-tweak-eqn-table))))
  787. X     (setq soln (math-solve-eqn eqn sel calc-hyperbolic-flag))
  788. X     (or soln
  789. X     (error "No solution found"))
  790. X     (setq soln (calc-encase-atoms
  791. X         (if (eq (not (calc-find-sub-formula (nth 2 eqn) sel))
  792. X             (eq (nth 1 soln) sel))
  793. X             soln
  794. X           (list (nth 1 (assq (car soln) calc-tweak-eqn-table))
  795. X             (nth 2 soln)
  796. X             (nth 1 soln)))))
  797. X     (calc-pop-push-record-list 1 "isol"
  798. X                (list (calc-replace-sub-formula
  799. X                       expr eqn soln))
  800. X                num
  801. X                (list (and reselect sel)))
  802. X     (calc-handle-whys)))
  803. )
  804. X
  805. (defun calc-sel-commute (many)
  806. X  (interactive "P")
  807. X  (let ((calc-assoc-selections nil))
  808. X    (calc-rewrite-selection "CommuteRules" many "cmut"))
  809. X  (calc-set-mode-line)
  810. )
  811. X
  812. (defun calc-sel-jump-equals (many)
  813. X  (interactive "P")
  814. X  (calc-rewrite-selection "JumpRules" many "jump")
  815. )
  816. X
  817. (defun calc-sel-distribute (many)
  818. X  (interactive "P")
  819. X  (calc-rewrite-selection "DistribRules" many "dist")
  820. )
  821. X
  822. (defun calc-sel-merge (many)
  823. X  (interactive "P")
  824. X  (calc-rewrite-selection "MergeRules" many "merg")
  825. )
  826. X
  827. (defun calc-sel-negate (many)
  828. X  (interactive "P")
  829. X  (calc-rewrite-selection "NegateRules" many "jneg")
  830. )
  831. X
  832. (defun calc-sel-invert (many)
  833. X  (interactive "P")
  834. X  (calc-rewrite-selection "InvertRules" many "jinv")
  835. )
  836. X
  837. SHAR_EOF
  838. chmod 0644 calc-sel-2.el ||
  839. echo 'restore of calc-sel-2.el failed'
  840. Wc_c="`wc -c < 'calc-sel-2.el'`"
  841. test 9143 -eq "$Wc_c" ||
  842.     echo 'calc-sel-2.el: original size 9143, current size' "$Wc_c"
  843. rm -f _shar_wnt_.tmp
  844. fi
  845. # ============= calc-sel.el ==============
  846. if test -f 'calc-sel.el' -a X"$1" != X"-c"; then
  847.     echo 'x - skipping calc-sel.el (File already exists)'
  848.     rm -f _shar_wnt_.tmp
  849. else
  850. > _shar_wnt_.tmp
  851. echo 'x - extracting calc-sel.el (Text)'
  852. sed 's/^X//' << 'SHAR_EOF' > 'calc-sel.el' &&
  853. ;; Calculator for GNU Emacs, part II [calc-sel.el]
  854. ;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
  855. ;; Written by Dave Gillespie, daveg@csvax.cs.caltech.edu.
  856. X
  857. ;; This file is part of GNU Emacs.
  858. X
  859. ;; GNU Emacs is distributed in the hope that it will be useful,
  860. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  861. ;; accepts responsibility to anyone for the consequences of using it
  862. ;; or for whether it serves any particular purpose or works at all,
  863. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  864. ;; License for full details.
  865. X
  866. ;; Everyone is granted permission to copy, modify and redistribute
  867. ;; GNU Emacs, but only under the conditions described in the
  868. ;; GNU Emacs General Public License.   A copy of this license is
  869. ;; supposed to have been given to you along with GNU Emacs so you
  870. ;; can know your rights and responsibilities.  It should be in a
  871. ;; file named COPYING.  Among other things, the copyright notice
  872. ;; and this notice must be preserved on all copies.
  873. X
  874. X
  875. X
  876. ;; This file is autoloaded from calc-ext.el.
  877. (require 'calc-ext)
  878. X
  879. (require 'calc-macs)
  880. X
  881. (defun calc-Need-calc-sel () nil)
  882. X
  883. X
  884. ;;; Selection commands.
  885. X
  886. (defun calc-select-here (num &optional once keep)
  887. X  (interactive "P")
  888. X  (calc-wrapper
  889. X   (calc-prepare-selection)
  890. X   (let ((found (calc-find-selected-part))
  891. X     (entry calc-selection-cache-entry))
  892. X     (or (and keep (nth 2 entry))
  893. X     (progn
  894. X       (if once (progn
  895. X              (setq calc-keep-selection nil)
  896. X              (message "(Selection will apply to next command only)")))
  897. X       (calc-change-current-selection 
  898. X        (if found
  899. X        (if (and num (> (setq num (prefix-numeric-value num)) 0))
  900. X            (progn
  901. X              (while (and (>= (setq num (1- num)) 0)
  902. X                  (not (eq found (car entry))))
  903. X            (setq found (calc-find-assoc-parent-formula
  904. X                     (car entry) found)))
  905. X              found)
  906. X          (calc-grow-assoc-formula (car entry) found))
  907. X          (car entry)))))))
  908. )
  909. X
  910. (defun calc-select-once (num)
  911. X  (interactive "P")
  912. X  (calc-select-here num t)
  913. )
  914. X
  915. (defun calc-select-here-maybe (num)
  916. X  (interactive "P")
  917. X  (calc-select-here num nil t)
  918. )
  919. X
  920. (defun calc-select-once-maybe (num)
  921. X  (interactive "P")
  922. X  (calc-select-once num t t)
  923. )
  924. X
  925. (defun calc-select-additional ()
  926. X  (interactive)
  927. X  (calc-wrapper
  928. X   (let (calc-keep-selection)
  929. X     (calc-prepare-selection))
  930. X   (let ((found (calc-find-selected-part))
  931. X     (entry calc-selection-cache-entry))
  932. X     (calc-change-current-selection
  933. X      (if found
  934. X      (let ((sel (nth 2 entry)))
  935. X        (if sel
  936. X        (progn
  937. X          (while (not (or (eq sel (car entry))
  938. X                  (calc-find-sub-formula sel found)))
  939. X            (setq sel (calc-find-assoc-parent-formula
  940. X                   (car entry) sel)))
  941. X          sel)
  942. X          (calc-grow-assoc-formula (car entry) found)))
  943. X    (car entry)))))
  944. )
  945. X
  946. (defun calc-select-more (num)
  947. X  (interactive "P")
  948. X  (calc-wrapper
  949. X   (calc-prepare-selection)
  950. X   (let ((entry calc-selection-cache-entry))
  951. X     (if (nth 2 entry)
  952. X     (let ((sel (nth 2 entry)))
  953. X       (while (and (not (eq sel (car entry)))
  954. X               (>= (setq num (1- (prefix-numeric-value num))) 0))
  955. X         (setq sel (calc-find-assoc-parent-formula (car entry) sel)))
  956. X       (calc-change-current-selection sel))
  957. X       (calc-select-here num))))
  958. )
  959. X
  960. (defun calc-select-less (num)
  961. X  (interactive "p")
  962. X  (calc-wrapper
  963. X   (calc-prepare-selection)
  964. X   (let ((found (calc-find-selected-part))
  965. X     (entry calc-selection-cache-entry))
  966. X     (calc-change-current-selection 
  967. X      (and found
  968. X       (let ((sel (nth 2 entry))
  969. X         old index op)
  970. X         (while (and sel
  971. X             (not (eq sel found))
  972. X             (>= (setq num (1- num)) 0))
  973. X           (setq old sel
  974. X             index (calc-find-sub-formula sel found))
  975. X           (and (setq sel (and index (nth index old)))
  976. X            calc-assoc-selections
  977. X            (setq op (assq (car-safe sel) calc-assoc-ops))
  978. X            (memq (car old) (nth index op))
  979. X            (setq num (1+ num))))
  980. X         sel)))))
  981. )
  982. X
  983. (defun calc-select-part (num)
  984. X  (interactive "P")
  985. X  (or num (setq num (- last-command-char ?0)))
  986. X  (calc-wrapper
  987. X   (calc-prepare-selection)
  988. X   (let ((sel (calc-find-nth-part (or (nth 2 calc-selection-cache-entry)
  989. X                      (car calc-selection-cache-entry))
  990. X                  num)))
  991. X     (if sel
  992. X     (calc-change-current-selection sel)
  993. X       (error "%d is not a valid sub-formula index" num))))
  994. )
  995. X
  996. (defun calc-find-nth-part (expr num)
  997. X  (if (and calc-assoc-selections
  998. X       (assq (car-safe expr) calc-assoc-ops))
  999. X      (let (op)
  1000. X    (calc-find-nth-part-rec expr))
  1001. X    (if (eq (car-safe expr) 'intv)
  1002. X    (and (>= num 1) (<= num 2) (nth (1+ num) expr))
  1003. X      (and (not (Math-primp expr)) (>= num 1) (< num (length expr))
  1004. X       (nth num expr))))
  1005. )
  1006. X
  1007. (defun calc-find-nth-part-rec (expr)   ; uses num, op
  1008. X  (or (if (and (setq op (assq (car-safe (nth 1 expr)) calc-assoc-ops))
  1009. X           (memq (car expr) (nth 1 op)))
  1010. X      (calc-find-nth-part-rec (nth 1 expr))
  1011. X    (and (= (setq num (1- num)) 0)
  1012. X         (nth 1 expr)))
  1013. X      (if (and (setq op (assq (car-safe (nth 2 expr)) calc-assoc-ops))
  1014. X           (memq (car expr) (nth 2 op)))
  1015. X      (calc-find-nth-part-rec (nth 2 expr))
  1016. X    (and (= (setq num (1- num)) 0)
  1017. X         (nth 2 expr))))
  1018. )
  1019. X
  1020. (defun calc-select-next (num)
  1021. X  (interactive "p")
  1022. X  (if (< num 0)
  1023. X      (calc-select-previous (- num))
  1024. X    (calc-wrapper
  1025. X     (calc-prepare-selection)
  1026. X     (let* ((entry calc-selection-cache-entry)
  1027. X        (sel (nth 2 entry)))
  1028. X       (if sel
  1029. X       (progn
  1030. X         (while (>= (setq num (1- num)) 0)
  1031. X           (let* ((parent (calc-find-parent-formula (car entry) sel))
  1032. X             (p parent)
  1033. X             op)
  1034. X         (and (eq p t) (setq p nil))
  1035. X         (while (and (setq p (cdr p))
  1036. X                 (not (eq (car p) sel))))
  1037. X         (if (cdr p)
  1038. X             (setq sel (or (and calc-assoc-selections
  1039. X                    (setq op (assq (car-safe (nth 1 p))
  1040. X                               calc-assoc-ops))
  1041. X                    (memq (car parent) (nth 2 op))
  1042. X                    (nth 1 (nth 1 p)))
  1043. X                   (nth 1 p)))
  1044. X           (if (and calc-assoc-selections
  1045. X                (setq op (assq (car-safe parent) calc-assoc-ops))
  1046. X                (consp (setq p (calc-find-parent-formula
  1047. X                        (car entry) parent)))
  1048. X                (eq (nth 1 p) parent)
  1049. X                (memq (car p) (nth 1 op)))
  1050. X               (setq sel (nth 2 p))
  1051. X             (error "No \"next\" sub-formula")))))
  1052. X         (calc-change-current-selection sel))
  1053. X     (if (Math-primp (car entry))
  1054. X         (calc-change-current-selection (car entry))
  1055. X       (calc-select-part num))))))
  1056. )
  1057. X
  1058. (defun calc-select-previous (num)
  1059. X  (interactive "p")
  1060. X  (if (< num 0)
  1061. X      (calc-select-next (- num))
  1062. X    (calc-wrapper
  1063. X     (calc-prepare-selection)
  1064. X     (let* ((entry calc-selection-cache-entry)
  1065. X        (sel (nth 2 entry)))
  1066. X       (if sel
  1067. X       (progn
  1068. X         (while (>= (setq num (1- num)) 0)
  1069. X           (let* ((parent (calc-find-parent-formula (car entry) sel))
  1070. X              (p (cdr-safe parent))
  1071. X              (prev nil)
  1072. X              op)
  1073. X         (if (eq (car-safe parent) 'intv) (setq p (cdr p)))
  1074. X         (while (and (not (eq (car p) sel))
  1075. X                 (setq prev (car p)
  1076. X                   p (cdr p))))
  1077. X         (if prev
  1078. X             (setq sel (or (and calc-assoc-selections
  1079. X                    (setq op (assq (car-safe prev)
  1080. X                               calc-assoc-ops))
  1081. X                    (memq (car parent) (nth 1 op))
  1082. X                    (nth 2 prev))
  1083. X                   prev))
  1084. X           (if (and calc-assoc-selections
  1085. X                (setq op (assq (car-safe parent) calc-assoc-ops))
  1086. X                (consp (setq p (calc-find-parent-formula
  1087. X                        (car entry) parent)))
  1088. X                (eq (nth 2 p) parent)
  1089. X                (memq (car p) (nth 2 op)))
  1090. X               (setq sel (nth 1 p))
  1091. X             (error "No \"previous\" sub-formula")))))
  1092. X         (calc-change-current-selection sel))
  1093. X     (if (Math-primp (car entry))
  1094. X         (calc-change-current-selection (car entry))
  1095. X       (let ((len (if (and calc-assoc-selections
  1096. X                   (assq (car (car entry)) calc-assoc-ops))
  1097. X              (let (op (num 0))
  1098. X                (calc-find-nth-part-rec (car entry))
  1099. X                (- 1 num))
  1100. X            (length (car entry)))))
  1101. X         (calc-select-part (- len num))))))))
  1102. )
  1103. X
  1104. (defun calc-find-parent-formula (expr part)
  1105. X  (cond ((eq expr part) t)
  1106. X    ((Math-primp expr) nil)
  1107. X    (t
  1108. X     (let ((p expr) res)
  1109. X       (while (and (setq p (cdr p))
  1110. X               (not (setq res (calc-find-parent-formula
  1111. X                       (car p) part)))))
  1112. X       (and p
  1113. X        (if (eq res t) expr res)))))
  1114. )
  1115. X
  1116. X
  1117. (defun calc-find-assoc-parent-formula (expr part)
  1118. X  (calc-grow-assoc-formula expr (calc-find-parent-formula expr part))
  1119. )
  1120. X
  1121. (defun calc-grow-assoc-formula (expr part)
  1122. X  (if calc-assoc-selections
  1123. X      (let ((op (assq (car-safe part) calc-assoc-ops)))
  1124. X    (if op
  1125. X        (let (new)
  1126. X          (while (and (consp (setq new (calc-find-parent-formula
  1127. X                        expr part)))
  1128. X              (memq (car new)
  1129. X                (nth (calc-find-sub-formula new part) op)))
  1130. X        (setq part new))))
  1131. X    part)
  1132. X    part)
  1133. )
  1134. X
  1135. (defun calc-find-sub-formula (expr part)
  1136. X  (cond ((eq expr part) t)
  1137. X    ((Math-primp expr) nil)
  1138. X    (t
  1139. X     (let ((num 1))
  1140. X       (while (and (setq expr (cdr expr))
  1141. X               (not (calc-find-sub-formula (car expr) part)))
  1142. X         (setq num (1+ num)))
  1143. X       (and expr num))))
  1144. )
  1145. X
  1146. (defun calc-unselect (num)
  1147. X  (interactive "P")
  1148. X  (calc-wrapper
  1149. X   (calc-prepare-selection num)
  1150. X   (calc-change-current-selection nil))
  1151. )
  1152. X
  1153. (defun calc-clear-selections ()
  1154. X  (interactive)
  1155. X  (calc-wrapper
  1156. X   (let ((limit (calc-stack-size))
  1157. X     (n 1))
  1158. X     (while (<= n limit)
  1159. X       (if (calc-top n 'sel)
  1160. X       (progn
  1161. X         (calc-prepare-selection n)
  1162. X         (calc-change-current-selection nil)))
  1163. X       (setq n (1+ n))))
  1164. X   (calc-clear-command-flag 'position-point))
  1165. )
  1166. X
  1167. (defun calc-show-selections (arg)
  1168. X  (interactive "P")
  1169. X  (calc-wrapper
  1170. X   (calc-preserve-point)
  1171. X   (setq calc-show-selections (if arg
  1172. X                  (> (prefix-numeric-value arg) 0)
  1173. X                (not calc-show-selections)))
  1174. X   (let ((p calc-stack))
  1175. X     (while (and p
  1176. X         (or (null (nth 2 (car p)))
  1177. X             (equal (car p) calc-selection-cache-entry)))
  1178. X       (setq p (cdr p)))
  1179. X     (or (and p
  1180. X          (let ((calc-selection-cache-default-entry
  1181. X             calc-selection-cache-entry))
  1182. X        (calc-do-refresh)))
  1183. X     (and calc-selection-cache-entry
  1184. X          (let ((sel (nth 2 calc-selection-cache-entry)))
  1185. X        (setcar (nthcdr 2 calc-selection-cache-entry) nil)
  1186. X        (calc-change-current-selection sel)))))
  1187. X   (message (if calc-show-selections
  1188. X        "Displaying only selected part of formulas"
  1189. X          "Displaying all but selected part of formulas")))
  1190. )
  1191. X
  1192. (defun calc-preserve-point ()
  1193. X  (or (looking-at "\\.\n+\\'")
  1194. X      (progn
  1195. X    (setq calc-final-point-line (+ (count-lines (point-min) (point))
  1196. X                       (if (bolp) 1 0))
  1197. X          calc-final-point-column (current-column))
  1198. X    (calc-set-command-flag 'position-point)))
  1199. )
  1200. X
  1201. (defun calc-enable-selections (arg)
  1202. X  (interactive "P")
  1203. X  (calc-wrapper
  1204. X   (calc-preserve-point)
  1205. X   (setq calc-use-selections (if arg
  1206. X                 (> (prefix-numeric-value arg) 0)
  1207. X                   (not calc-use-selections)))
  1208. X   (calc-set-command-flag 'renum-stack)
  1209. X   (message (if calc-use-selections
  1210. X        "Commands operate only on selected sub-formulas"
  1211. X          "Selections of sub-formulas have no effect")))
  1212. )
  1213. X
  1214. (defun calc-break-selections (arg)
  1215. X  (interactive "P")
  1216. X  (calc-wrapper
  1217. X   (calc-preserve-point)
  1218. X   (setq calc-assoc-selections (if arg
  1219. X                   (<= (prefix-numeric-value arg) 0)
  1220. X                 (not calc-assoc-selections)))
  1221. X   (message (if calc-assoc-selections
  1222. X        "Selection treats a+b+c as a sum of three terms"
  1223. X          "Selection treats a+b+c as (a+b)+c")))
  1224. )
  1225. X
  1226. (defun calc-prepare-selection (&optional num)
  1227. X  (or num (setq num (calc-locate-cursor-element (point))))
  1228. X  (setq calc-selection-true-num num
  1229. X    calc-keep-selection t)
  1230. X  (or (> num 0) (setq num 1))
  1231. X  ;; (if (or (< num 1) (> num (calc-stack-size)))
  1232. X  ;;     (error "Cursor must be positioned on a stack element"))
  1233. X  (let* ((entry (calc-top num 'entry))
  1234. X     ww w)
  1235. X    (or (equal entry calc-selection-cache-entry)
  1236. X    (progn
  1237. X      (setcar entry (calc-encase-atoms (car entry)))
  1238. X      (setq calc-selection-cache-entry entry
  1239. X        calc-selection-cache-num num
  1240. X        calc-selection-cache-comp
  1241. X        (let ((math-comp-tagged t))
  1242. X          (math-compose-expr (car entry) 0))
  1243. X        calc-selection-cache-offset
  1244. X        (+ (car (math-stack-value-offset calc-selection-cache-comp))
  1245. X           (length calc-left-label)
  1246. X           (if calc-line-numbering 4 0))))))
  1247. X  (calc-preserve-point)
  1248. )
  1249. (setq calc-selection-cache-entry nil)
  1250. X
  1251. ;;; The following ensures that no two subformulas will be "eq" to each other!
  1252. (defun calc-encase-atoms (x)
  1253. X  (if (or (not (consp x))
  1254. X      (equal x '(float 0 0)))
  1255. X      (list 'cplx x 0)
  1256. X    (calc-encase-atoms-rec x)
  1257. X    x)
  1258. )
  1259. X
  1260. (defun calc-encase-atoms-rec (x)
  1261. X  (or (Math-primp x)
  1262. X      (progn
  1263. X    (if (eq (car x) 'intv)
  1264. X        (setq x (cdr x)))
  1265. X    (while (setq x (cdr x))
  1266. X      (if (or (not (consp (car x)))
  1267. X          (equal (car x) '(float 0 0)))
  1268. X          (setcar x (list 'cplx (car x) 0))
  1269. X        (calc-encase-atoms-rec (car x))))))
  1270. )
  1271. X
  1272. (defun calc-find-selected-part ()
  1273. X  (let* ((math-comp-sel-hpos (- (current-column) calc-selection-cache-offset))
  1274. X     toppt
  1275. X     (lcount 0)
  1276. X     (spaces 0)
  1277. X     (math-comp-sel-vpos (save-excursion
  1278. X                   (beginning-of-line)
  1279. X                   (let ((line (point)))
  1280. X                 (calc-cursor-stack-index
  1281. X                  calc-selection-cache-num)
  1282. X                 (setq toppt (point))
  1283. X                 (while (< (point) line)
  1284. X                   (forward-line 1)
  1285. X                   (setq spaces (+ spaces
  1286. X                           (current-indentation))
  1287. X                     lcount (1+ lcount)))
  1288. X                 (- lcount (math-comp-ascent
  1289. X                        calc-selection-cache-comp) -1))))
  1290. X     (math-comp-sel-cpos (- (point) toppt calc-selection-cache-offset
  1291. X                spaces lcount))
  1292. X     (math-comp-sel-tag nil))
  1293. X    (and (>= math-comp-sel-hpos 0)
  1294. X     (> calc-selection-true-num 0)
  1295. X     (math-composition-to-string calc-selection-cache-comp 1000000))
  1296. X    (nth 1 math-comp-sel-tag))
  1297. )
  1298. X
  1299. (defun calc-change-current-selection (sub-expr)
  1300. X  (or (eq sub-expr (nth 2 calc-selection-cache-entry))
  1301. X      (let ((calc-prepared-composition calc-selection-cache-comp)
  1302. X        (buffer-read-only nil)
  1303. X        top)
  1304. X    (calc-set-command-flag 'renum-stack)
  1305. X    (setcar (nthcdr 2 calc-selection-cache-entry) sub-expr)
  1306. X    (calc-cursor-stack-index calc-selection-cache-num)
  1307. X    (setq top (point))
  1308. X    (calc-cursor-stack-index (1- calc-selection-cache-num))
  1309. X    (delete-region top (point))
  1310. X    (let ((calc-selection-cache-default-entry calc-selection-cache-entry))
  1311. X      (insert (math-format-stack-value calc-selection-cache-entry)
  1312. X          "\n"))))
  1313. )
  1314. X
  1315. (defun calc-top-selected (&optional n m)
  1316. X  (and calc-any-selections
  1317. X       calc-use-selections
  1318. X       (progn
  1319. X     (or n (setq n 1))
  1320. X     (or m (setq m 1))
  1321. X     (calc-check-stack (+ n m -1))
  1322. X     (let ((top (nthcdr (+ m calc-stack-top -1) calc-stack))
  1323. X           (sel nil))
  1324. X       (while (>= (setq n (1- n)) 0)
  1325. X         (if (nth 2 (car top))
  1326. X         (setq sel (if sel t (nth 2 (car top)))))
  1327. X         (setq top (cdr top)))
  1328. X       sel)))
  1329. )
  1330. X
  1331. (defun calc-replace-sub-formula (expr old new)
  1332. X  (setq new (calc-encase-atoms new))
  1333. X  (calc-replace-sub-formula-rec expr)
  1334. )
  1335. X
  1336. (defun calc-replace-sub-formula-rec (expr)
  1337. X  (cond ((eq expr old) new)
  1338. X    ((Math-primp expr) expr)
  1339. X    (t
  1340. X     (cons (car expr)
  1341. X           (mapcar 'calc-replace-sub-formula-rec (cdr expr)))))
  1342. )
  1343. X
  1344. (defun calc-sel-error ()
  1345. X  (error "Illegal operation on sub-formulas")
  1346. )
  1347. X
  1348. (defun calc-replace-selections (n vals m)
  1349. X  (if (calc-top-selected n m)
  1350. X      (let ((num (length vals)))
  1351. X    (calc-preserve-point)
  1352. X    (cond
  1353. X     ((= n num)
  1354. X      (let* ((old (calc-top-list n m 'entry))
  1355. X         (new nil)
  1356. X         (sel nil)
  1357. X         val)
  1358. X        (while old
  1359. X          (if (nth 2 (car old))
  1360. X          (setq val (calc-encase-atoms (car vals))
  1361. X            new (cons (calc-replace-sub-formula (car (car old))
  1362. X                                (nth 2 (car old))
  1363. X                                val)
  1364. X                  new)
  1365. X            sel (cons val sel))
  1366. X        (setq new (cons (car vals) new)
  1367. X              sel (cons nil sel)))
  1368. X          (setq vals (cdr vals)
  1369. X            old (cdr old)))
  1370. X        (calc-pop-stack n m t)
  1371. X        (calc-push-list (nreverse new)
  1372. X                m (and calc-keep-selection (nreverse sel)))))
  1373. X     ((= num 1)
  1374. X      (let* ((old (calc-top-list n m 'entry))
  1375. X         more)
  1376. X        (while (and old (not (nth 2 (car old))))
  1377. X          (setq old (cdr old)))
  1378. X        (setq more old)
  1379. X        (while (and (setq more (cdr more)) (not (nth 2 (car more)))))
  1380. X        (and more
  1381. X         (calc-sel-error))
  1382. X        (calc-pop-stack n m t)
  1383. X        (if old
  1384. X        (let ((val (calc-encase-atoms (car vals))))
  1385. X          (calc-push-list (list (calc-replace-sub-formula
  1386. X                     (car (car old))
  1387. X                     (nth 2 (car old))
  1388. X                     val))
  1389. X                  m (and calc-keep-selection (list val))))
  1390. X          (calc-push-list vals))))
  1391. X     (t (calc-sel-error))))
  1392. X    (calc-pop-stack n m t)
  1393. X    (calc-push-list vals m))
  1394. )
  1395. (setq calc-keep-selection t)
  1396. X
  1397. (defun calc-delete-selection (n)
  1398. X  (let ((entry (calc-top n 'entry)))
  1399. X    (if (nth 2 entry)
  1400. X    (if (eq (nth 2 entry) (car entry))
  1401. X        (progn
  1402. X          (calc-pop-stack 1 n t)
  1403. X          (calc-push-list '(0) n))
  1404. X      (let ((parent (calc-find-parent-formula (car entry) (nth 2 entry)))
  1405. X        (repl nil))
  1406. X        (calc-preserve-point)
  1407. X        (calc-pop-stack 1 n t)
  1408. X        (cond ((or (memq (car parent) '(* / %))
  1409. X               (and (eq (car parent) '^)
  1410. X                (eq (nth 2 parent) (nth 2 entry))))
  1411. X           (setq repl 1))
  1412. X          ((memq (car parent) '(vec calcFunc-min calcFunc-max)))
  1413. X          ((and (assq (car parent) calc-tweak-eqn-table)
  1414. X            (= (length parent) 3))
  1415. X           (setq repl 'del))
  1416. X          (t
  1417. X           (setq repl 0)))
  1418. X        (cond
  1419. X         ((eq repl 'del)
  1420. X          (calc-push-list (list
  1421. X                   (calc-normalize
  1422. X                (calc-replace-sub-formula
  1423. X                 (car entry)
  1424. X                 parent
  1425. X                 (if (eq (nth 2 entry) (nth 1 parent))
  1426. X                     (nth 2 parent)
  1427. X                   (nth 1 parent)))))
  1428. X                  n))
  1429. X         (repl
  1430. X          (calc-push-list (list
  1431. X                   (calc-normalize
  1432. X                (calc-replace-sub-formula (car entry)
  1433. X                              (nth 2 entry)
  1434. X                              repl)))
  1435. X                  n))
  1436. X         (t
  1437. X          (calc-push-list (list
  1438. X                   (calc-normalize
  1439. X                (calc-replace-sub-formula (car entry)
  1440. X                              parent
  1441. X                              (delq (nth 2 entry)
  1442. X                                (copy-sequence
  1443. X                                 parent)))))
  1444. X                  n)))))
  1445. X      (calc-pop-stack 1 n t)))
  1446. )
  1447. X
  1448. (defun calc-roll-down-with-selections (n m)
  1449. X  (let ((vals (append (calc-top-list m 1)
  1450. X              (calc-top-list (- n m) (1+ m))))
  1451. X    (sels (append (calc-top-list m 1 'sel)
  1452. X              (calc-top-list (- n m) (1+ m) 'sel))))
  1453. X    (calc-pop-push-list n vals 1 sels))
  1454. )
  1455. X
  1456. (defun calc-roll-up-with-selections (n m)
  1457. X  (let ((vals (append (calc-top-list (- n m) 1)
  1458. X              (calc-top-list m (- n m -1))))
  1459. X    (sels (append (calc-top-list (- n m) 1 'sel)
  1460. X              (calc-top-list m (- n m -1) 'sel))))
  1461. X    (calc-pop-push-list n vals 1 sels))
  1462. )
  1463. X
  1464. (defun calc-auto-selection (entry)
  1465. X  (or (nth 2 entry)
  1466. X      (progn
  1467. X    (and (boundp 'reselect) (setq reselect nil))
  1468. X    (calc-prepare-selection)
  1469. X    (calc-grow-assoc-formula (car entry) (calc-find-selected-part))))
  1470. )
  1471. X
  1472. (defun calc-copy-selection ()
  1473. X  (interactive)
  1474. X  (calc-wrapper
  1475. X   (calc-preserve-point)
  1476. X   (let* ((num (max 1 (calc-locate-cursor-element (point))))
  1477. X      (entry (calc-top num 'entry)))
  1478. X     (calc-push (or (calc-auto-selection entry) (car entry)))))
  1479. )
  1480. X
  1481. (defun calc-del-selection ()
  1482. X  (interactive)
  1483. X  (calc-wrapper
  1484. X   (calc-preserve-point)
  1485. X   (let* ((num (max 1 (calc-locate-cursor-element (point))))
  1486. X      (entry (calc-top num 'entry))
  1487. X      (sel (calc-auto-selection entry)))
  1488. X     (setcar (nthcdr 2 entry) (and (not (eq sel (car entry))) sel))
  1489. X     (calc-delete-selection num)))
  1490. )
  1491. X
  1492. (defun calc-enter-selection ()
  1493. X  (interactive)
  1494. X  (calc-wrapper
  1495. X   (calc-preserve-point)
  1496. X   (let* ((num (max 1 (calc-locate-cursor-element (point))))
  1497. X      (reselect calc-keep-selection)
  1498. X      (entry (calc-top num 'entry))
  1499. X      (expr (car entry))
  1500. X      (sel (or (calc-auto-selection entry) expr))
  1501. X      alg)
  1502. X     (let ((calc-dollar-values (list sel))
  1503. X       (calc-dollar-used 0))
  1504. X       (setq alg (calc-do-alg-entry "" "Replace selection with: "))
  1505. X       (and alg
  1506. X        (progn
  1507. X          (setq alg (calc-encase-atoms (car alg)))
  1508. X          (calc-pop-push-record-list 1 "repl"
  1509. X                     (list (calc-replace-sub-formula
  1510. X                        expr sel alg))
  1511. X                     num
  1512. X                     (list (and reselect alg))))))
  1513. X     (calc-handle-whys)))
  1514. )
  1515. X
  1516. (defun calc-edit-selection ()
  1517. X  (interactive)
  1518. X  (calc-wrapper
  1519. X   (calc-preserve-point)
  1520. X   (let* ((num (max 1 (calc-locate-cursor-element (point))))
  1521. X      (reselect calc-keep-selection)
  1522. X      (entry (calc-top num 'entry))
  1523. X      (expr (car entry))
  1524. X      (sel (or (calc-auto-selection entry) expr))
  1525. X      alg)
  1526. X     (let ((str (math-showing-full-precision
  1527. X         (math-format-nice-expr sel (screen-width)))))
  1528. X       (calc-edit-mode (list 'calc-finish-selection-edit
  1529. X                 num (list 'quote sel) reselect))
  1530. X       (insert str "\n"))))
  1531. X  (calc-show-edit-buffer)
  1532. )
  1533. X
  1534. (defun calc-finish-selection-edit (num sel reselect)
  1535. X  (let ((buf (current-buffer))
  1536. X    (str (buffer-substring (point) (point-max)))
  1537. X    (start (point)))
  1538. X    (switch-to-buffer calc-original-buffer)
  1539. X    (let ((val (math-read-expr str)))
  1540. X      (if (eq (car-safe val) 'error)
  1541. X      (progn
  1542. X        (switch-to-buffer buf)
  1543. X        (goto-char (+ start (nth 1 val)))
  1544. X        (error (nth 2 val))))
  1545. X      (calc-wrapper
  1546. X       (calc-preserve-point)
  1547. X       (if disp-trail
  1548. X       (calc-trail-display 1 t))
  1549. X       (setq val (calc-encase-atoms (calc-normalize val)))
  1550. X       (let ((expr (calc-top num 'full)))
  1551. X     (if (calc-find-sub-formula expr sel)
  1552. X         (calc-pop-push-record-list 1 "edit"
  1553. X                    (list (calc-replace-sub-formula
  1554. X                           expr sel val))
  1555. X                    num
  1556. X                    (list (and reselect val)))
  1557. X       (calc-push val)
  1558. X       (error "Original selection has been lost"))))))
  1559. )
  1560. X
  1561. (defun calc-sel-evaluate (arg)
  1562. X  (interactive "p")
  1563. X  (calc-slow-wrapper
  1564. X   (calc-preserve-point)
  1565. X   (let* ((num (max 1 (calc-locate-cursor-element (point))))
  1566. X      (reselect calc-keep-selection)
  1567. X      (entry (calc-top num 'entry))
  1568. X      (sel (or (calc-auto-selection entry) (car entry))))
  1569. X     (calc-with-default-simplification
  1570. X      (let ((math-simplify-only nil))
  1571. X    (calc-modify-simplify-mode arg)
  1572. X    (let ((val (calc-encase-atoms (calc-normalize sel))))
  1573. X      (calc-pop-push-record-list 1 "jsmp"
  1574. X                     (list (calc-replace-sub-formula
  1575. X                        (car entry) sel val))
  1576. X                     num
  1577. X                     (list (and reselect val))))))
  1578. X     (calc-handle-whys)))
  1579. )
  1580. X
  1581. (defun calc-sel-expand-formula (arg)
  1582. X  (interactive "p")
  1583. X  (calc-slow-wrapper
  1584. X   (calc-preserve-point)
  1585. X   (let* ((num (max 1 (calc-locate-cursor-element (point))))
  1586. X      (reselect calc-keep-selection)
  1587. X      (entry (calc-top num 'entry))
  1588. X      (sel (or (calc-auto-selection entry) (car entry))))
  1589. X     (calc-with-default-simplification
  1590. X      (let ((math-simplify-only nil))
  1591. X    (calc-modify-simplify-mode arg)
  1592. X    (let* ((math-expand-formulas (> arg 0))
  1593. X           (val (calc-normalize sel))
  1594. X           top)
  1595. X      (and (<= arg 0)
  1596. X           (setq top (math-expand-formula val))
  1597. X           (setq val (calc-normalize top)))
  1598. X      (setq val (calc-encase-atoms val))
  1599. X      (calc-pop-push-record-list 1 "jexf"
  1600. X                     (list (calc-replace-sub-formula
  1601. X                        (car entry) sel val))
  1602. X                     num
  1603. X                     (list (and reselect val))))))
  1604. X     (calc-handle-whys)))
  1605. )
  1606. X
  1607. (defun calc-sel-mult-both-sides (no-simp &optional divide)
  1608. X  (interactive "P")
  1609. X  (calc-wrapper
  1610. X   (calc-preserve-point)
  1611. X   (let* ((num (max 1 (calc-locate-cursor-element (point))))
  1612. X      (reselect calc-keep-selection)
  1613. X      (entry (calc-top num 'entry))
  1614. X      (expr (car entry))
  1615. X      (sel (or (calc-auto-selection entry) expr))
  1616. X      (func (car-safe sel))
  1617. X      alg lhs rhs)
  1618. X     (setq alg (calc-with-default-simplification
  1619. X        (car (calc-do-alg-entry ""
  1620. X                    (if divide
  1621. X                        "Divide both sides by: "
  1622. X                      "Multiply both sides by: ")))))
  1623. X     (and alg
  1624. X      (progn
  1625. X        (if (and (or (eq func '/)
  1626. X             (assq func calc-tweak-eqn-table))
  1627. X             (= (length sel) 3))
  1628. X        (progn
  1629. X          (or (memq func '(/ calcFunc-eq calcFunc-neq))
  1630. X              (if (math-known-nonposp alg)
  1631. X              (progn
  1632. X                (setq func (nth 1 (assq func
  1633. X                            calc-tweak-eqn-table)))
  1634. X                (or (math-known-negp alg)
  1635. X                (message "Assuming this factor is nonzero")))
  1636. X            (or (math-known-posp alg)
  1637. X                (if (math-known-nonnegp alg)
  1638. X                (message "Assuming this factor is nonzero")
  1639. X                  (message "Assuming this factor is positive")))))
  1640. X          (setq lhs (list (if divide '/ '*) (nth 1 sel) alg)
  1641. X            rhs (list (if divide '/ '*) (nth 2 sel) alg))
  1642. X          (or no-simp
  1643. X              (progn
  1644. X            (setq lhs (math-simplify lhs)
  1645. X                  rhs (math-simplify rhs))
  1646. X            (and (eq func '/)
  1647. X                 (or (Math-equal (nth 1 sel) 1)
  1648. X                 (Math-equal (nth 1 sel) -1)
  1649. X                 (and (memq (car-safe (nth 2 sel)) '(+ -))
  1650. X                      (memq (car-safe alg) '(+ -))))
  1651. X                 (setq rhs (math-expand-term rhs)))))
  1652. X          (setq alg (calc-encase-atoms
  1653. X                 (calc-normalize (list func lhs rhs)))))
  1654. X          (setq rhs (list (if divide '* '/) sel alg))
  1655. X          (or no-simp
  1656. X          (setq rhs (math-simplify rhs)))
  1657. X          (setq alg (calc-encase-atoms
  1658. X             (calc-normalize (if divide
  1659. X                         (list '/ rhs alg)
  1660. X                       (list '* alg rhs))))))
  1661. X        (calc-pop-push-record-list 1 (if divide "div" "mult")
  1662. X                       (list (calc-replace-sub-formula
  1663. X                          expr sel alg))
  1664. X                       num
  1665. X                       (list (and reselect alg)))))
  1666. X     (calc-handle-whys)))
  1667. )
  1668. X
  1669. (defun calc-sel-div-both-sides (no-simp)
  1670. X  (interactive "P")
  1671. X  (calc-sel-mult-both-sides no-simp t)
  1672. )
  1673. X
  1674. (defun calc-sel-add-both-sides (no-simp &optional subtract)
  1675. X  (interactive "P")
  1676. X  (calc-wrapper
  1677. X   (calc-preserve-point)
  1678. X   (let* ((num (max 1 (calc-locate-cursor-element (point))))
  1679. X      (reselect calc-keep-selection)
  1680. X      (entry (calc-top num 'entry))
  1681. X      (expr (car entry))
  1682. X      (sel (or (calc-auto-selection entry) expr))
  1683. X      (func (car-safe sel))
  1684. X      alg lhs rhs)
  1685. X     (setq alg (calc-with-default-simplification
  1686. X        (car (calc-do-alg-entry ""
  1687. X                    (if subtract
  1688. X                        "Subtract from both sides: "
  1689. X                      "Add to both sides: ")))))
  1690. X     (and alg
  1691. X      (progn
  1692. X        (if (and (assq func calc-tweak-eqn-table)
  1693. X             (= (length sel) 3))
  1694. X        (progn
  1695. X          (setq lhs (list (if subtract '- '+) (nth 1 sel) alg)
  1696. X            rhs (list (if subtract '- '+) (nth 2 sel) alg))
  1697. X          (or no-simp
  1698. X              (setq lhs (math-simplify lhs)
  1699. X                rhs (math-simplify rhs)))
  1700. X          (setq alg (calc-encase-atoms
  1701. X                 (calc-normalize (list func lhs rhs)))))
  1702. X          (setq rhs (list (if subtract '+ '-) sel alg))
  1703. X          (or no-simp
  1704. X          (setq rhs (math-simplify rhs)))
  1705. X          (setq alg (calc-encase-atoms
  1706. X             (calc-normalize (list (if subtract '- '+) alg rhs)))))
  1707. X        (calc-pop-push-record-list 1 (if subtract "sub" "add")
  1708. X                       (list (calc-replace-sub-formula
  1709. X                          expr sel alg))
  1710. SHAR_EOF
  1711. true || echo 'restore of calc-sel.el failed'
  1712. fi
  1713. echo 'End of  part 26'
  1714. echo 'File calc-sel.el is continued in part 27'
  1715. echo 27 > _shar_seq_.tmp
  1716. exit 0
  1717. exit 0 # Just in case...
  1718. -- 
  1719. Kent Landfield                   INTERNET: kent@sparky.IMD.Sterling.COM
  1720. Sterling Software, IMD           UUCP:     uunet!sparky!kent
  1721. Phone:    (402) 291-8300         FAX:      (402) 291-4362
  1722. Please send comp.sources.misc-related mail to kent@uunet.uu.net.
  1723.