view test.lisp @ 0:81137f478b5c

initial examples and some of my own functions/macros
author Lewin Bormann <lbo@spheniscida.de>
date Fri, 04 Oct 2019 11:49:00 +0200
parents
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))))