Simple database: Difference between revisions
Content added Content deleted
No edit summary |
|||
Line 666: | Line 666: | ||
=={{header|Common Lisp}}== |
=={{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: |
|||
$ clisp db.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) |
|||
(title " ") |
|||
(category "default") |
|||
((= (first a) (first b)) |
|||
(date (progn (get-universal-time)))) |
|||
(t (< (first a) (first b))))) |
|||
(defun |
(defun set-category(new-item) |
||
(setf (gethash (item-category new-item) *db-cat*) 't)) |
|||
(compare-date (episode-date a) (episode-date b))) |
|||
(defun |
(defun find-item-in-db (&optional category) |
||
(if (null category) |
|||
(format *query-io* "~a~@[ (~a)~]: " prompt default) |
|||
( |
(car *db*) |
||
(find category *db* :key #'item-category :test #'string=))) |
|||
(let ((answer (read-line *query-io*))) |
|||
(if (string= answer "") |
|||
default |
|||
answer))) |
|||
(defun |
(defun scan-category () |
||
"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 |
(defun pr-univ-time (utime) |
||
(multiple-value-bind |
(multiple-value-bind |
||
(second minute hour date month year day-of-week dst-p tz) |
|||
(decode-universal-time utime) |
|||
(declare (ignore 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 |
(defun pr-per-category () |
||
"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 |
(defun pr-all () |
||
"print all the items, *db* is sorted by time." |
|||
(when (and tags (string-not-equal "" tags)) |
|||
(dolist (itm *db*) (pr itm))) |
|||
(defun |
(defun pr-all-categories (&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 |
(defun read-db-from-file (&optional (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))) |
|||
(scan-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 |
(defun save-db-to-file (&optional (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 |
(defun del-db () |
||
(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 |
(defun del-item (itm) |
||
( |
(read-db-from-file) |
||
(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 |
(defun add-item-to-db (args) |
||
( |
(read-db-from-file) |
||
(insert-item (make-item :title (first args) :category (second args))) |
|||
(save-db-to-file)) |
|||
(defun |
(defun help-menu () |
||
(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 |
(defun db-cmd-run (args) |
||
( |
(cond ((and (> (length args) 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 |
(or |
||
#+clisp ext:*args* |
|||
#+sbcl (cdr sb-ext:*posix-argv*) |
|||
#+allegro (cdr (sys:command-line-arguments)) |
|||
#+lispworks (cdr sys:*line-arguments-list*) |
|||
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))))))) |
|||
( |
(db-cmd-run (db-argv))</lang> |
||
=={{header|D}}== |
=={{header|D}}== |