|
=={{header|Common Lisp}}==
{{incorrect|Lisp|"add" operation fails to create database if it doesn't exist.}}
A tool to track the episodes you have watched in a series.
Tested with [[SBCL]] but should work with other implementations.
Tested with [[CLISP]]
Run from the commandline as:
sbcl$ --scriptclisp watchdb.lisp
clisp db.lisp delete <item-name> ------------------- delete an item
delete-all --------------------------- delete the database
insert <item-name> <item-category> --- insert an item with its category
show --------------------------------- shows the latest inserted item
show-categories ---------------------- show all categories
show-all ----------------------------- show all items
show-per-category -------------------- show the latest item per category
Here are a few steps to add a few titles, and their categories.
Without arguments the function <code>(watch-list)</code> is invoked to show the last episode of each series.
$ clisp db.lisp insert "title-vinyl-1" "vinyl"
With the argument <code>add</code> the function <code>(watch-add)</code> will allow you to add a new episode with series name, episode title, episode number and date watched. If the series does not yet exist, you will be asked if you want to create it.
$ clisp db.lisp insert "title-cd-1" "cd"
$ clisp db.lisp insert "title-dvd-1" "dvd"
$ clisp db.lisp insert "title-tape-1" "tape"
$ clisp db.lisp insert "title-tape-2" "tape"
Here is the very latest entry in the db
This code is also available under the GNU GPLv3.
$ clisp db.lisp show
<lang lisp>(defvar *db* nil)
title-tape-2: (tape) (2017-04-04 20:19:06)
Here is a (sorted time wise) list of all the entries
(defstruct series description tags episodes)
$ clisp db.lisp show-all
title-tape-2: (tape) (2017-04-04 20:19:06)
title-tape-1: (tape) (2017-04-04 20:19:00)
title-dvd-1: (dvd) (2017-04-04 20:18:55)
title-cd-1: (cd) (2017-04-04 20:18:48)
title-vinyl-1: (vinyl) (2017-04-04 20:18:41)
Here is the latest entry for each category
(defstruct (episode (:print-function print-episode-struct))
$ clisp db.lisp show-per-category
series title season episode part date tags)
title-vinyl-1: (vinyl) (2017-04-04 20:18:41)
title-cd-1: (cd) (2017-04-04 20:18:48)
title-dvd-1: (dvd) (2017-04-04 20:18:55)
title-tape-2: (tape) (2017-04-04 20:19:06)
Here is the list of all categories
(defun format-ymd (date)
$ clisp db.lisp show-categories
(format nil "~{~a.~a.~a~}" date))
(vinyl) (cd) (dvd) (tape)
To delete an entry
(defun print-episode-struct (ep stream level)
$ clisp db.lisp delete "title-tape-2"
(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))))
To delete all entries
(defun get-value (key alist)
$ clisp db.lisp delete-all
(cdr (assoc key alist)))
This code is also available under the MIT License.
<lang lisp>(defvar *db* nil)
(defvar *db-cat* (make-hash-table :test 'equal))
(defun get-latest (database)
(when database
(cons (car (series-episodes (cdar database))) (get-latest (cdr database)))))
(defvar *db-file* "db.txt")
(defun get-all (database)
(when database
(append (series-episodes (cdar database)) (get-all (cdr database)))))
(defstruct item
(defun compare-date (a b)
"this is the unit of data stored/displayed in *db*"
(cond ((not a) t)
((nottitle b)" nil")
(category "default")
((= (first a) (first b))
(compare-date (restprogn a(get-universal-time) (rest b)))
(t (< (first a) (first b)))))
(defun compareset-by-date category(a bnew-item)
(setf (gethash (item-category new-item) *db-cat*) 't))
(compare-date (episode-date a) (episode-date b)))
(defun promptfind-readitem-in-db (prompt &optional defaultcategory)
(if (null category)
(format *query-io* "~a~@[ (~a)~]: " prompt default)
(force-outputcar *query-iodb*)
(find category *db* :key #'item-category :test #'string=)))
(let ((answer (read-line *query-io*)))
(if (string= answer "")
default
answer)))
(defun splitscan-category (seperator string)
"scan categories from an existing database -- after reading it from disk"
(loop for i = 0 then (1+ j)
(dolist (itm *db*) (set-category itm)))
as j = (search seperator string :start2 i)
collect (subseq string i j)
while j))
(defun getpr-currentuniv-datetime (utime)
(multiple-value-bind
(second minute hour date month year day-of-week dst-p tz)
(getdecode-decodeduniversal-time utime)
(declare (ignore second minute hour day-of-week dst-p tz))
(format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d" year month date hour minute second)))
(list date month year)))
(defun pr (&optional (item (find-item-in-db)) (stream t))
"print an item"
(when item
(format stream "~a: (~a) (~a)~%"
(item-title item)
(item-category item)
(pr-univ-time (item-date item)))))
(defun parsepr-dateper-category (date)
"print the latest item from each category"
(reverse (mapcar #'parse-integer (split "." date))))
(loop for k being the hash-keys in *db-cat*
do (pr (find-item-in-db k))))
(defun parsepr-tagsall (tags)
"print all the items, *db* is sorted by time."
(when (and tags (string-not-equal "" tags))
(mapcar #'interndolist (splititm "*db*) " (string-upcasepr tags))itm)))
(defun parsepr-numberall-categories (number&optional (stream t))
(loop for k being the hash-keys in *db-cat*
(if (stringp number)
do (format stream "(~a) " k)))
(parse-integer number :junk-allowed t)
number))
(defun insert-item (item)
"insert item into database in a time sorted list. okay for a small list, as per spec."
(let ((first-item (car *db*)) (new-itm item))
(set-category new-itm)
(push new-itm *db*)
(when (and first-item (>= (item-date new-itm) (item-date first-item)))
(setf *db* (sort *db* #'> :key #'item-date)))
*db*))
(defun promptread-fordb-episodefrom-file (&optional last(file *db-file*))
(with-open-file (in file :if-does-not-exist nil)
(when (not last)
(when in
(setf last (make-episode)))
(with-standard-io-syntax (setf *db* (read in)))
(let* ((series (prompt-read "Series Title" (episode-series last)))
(title (promptscan-read "Title"category))))
(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 parsesave-integerdb-quietlyto-file (&restoptional args(file *db-file*))
(with-open-file (out file :direction :output :if-exists :supersede)
(ignore-errors (apply #'parse-integer args)))
(with-standard-io-syntax
(print *db* out))))
(defun getdel-next-versiondb (basename)
(setf *db* nil)
(flet ((parse-version (pathname)
(save-db-to-file))
(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 savedel-dbitem (dbfile databaseitm)
(let ((file (proberead-db-from-file dbfile)))
(setf *db* (remove itm *db* :key #'item-title :test #'string=))
(rename-file file (get-next-version file))
(save-db-to-file))
(with-open-file (out file :direction :output)
(with-standard-io-syntax
(let ((*print-case* :downcase))
(pprint database out))))))
(defun watchadd-saveitem-to-db (dbfileargs)
(saveread-db dbfile *db*)-from-file)
(insert-item (make-item :title (first args) :category (second args)))
(save-db-to-file))
(defun loadhelp-dbmenu (dbfile)
(format t "clisp db.lisp ~{~15T~a~^~% ~}"
(with-open-file (in dbfile)
'("delete <item-name> ------------------- delete an item"
(with-standard-io-syntax
"delete-all --------------------------- delete the database"
(read in))))
"insert <item-name> <item-category> --- insert an item with its category"
"show --------------------------------- shows the latest inserted item"
"show-categories ---------------------- show all categories"
"show-all ----------------------------- show all items"
"show-per-category -------------------- show the latest item per category")))
(defun getdb-seriescmd-run (name databaseargs)
(cdrcond (assoc(and name(> database(length :testargs) #'string-1) (equal (first args) "delete"))
(del-item (second args)))
((equal (first args) "delete-all") (del-db))
((and (> (length args) 2) (equal (first args) "insert"))
(add-item-to-db (rest args)))
((equal (first args) "show") (read-db-from-file) (pr))
((equal (first args) "show-categories") (read-db-from-file) (pr-all-categories))
((equal (first args) "show-all") (read-db-from-file) (pr-all))
((equal (first args) "show-per-category") (read-db-from-file) (pr-per-category))
(t (help-menu))))
;; modified https://rosettacode.org/wiki/Command-line_arguments#Common_Lisp
(defun get-episode-list (series database)
(defun db-argv ()
(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)*args*
#+sbcl (cdr sb-ext:*posix-argv*)
#+clozureallegro (ccl:cdr (sys:command-line-arguments))
#+gcllispworks si(cdr sys:*commandline-arguments-argslist*)
nil))
#+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)))))))
(maindb-cmd-run (db-argv))</lang>
=={{header|D}}==
|