quickref.lisp

(defpackage quickref
  (:use :cl :split-sequence)
  (:import-from :alexandria
   :starts-with-subseq)
  (:export :print-primary-systems
	   :get-primary-system-name
	   :print-columns
	   :get-directory-list
	   :build-index))

(in-package :quickref)

(defun remove-cl-prefix (name)
  (if (starts-with-subseq "cl-" name)
      (subseq name 3)
      name))

(defun get-release-name (system)
  (ql-dist:name (ql-dist:release system)))

(defun get-provided-systems (release)
  (let* ((all-provided-systems (ql-dist:provided-systems t))
	 (first-system-found (find release all-provided-systems
				   :key #'get-release-name
				   :test #'string=)))
    (unless first-system-found
      (error "Release not found"))
    (ql-dist:provided-systems (ql-dist:release first-system-found))))

(defun get-trimmed-system-name (system)
  (remove-cl-prefix (ql-dist:name system)))

(defun get-primary-system-name (release)
  (let ((project (remove-cl-prefix release))
	(provided-systems (get-provided-systems release)))
    (ql-dist:name
     (or (find project provided-systems
	       :key #'get-trimmed-system-name
	       :test #'string=
	       :from-end t)
	 (car (last provided-systems))))))

(defun print-primary-systems ()
  (dolist (release (ql-dist:provided-releases t))
    (print (get-primary-system-name (ql-dist:name release)))))

(defun get-columns-length (size)
  (if (equal size 1) (values 1 0 0)
      (multiple-value-bind (split remainder) (floor size 3)
	(case remainder
	  (0 (values split split split))
	  (1 (values (+ split 1) (+ split 1) (- split 1)))
	  (2 (values (+ split 1) (+ split 1) split))))))

(defun print-columns (l size file)
  (multiple-value-bind (lfirst lsecond lthird)
      (get-columns-length size)
    (do ((n 0 (+ n 1))
	 (f l (cdr f))
	 (s (nthcdr lfirst l) (cdr s))
	 (th (nthcdr (+ lfirst lsecond) l) (cdr th)))
	((= n lfirst) nil)
      (if (>= n lsecond)
	  (format file
		  "<tr><td></td><td>~a</td></tr>~%"
		  (car f))
          (if (>= n lthird)
	      (format file
		      "<tr><td></td><td>~a</td><td></td><td>~a</td></tr>~%"
		      (car f) (car s))
	      (format file
		      "<tr><td></td><td>~a</td><td></td><td>~a</td><td></td><td>~a</td></tr>~%"
		      (car f) (car s) (car th)))))))

(defun get-directory-list (path)
  (loop for dir in (directory path)
    collect (car (last (pathname-directory dir)))))

(defun get-first-letter (sequence)
  (subseq sequence 0 1))

(defun is-number (string)
  (let ((chara (char string 0)))
    (and (>= (char-code chara) (char-code #\0))
	 (<= (char-code chara) (char-code #\9)))))

(defun letter-has-changed (previous new)
  (if (and (is-number previous)
	   (is-number new))
      t
      (string= previous new)))

(defun build-index (path file-path)
  (with-open-file (file file-path
			:direction :output
			:if-exists :supersede
			:if-does-not-exist :create)
    (let* ((dir-list (get-directory-list path))
	   (first-letter (get-first-letter (first dir-list)))
	   (length 0)
	   (pos dir-list))
      (loop until (endp pos)
	 do (if (letter-has-changed first-letter (get-first-letter (car pos)))
		(progn (setq length (+ length 1))
		       (setq pos (cdr pos)))
		(progn
		  (print-columns dir-list length file)
		  (setq length 0)
		  (setq dir-list pos)
		  (setq first-letter (get-first-letter (car pos))))))
      (print-columns dir-list length file))))