#!/usr/bin/newlisp

; Strip away the arch tail if any of a package
(define (noarch P) (if (find ":" P) (0 $it P) P))

; Determine the list of "all installed"
(setf INSTALLED (map noarch (exec "apt-mark showinstall")))
(write-line 2 (format "There are %d installed packages" (length INSTALLED)))

; Returns list of parsed result lines
(define (dpkg-exec FMT) (map (fn (S) (parse S " ")) (exec FMT)))

; Set up hash table of provided packages by currently installed. This
; is needed for following up dependencies, which for an option
; dependency only automatically resolves the first of options.
(write 2 "Initializing 'provided-by' ")
(setf PROVFMT "dpkg-query -W -f '${Package} ${Provides}\\n' %s")
(define PROV:PROV nil)
(dolist (P INSTALLED) (if (PROV P) (push P (PROV P)) (PROV P (list P))))
(dolist (PL (explode INSTALLED 10000))
  (write 2 ".")
  (dolist (PPV (dpkg-exec (format PROVFMT (join PL " "))))
    (let ((P (PPV 0)))
      (dolist (PV (1 PPV))
        (when PV (if (PROV PV) (push P (PROV PV)) (PROV PV (list P))))))))
(dolist (P (PROV)) (PROV (P 0) (sort (unique (P 1)))))
(write-line 2 " done")

; set up a hashtable of recommenders
(write 2 "Initializing 'recommended-by' ")
(setf RECFMT "dpkg-query -W -f '${Package} ${Recommends}' %s")
(define REC:REC nil)
(dolist (PL (explode INSTALLED 10000))
  (write 2 ".")
  (dolist (RR  (dpkg-exec (format RECFMT (join PL " "))))
    (let ((P (RR 0)))
      (dolist (R (1 RR))
        (if (REC R) (push P (REC R)) (REC R (list P)))))))
(dolist (P (REC)) (REC (P 0) (sort (unique (P 1)))))
(write-line 2 " done")

; ========================================
; Set up hashtable for dependencies without those not installed or
; shadowed by non-default choice

; Returns the "depends choice" of an automatically dependent package
; as supported by currently installed packages. Only the first of
; providers is an automatic dependency. Thus, it returns either a) the
; depedent package itself if it's the first of its providers, or b)
; that first of providers if the dependent package is not among the
; providers (a fully virtual package), or c) nil if the depedent
; package is a provider but not the first.
(define (depends-choice P)
  (let ((Y (if (PROV P) (first $it) nil)))
    (if (null? Y) nil (member P (PROV P)) (and (= P Y) P) Y)))

; Strip away all version specs from a dependency line
(define (noversions X) (replace " \\([^)]*\\)" (copy X) "" 0))

; Resolves a depedency list with respect to installed package
; provisions, where in particular an option depedency only
; automatically pulls in its first option. This may return nil, which
; is for a choice dependency with installed non-default provisioning.
(define (depends-choices X)
  (depends-choice (trim (first (parse (noversions X) "|")))))

; Returns the fixed up a dependency line as list of packages.
(define (depends-fix X)
  (clean null? (map depends-choices (clean empty? (map trim (parse X ","))))))

(write 2 "Initializing actual 'depends' ")
(setf DEPFMT "dpkg-query -W -f '${Package} ${Pre-Depends} ${Depends}\\n' %s")
(define DEP:DEP nil)
(dolist (PL (explode INSTALLED 10000))
  (write 2 ".")
  (dolist (RR (exec (format DEPFMT (join PL " "))))
    (when (regex "([^ ]+) (.*)" RR)
      (let ((P $1) (RL (flat (depends-fix $2))))
        (DEP P RL)))))
(write-line 2 " done")

; Return the dependencies for installed package of empty list otherwise
(define (depends P) (or (DEP P) '()))

; Determine the list of "manually installed"
(setf MANUAL (map noarch (exec "apt-mark showmanual")))

; Expands a list of packages to include the closure of its dependencies
(define (closure L)
  (let ((P (sort L)))
    (write-line 2 (format "checking %d manual packages" (length P)))
    (while (!= P (setf L (sort (union P (apply union (map depends P))))))
      (setf P L)
      (write-line 2 (format " %d with dependencies" (length P)))
      )
    P))

## main: report the set difference between "all installed" and the
## dependency closure of "manually installed"

(let ((Y (difference INSTALLED (closure MANUAL))))
  (write-line 2 (format "=> %d automatic recommended packages" (length Y)))
  (map (fn (P) (println P " by " (join (or (REC P) '("???")) " "))) Y))

(exit 0)