Added Common Lisp Bits & Pieces.

Common-Lisp-Bits-And-Pieces/Chapter-02/hello-world.lisp

@@ -0,0 +1,4 @@
+(defun hello-world ()
+  (format t "Hello, world!"))
+
+(hello-world)

Common-Lisp-Bits-And-Pieces/Chapter-03/cds.db

@@ -0,0 +1,2 @@
+
+((:TITLE "Jailbreak" :ARTIST "Thin Lizzy" :RATING 10 :RIPPED T) (:TITLE "Lateralus" :ARTIST "TOOL" :RATING 10 :RIPPED T) (:TITLE "Poopenfarten" :ARTIST "Zweibrüder" :RATING 11 :RIPPED T) (:TITLE "Ride The Lightning" :ARTIST "Metallica" :RATING 9 :RIPPED T) (:TITLE "The Sound Of Rancid Juices Sloshing Around Your Coffin" :ARTIST "Last Days Of Humanity" :RATING 5 :RIPPED T)) 

Common-Lisp-Bits-And-Pieces/Chapter-03/cds.lisp

@@ -0,0 +1,94 @@
+;;;; Simple CD Database program:
+(defvar *cd-database* nil "The current state of the CD database.")
+
+(defun make-cd (title artist rating ripped)
+  "Creates a CD record."
+  (list :title title :artist artist :rating rating :ripped ripped))
+
+(defun add-cd (cd)
+  "Adds a CD record to the database."
+  (push cd *cd-database*) (setf *cd-database* (sort *cd-database* #'cd-sort-by-title)))
+
+(defun print-cd-database (&optional database)
+  "Prints the current CD database, or, optionally, a passed in database."
+  (if database
+      (dolist (cd database)
+	(format t "~{~a: ~10t~a~%~}~%" cd))
+      (dolist (cd *cd-database*)
+	(format t "~{~a: ~10t~a~%~}~%" cd))))
+  
+(defun prompt-read (prompt)
+  "Prompts for a single line of user input."
+  (format *query-io* "~a: " prompt)
+  (force-output *query-io*)
+  (read-line *query-io*))
+
+(defun prompt-for-cd ()
+  "Creates a CD record using user input."
+  (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 ()
+  "Adds one or more CDs to the database with user input."
+  (loop (add-cd (prompt-for-cd))
+	(if (not (y-or-n-p "Another? [y/n]: ")) (return))))
+
+(defun cd-sort-by-title (a b)
+  "Sorts two CD records alphabetically."
+  (string< (getf a :title) (getf b :title)))
+
+(defun save-cds (filename)
+  "Saves the CD database to a file."
+  (with-open-file 
+      (file-output filename
+	   :direction :output
+	   :if-exists :supersede)
+    (with-standard-io-syntax
+      (print *cd-database* file-output))))
+
+(defun read-cds (filename)
+  "Loads a CD database from a file."
+  (with-open-file
+      (file-input filename)
+    (with-standard-io-syntax
+      (print-cd-database (setf *cd-database* (read file-input))))))
+
+(defun delete-cds (selector-function)
+  "Deletes CD records according to a selector function."
+  (print-cd-database (setq *cd-database* (remove-if selector-function *cd-database*))))
+
+(defun select (selector-function)
+  "Select records from a database based on a selector function."
+  (print-cd-database (remove-if-not selector-function *cd-database*)))
+
+(defun update (selector-function &key title artist rating (ripped nil ripped-p))
+  "Update selected records in a database."
+  (setf *cd-database*
+        (mapcar
+         #'(lambda (row)
+             (when (funcall selector-function 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) *cd-database*)))
+
+(defun make-comparison-expression (field value)
+  "Create a comparison function for a field and a value in a plist."
+  `(equal (getf cd ,field) ,value))
+
+(defun make-comparisons-list (fields)
+  "Create a list of plist comparison functions."
+  (loop while fields
+     collecting (make-comparison-expression (pop fields) (pop fields))))
+
+(defmacro where (&rest clauses)
+  "Create an expression where all plist comparisons must be true."
+  `#'(lambda (row) (and ,@(make-comparisons-list clauses))))
+
+;; Load up the CD database on startup:
+(read-cds "~/.cds.db")
+(print-cd-database)

Common-Lisp-Bits-And-Pieces/Chapter-09/testing-framework.lisp

@@ -0,0 +1,38 @@
+(defpackage :BARRA-TESTING-FRAMEWORK
+  (:use :common-lisp))
+
+(in-package "BARRA-TESTING-FRAMEWORK")
+
+(defvar *test-name* nil)
+
+(defmacro with-gensyms ((&rest names) &body body)
+`(let ,(loop for n in names collect `(,n (gensym)))
+   ,@body))
+
+(defmacro deftest (name parameters &body body)
+  "Define a test function. Within a test function we can call
+   other test functions or use 'check' to run individual test
+   cases."
+  `(defun ,name ,parameters
+    (let ((*test-name* (append *test-name* (list ',name))))
+      ,@body)))
+
+(defmacro check (&body forms)
+  "Run each expression in 'forms' as a test case."
+  `(combine-results
+    ,@(loop for f in forms collect `(report-result ,f ',f))))
+
+(defmacro combine-results (&body forms)
+  "Combine the results (as booleans) of evaluating 'forms' in order."
+  (with-gensyms (result)
+    `(let ((,result t))
+      ,@(loop for f in forms collect `(unless ,f (setf ,result nil)))
+      ,result)))
+
+(defun report-result (result form)
+  "Report the results of a single test case. Called by 'check'."
+  (format t "~:[FAIL~;PASS~] - ~a: ~a~%" result *test-name* form)
+  result)
+
+(let ((pack (find-package :foo)))
+  (do-all-symbols (sym pack) (when (eql (symbol-package sym) pack) (export sym))))

Common-Lisp-Bits-And-Pieces/Chapter-15/barra-filename-library.lisp

@@ -0,0 +1,99 @@
+(defpackage BARRA-FILENAME-PACKAGE
+  (:use common-lisp)
+  (:export 
+   :component-present-p
+   :directory-pathname-p
+   :pathname-as-directory
+   :pathname-as-file
+   :directory-wildcard
+   :file-exists-p
+   :list-directory
+   :walk-directory))
+
+(in-package BARRA-FILENAME-PACKAGE)
+
+(defun component-present-p (value)
+  (and value (not (eql value :unspecified))))
+
+(defun directory-pathname-p (pathname)
+  (and
+   (not (component-present-p (pathname-name pathname)))
+   (not (component-present-p (pathname-type pathname)))))
+
+(defun pathname-as-directory (path)
+  (let ((pathname (pathname path)))
+    (if
+     (directory-pathname-p pathname)
+     pathname
+     (make-pathname
+      :host (pathname-host pathname)
+      :device (pathname-device pathname)
+      :directory (append (or (pathname-directory pathname) (file-namestring pathname)) 
+			 (list (file-namestring pathname)))
+      :name nil
+      :type nil
+      :defaults pathname))))
+
+(defun directory-wildcard (dirname)
+  (make-pathname
+   :name :wild
+   :type #-clisp :wild #+clisp nil
+   :defaults (pathname-as-directory dirname)))
+
+(defun list-directory (dirname)
+  (when (wild-pathname-p dirname)
+    (error "Can only list concrete directory names."))
+  (directory (directory-wildcard dirname)))
+
+(defun file-exists-p (pathname)
+  #+(or sbcl lispworks openmcl)
+  (probe-file pathname)
+
+  #+(or allegro cmu)
+  (or (probe-file (pathname-as-directory pathname))
+      (probe-file pathname))
+
+  #+clisp
+  (or (ignore-errors
+       (probe-file (pathname-as-file pathname)))
+      (ignore-errors
+       (let ((directory-form (pathname-as-directory pathname)))
+         (when (ext:probe-directory directory-form)
+           directory-form))))
+
+  #-(or sbcl cmu lispworks openmcl allegro clisp)
+  (error "list-directory not implemented"))
+
+#+clisp
+(defun clisp-subdirectories-wildcard (wildcard)
+  (make-pathname
+   :directory (append (pathname-directory wildcard) (list :wild))
+   :name nil
+   :type nil
+   :defaults wildcard))
+
+(defun pathname-as-file (name)
+  (let ((pathname (pathname name)))
+    (when (wild-pathname-p pathname)
+      (error "Can't reliably convert wild pathnames."))
+    (if (directory-pathname-p name)
+	(let* ((directory (pathname-directory pathname))
+               (name-and-type (pathname (first (last directory)))))
+          (make-pathname
+           :directory (butlast directory)
+           :name (pathname-name name-and-type)
+           :type (pathname-type name-and-type)
+           :defaults pathname))
+	pathname)))
+
+(defun walk-directory (dirname fn &key directories (test (constantly t)))
+  (labels
+      ((walk (name)
+         (cond
+           ((directory-pathname-p name)
+            (when (and directories (funcall test name))
+              (funcall fn name))
+            (dolist (x (list-directory name)) (walk x)))
+           ((funcall test name) (funcall fn name)))))
+    (walk (pathname-as-directory dirname))))
+

Common-Lisp-Bits-And-Pieces/GTK-Test.lisp

@@ -0,0 +1,34 @@
+(ql:quickload :cl-cffi-gtk)
+
+; Main window
+(defvar window (make-instance 'gtk:gtk-window :type :toplevel :title "GTK Test"))
+(defvar vbox (make-instance 'gtk:gtk-box :orientation :vertical
+                                         :spacing 10
+                                         :margin 10))
+
+(defvar text-panel-box (make-instance 'gtk:gtk-box :orientation :horizontal :spacing 1 :margin 10))
+(defvar panel-left-window (make-instance 'gtk:gtk-scrolled-window :height-request 500 :width-request 100))
+(defvar panel-left (make-instance 'gtk:gtk-text-view :height-request 300 :width-request 100 :wrap-mode :word-char :vscroll-policy :natural))
+(defvar panel-right-window (make-instance 'gtk:gtk-scrolled-window :height-request 500 :width-request 300))
+(defvar panel-right (make-instance 'gtk:gtk-text-view :height-request 300 :width-request 300 :wrap-mode :word-char :vscroll-policy :natural))
+
+(gtk:gtk-box-pack-start vbox text-panel-box)
+(gtk:gtk-container-add panel-left-window panel-left)
+(gtk:gtk-box-pack-start text-panel-box panel-left-window)
+(gtk:gtk-container-add panel-right-window panel-right)
+(gtk:gtk-box-pack-end text-panel-box panel-right-window)
+
+(gtk:within-main-loop
+  ; Quit program when window closed
+  (gobject:g-signal-connect window "destroy" (lambda (widget)
+    (declare (ignore widget))
+    (gtk:leave-gtk-main)))
+  ; Display GUI
+  (gtk:gtk-container-add window vbox)
+  (gtk:gtk-widget-show-all window))
+
+(loop
+  (sleep 3)
+(setf (gtk:gtk-text-buffer-text (gtk:gtk-text-view-buffer panel-right)) (format nil "~a~a" (gtk:gtk-text-buffer-text (gtk:gtk-text-view-buffer panel-right)) "
+Hello, world!
+")))

Common-Lisp-Bits-And-Pieces/Web-Chat.lisp

@@ -0,0 +1,88 @@
+(ql:quickload '(clack websocket-driver alexandria))
+
+(defvar *connections* (make-hash-table))
+
+(defun handle-new-connection (con)
+  (setf (gethash con *connections*)
+        (format nil "user-~a" (random 100000))))
+
+(defun broadcast-to-room (connection message)
+  (let ((message (format nil "~a: ~a"
+                         (gethash connection *connections*)
+                         message)))
+    (loop :for con :being :the :hash-key :of *connections* :do
+          (websocket-driver:send con message))))
+
+(defun handle-close-connection (connection)
+  (let ((message (format nil " .... ~a has left."
+                         (gethash connection *connections*))))
+    (remhash connection *connections*)
+    (loop :for con :being :the :hash-key :of *connections* :do
+          (websocket-driver:send con message))))
+
+(defun chat-server (env)
+  (let ((ws (websocket-driver:make-server env)))
+    (websocket-driver:on :open ws
+                         (lambda () (handle-new-connection ws)))
+
+    (websocket-driver:on :message ws
+                         (lambda (msg)
+                           (broadcast-to-room ws msg)))
+
+    (websocket-driver:on :close ws
+                         (lambda (&key code reason)
+                           (declare (ignore code reason))
+                           (handle-close-connection ws)))
+    (lambda (responder)
+      (declare (ignore responder))
+      (websocket-driver:start-connection ws))))
+
+(defvar *html*
+  "<!doctype html>
+
+<html lang=\"en\">
+<head>
+  <meta charset=\"utf-8\">
+  <title>LISP-CHAT</title>
+</head>
+
+<body>
+    <ul id=\"chat-echo-area\">
+    </ul>
+    <div style=\"position:fixed; bottom:0;\">
+        <input id=\"chat-input\" placeholder=\"say something\" >
+    </div>
+    <script>
+     window.onload = function () {
+         const inputField = document.getElementById(\"chat-input\");
+
+         function receivedMessage(msg) {
+             let li = document.createElement(\"li\");
+             li.textContent = msg.data;
+             document.getElementById(\"chat-echo-area\").appendChild(li);
+         }
+
+         const ws = new WebSocket(\"ws://localhost:12345/\");
+         ws.addEventListener('message', receivedMessage);
+
+         inputField.addEventListener(\"keyup\", (evt) => {
+             if (evt.key === \"Enter\") {
+                 ws.send(evt.target.value);
+                 evt.target.value = \"\";
+             }
+         });
+     };
+
+    </script>
+</body>
+</html>
+")
+
+(defun client-server (env)
+  (declare (ignore env))
+  `(200 (:content-type "text/html")
+     (,*html*)))
+
+(defvar *chat-handler* (clack:clackup #'chat-server :port 12345))
+(defvar *client-handler* (clack:clackup #'client-server :port 8080))
+