Source code in the common programming language

(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)))))


(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*))))))


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
...