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
You can’t perform that action at this time.