# Pastebin 22xjMetv
(defun shorten (pathname n)
  (let* ((directory (pathname-directory pathname))
         (key (first directory))
         (truncated (let ((rest (rest directory)))
                      (if (< n (length rest)) (subseq (rest directory) 0 n) rest))))
    (make-pathname :defaults pathname
                   :directory (append (list key) truncated))))