dual.lisp

; Original Version from Atabey Kaygun, Conjugate Partitions
; http://kaygun.tumblr.com/post/145269023094/conjugate-partitions

; Derived versions: Rainer Joswig, [email protected], 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)))