diff --git a/Common-Lisp-Bits-And-Pieces/Chapter-02/hello-world.fasl b/Common-Lisp-Bits-And-Pieces/Chapter-02/hello-world.fasl new file mode 100644 index 0000000..0f65f7b Binary files /dev/null and b/Common-Lisp-Bits-And-Pieces/Chapter-02/hello-world.fasl differ diff --git a/Common-Lisp-Bits-And-Pieces/Chapter-02/hello-world.lisp b/Common-Lisp-Bits-And-Pieces/Chapter-02/hello-world.lisp new file mode 100644 index 0000000..832b828 --- /dev/null +++ b/Common-Lisp-Bits-And-Pieces/Chapter-02/hello-world.lisp @@ -0,0 +1,4 @@ +(defun hello-world () + (format t "Hello, world!")) + +(hello-world) diff --git a/Common-Lisp-Bits-And-Pieces/Chapter-03/cds.db b/Common-Lisp-Bits-And-Pieces/Chapter-03/cds.db new file mode 100644 index 0000000..9c9b6cd --- /dev/null +++ b/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)) \ No newline at end of file diff --git a/Common-Lisp-Bits-And-Pieces/Chapter-03/cds.fasl b/Common-Lisp-Bits-And-Pieces/Chapter-03/cds.fasl new file mode 100644 index 0000000..45b7c38 Binary files /dev/null and b/Common-Lisp-Bits-And-Pieces/Chapter-03/cds.fasl differ diff --git a/Common-Lisp-Bits-And-Pieces/Chapter-03/cds.lisp b/Common-Lisp-Bits-And-Pieces/Chapter-03/cds.lisp new file mode 100644 index 0000000..a8de58e --- /dev/null +++ b/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) diff --git a/Common-Lisp-Bits-And-Pieces/Chapter-09/testing-framework.fasl b/Common-Lisp-Bits-And-Pieces/Chapter-09/testing-framework.fasl new file mode 100644 index 0000000..f34baaf Binary files /dev/null and b/Common-Lisp-Bits-And-Pieces/Chapter-09/testing-framework.fasl differ diff --git a/Common-Lisp-Bits-And-Pieces/Chapter-09/testing-framework.lisp b/Common-Lisp-Bits-And-Pieces/Chapter-09/testing-framework.lisp new file mode 100644 index 0000000..b93dafc --- /dev/null +++ b/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)))) diff --git a/Common-Lisp-Bits-And-Pieces/Chapter-15/barra-filename-library.fasl b/Common-Lisp-Bits-And-Pieces/Chapter-15/barra-filename-library.fasl new file mode 100644 index 0000000..b6f582b Binary files /dev/null and b/Common-Lisp-Bits-And-Pieces/Chapter-15/barra-filename-library.fasl differ diff --git a/Common-Lisp-Bits-And-Pieces/Chapter-15/barra-filename-library.lisp b/Common-Lisp-Bits-And-Pieces/Chapter-15/barra-filename-library.lisp new file mode 100644 index 0000000..1a51fc5 --- /dev/null +++ b/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)))) + diff --git a/Common-Lisp-Bits-And-Pieces/GTK-Test.lisp b/Common-Lisp-Bits-And-Pieces/GTK-Test.lisp new file mode 100644 index 0000000..1d92c8f --- /dev/null +++ b/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! +"))) diff --git a/Common-Lisp-Bits-And-Pieces/Web-Chat.lisp b/Common-Lisp-Bits-And-Pieces/Web-Chat.lisp new file mode 100644 index 0000000..2d792f8 --- /dev/null +++ b/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* + " + + + + + LISP-CHAT + + + + +
+ +
+ + + +") + +(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)) +