share/integer_sequence/integer_sequence.lisp

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