1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
|
#|
Author: Barton Willis, June 2008
I, Barton Willis, hereby place this code into the public domain.
The dot-dot operator generates terms of an arithmetic sequence. The
two argument dot-dot operator is defined by (Z is the set of integers).
a .. b = [a + k | k in Z, 0 <= k <= (b - a)].
Thus a .. b = [a, a + 1, a + 2, ..., a + n], where n = floor(b - a). The three
argument dot-dot operator is defined by
a .. h .. b = [a + h * k | k in 0 .. (b - a) / h].
a .. b expands to a list when either floor(b - a) is an integer (not a
declared integer) or sign(b - a) is negative or zero; otherwise, the dot-dot
operator returns a noun form.
a .. h .. b expands to a list when floor((b-a) / h) is an integer (not a
declared integer) or sign(b - a) is negative or zero and h is nonzero.
|#
;; These binding powers make a .. b op c == a .. (b op c), where op = +, -, *, /, or ^.
($nary ".." 80)
(setf (get '$.. 'operators) 'simp-integer-sequence)
(defun simp-integer-sequence (e yy z)
(declare (ignore yy))
(let ((i) (j) (k) (lo) (hi) (h) (n) (sgn) (sgn-h) (acc nil))
(pop e)
(setq i (if e (simpcheck (pop e) z) (merror "The '..' operator needs 2 or 3 arguments, not 0")))
(setq j (if e (simpcheck (pop e) z) (merror "The '..' operator needs 2 or 3 arguments, not 1")))
(setq k (if e (simpcheck (pop e) z) nil))
(if e (merror "The '..' operator needs 3 or fewer arguments"))
(if k (setq lo i hi k h j) (setq lo i h 1 hi j))
(if (zerop1 h) (merror "The step argument to '..' must be nonzero"))
(setq sgn (if (like hi lo) '$zero (csign (sub hi lo))))
(setq sgn-h (csign h))
(setq n (if (eq sgn '$zero) 0 (take '($floor) (div (sub hi lo) h))))
(cond ((and (integerp n) (memq sgn-h '($neg $pos $pn)))
(while (>= n 0)
(push (add lo (mul n h)) acc)
(decf n))
(simplify (cons '(mlist) acc)))
((or (and (eq '$neg sgn) (eq '$pos sgn-h))
(and (eq '$pos sgn) (eq '$neg sgn-h)))
(simplify `((mlist))))
((not k) `(($.. simp) ,i ,j))
((eq 1 j) `(($.. simp) ,i ,k)) ; a .. 1 .. b == a .. b
(t `(($.. simp) ,i ,j ,k)))))
|
