(setf *load-print* T)

(defun firstk (x k) 
  (if (< (length x) k)
      NIL
    (loop for i from 0 to (- k 1) collect (nth i x))
    )
  )

(defun permute (x)
  (let (r s v)
    (if (not (cdr x))      ; then: base case; return ((i))
        (list x)

      ;; else: loop through top level
      (dotimes (i (length x) v)  ; v = accum, NIL initially
            (setf r (nth i x))       ; r = next top-level elem
            (setf s (remove r x :count 1))    ; s = what's left

        ;; inner loop over elements of (permute s)
        (setf v (append v
                   (mapcar #'(lambda (z) (cons r z)) (permute s))
                 )
        )
      )
    )
  )
)

(defun subsets (lis len) 
  (let (plis r)
       (setf plis (permute lis))
       (loop for i in plis do (push (firstk i len) r))
       (remove-duplicates r :test #'equal)
       )
)

(subsets '(1 2 3 4) 1)
(subsets '(1 2 3 4) 2)
(subsets '(1 2 3 4) 3)
(subsets '(1 2 3 4) 4)
(subsets '(1 2 3 4) 5)


; Loading #p"/h/tas/fischman/h04-solved".
; FIRSTK
; PERMUTE
; SUBSETS
; ((4) (3) (2) (1))
; ((4 3) (4 2) (4 1) (3 4) (3 2) (3 1) (2 4) (2 3) (2 1) (1 4) (1 3) (1 2))
; ((4 3 2) (4 3 1) (4 2 3) (4 2 1) (4 1 3) (4 1 2) (3 4 2) (3 4 1) (3 2 4)
;  (3 2 1) (3 1 4) (3 1 2) (2 4 3) (2 4 1) (2 3 4) (2 3 1) (2 1 4) (2 1 3)
;  (1 4 3) (1 4 2) (1 3 4) (1 3 2) (1 2 4) (1 2 3))
; ((4 3 2 1) (4 3 1 2) (4 2 3 1) (4 2 1 3) (4 1 3 2) (4 1 2 3) (3 4 2 1)
;  (3 4 1 2) (3 2 4 1) (3 2 1 4) (3 1 4 2) (3 1 2 4) (2 4 3 1) (2 4 1 3)
;  (2 3 4 1) (2 3 1 4) (2 1 4 3) (2 1 3 4) (1 4 3 2) (1 4 2 3) (1 3 4 2)
;  (1 3 2 4) (1 2 4 3) (1 2 3 4))
; (NIL)