Data commit

Task/Dining-philosophers/Common-Lisp/dining-philosophers-1.lisp

@@ -0,0 +1,80 @@
+(in-package :common-lisp-user)
+
+;;
+;; FLAG -- if using quicklisp, you can get bordeaux-threads loaded up
+;; with: (ql:quickload :bordeaux-threads)
+;;
+
+(defvar *philosophers* '(Aristotle Kant Spinoza Marx Russell))
+
+(defclass philosopher ()
+  ((name :initarg :name :reader name-of)
+   (left-fork :initarg :left-fork :accessor left-fork-of)
+   (right-fork :initarg :right-fork :accessor right-fork-of)
+   (meals-left :initarg :meals-left :accessor meals-left-of)))
+
+(defclass fork ()
+  ((lock :initform (bt:make-lock "fork") :reader lock-of)))
+
+(defun random-normal (&optional (mean 0.0) (sd 1.0))
+  (do* ((x1 #1=(1- (* 2.0d0 (random 1d0))) #1#)
+        (x2 #2=(1- (* 2.0d0 (random 1d0))) #2#)
+        (w  #3=(+ (* x1 x1) (* x2 x2)) #3#))
+      ((< w 1d0) (+ (* (* x1 (sqrt (/ (* -2d0 (log w)) w))) sd) mean))))
+
+(defun sleep* (time) (sleep (max time (/ (expt 10 7)))))
+
+(defun dining-philosophers (&key (philosopher-names *philosophers*)
+                                 (meals 30)
+                                 (dining-time'(1 2))
+                                 (thinking-time '(1 2))
+                                 ((stream e) *error-output*))
+  (let* ((count (length philosopher-names))
+         (forks (loop repeat count collect (make-instance 'fork)))
+         (philosophers (loop for i from 0
+                             for name in philosopher-names collect
+                               (make-instance 'philosopher
+                                    :left-fork (nth (mod i count) forks)
+                                    :right-fork (nth (mod (1+ i) count) forks)
+                                    :name name
+                                    :meals-left meals)))
+         (condition (bt:make-condition-variable))
+         (lock (bt:make-lock "main loop"))
+         (output-lock (bt:make-lock "output lock")))
+    (dolist (p philosophers)
+      (labels ((think ()
+                 (/me "is now thinking")
+                 (sleep* (apply #'random-normal thinking-time))
+                 (/me "is now hungry")
+                 (dine))
+               (dine ()
+                 (bt:with-lock-held ((lock-of (left-fork-of p)))
+                   (or (bt:acquire-lock (lock-of (right-fork-of p)) nil)
+                       (progn (/me "couldn't get a fork and ~
+                                    returns to thinking")
+                              (bt:release-lock (lock-of (left-fork-of p)))
+                              (return-from dine (think))))
+                   (/me "is eating")
+                   (sleep* (apply #'random-normal dining-time))
+                   (bt:release-lock (lock-of (right-fork-of p)))
+                   (/me "is done eating (~A meals left)"
+                        (decf (meals-left-of p))))
+                 (cond ((<= (meals-left-of p) 0)
+                        (/me "leaves the dining room")
+                        (bt:with-lock-held (lock)
+                          (setq philosophers (delete p philosophers))
+                          (bt:condition-notify condition)))
+                       (t (think))))
+               (/me (control &rest args)
+                 (bt:with-lock-held (output-lock)
+                   (write-sequence (string (name-of p)) e)
+                   (write-char #\Space e)
+                   (apply #'format e (concatenate 'string control "~%")
+                          args))))
+        (bt:make-thread #'think)))
+    (loop (bt:with-lock-held (lock)
+            (when (endp philosophers)
+              (format e "all philosophers are done dining~%")
+              (return)))
+          (bt:with-lock-held (lock)
+            (bt:condition-wait condition lock)))))

Task/Dining-philosophers/Common-Lisp/dining-philosophers-2.lisp

@@ -0,0 +1,49 @@
+(ql:quickload '(:stmx :bordeaux-threads))
+
+(defpackage :dining-philosophers
+  (:use :cl))
+
+(in-package :dining-philosophers)
+
+(defstruct philosopher
+  name
+  left-fork
+  right-fork)
+
+(defparameter *philosophers* '("Aristotle" "Kant" "Spinoza" "Marx" "Russell"))
+(defparameter *eating-max* 5.0)
+(defparameter *thinking-max* 5.0)
+(defvar *log-lock* (bt:make-lock))
+(defvar *running* nil)
+
+(defun print-log (name status)
+  (bt:with-lock-held (*log-lock*)
+    (format t "~a is ~a~%" name status)))
+
+(defun philosopher-cycle (philosopher)
+  "Continously atomically grab and return the left and right forks of the given PHILOSOPHER."
+  (with-slots (name left-fork right-fork) philosopher
+    (loop while *running*
+       do
+         (print-log name "hungry")
+         (stmx:atomic
+          (stmx.util:take left-fork)
+          (stmx.util:take right-fork))
+         (print-log name "eating")
+         (sleep (random *eating-max*))
+         (stmx:atomic
+          (stmx.util:put left-fork t)
+          (stmx.util:put right-fork t))
+         (print-log name "thinking")
+         (sleep (random *thinking-max*)))))
+
+(defun scenario ()
+  (let ((forks (loop repeat (length *philosophers*) collect (stmx.util:tcell t))))
+    (setf *running* t)
+    (loop for name in *philosophers*
+       for left-fork in forks
+       for right-fork in (append (cdr forks) (list (car forks)))
+       do (let ((philosopher (make-philosopher :name name :left-fork left-fork :right-fork right-fork)))
+            (bt:make-thread (lambda () (philosopher-cycle philosopher))
+                            :initial-bindings (cons (cons '*standard-output* *standard-output*)
+                                                    bt:*default-special-bindings*))))))

Task/Dining-philosophers/Common-Lisp/dining-philosophers-3.lisp

@@ -0,0 +1,44 @@
+DINING-PHILOSOPHERS> (scenario)
+Aristotle is hungry
+Aristotle is eating
+Kant is hungry
+Spinoza is hungry
+Spinoza is eating
+Marx is hungry
+NIL
+Russell is hungry
+Aristotle is thinking
+Russell is eating
+Spinoza is thinking
+Kant is eating
+Spinoza is hungry
+Russell is thinking
+Marx is eating
+Kant is thinking
+Aristotle is hungry
+Aristotle is eating
+Marx is thinking
+Spinoza is eating
+Spinoza is thinking
+Marx is hungry
+Marx is eating
+Russell is hungry
+Marx is thinking
+Kant is hungry
+Aristotle is thinking
+Russell is eating
+Kant is eating
+Marx is hungry
+Spinoza is hungry
+Kant is thinking
+Spinoza is eating
+Kant is hungry
+Aristotle is hungry
+Russell is thinking
+Aristotle is eating
+Aristotle is thinking
+Aristotle is hungry
+Aristotle is eating
+Spinoza is thinking
+Marx is eating
+...