Rosetta Code

Simple database: Difference between revisions

Page Discussion

Simple database (view source)

Revision as of 14:42, 24 November 2011

657 bytes added ,  12 years ago
→‎{{header|Common Lisp}}: add function to list all episodes, implement some suggestions from the friendly people in #lisp
(→‎{{header|Common Lisp}}: handle non-numeric month values)
(→‎{{header|Common Lisp}}: add function to list all episodes, implement some suggestions from the friendly people in #lisp)
Line 36:
 
This code is also available under the GNU GPLv3.
<lang lisp>(defvar *db* nil)
 
(defun get-value (key alist)
(cdr (assoc key alist)))
 
(defun make-episode (&key series title season episode date tags)
`((series . ,series) (season . ,season) (episode . ,episode) (title . ,title) (date . ,date) (tags . ,tags)))
 
(defun print-episode (episode)
(format t " ~30a ~@[~a-~]~a~40T~a~@[ ~70T(~{~a~^.~})~]~@[ (~{~a~^ ~})~]~%"
(cdr (assocget-value 'series episode))
(cdr (assocget-value 'season episode))
(cdr (assocget-value 'episode episode))
(cdr (assocget-value 'title episode))
(cdr (assocget-value 'date episode))
(cdr (assocget-value 'tags episode))))
 
(defun print-episodes (episodes series)
Line 58 ⟶ 61:
(cond ((endp database) nil)
(T (cons (cadr (assoc 'episodes (cdar database))) (get-latest (cdr database))))))
 
(defun get-all (database)
(cond ((endp database) nil)
(T (append (get-value 'episodes (cdar database)) (get-all (cdr database))))))
 
(defun cal->int (cal)
(cond ((integerp cal) cal)
(T (get-value cal '(('jan . 1) ('feb . 2) ('mar . 3) ('apr . 4)
('may . 5) ('jun . 6) ('jul . 7) ('aug . 8)
('sep . 9) ('oct . 10) ('nov . 11) ('dec . 12))))))
 
Line 69 ⟶ 76:
((null a) (not (null b)))
((null b) nil)
((= (cal->int (first a)) (cal->int (first b)))
(compare-date (rest a) (rest b)))
(t (< (cal->int (first a)) (cal->int (first b))))))
 
(defun compare-by-date (a b)
(compare-date (reverse (cdr (assocget-value 'date a))) (reverse (cdr (assocget-value 'date b)))))
 
(defun prompt-read (prompt &optional default)
Line 80 ⟶ 87:
(force-output *query-io*)
(let ((answer (read-line *query-io*)))
(if (string= answer "") default 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 format-ymd ()
(multiple-value-bind (second minute hour date month year day-of-week dst-p tz)
Line 92 ⟶ 102:
(declare (ignore second minute hour day-of-week dst-p tz))
(format nil "~a.~a.~a" date month year)))
 
 
(defun parse-date (date)
Line 101 ⟶ 112:
 
(defun parse-number (number)
(if (stringp number) (parse-integer number :junk-allowed t) number))
(parse-integer number :junk-allowed t)
number))
 
(defun prompt-for-episode (&optional last)
(make-episode
:series (prompt-read "Series Title" (cdr (assocget-value 'series last)))
:title (prompt-read "Title")
:season (parse-number (prompt-read "Season" (cdr (assocget-value 'season last))))
:episode (parse-number (prompt-read "Episode" (1+ (cdror (assocget-value 'episode last) 0))))
:date (parse-date (prompt-read "Date watched" (format-ymd)))
:tags (parse-tags (prompt-read "Tags"))))
 
(defun save-db (filename database)
Line 123 ⟶ 136:
 
(defun watch-save ()
(save-db "lwatch" *db*))
 
(defun load-db (filename)
Line 131 ⟶ 144:
 
(defun get-series (name database)
(cdr (assocget-value name database :test #'equal)))
 
(defun get-episode-list (series database)
(cdr (assocget-value 'episodes (get-series series database))))
 
(defun print-series (series)
(format t "~30a ~10a@[ (~{~a~^ ~})~]~%" (cdr (assocget-value 'series series)) (cdr (assocget-value 'statustags series)))
(mapcar #'print-episode (cdr (assocget-value 'episodes series))))
 
(defun watch-series (title)
(let ((series (get-series title *db*)))
(format t "~30a ~10a@[ (~{~a~^ ~})~]~%" (cdr (assocget-value 'series series)) (cdr (assocget-value 'statustags series)))
(mapcar #'print-episode (reverse (cdr (assocget-value 'episodes series))))))
 
(defun dump-db (database)
Line 150 ⟶ 163:
 
(defun watch-latest ()
(mapcar #'print-episode (sort (get-latest *db*) #'compare-by-date)))
 
(defun watch-all ()
(mapcar #'print-episode (sort (get-all *db*) #'compare-by-date)))
 
(defun watch-new-series (&key name statusdescription tags)
(cdar (push `(,name (seriesdescription . ,namedescription) (statustags . ,statustags) (episodes)) *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 'active) nil)))
: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*)))
;(episodesloop until (cdrget-or-add-series (assocprompt-read 'episodes"Series") series*db*) return it))
(episodes (get-value 'episodes series))
(episode (prompt-for-episode (car episodes))))
(rplacd (assoc 'episodes series)
(cons episode episodes))))
 
(defun watch-series-names ()
(format T "~{~a~%~}"
(sort (mapcar #'car *db*)
#'(lambda (series1 series2)
(compare-by-date (cadr (assoc 'episodes (cdr (assocget-value series1 *db)*)))
(cadr (assoc 'episodes (cdr (assocget-value series2 *db)*))))))))
 
(defun watch-load (dbfile)
(setf *db* (load-db "lwatch"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)
(watch-load (make-pathname :name "lwatch" :type nil :defaults *load-truename*))
(watch-load)
(cond ((equal (cadr argv) "add") (watch-add) (watch-save))
((equal (cadr argv) "latest") (watch-latest))
((null (cadr argv)) (watch-latest))
((equal (cadr argv) "series") (watch-series-names))
((equal (cadr argv) "all") (watch-all))
(T (watch-series (cadr argv)))))
 
Anonymous user
Retrieved from "https://rosettacode.org/wiki/Special:MobileDiff/205079"