cl

CommonLisp testbed
git clone git://git.janpasierb.com/cl.git
Log | Files | Refs

mp3.lisp (1899B)


      1 (defvar *db* nil)
      2 
      3 (defun make-cd (title artist rating ripped)
      4   (list :title title :artist artist :rating rating :ripped ripped))
      5 
      6 (defun add-record (cd) 
      7   (push cd *db*))
      8 
      9 (defun dump-db ()
     10   (dolist (cd *db*)
     11      (format t "~{~a:~10t~a~%~}~%" cd)))
     12 
     13 (defun prompt-read (prompt)
     14   (format *query-io* "~a: " prompt)
     15   (force-output *query-io*)
     16   (read-line *query-io*))
     17 
     18 (defun prompt-for-cd ()
     19   (make-cd
     20     (prompt-read "Title")
     21     (prompt-read "Artist")
     22     (or (parse-integer (prompt-read "Rating") :junk-allowed t) 0)
     23     (y-or-n-p "Ripped [y/n]: ")))
     24 
     25 (defun add-cds ()
     26   (loop (add-record (prompt-for-cd))
     27         (if (not (y-or-n-p "Another? [y/n]: ")) (return))))
     28 
     29 (defun save-db (filename)
     30   (with-open-file (out filename
     31                        :direction :output
     32                        :if-exists :supersede)
     33     (with-standard-io-syntax
     34       (print *db* out))))
     35 
     36 (defun load-db (filename)
     37   (with-open-file (in filename)
     38     (with-standard-io-syntax
     39       (setf *db* (read in)))))
     40 
     41 (defun select (selector-fn)
     42   (remove-if-not selector-fn *db*))
     43 
     44 (defun update (selector-fn &key title artist rating (ripped nil ripped-p))
     45   (setf *db*
     46         (mapcar
     47           #'(lambda (row)
     48              (when (funcall selector-fn row)
     49               (if title     (setf (getf row :title) title)) 
     50               (if artist    (setf (getf row :artist) artist)) 
     51               (if rating    (setf (getf row :rating) rating)) 
     52               (if ripped-p  (setf (getf row :ripped) ripped))) 
     53               row) *db*)))
     54 
     55 (defun delete-rows (selector-fn)
     56   (setf *db* (remove-if selector-fn *db*)))
     57 
     58 (defun make-comparison-expr (field value)
     59   `(equal (getf cd ,field) ,value))
     60 
     61 (defun make-comparisons-list (fields)
     62   (loop while fields
     63         collecting (make-comparison-expr (pop fields) (pop fields))))
     64 
     65 (defmacro where (&rest clauses)
     66   `#'(lambda (cd) (and ,@(make-comparisons-list clauses))))
     67