Skip to content

Instantly share code, notes, and snippets.

@lispm

lispm/dual.lisp

Last active Jun 2, 2016
Embed
What would you like to do?
; Original Version from Atabey Kaygun, Conjugate Partitions
; http://kaygun.tumblr.com/post/145269023094/conjugate-partitions
; Derived versions: Rainer Joswig, joswig@lisp.de, 2016
; version 1 using LOOP
(defun dual (xs &aux k n r)
(loop while xs do
(setf k (reduce #'min xs)
n (length xs)
xs (sort (loop for x in xs
for x1 = (- x k)
unless (zerop x1)
collect x1)
#'<))
(loop repeat k do (push n r)))
r)
; version 2, using LOOP with integrated minimum/length computation
(defun dual (xs &aux k k1 (n (length xs)) (n1 n) r)
(loop while xs do
(setf k (or k (reduce #'min xs))
k1 k
xs (sort (loop for x in xs
for x1 = (- x k)
when (zerop x1)
do (decf n1)
else collect x1 and do (when (< x1 k1) (setf k1 x1)))
#'<))
(loop repeat k do (push n r))
(setf n n1 k k1))
r)
; version 3, without sorting, minimum is the first element
(defun dual (xs &aux (n (length xs)) (n1 n) r)
(setf xs (sort xs #'<))
(loop for k = (first xs)
while xs do
(setf xs (loop for x in xs
for x1 = (- x k)
when (zerop x1)
do (decf n1)
else collect x1))
(loop repeat k do (push n r))
(setf n n1))
r)
; version 4, recursive, needs TCO, similar to version 3
; without TCO -> stack overflow for long lists...
(defun repeat (n i l)
"Creates a list of N times the value of I.
L is the accumulator for the return value."
(if (zerop n)
l
(repeat (1- n) i (cons i l))))
(defun dual-aux-1 (xs k n r)
"The list XS of positive integers has N elements.
Subtract K from each element and remove any resulting values of zero.
Returns the resulting list R and its length as two values."
(if (null xs)
(values (reverse r) n)
(let ((i (- (first xs) k)))
(dual-aux-1 (rest xs)
k
(if (zerop i) (1- n) n)
(if (zerop i) r (cons i r))))))
(defun dual-aux (xs n min r)
(if (null xs)
r
(multiple-value-bind (l len)
(dual-aux-1 xs min n nil)
(dual-aux l len (first l) (repeat (first xs) n r)))))
(defun dual (xs)
(when xs
(setf xs (sort xs #'<))
(dual-aux xs (length xs) (first xs) nil)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment