Mercurial > lbo > hg > lispplay
view test.lisp @ 3:83743e601985 default tip
Add new lisp files
author | Lewin Bormann <lbo@spheniscida.de> |
---|---|
date | Sun, 13 Oct 2019 14:00:24 +0200 |
parents | 81137f478b5c |
children |
line wrap: on
line source
(defun make-cd (title artist rating ripped) (list :title title :artist artist :rating rating :ripped ripped)) (defvar *db* nil) (defun add-record (cd) (push cd *db*)) (defun dump-db () (dolist (cd *db*) (format t "~{~a:~10t~a~%~}~%" cd))) (defun prompt-read (prompt) (format *query-io* "~a: " prompt) (force-output *query-io*) (read-line *query-io*)) (defun prompt-cd () (make-cd (prompt-read "title") (prompt-read "artist") (or (parse-integer (prompt-read "rating x/5")) 0) (y-or-n-p "ripped y/n"))) (defun add-cds () (loop (add-record (prompt-cd)) (if (not (y-or-n-p "one more? y/n ")) (return)))) (defun save-db (filename) (with-open-file (out filename :direction :output :if-exists :supersede) (with-standard-io-syntax (print *db* out)))) (defun load-db (filename) (with-open-file (in filename) (with-standard-io-syntax (setf *db* (read in))))) (defun select-eq (key val) (remove-if-not (lambda (record) (equal (getf record key) val)) *db*)) (defun select (pred) (remove-if-not pred *db*)) (defun where (&key title artist rating (ripped nil ripped-p)) (lambda (record) (and (if title (equal title (getf record :title)) 't) (if artist (equal artist (getf record :artist)) 't) (if ripped-p (equal ripped (getf record :ripped)) 't) (if rating (equal rating (getf record :rating)) 't)))) (defun where-2 (key val) (lambda (record) (if (equal val (getf record key)) 't nil))) (defun update (pred &key title artist rating (ripped nil ripped-p)) (setf *db* (mapcar (lambda (record) (when (funcall pred record) (if title (setf (getf record :title) title)) (if artist (setf (getf record :artist) artist)) (if rating (setf (getf record :rating) rating)) (if ripped-p (setf (getf record :ripped) ripped))) record) *db*))) (defun delete-cds (pred) (setf *db* (remove-if pred *db*))) ;; Fancy selection with macros (defun make-comparison-expr (field value) `(equal (getf cd ,field) ,value)) (defun make-comparisons-list (fields) (loop while fields collecting (make-comparison-expr (pop fields) (pop fields)))) (defmacro where-m (&rest clauses) `#'(lambda (cd) (and ,@(make-comparisons-list clauses))))