397 lines
15 KiB
Common Lisp
397 lines
15 KiB
Common Lisp
(defvar *db* nil)
|
|
|
|
(defstruct series description tags episodes)
|
|
|
|
(defstruct (episode (:print-function print-episode-struct))
|
|
series title season episode part date tags)
|
|
|
|
(defun format-ymd (date)
|
|
(format nil "~{~a.~a.~a~}" date))
|
|
|
|
(defun print-episode-struct (ep stream level)
|
|
(let ((*print-pretty* nil))
|
|
(format stream (if *print-escape*
|
|
"#s(episode~@{~*~@[ :~1:*~a ~s~]~})"
|
|
"~32<~*~a~; ~*~@[~d-~]~*~d~> ~45<~*~@[~a ~]~*~@[(~a) ~]~;~*~@[(~a)~]~>~*~@[ (~{~a~^ ~})~]")
|
|
:series (episode-series ep)
|
|
:season (episode-season ep)
|
|
:episode (episode-episode ep)
|
|
:title (episode-title ep)
|
|
:part (episode-part ep)
|
|
:date (if *print-escape*
|
|
(episode-date ep)
|
|
(when (episode-date ep)
|
|
(format-ymd (episode-date ep))))
|
|
:tags (episode-tags ep))))
|
|
|
|
(defun get-value (key alist)
|
|
(cdr (assoc key alist)))
|
|
|
|
|
|
(defun get-latest (database)
|
|
(when database
|
|
(cons (car (series-episodes (cdar database))) (get-latest (cdr database)))))
|
|
|
|
(defun get-all (database)
|
|
(when database
|
|
(append (series-episodes (cdar database)) (get-all (cdr database)))))
|
|
|
|
(defun compare-date (a b)
|
|
(cond ((not a) t)
|
|
((not b) nil)
|
|
((= (first a) (first b))
|
|
(compare-date (rest a) (rest b)))
|
|
(t (< (first a) (first b)))))
|
|
|
|
(defun compare-by-date (a b)
|
|
(compare-date (episode-date a) (episode-date b)))
|
|
|
|
(defun prompt-read (prompt &optional default)
|
|
(format *query-io* "~a~@[ (~a)~]: " prompt default)
|
|
(force-output *query-io*)
|
|
(let ((answer (read-line *query-io*)))
|
|
(if (string= answer "")
|
|
default
|
|
answer)))
|
|
|
|
(defun split (seperator string)
|
|
(loop for i = 0 then (1+ j)
|
|
as j = (search seperator string :start2 i)
|
|
collect (subseq string i j)
|
|
while j))
|
|
|
|
(defun get-current-date ()
|
|
(multiple-value-bind
|
|
(second minute hour date month year day-of-week dst-p tz)
|
|
(get-decoded-time)
|
|
(declare (ignore second minute hour day-of-week dst-p tz))
|
|
(list date month year)))
|
|
|
|
|
|
(defun parse-date (date)
|
|
(reverse (mapcar #'parse-integer (split "." date))))
|
|
|
|
(defun parse-tags (tags)
|
|
(when (and tags (string-not-equal "" tags))
|
|
(mapcar #'intern (split " " (string-upcase tags)))))
|
|
|
|
(defun parse-number (number)
|
|
(if (stringp number)
|
|
(parse-integer number :junk-allowed t)
|
|
number))
|
|
|
|
(defun prompt-for-episode (&optional last)
|
|
(when (not last)
|
|
(setf last (make-episode)))
|
|
(let* ((series (prompt-read "Series Title" (episode-series last)))
|
|
(title (prompt-read "Title"))
|
|
(season (parse-number (prompt-read "Season" (episode-season last))))
|
|
(episode (parse-number (prompt-read "Episode"
|
|
(if (eq (episode-season last) season)
|
|
(1+ (episode-episode last))
|
|
1))))
|
|
(part (parse-number (prompt-read "Part"
|
|
(when (and (episode-part last)
|
|
(or (eq (episode-season last) season)
|
|
(eq (episode-part last) 1)))
|
|
(1+ (episode-part last))))))
|
|
(date (parse-date (prompt-read "Date watched" (format-ymd (get-current-date)))))
|
|
(tags (parse-tags (prompt-read "Tags"))))
|
|
(make-episode
|
|
:series series
|
|
:title title
|
|
:season season
|
|
:episode episode
|
|
:part part
|
|
:date date
|
|
:tags tags)))
|
|
|
|
(defun parse-integer-quietly (&rest args)
|
|
(ignore-errors (apply #'parse-integer args)))
|
|
|
|
(defun get-next-version (basename)
|
|
(flet ((parse-version (pathname)
|
|
(or (parse-integer-quietly
|
|
(string-left-trim (file-namestring basename)
|
|
(file-namestring pathname))
|
|
:start 1) 0)))
|
|
(let* ((files (directory (format nil "~A,*" (namestring basename))))
|
|
(max (if files
|
|
(reduce #'max files :key #'parse-version)
|
|
0)))
|
|
(merge-pathnames (format nil "~a,~d" (file-namestring basename) (1+ max))
|
|
basename))))
|
|
|
|
(defun save-db (dbfile database)
|
|
(let ((file (probe-file dbfile)))
|
|
(rename-file file (get-next-version file))
|
|
(with-open-file (out file :direction :output)
|
|
(with-standard-io-syntax
|
|
(let ((*print-case* :downcase))
|
|
(pprint database out))))))
|
|
|
|
(defun watch-save (dbfile)
|
|
(save-db dbfile *db*))
|
|
|
|
(defun load-db (dbfile)
|
|
(with-open-file (in dbfile)
|
|
(with-standard-io-syntax
|
|
(read in))))
|
|
|
|
(defun get-series (name database)
|
|
(cdr (assoc name database :test #'string-equal)))
|
|
|
|
(defun get-episode-list (series database)
|
|
(series-episodes (get-series series database)))
|
|
|
|
(defun print-series (title series)
|
|
(format t "~&~30a ~@[ (~{~a~^ ~})~]~%~@[ ~a~%~]" title (series-tags series)
|
|
(series-description series))
|
|
(format t "~{~& ~a~%~}" (reverse (series-episodes series))))
|
|
|
|
(defun watch-series (title)
|
|
(let ((series (get-series title *db*)))
|
|
(when series
|
|
(print-series title series))))
|
|
|
|
(defun print-all-series (database)
|
|
(loop for (title . series)
|
|
in (sort database #'(lambda (a b)(compare-by-date (car (series-episodes (cdr a)))
|
|
(car (series-episodes (cdr b))))))
|
|
do (terpri) (print-series title series)))
|
|
|
|
(defun watch-all-series ()
|
|
(print-all-series *db*))
|
|
|
|
(defun watch-latest ()
|
|
(format t "~{~& ~a~%~}" (sort (get-latest *db*) #'compare-by-date)))
|
|
|
|
(defun timeline-all (database)
|
|
(let* ((all (get-all database))
|
|
(max (length all))
|
|
(count max)
|
|
(all-series-names nil)
|
|
(all-series (make-hash-table :test 'equal)))
|
|
(loop for episode in (reverse (sort all #'compare-by-date))
|
|
do (unless (gethash (episode-series episode) all-series)
|
|
(setf (gethash (episode-series episode) all-series)
|
|
(make-array max :initial-element nil))
|
|
(setf all-series-names
|
|
(cons (episode-series episode) all-series-names)))
|
|
(setf (elt (gethash (episode-series episode) all-series) (decf count))
|
|
episode))
|
|
(values all-series all-series-names max)))
|
|
|
|
(defun watch-timeline ()
|
|
(multiple-value-bind (all-series all-series-names max) (timeline-all *db*)
|
|
(loop for series in all-series-names
|
|
do (format t "~30a (~{~:[ ~;•~]~})~%" series
|
|
(coerce (subseq (gethash series all-series) (- max 60)) 'list)))))
|
|
|
|
(defun watch-timelinec ()
|
|
(multiple-value-bind (all-series all-series-names max) (timeline-all *db*)
|
|
(let ((chart (make-array (list (length all-series-names) max) :initial-element nil))
|
|
(newcol 0)
|
|
(oldrow -1))
|
|
(loop for oldcol upto (1- max)
|
|
do (loop for series in all-series-names
|
|
for row from 0 upto (length all-series-names)
|
|
do (when (elt (gethash series all-series) oldcol)
|
|
(when (<= row oldrow)
|
|
(incf newcol))
|
|
(setf (aref chart row newcol)
|
|
(elt (gethash series all-series) oldcol))
|
|
(setf oldrow row))))
|
|
(loop for series in all-series-names
|
|
for i from 0 upto (length all-series-names)
|
|
do (format t "~30a (" series)
|
|
(loop for j from (- newcol 60) upto newcol
|
|
do (format t "~:[ ~;•~]" (aref chart i j))
|
|
(if (= j newcol)
|
|
(format t ")~%")))))))
|
|
|
|
(defun watch-timelinev ()
|
|
(multiple-value-bind (all-series all-series-names max) (timeline-all *db*)
|
|
(loop for series in all-series-names
|
|
counting series into count
|
|
do (format t "~va ~30a~%" count " " series ))
|
|
(loop for i from 0 upto (1- max)
|
|
do (let ((episode nil))
|
|
(loop for series in all-series-names
|
|
do (format t "~:[ ~;~:*~02a~]"
|
|
(when (elt (gethash series all-series) i)
|
|
(setf episode (elt (gethash series all-series) i))
|
|
(episode-episode episode))))
|
|
(format t " (~a)~%" (episode-series episode))))))
|
|
|
|
(defun watch-all ()
|
|
(format t "~{~& ~a~%~}" (sort (get-all *db*) #'compare-by-date)))
|
|
|
|
(defun watch-new-series (&key name description tags)
|
|
(cdar (push (cons name (make-series :description description :tags tags)) *db*)))
|
|
|
|
(defun get-or-add-series (name database)
|
|
(or (get-series name database)
|
|
(if (y-or-n-p "Add new series? [y/n]: ")
|
|
(watch-new-series
|
|
:name name
|
|
:description (prompt-read "Description" name)
|
|
:tags (parse-tags (prompt-read "Tags" "active")))
|
|
nil)))
|
|
|
|
(defun watch-add ()
|
|
(let* ((series (loop thereis (get-or-add-series (prompt-read "Series") *db*)))
|
|
(episode (prompt-for-episode (car (series-episodes series)))))
|
|
(push episode (series-episodes series))))
|
|
|
|
(defun watch-series-names ()
|
|
(format T "~{~& ~a~%~}"
|
|
(sort (mapcar #'car *db*)
|
|
(lambda (series1 series2)
|
|
(compare-by-date (car (series-episodes (get-value series1 *db*)))
|
|
(car (series-episodes (get-value series2 *db*))))))))
|
|
|
|
(defun exact-match (term text)
|
|
(string-equal (format nil "~{~a~^ ~}" term) text))
|
|
|
|
(defun fuzzy-match (term text)
|
|
(loop for word in term
|
|
when (search word text :test 'string-equal)
|
|
collect it))
|
|
|
|
(defun match-tags (term tags)
|
|
(intersection (mapcar #'intern term) tags))
|
|
|
|
(defun search-title (term database)
|
|
(loop for episode in (get-all database)
|
|
when (exact-match term (episode-title episode))
|
|
collect episode))
|
|
|
|
(defun search-tags (term database)
|
|
(sort (loop for episode in (get-all database)
|
|
for matches = (match-tags term (episode-tags episode))
|
|
when matches collect (list (length matches) episode))
|
|
#'> :key #'car))
|
|
|
|
(defun search-title-fuzzy (term database)
|
|
(sort (loop for episode in (get-all database)
|
|
for matches = (fuzzy-match term (episode-title episode))
|
|
when matches collect (list (length matches) episode))
|
|
#'> :key #'car))
|
|
|
|
(defun search-all (term database)
|
|
(let ((exact-results '())
|
|
(fuzzy-results '())
|
|
(tag-results '()))
|
|
(dolist (episode (get-all database))
|
|
(cond ((exact-match term (episode-title episode))
|
|
(push episode exact-results))
|
|
((fuzzy-match term (episode-title episode))
|
|
(push episode fuzzy-results))
|
|
((match-tags term (episode-tags episode))
|
|
(push episode tag-results))))
|
|
(append (sort exact-results #'compare-by-date)
|
|
(sort tag-results #'compare-by-date)
|
|
(sort fuzzy-results #'compare-by-date))))
|
|
|
|
(defun watch-search (term)
|
|
(format t "~{~& ~a~%~}" (search-all term *db*)))
|
|
|
|
(defun list-all-tags (database)
|
|
(let ((tags (make-hash-table :test 'equal)))
|
|
(dolist (tag (apply #'append (mapcar #'episode-tags (get-all database))))
|
|
(setf (gethash tag tags) (1+ (or (gethash tag tags) 0))))
|
|
tags))
|
|
|
|
(defun watch-tags ()
|
|
(maphash #'(lambda (tag count) (format t "~a (~d) " tag count))
|
|
(list-all-tags *db*))
|
|
(terpri))
|
|
|
|
(defun find-series-episode (term database)
|
|
(let ((series (get-series (format nil "~{~a~^ ~}" (butlast term)) database)))
|
|
(if series
|
|
(let* ((season-episode (car (last term)))
|
|
(pos (position #\- season-episode))
|
|
(season-str (when pos (subseq season-episode 0 pos)))
|
|
(season (or (parse-integer-quietly season-str) season-str))
|
|
(episode-str (if pos
|
|
(subseq season-episode (1+ pos))
|
|
season-episode))
|
|
(episode-nr (or (parse-integer-quietly episode-str) episode-str)))
|
|
(loop for episode in (series-episodes series)
|
|
when (and (equal (episode-episode episode) episode-nr)
|
|
(equal (episode-season episode) season))
|
|
collect episode))
|
|
(let ((series (get-series (format nil "~{~a~^ ~}" term) database)))
|
|
(if series
|
|
(list (car (series-episodes series))))))))
|
|
|
|
|
|
(defun find-episode (term database)
|
|
(or (find-series-episode term database)
|
|
(search-title term database)
|
|
(let* ((res (or (search-tags term database)
|
|
(search-title-fuzzy term database)))
|
|
(max (caar res)))
|
|
(loop for (matches episode) in res when (equal matches max) collect episode))))
|
|
|
|
(defun edit-episode (episode database)
|
|
(format t "editing:~%~a~%" episode)
|
|
(setf (episode-series episode)
|
|
(prompt-read "Series Title" (episode-series episode)))
|
|
(setf (episode-title episode)
|
|
(prompt-read "Title" (episode-title episode)))
|
|
(setf (episode-season episode)
|
|
(parse-number (prompt-read "Season" (episode-season episode))))
|
|
(setf (episode-episode episode)
|
|
(parse-number (prompt-read "Episode" (episode-episode episode))))
|
|
(setf (episode-part episode)
|
|
(parse-number (prompt-read "Part" (episode-part episode))))
|
|
(setf (episode-date episode)
|
|
(parse-date (prompt-read "Date watched" (format-ymd (episode-date episode)))))
|
|
(setf (episode-tags episode)
|
|
(parse-tags (prompt-read "Tags" (format nil "~{~a~^ ~}" (episode-tags episode))))))
|
|
|
|
(defun watch-edit (term)
|
|
(let ((episodes (find-episode term *db*)))
|
|
(if (> (length episodes) 1)
|
|
(format t "found more than one episode, please be more specific:~%~{~& ~a~%~}" episodes)
|
|
(edit-episode (car episodes) *db*))))
|
|
|
|
(defun watch-load (dbfile)
|
|
(setf *db* (load-db dbfile)))
|
|
|
|
|
|
(defun argv ()
|
|
(or
|
|
#+clisp (ext:argv)
|
|
#+sbcl sb-ext:*posix-argv*
|
|
#+clozure (ccl::command-line-arguments)
|
|
#+gcl si:*command-args*
|
|
#+ecl (loop for i from 0 below (si:argc) collect (si:argv i))
|
|
#+cmu extensions:*command-line-strings*
|
|
#+allegro (sys:command-line-arguments)
|
|
#+lispworks sys:*line-arguments-list*
|
|
nil))
|
|
|
|
(defun main (argv)
|
|
(let ((dbfile (make-pathname :name "lwatch" :type nil :defaults *load-pathname*)))
|
|
(watch-load dbfile)
|
|
(format t "loaded db~%")
|
|
(cond ((equal (cadr argv) "add") (watch-add) (watch-save dbfile))
|
|
((equal (cadr argv) "latest") (watch-latest))
|
|
((null (cadr argv)) (watch-latest))
|
|
((equal (cadr argv) "series") (watch-series-names))
|
|
((and (equal (cadr argv) "all") (equal (caddr argv) "series")) (watch-all-series))
|
|
((equal (cadr argv) "all") (watch-all))
|
|
((equal (cadr argv) "tags") (watch-tags))
|
|
((equal (cadr argv) "search") (watch-search (cddr argv)))
|
|
((equal (cadr argv) "edit") (watch-edit (cddr argv)) (watch-save dbfile))
|
|
((equal (cadr argv) "timeline") (watch-timeline))
|
|
((equal (cadr argv) "timelinev") (watch-timelinev))
|
|
((equal (cadr argv) "timelinec") (watch-timelinec))
|
|
(T (watch-series (format nil "~{~a~^ ~}" (cdr argv)))))))
|
|
|
|
(main (argv))
|