{-# LANGUAGE PatternSignatures, FlexibleInstances, TypeSynonymInstances   #-}

import IO
import Control.Concurrent
import Control.Concurrent.STM

import List

import Join.Base
import Join.Join

{-

Jingle Bells: Solving the Santa Claus Problem in HaskellJoin 


In 2003 Nick Benton wrote a paper
"Jingle Bells: Solving the Santa Claus Problem in Polyphonic C".
He shows how to solve a challenging concurrency problem in 
Polyphonic C, an experimental extension of C# with concurrency constructs
based on the join calculus. Polyphonic C is no longer maintained (as far
as I know) but instead you can use Claudio Russo's
"The Joins Concurrency Library" which provides the same functionality.

Here, we will revisit the Santa Claus Problem and consider some extensions
to make the problem a bit more challenging. We will use HaskellJoin,
a library to provide join calculus functionality in Haskell.


-------------------------
-- Santa Claus Problem

The original specification says:

Santa repeatedly sleeps until wakened by either all of his nine reindeer, 
back from their holidays, or by a group of three of his ten elves. 
If awakened by the reindeer, he harnesses each of them to his sleigh, delivers
 toys with them and finally unharnesses them (allowing them to go off on holiday). 
If awakened by a group of elves, he shows each of the group into his study, 
consults with them on toy R\&D and finally shows them each out 
(allowing them to go back to work). 
Santa gives priority to the reindeer 
if there are matching groups of both elves and reindeer waiting.


-------------------------
-- Problem variant

We consider the following variant.

 - there are 12 Santas
 - 9 deers as before, we only require a group of 3 deers to wake-up
   one of the Santas 
-  12 elves

We first consider the impact of having several Santas.

Nick's solution incrementally accummulates deers/elves until
we have reached a sufficiently large group of deers/elves.


In case of several Santas this possbily leads to a deadlock.
For example, suppose that Santa1 accummulates 4 and Santa2
accummulates 5 deers.

The fix is to guarantee atomic wake-up by a group of deers
via the join pattern

 deer() & deer() & deer() & deer() & deer() & deer() &
 deer() & deer() & deer() = deersReady()


The join pattern semantic guarantees that the elements
matching the left-hand side are consumed all at once
or not at all. Thus, we avoid the above deadlock.

In our solution we only require three deers to form a group.
Hence, we find

 deer() & deer() & deer() = deersReady()

 elf() & elf() & elf() = elvesReady()


We yet need to wake up a santa if there's a group
of three deers or elves waiting (ready).
Each santa carries a unique id for indentification.

 santa(id) & deersReady() = "deliver toys"
 
 santa(id) & elvesReady() = "show study and consult on R&D"


 Are we done yet?

The specification says:
"Santa gives priority to the reindeer 
if there are matching groups of both elves and reindeer waiting."

Experiments (on my mac dual-core) show that the ratio between
the number of groups of deers to groups of elves (which wake-up a santa)
is one to two (1:2). 

How can we give higher priority to a group of deers? 

We're happy with an approximate solution. Each santa first checks
for a group of deers before considering a group of elves. It's clear
that a fresh group of deers may become available just right after
we've chosen a group of deers. We're have to accept such choices.
They are unavoidable in a highly concurrent setting where resources
become (un)available at any point in time.


In HaskellJoin, join patterns are tried from top to bottom order
(like in other pattern matching based languages like
Prolog and Haskell). Hence, we order join pattern clauses
as follows.


 santa(id) & deersReady() = "deliver toys"
 
 santa(id) & elvesReady() = "show study and consult on R&D"

 deer() & deer() & deer() = deersReady()

 elf() & elf() & elf() = elvesReady()


The order of the last two clauses is irrelevant.
But it's important to try clause

 santa(id) & deersReady() = "deliver toys"

before trying

 santa(id) & elvesReady() = "show study and consult on R&D"

However, this doesn't yet achieve the desired effect.
For example, suppose we have

 - a sleeping santa, santa(1)
 - a group of deers waiting, deersReady()
 - a group of elves waiting, elvesReady()


Each deersReady() and elvesReady()
try the above clauses in top to bottom order.

(a) deersReady() can trigger the first clause in combination with santa(1)

(b) elvesReady() can trigger the second clause in combination with santa(1)

We have no control which computation will take place first (eg there
are many run-time factors involved, number of cores, threads, context
switching time etc). Computation of (a) will invalidate (b) and vice versa.
How can we give preference to (a)?

The trick is to include the following clause


 elvesReady() & santa(id) & deersReady() = do elvesReady()
                                              "deliver toys"

If there's a group of elves and deers ready, we prefer
the group of deers. Because we haven't selected the group
of elves, we call elvesReady again in the join body.


 santa(id) & deersReady() = "deliver toys"
 
 elvesReady() & santa(id) & deersReady() = do elvesReady()
                                              "deliver toys"

 santa(id) & elvesReady() = "show study and consult on R&D"

 deer() & deer() & deer() = deersReady()

 elf() & elf() & elf() = elvesReady()


Experiments show that the ratio between the number of groups of deers 
to groups of elves (which wake-up a santa) is now one to one (1:1). 

Minor point:


The consecutive removal and addition of the same element elvesReady()
seems wasteful. In HaskellJoin, we can express propagation of join pattern elements
by writing them to the left of \. Elements to the right
will be removed.

 elvesReady() \ santa(id) & deersReady() = "deliver toys"



Comparison to Nick's solution to enforce priorities

waittobewoken() & elvesReady() & deerNotReady() = deerNotReady ...
-- we could use propagation
-- deerNotReady() \ waittobewoken() & elvesReady() = ...
-- to allow that multiple elf groups can execute concurrently
-- (if the deers are not ready yet)

deer() & deer() & deer() = do clearDeerNotReady()
                              deerReady()

clearDeerNotReady() & deerNotReady() = return ()

waittobewoken() & deerReady() = deerNotReady

Points to note:

 - a group of elves must explicitely synchronize with a deerNotReady token.
   It's unclear how to extend Nick's priority solution to our variant
   of 12 santas, 9 deers and 12 elves.

 - Nick's priority solution doesn't depend on the (top to bottom) execution order.
   He claims a fixed execution order may prevent optimization. 
   Our (implementation) experiences show that this is not the case.
   A valid argument is that top to bottom execution order leads to non-modular code.



References:

http://research.microsoft.com/~nick/polyphony/
http://research.microsoft.com/~crusso/joins/
http://research.microsoft.com/~nick/santa.pdf 

-}




-- patterns
santaPat id = method "Santa" id

deerPat = method "Deer" ()

elfPat = method "Elf" ()

readyDeersPat = method "readyDeers" ()

readyElvesPat = method "readyElves" ()

-- method calls (all asynchronous)

santa :: Join -> Int -> IO ()
santa join id = --callPassive
                call 
                join "Santa" id


elf :: Join -> IO ()
elf join = call join "Elf" ()

deer :: Join -> IO ()
deer join = do
   call join "Deer" ()

readyDeers :: Join -> IO ()  
readyDeers join = call join "readyDeers" ()

readyElves :: Join -> IO ()
readyElves join = call join "readyElves" ()


santaJoinDefinitions output (cntE, cntD, cntD2) join activeMethod = do
   c <- newVar :: IO (VAR Int)

   let prog = translateJoinDefinitions
         [

         [santaPat c, readyDeersPat] 
              .->. do

                    v_c <- readVar c

                    -- harness each deer to sleigh and deliver toys

                    atomically $ do
                           v <- readTVar cntD
                           writeTVar cntD (v+1)

                    mapM_ (\v -> deer join) 
                          [1..3]
                            
                    santa join v_c

         , [readyElvesPat] .\. [santaPat c, readyDeersPat] 
              .->. do

                    v_c <- readVar c

                    -- harness each deer to sleigh and deliver toys

                    atomically $ do
                           v <- readTVar cntD2
                           writeTVar cntD2 (v+1)


                    mapM_ (\v -> deer join) 
                          [1..3]
                            
                    santa join v_c

        ,[santaPat c, readyElvesPat] 
              .->. do v_c <- readVar c

                      -- consult on R&D

                      atomically $ do
                           v <- readTVar cntE
                           writeTVar cntE (v+1)

                      mapM_ (\v -> elf join) [1..3]

                      santa join v_c


         ,[deerPat , deerPat , deerPat]
              .->. readyDeers join

         , [elfPat, elfPat, elfPat] 
              .->. readyElves join 


           ]
                          

   res <- runJoinOnGoal (store join) activeMethod prog
   case res of
         Just action -> action
         Nothing -> return ()




-- testing

printOutput o = do
         do w <- readChan o
            putStrLn w
            printOutput o


main :: IO ()
main = do
  
   jStore <- newJoinStore
   output <- newChan

   [c1,c2,c3] <- mapM (\_ -> atomically $ newTVar 0) [1..3]

   let join = Join {store = jStore, rules = santaJoinDefinitions output (c1,c2,c3)}

   let elfNo = 18
   let deerNo = 9
   let santaNo = 12

   mapM_ (\_ -> elf join) [1..elfNo]

   mapM_ (\x -> deer join) [1..deerNo]


   mapM_ (\s -> santa join s) [1..santaNo]

   let printLoop = do
         (a,b,c) <- atomically $ do
                      v1 <- readTVar c1
                      v2 <- readTVar c2
                      v3 <- readTVar c3           
                      return (v1,v2,v3)
         putStrLn $ show (a,b,c)
         threadDelay 20000
         printLoop

   printLoop