(defun ab-d-product(x y)
(let (q)
(setf q (mapcar #'* x y))
(apply #'+ q)
))
(defun ab-x-product(procedure x y)
(let ((q '()))
(dolist (entry y q)
(setf q (append q
(mapcar #'(lambda(z) (funcall
procedure z entry)) x)))
)))
(defun temp-product(procedure x y)
(let ((q nil))
(dolist (entry y q)
(setf q
(append q (mapcar #'(lambda
(z) (funcall procedure entry z)) x)))
)))
(defun ab-k-product (x)
(setf x (reverse x))
(let ((temp1 (car x))
(temp2 (cadr x)))
(do ()
((not (car temp2)) (car
x))
(cond
((equal temp1 nil))
((equal temp2 nil) temp1)
((atom (car temp1))
(setf x (append (list (temp-product
#'list temp1 temp2)) (cddr x))))
((listp (car temp1))
(setf x (append (list (temp-product
#'cons temp1 temp2)) (cddr x))))
(t (print 'error)))
(setf temp1 (car x))
(setf temp2 (cadr x)))))
;;Pooja Khati CSCE876 HW 3 (challenge) Due Feb 20 2002
;;Problem 1
;; This function takes two vectors of equal lengths given as
;;lists of numbers and generates the dot product.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun listmult (list1 list2)
(if (not (=(length list1)(length list2)))
(setf a '(NOT EQUAL LENGTH))
(cond((endp list1)list1)
((not (endp list1))(cons
(* (first list1)(first list2))
(listmult (rest list1)(rest list2)))))))
;;the above function multiplies and keeps the product into one list
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun listadd (list)
(let ((result 0))
(dolist (element list result)
(setf result (+ result element)))result))
;;the above function add those products together
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun pk-d-product( list1 list2)
(if (not (=(length list1)(length list2)))
(setf a '(NOT EQUAL LENGTH))
(listadd( listmult list1 list2))))
;;this function is the main fucntion that calls the other two.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Pooja Khati
;; CSE876 HW 3 (challenge)
;; Due Feb 20 2002
;; Problem 2
;; this function takes a function name and two lists and
;;returns the cross product.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun pk-x-product (procedure m n)
(mapcar procedure (make-first-list m n)(reverse(make-second-list
m n))))
;
;;the above function is the main function and it calls the other two.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun make-first-list (m n)
(let ((first_list NIL))
(dotimes (count (length n) first_list)
(setf first_list (append m first_list)))))
;;the above function makes one long list for the first list
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun make-second-list (m n)
(let ((second_list NIL))
(dolist (element n second_list)
(dotimes (count (length m) second_list)
(setf second_list (cons element second_list))))))
;;the above function makes one long list of the second list
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
;(defun pk-x-product (procedure m n)
; (mapcar procedure (make-first-list m n)(reverse(make-second-list
m n))))
;
;;the above function is the main function and it calls the other two.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Pooja Khati
;; CSE876 HW 3 (challenge)
;; Due Feb 20 2002
;; Problem 3
;; This is a function that takes a list of any number of lists and
;; returns the cartesian product.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun find-length (main-list)
(let ((result 1))
(dolist (element main-list result)
(setf result (* (length element) result)))result
))
;;the above function finds out the number of lists that need to be returned.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun new-lists(len main-list)
(let ((result-list NIL))
(unless (endp main-list)
(cons
(reverse
(dotimes (count (/ len (find-length main-list)) result-list)
(dolist (element (first main-list) result-list)
(dotimes (count (find-length (rest main-list))
result-list)
(setf result-list(cons element
result-list))))))
(new-lists len (rest main-list))))))
;;The above function makes new-lists from each of the input lists.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun pk-k-product (main-list)
(let ((len (find-length main-list)))
(divide-list (length main-list)(k5-product len
(new-lists len main-list)))))
;; this is the main function that takes in the lists,
;;and gives out the carttesian product.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun k5-product (len list)
(let ((result5 NIL)(mainresult NIL))
(setf mainresult
(dotimes (count len result5)
(list
(dolist (element list result5)
(setf result5
(cons (nth count element) result5)))
mainresult)))
(reverse mainresult)))
;;THe above function finds out the cartesian product but puts
;;them all in one list.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun divide-list( len2 list1)
(unless (endp list1)
(let ((result6 NIL))
(cons
(reverse
(dotimes (count len2 result6)
(setf result6 (cons (nth count list1) result6))))
(divide-list len2 (nthcdr len2
list1))))))
;;One big list of carttesian products is divided into smaller lists.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package :cl-user)
;;; NOTE: These both re-use structure rather than making copies of tuples.
;;; Therefore the result looks strange when printed (using circular
notation),
;;; but destructuring the resulting list should provide what you expect.
;;; Take a list l1 of atoms '(a b) and a list l2 of tuples '((d e) (f
g))
;;; and returns list of tuples '((b f g) (b d e) (a f g) (a d e)).
;;; You'll see why we don't reverse the result to maintain order when
you
;;; see how this is called in em-k-product.
(defun subproduct (l1 l2)
(declare (optimize (speed 3) (space 0) (safety 0)))
(let ((result (list)))
(dolist (itemi l1)
(dolist (tuplei l2)
(push (cons itemi tuplei) result)))
result))
;;; Take a list of lists '((a b) (c d) (e f) ...) and return the
;;; cartesian product in the expected order:
;;; '((a c e) (a c f) (a d e) (a d f) (b c e) (b c f) (b d e) (b d
f))
;;;
;;; Notice that we first decide if there are an even or odd number
of sublists.
;;; Since we push results onto a list, if there are an odd number of
sublists,
;;; we end up reversing an even number of times (if there's only one
sublist,
;;; we don't reverse anything). If there are an even number of
sublists, our
;;; pushing onto the result ends up reversing an odd number of times.
At each
;;; sublist we encounter, our reversing via pushing requires that we
push new
;;; conses in reverse order from the previous cons, so that upon the
very next
;;; set of pushes, the reversal brings the subresult back into a consistent
;;; order
;;; Reasoning about such an approach is tricky, but this way, we effectively
;;; reverse the contents of only half of the sublists, and we require
at most
;;; one entire list reversal at the conclusion.
;;; Note that we *may* be able to nreverse in places we currently reverse,
but
;;; I didn't take the time to check.
(defun em-k-product (lists)
(declare (optimize (speed 3) (space 0) (safety 0)))
(let ((c (length lists))
(i 0))
(labels ((combine (head tail)
(cond
((endp tail)
(incf i)
(mapcar #'list head))
((evenp (- c i))
(incf i)
(subproduct head (combine (car tail) (cdr tail))))
((oddp (- c i))
(incf i)
(subproduct (reverse head) (combine (car tail) (cdr tail)))))))
(if (evenp c)
(nreverse (combine (car lists) (cdr lists)))
(combine (car lists) (cdr lists))))))
;;; evaluate the following form to verify that the resulting lists are
correct.
;;(dolist (i (em-k-product '((a b c) (c d e) (e f) (g h) (i j))))
;;(format t "~A~%" i))
;;Ken Bayer
(defun kb-d-product (Vector1 Vector2)
(cond
((or (null vector1) (null vector2)) 0)
(T (+ (* (car Vector1) (car Vector2))
(kb-d-product (cdr Vector1) (cdr Vector2))))))
(defun kb-x-product (operation vector1 vector2)
(cond
((or (null vector1) (null vector2)) ())
(T (let ((result nil))
(dolist (firstelement (reverse vector2))
(dolist (secondelement (reverse vector1))
(setf result
(cons (funcall operation secondelement
firstelement) result))))
result))))
;;;This function operates in two parts; the first part is the helper
;;;function khelp, which does the meat of the work. It recursively
;;;defines the k-product as what you get if you prepend each element
in
;;;the first vector with each element in the k-product of the remaining
;;;vectors. The second part, where khelp is called, is done because
the
;;;process I use to compute the k-product puts things in the incorrect
;;;order (because the most efficient way of modifying a list is by
adding
;;;and removing from the beginning.) This reverses all the lists,
so
;;;that the ordering will be correct in the final product (this reversing
;;;is done first, because it is more efficient to perform this operation
;;;on shorter lists.)
(defun kb-k-product (Vectors)
(declare (optimize (safety 0) (speed 3)))
(labels ((khelp (vec)
(if (null vec)
'(())
(let ((restproduct (khelp
(rest vec)))
(sublist nil))
(dolist (firstelement (first vec))
(dolist (restelement restproduct)
(setf sublist
(cons (cons firstelement
restelement) sublist))))
sublist))))
(khelp (let ((result nil)
(index 1))
(dolist (item vectors)
(progn
(if (oddp index)
(setf result (cons (nreverse item)
result))
(setf result (cons item result)))
(setf index (1+ index))))
(nreverse result)))))
(defun d-product (list1 list2)
(do ((l (length list1) (1- l))
(l1 list1 (rest l1))
(l2 list2 (rest l2))
(result 0 (+ result (* (first
l1) (first l2)))))
((equal l 0) result)))
;;;ALTERNATE IMPLEMENTATIONS:
(defun d-product2 (l1 l2)
(cond ((endp l1) 0)
(T (+ (* (first l1) (first l2)) (d-product2 (rest l1) (rest l2))))))
(defun d-product3 (list1 list2)
(do ((l (length list1) (1- l))
(list (mapcar #'* list1 list2)
(rest list))
(result 0 (+ result (first list))))
((equal l 0) result)))
(defun x-product (fn list1 list2)
(do* ((sz (length list1))
(l sz (1- l))
(l2 list2 (rest l2))
(tmp (make-list sz :initial-element (first l2))
(make-list sz :initial-element (first
l2)))
(result (mapcar fn list1 tmp)
(append result (mapcar fn list1 tmp))))
((equal l 1) result)))
;;;ALTERNATE (slower) IMPLEMENTATIONS:
(defun x-product1 (fn list1 list2)
(let ((sz (length list1)))
(do* ((l sz (1- l))
(l2 list2 (rest l2))
(tmp (make-list sz :initial-element (first l2))
(make-list sz :initial-element
(first l2)))
(result (mapcar fn list1 tmp)
(append result (mapcar fn list1 tmp))))
((equal l 1) result))))
(defun x-product2 (fn list1 list2)
(let ((sz (length list1)))
(do* ((l sz (1- l))
(l2 list2 (rest l2))
(tmp (make-list sz :initial-element (first l2))
(make-list sz :initial-element
(first l2)))
(result NIL))
((equal l 0) result)
(setf result (append result (mapcar
fn list1 tmp))))))
(defun x-product3 (fn list1 list2)
(let ((sz (length list1))
(tmp NIL)
(result NIL))
(do* ((l sz (1- l))
(l2 list2 (rest l2)))
((equal l 0) result)
(setf tmp (make-list sz :initial-element
(first l2)))
(setf result (append result (mapcar
fn list1 tmp))))))
(defun x-product4 (fn list1 list2)
(let ((result NIL)
(len (length list1)))
(do ((l2 0 (1+ l2)))
((equal l2 len) (reverse result))
(do ((l1 0 (1+ l1)))
((equal l1 len) NIL)
(setf result (cons (funcall fn (first (nthcdr l1 list1)) (first
(nthcdr l2 list2))) result))))))
(defun x-product5 (fn list1 list2)
(let ((result NIL))
(do ((l2 0 (1+ l2)))
((equal l2 (length list2)) (reverse result))
(do ((l1 0 (1+ l1)))
((equal l1 (length list1)) NIL)
(setf result (cons (funcall fn (first (nthcdr l1 list1)) (first
(nthcdr l2 list2))) result))))))
(defun k-product (list)
(let*
((l (length list))
(totalsteps 1)
(capacity (make-array l))
(places (make-array l :initial-element
0))
(y 0))
(dolist (x list NIL)
(setf totalsteps (* totalsteps (length
x)))
(setf (aref capacity y) (length x))
(setf y (+ 1 y)))
(do ((steps 1 (+ 1 steps))
(result (list
(let ((res2 NIL))
(dotimes (x (length list) (reverse res2))
(setf res2
(cons (first (nthcdr (aref places x)
(first (nthcdr
x list))))
res2)))))
(cons
(let ((res2 NIL))
(dotimes (x (length list) (reverse res2))
(setf res2
(cons (first (nthcdr (aref places x)
(first (nthcdr
x list))))
res2))))
result)))
((equal steps totalsteps) (reverse result))
(do* ((x (- l 1) (- x 1))
(carry T))
((or (equal x -1) (equal carry NIL)) NIL)
(setf (aref places x) (+ 1 (aref places x)))
(if (equal (aref places x) (aref capacity x))
(setf (aref places x) 0)
(setf carry NIL))))))
;;; ALTERNATE IMPLEMENTATION:
;;; the implementation below uses subfunctions as components, and is
;;; equivalent to above, but is more easily followed at the price of
;;; being slower.
(defun update (places capacity)
(do* ((l (length places))
(x (- l 1) (- x 1))
(carry T))
((or (equal x -1) (equal carry
NIL)) NIL)
(setf (aref places x) (+ 1 (aref places x)))
(if (equal (aref places x) (aref capacity x))
(setf (aref places
x) 0)
(setf carry NIL))))
(defun kth-term (places list)
(let ((res2 NIL))
(dotimes (x (length list) (reverse res2))
(setf res2 (cons (first (nthcdr (aref
places x) (first (nthcdr x list)))) res2)))))
(defun k-product2 (list)
(let* ((l (length list))
(totalsteps 1)
(capacity (make-array l))
(places (make-array l :initial-element 0))
(y 0))
(dolist (x list NIL)
(setf totalsteps (* totalsteps (length
x)))
(setf (aref capacity y) (length x))
(setf y (+ 1 y)))
(do ((steps 1 (+ 1 steps))
(result (list (kth-term places list))
(cons (kth-term places list) result)))
((equal steps totalsteps) (reverse result))
(update places capacity))))
(defun ag-d-product (l1 l2)
(if (equal l1 nil) 0
(+ (* (first l1) (first l2)) (ag-d-product
(rest l1) (rest l2)))))
(defun ag-x-product (op l1 l2)
(if (equal l2 nil) nil
(append (mapcar #'(lambda (x) (funcall op x (first
l2))) l1)
(ag-x-product op l1 (rest l2)))))
(defun ag-y-product (op l1 l2)
(if (equal l1 nil) nil
(append (mapcar #'(lambda (y) (funcall op (first
l1) y)) l2)
(ag-y-product op (rest l1) l2))))
(defun ag-K-product (l1)
(if (equal l1 nil) '(())
(ag-y-product #'cons (first l1) (ag-K-product (rest
l1)))))
Last modified: