Conjugate Partitions

dual.lisp

; http://kaygun.tumblr.com/post/145269023094/conjugate-partitions

; version 1

(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

(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

(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

(defun dual-aux-1 (xs k n r)
  (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 repeat (n i l)
  (if (zerop n)
      l
    (repeat (1- n) i (cons i l))))

(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)))