| | 1 | Mr. Lamkin's implementation of Edsgar Dijkstra's famous [http://en.wikipedia.org/wiki/Dining_philosophers dining philosophers] problem uses [http://www.openmcl.org/openmcl-wiki/DigiTool DigiTool] MCL-style processes and locks, which are implemented differently in OpenMCL. |
| | 2 | |
| | 3 | {{{ |
| | 4 | DigiTool MCL-style processes and locks, which are implemented differently in OpenMCL. |
| | 5 | |
| | 6 | ;;; |
| | 7 | ;;; Dining Philosophers, from David B. Lamkin's book "Successful Lisp" |
| | 8 | ;;; Publisher: bookfix.com (December 8, 2004) |
| | 9 | ;;; ISBN: 3937526005 |
| | 10 | ;;; |
| | 11 | ;;; Converted to work under OpenMCL by Brent Fulgham (10/2006) |
| | 12 | ;;; |
| | 13 | (defstruct philosopher |
| | 14 | (amount-eaten 0) |
| | 15 | (task nil)) |
| | 16 | |
| | 17 | (defmacro acquire-lock-or-skip (lock post-acquire pre-release &body body) |
| | 18 | `(progn |
| | 19 | ;; Random sleep makes the output more interesting |
| | 20 | ;; by introducing variability into the order of |
| | 21 | ;; execution. This is a simple way of simulating |
| | 22 | ;; the nondeterminacy that would result from having |
| | 23 | ;; additional processes compete for CPU cycles. |
| | 24 | (sleep (random 5)) |
| | 25 | (unless (ccl::%%lock-owner ,lock) |
| | 26 | (grab-lock ,lock) |
| | 27 | ,post-acquire |
| | 28 | (unwind-protect |
| | 29 | (progn ,@body) |
| | 30 | ,pre-release |
| | 31 | (release-lock ,lock))))) |
| | 32 | |
| | 33 | (let ((philosophers #()) |
| | 34 | (philosophers-output t)) |
| | 35 | |
| | 36 | (defun dining-philosophers (number-of-philosophers &optional (stream t)) |
| | 37 | (unless (equalp philosophers #()) |
| | 38 | (stop-philosophers)) |
| | 39 | (assert (> number-of-philosophers 1) (number-of-philosophers)) |
| | 40 | (setq philosophers-output stream) |
| | 41 | (format philosophers-output |
| | 42 | "~2&Seating ~D philosophers for dinner.~%" |
| | 43 | number-of-philosophers) |
| | 44 | (force-output philosophers-output) |
| | 45 | (flet ((announce-acquire-fork (who fork) |
| | 46 | (format philosophers-output |
| | 47 | "~&Philosopher ~A has picked up ~A.~%" |
| | 48 | who (lock-name fork))) |
| | 49 | (announce-release-fork (who fork) |
| | 50 | (format philosophers-output |
| | 51 | "~&Philosopher ~A is putting down ~A.~%" |
| | 52 | who (lock-name fork))) |
| | 53 | (eat (who) |
| | 54 | (format philosophers-output |
| | 55 | "~&Philosopher ~A is EATING bite ~D.~%" |
| | 56 | who (incf (philosopher-amount-eaten (aref philosophers who)))))) |
| | 57 | (flet ((philosopher-task (who left-fork right-fork) |
| | 58 | (loop |
| | 59 | (acquire-lock-or-skip left-fork |
| | 60 | (announce-acquire-fork who left-fork) |
| | 61 | (announce-release-fork who left-fork) |
| | 62 | (acquire-lock-or-skip right-fork |
| | 63 | (announce-acquire-fork who right-fork) |
| | 64 | (announce-release-fork who right-fork) |
| | 65 | (eat who))) |
| | 66 | (force-output stream) |
| | 67 | (process-allow-schedule)))) |
| | 68 | (let ((forks (make-sequence 'vector number-of-philosophers))) |
| | 69 | (dotimes (i number-of-philosophers) |
| | 70 | (setf (aref forks i) (make-lock (format nil "fork ~D" i)))) |
| | 71 | (flet ((left-fork (who) |
| | 72 | (aref forks who)) |
| | 73 | (right-fork (who) |
| | 74 | (aref forks (mod (1+ who) number-of-philosophers)))) |
| | 75 | (setq philosophers (make-sequence 'vector number-of-philosophers)) |
| | 76 | (dotimes (i number-of-philosophers) |
| | 77 | (setf (aref philosophers i) |
| | 78 | (make-philosopher |
| | 79 | :task (process-run-function (format nil "Philosopher-~D" i) |
| | 80 | #'philosopher-task |
| | 81 | i |
| | 82 | (left-fork i) |
| | 83 | (right-fork i))))))))) |
| | 84 | (values)) |
| | 85 | |
| | 86 | (defun stop-philosophers () |
| | 87 | (dotimes (i (length philosophers)) |
| | 88 | (process-kill (philosopher-task (aref philosophers i)))) |
| | 89 | (format philosophers-output |
| | 90 | "~&Dinner is finished. Amounts eaten: {~{~D~^, ~}}~2%" |
| | 91 | (map 'list #'philosopher-amount-eaten philosophers)) |
| | 92 | (force-output philosophers-output) |
| | 93 | (setq philosophers #()) |
| | 94 | (values)) |
| | 95 | ) |
| | 96 | }}} |
