# Chandy / Misra solution to Dining Philosophers Problem (no locking)
# http://en.wikipedia.org/wiki/Dining_philosophers_problem
# phil.l -- 07feb2009 Tomas Hlavaty
# credits: picolisp related improvements by Alexander Burger
# running: $ ~/picolisp/p phil.l

# *Philosophers      List of PIDs (process IDs)
# *LeftNeighbor      PID of left neighbor
# *RightNeighbor     PID of right neighbor
# *LeftFork          Left fork (NIL, dirty or clean)
# *RightFork         Right fork (NIL, dirty or clean)
# *Monitor           PID of the animation process
# *Pending           Queue of defered requests

# algorithm from http://www.cs.wustl.edu/~joeh/IPL-ChandyMisra.ps
#
# State                   Behavior
# -----------------------------------------------------------------------
# Trying (Hungry)         Request all forks that the philosopher doesn't
#                         currently have.
#                         Grant all requests for dirty forks.
#                         (Forks will be cleaned when sent.) 
#                         >> ask back for handed over forks <<
#                         Defer all requests for clean forks.
#                         May move to Critical state when all forks are
#                         present.
# -----------------------------------------------------------------------
# Critical (Eating)       Defer all requests for forks clean or dirty.
#                         Make all forks dirty.
#                         May move to Exit state at any time.
# -----------------------------------------------------------------------
# Exit (Finished Eating)  May move to Remainder state when all deferred
#                         requests have been granted.
# -----------------------------------------------------------------------
# Remainder (Thinking)    Grant all requests.
#                         (Forks will be cleaned when sent.)
#                         May move to Trying state at any time.
# -----------------------------------------------------------------------
#
# pros:
# - scales
# - no need for locks
# cons:
# - IPC must be reliable, no message can get lost

(de log @
   (pass println *Pid)
   (flush) )

(de idle ()
   (wait (rand 100 10000)) )

(de obtain (P)
   (cond
      ((= P *LeftNeighbor)
         (if *LeftFork
            (quit "Already have the left fork")
            (setq *LeftFork 'clean) ) )
      ((= P *RightNeighbor)
         (if *RightFork
            (quit "Already have the right fork")
            (setq *RightFork 'clean) ) )
      (T (quit "Wrong pid")) )
   (draw) )

(de handOver (P Var)
   (ifn (val Var)
      (quit "No fork to hand over")
      (set Var NIL)
      (tell 'pid P 'obtain *Pid) )
   (changed) )

(de giveNow (P)
   (cond
      ((= P *LeftNeighbor)
       (handOver P '*LeftFork) )
      ((= P *RightNeighbor)
       (handOver P '*RightFork) )
      (T (quit "Wrong pid")) ) )

(de defer (P)
   (fifo '*Pending (list 'giveNow P)) )

(de give (P)
   (case *State
      (thinking
         (giveNow P) )
      (hungry
         (cond
            ((= P *LeftNeighbor)
             (if (== 'clean *LeftFork)
                (defer P)
                (handOver P '*LeftFork)
                (tell 'pid P 'give *Pid) ) )
            ((= P *RightNeighbor)
             (if (== 'clean *RightFork)
                (defer P)
                (handOver P '*RightFork)
                (tell 'pid P 'give *Pid) ) )
            (T (quit "Wrong pid")) ) )
      ((eating finished)
         (defer P) )
      (T (quit "Wrong state")) ) )

(de think ()
   (setq *State 'thinking)
   (draw)
   (idle) )

(de grab ()
   (setq *State 'hungry)
   (draw)
   (unless *LeftFork
      (tell 'pid *LeftNeighbor 'give *Pid) )
   (unless *RightFork
      (tell 'pid *RightNeighbor 'give *Pid) )
   (wait NIL (and *LeftFork *RightFork)) )

(de eat ()
   (setq *State 'eating)
   (setq *LeftFork (setq *RightFork 'dirty))
   (draw)
   (idle) )

(de finish ()
   (setq *State 'finished)
   (draw)
   (while (fifo '*Pending)
      (eval @) ) )
   
(de phil ()
   (wait NIL (and *LeftNeighbor *RightNeighbor))
   (setq *LeftFork 'dirty)
   (seed (in "/dev/urandom" (rd 3)))
   (loop
      (think)
      (grab)
      (eat)
      (finish) ) )

(de changed (S)
   (tell 'pid *Monitor 'update (philState)) )
   
(de update (S)
   (if (assoc (car S) *State)
      (con @ (cdr S))
      (push '*State S) ) )
   
(de draw ()
   (tell 'pid *Monitor 'drawAll (philState)) )
   
(de drawFork (F)
   (prin (case F
            (dirty ":")
            (clean "|")
            (NIL ".")
            (T (quit "Bad fork")) )) )

(de philState ()
   (list *Pid *State *LeftFork *RightFork) )

(de drawState (S)
   (drawFork (caddr S))
   (prin (case (cadr S)
            (thinking "?")
            (hungry "=")
            (eating "o")
            (finished "x")
            (T (quit "Bad state")) ))
   (drawFork (cadddr S)) )
  
(de drawAll (S)
   (update S)
   (for P *Philosophers
      (prin " ")
      (if (assoc P *State)
         (drawState @)
         (prin "___") ) )
   (prinl)
   (flush) )

(de main (N)
   (ifn (fork)
      (wait)
      (setq *Monitor @)
      (push '*Bye '(kill *Monitor)) )
   (setq *Philosophers  # Build a list of PIDs
      (make
         (do N
            (if (fork) (link @) (phil)) ) ) )
   (push '*Bye '(mapc kill *Philosophers))
   (tell 'pid *Monitor 'setq '*Philosophers *Philosophers)
   (do N  # Send to each philosopher the PIDs of his neighbors
      (tell 'pid (car *Philosophers)
         'setq
         '*Monitor *Monitor
         '*LeftNeighbor (last *Philosophers)
         '*RightNeighbor (cadr *Philosophers) )
      (rot *Philosophers) ) )

(main 5)