source: CGBLisp/trunk/src/makelist.lisp@ 23

#|
  *--------------------------------------------------------------------------*
  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
  |                                                                          |
  | Everyone is permitted to copy, distribute and modify the code in this    |
  | directory, as long as this copyright note is preserved verbatim.         |
  *--------------------------------------------------------------------------*
|#

(defpackage "MAKELIST"
  (:use "COMMON-LISP")
  (:export makelist-1  makelist list-of set-of union-of select sum summation difference standard-vector))

(in-package "MAKELIST")

#+debug(proclaim '(optimize (speed 0) (debug 3)))
#-debug(proclaim '(optimize (speed 3) (debug 0)))


;; Macros for making lists with iterators - an exammple of GENSYM
;; MAKELIST-1 makes a list with one iterator, while MAKELIST accepts an
;; arbitrary number of iterators

;; Sample usage:
;; Without a step:
;; >(makelist-1 (* 2 i) i 0 10)
;; (0 2 4 6 8 10 12 14 16 18 20)
;; With a step of 3:
;; >(makelist-1 (* 2 i) i 0 10 3)
;; (0 6 12 18)

;; Generate sums of squares of numbers between 1 and 4:
;; >(makelist (+ (* i i) (* j j)) (i 1 4) (j 1 i))
;; (2 5 8 10 13 18 17 20 25 32)
;; >(makelist (list i j '---> (+ (* i i) (* j j))) (i 1 4) (j 1 i))
;; ((1 1 ---> 2) (2 1 ---> 5) (2 2 ---> 8) (3 1 ---> 10) (3 2 ---> 13)
;; (3 3 ---> 18) (4 1 ---> 17) (4 2 ---> 20) (4 3 ---> 25) (4 4 ---> 32))

;; Summation with SUM:
;; Sum of squares of integers from 1 to 10:
;; >(sum (expt i 2) (i 1 10))
;; 385
;; Sum of inverses of integers from 1 to 50:
;; >(sum (/ n) (n 1 50))
;; 13943237577224054960759/3099044504245996706400
;; Sum of 1/(m^2+n^2) where m,n vary from 1 to 10:
;; >(sum (/ (+ (expt m 2) (expt n 2))) (n 1 10) (m 1 10))
;; 125085870045079516933345908893314157/42204464874461454985621846571472000
;; Sum of 1/(m^2+n^2) where m,n vary from 1 to 10 and m>n:
;; >(sum (/ (+ (expt m 2) (expt n 2))) (n 1 10) (m 1 (1- n)))
;; 13092731173226115661182811487147/11962716801151206061684196874000

;; Evaluate expression expr with variable set to lo, lo+1,... ,hi
;; and put the results in a list.
(defmacro makelist-1 (expr var lo hi &optional (step 1))
  (let ((l (gensym)))
    `(do ((,var ,lo (+ ,var ,step))
          (,l nil (cons ,expr ,l)))
      ((> ,var ,hi) (reverse ,l))
      (declare (fixnum ,var)))))
      
(defmacro makelist (expr (var lo hi &optional (step 1)) &rest more)
  (if (endp more)
      `(makelist-1 ,expr ,var ,lo ,hi ,step)
    (let* ((l (gensym)))
      `(do ((,var ,lo (+ ,var ,step))
            (,l nil (nconc ,l `,(makelist ,expr ,@more))))
        ((> ,var ,hi) ,l)
        (declare (fixnum ,var))))))
      
(defmacro sum (&body body)
  `(reduce #'+ (makelist ,@body)))

(defmacro summation (&body body)
  ``(+ ,@(makelist ,@body)))

(defmacro difference (&body body)
  ``(- ,@(makelist ,@body)))

;; List of all EXPR where VAR varies over the list LST
(defmacro list-of (expr (var lst) &rest more)
  (if (endp more)
      `(list-of-1 ,expr ,var ,lst)
    (let ((l (gensym)))
      `(let ((,l))
        (dolist (,var ,lst ,l)
          (setf  ,l (nconc ,l ,`(list-of ,expr ,@more))))))))

(defmacro list-of-1 (expr var lst)
  (let ((l (gensym)))
    `(let ((,l))
      (dolist (,var ,lst (reverse ,l))
        (setf ,l ,`(cons ,expr ,l))))))

;; Union of all EXPR where VAR varies over the list LST
(defmacro union-of (expr (var lst) &rest more)
  (if (endp more)
      `(union-of-1 ,expr ,var ,lst)
    (let ((l (gensym)))
      `(let ((,l))
        (dolist (,var ,lst ,l)
          (setf  ,l (union ,l ,`(union-of ,expr ,@more) :test #'equalp)))))))

(defmacro union-of-1 (expr var lst)
  (let ((l (gensym)))
    `(let ((,l))
      (dolist (,var ,lst (reverse ,l))
        (setf ,l ,`(union ,expr ,l :test #'equalp))))))


;; Set of all EXPR where VAR varies over the list LST
(defmacro set-of (expr (var lst) &rest more)
  (if (endp more)
      `(set-of-1 ,expr ,var ,lst)
    (let ((l (gensym)))
      `(let ((,l))
        (dolist (,var ,lst ,l)
          (setf  ,l (union ,l ,`(set-of ,expr ,@more) :test #'equalp)))))))

(defmacro set-of-1 (expr var lst)
  (let ((l (gensym)))
    `(let ((,l))
      (dolist (,var ,lst (reverse ,l))
        (pushnew ,expr ,l :test #'equalp)))))

;; sublist of LST consisting of elements with indecies in IND
(defun select (ind lst)
  (cond 
    ((endp ind) nil)
    (t (cons (elt lst (car ind)) (select (cdr ind) lst)))))

(defun standard-vector (n k &optional (coeff 1)
                        &aux (v (make-list n :initial-element 0)))
  "Returns vector (0 0 ... 1 ... 0 0) of length N, where 1 appears on K-th place."
  (setf (elt v k) coeff)
  v)