Practical Common Lisp（二）一个简单的“数据库”

Practical Common Lisp（二）一个简单的“数据库”

lisp的功能还是挺强大的，简单的几十行代码就搞定了一个小的“数据库”（经验：调试macro的时候可以用macroexpand-1展开该macro，看是否与设想的一样）。

感受一下lisp吧：

CL-USER> (load "D:/database.lisp")
T
CL-USER> (add-cds)
Title: hacker
Artist: PG
Rating: 10

Ripped[y/n]:  (y or n) y

Another? [y/n]:  (y or n) n
NIL
CL-USER> (save-db "D:/save.db")
((:TITLE "hacker" :ARTIST "PG" :RATING 10 :RIPPED T))
CL-USER> (add-cds)
Title: painter
Artist: PG
Rating: 10

Ripped[y/n]:  (y or n) y

Another? [y/n]:  (y or n) n
NIL
CL-USER> (dump-db)
TITLE: painter
ARTIST:   PG
RATING:   10
RIPPED:   T

TITLE:    hacker
ARTIST:   PG
RATING:   10
RIPPED:   T

NIL
CL-USER> (select (where :title "hacker"))
((:TITLE "hacker" :ARTIST "PG" :RATING 10 :RIPPED T))
CL-USER> (update (where :title "painter") :title "paint")
((:TITLE "paint" :ARTIST "PG" :RATING 10 :RIPPED T)
          (:TITLE "hacker" :ARTIST "PG" :RATING 10 :RIPPED T))

代码出自practical common lisp 一书，有改动~

(defvar  * db *  nil)

(defun make - cd (title artist rating ripped)
  (list :title title :artist artist :rating rating :ripped ripped))

(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 - for - cd ()
  (make - cd 
   (prompt - read  " Title " )
   (prompt - read  " Artist " )
   (or (parse - integer (prompt - read  " Rating " ) :junk - allowed t)  0 )
   (y - or - n - p  " Ripped[y/n]:  " )))

(defun add - cds ()
  (loop (add - record (prompt - for - cd))
     ( if  (not (y - or - n - p  " Another? [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 (selector - fn)
  (remove - if - not selector - fn  * db * ))

(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 ( & rest clauses)
  `# ' (lambda (cd) (and ,@(make-comparisons-list clauses))))

;(defun where ( & key title artist rating (ripped nil ripped - p))
;  # ' (lambda (cd)
;      (and
;       ( if  title    (equal (getf cd :title) title) t)
;       ( if  artist   (equal (getf cd :artist) artist) t)
;       ( if  rating   (equal (getf cd :rating) rating) t)
;       ( if  ripped - p (equal (getf cd :ripped) ripped) t))))

(defun make - set - expr (field value)
  `(setf (getf row ,field) ,value))

(defun make - set - list (fields)
  (loop  while  fields
       collecting (make - set - expr (pop fields) (pop fields))))

(defmacro update (selector - fn  & rest clauses)
  `(setf  * db *
     (mapcar
     # ' (lambda (row) 
         (when (funcall ,selector - fn row) ,@(make - set - list clauses))
         row)  * db * )))
     

;(defun update (selector - fn  & key title artist rating (ripped nil ripped - p))
;  (setf  * db *
;    (mapcar
;     # ' (lambda (row)
;         (when (funcall selector - fn row)
;           ( if  title    (setf (getf row :title) title))
;           ( if  artist   (setf (getf row :artist) artist))
;           ( if  rating   (setf (getf row :rating) rating))
;           ( if  ripped - p (setf (getf row :ripped) ripped)))
;         row)  * db * )))

(defun delete - rows (selector - fn)
  (setf  * db *  (remove - if  selector - fn  * db * )))