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

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

import Join.Base
import Join.Join

{-  The bagger problem in Join


 There are n number of bags which can be filled up with
 either large, medium or small items. The weight of items of
 a specific kind is fixed. The maximum weight carried by
 a bag is fixed.

 Bags are filled up with items in a fixed order:

  1. In sequential order from lowest to highest bag number
  2. Exhaustively fill up the bag first with
       (a) large items, then
       (b) medium items, then
       (c) small items.
 
 The straightforward solution is to

  1. Fill up bags with large items, then
  2. with medium items, and then finally with
  3. small items.

 However, once a bag has been exhaustively filled up with
 large items (we either stop because the bag reached its
 maximum capacity of large items, or we're simply running out
 of large items), we can start filling up this bag with
 medium items. The point is that we don't have to wait until
 all bags are exhaustively filled up with large items.
 
 This form of concurrency has clear connection to
 instruction pipelining. What we want to show here 
 is how to come up with a concurrent solution to the
 bagger problem using

  join-patterns extended with guards (referred to as Join)

 
 Here's the solution in Join:

 The methods we introduce are:

  Bag(kind,no,content) denotes a bag which
       
        - currently expects to be filled with items of kind 'kind'
        - no is the bags number
        - content refers to the current content

  Initially, all bags are of the form

     Bag(Large,i,Empty)


  Item(k) denotes an item of kind 'kind'


  The above methods are all asynchronous.

  We introduce two synchronous methods.

  Iterator(kind,no) fills up bag number no with items of kind 'kind'.
  Initially, there are three 'iterators':

          - Iterator(Large,1)
          - Iterator(Medium,1)
          - Iterator(Small,1)

  Each will run in its own thread. Each starts in 'Large' mode.
  That is, only the large iterator can fill up the bags (sequentially).
  Once the large iterator is done with bag number i, the bag is
  'unlocked' by moving from 'Large' to 'Medium' mode and so on.

  GetItem(kind,r) looks for an item of kind 'kind', the outcome
  is reported in r of type Maybe Weight.

  Here are the join patterns and their bodies.
  (We assume that join patterns are executed from top to bottom,
   for convenience only)

  Bag(kind,no,content) & Iterator(kind,no) = 
               if (weight content) + (weight kind) >= maxBagWeight
               then do bag kind no content
                       if no < MaxBagNo
                       then iterator kind (no+1)
                       else return ()
               else do
                        r <- getItem k
                        case r of
                          Nothing -> do
                               bag (next kind) no content
                               if no < MaxBagNo               -- (***)
                                then iterator kind (no+1)
                                else return ()
                          Just itemWeight -> do
                               bag kind no (add content itemWeight)
                               iterator kind no    
 

  Item(k) & GetItem(k,x) = case k of
                             Large -> x := Just Large
                             ...

  GetItem(k,x) = x:= Nothing


 NOTE:

  First, I thought we could replace (***) by the 'default' rule

  Iterator(kind, no) = return ()

  which we put *after* the first rule.

  However, this won't work because the 'small' iterator waiting for
  the medium and large iterator may terminate prematurely.

-}


----------------------------------------------------------------
-- The actual implementation using the Join library



type Item = Int

large = 0
medium = 1
small = 2
done = 3


next :: Item -> Item
next kind = kind+1

type Bag = [Int]

emptyBag :: Bag
emptyBag = []

addToBag :: Bag -> Item -> Bag
addToBag b i = i:b

class Weight a where
   weight :: a -> Int

instance Weight Item where
   weight 0 = 6
   weight 1 = 4
   weight 2 = 2
   weight _ = error "impossible weight"

instance Weight Bag where
   weight xs = sum (map weight xs)


maxBagWeight :: Int
maxBagWeight = 16

maxBagNo :: Int
maxBagNo = 20


-- patterns
bagPat kind no content = method "Bag" (kind,no,content)

iteratorPat kind no status = method "Iterator" (kind,no,status)

itemPat kind = method "Item" kind

getItemPat kind x = method "GetItem" (kind,x)

readPat status = method "Read" status

-- method calls

-- bag's are asynchronous and they can 'reawake' suspended iterators
-- to fire a join-pattern

bag :: Join -> Item -> Int -> Bag -> IO ()
bag join kind no content = call join "Bag" (kind,no,content)


-- the iterator propagates the status
iterator :: Join -> Item -> Int -> Sync Int -> IO ()
iterator join kind no status = call join "Iterator" (kind,no,status)

-- we look if an item of that kind exists
-- Nothing --> Fail
-- Just _  --> Success
getItem :: Join -> Item -> IO (Maybe Item)
getItem join kind = do
   r <- newSync
   call join "GetItem" (kind,r)
   v <- waitSync r
   case v of
     "Nothing" -> return Nothing
     x -> return (Just ((read x)::Int))

-- there's no need to call the solver, we just add the method
-- each sync call by getItem will trigger one of the rules

item :: Join -> Item -> IO ()
item join kind = callPassive join "Item" kind


readCall :: Join -> Sync Int -> IO ()
readCall join status = call join "Read" status

-- the set of join-patterns
bagger output join activeMethod = do
   kind <- newVar :: IO (VAR Int)
   no <- newVar :: IO (VAR Int)
   content <- newVar :: IO (VAR [Int])
   status <- newVar :: IO (VAR (Sync Int))
   res <- newVar :: IO (VAR (Sync String))

   let prog = translateJoinDefinitions
         [      

           [bagPat kind no content, iteratorPat kind no status] .->. do
               v_content <- readVar content
               v_kind <- readVar kind 
               v_no <- readVar no
               v_status <- readVar status
               if (weight v_content) + (weight v_kind) > maxBagWeight
                then do bag join (next v_kind) v_no v_content
                        if v_no < maxBagNo
                         then iterator join v_kind (v_no+1) v_status
                         else status .=. (1::Int) -- unblock the original 'iterator' call
                else do
                        w <- getItem join v_kind
                        case w of
                          Nothing -> do
                               bag join (next v_kind) v_no v_content
                               if v_no < maxBagNo         
                                then iterator join v_kind (v_no+1) v_status
                                else status .=. (1::Int) -- unblock the original 'iterator' call
                          Just _ -> do
                               bag join v_kind v_no (addToBag v_content v_kind)
                               iterator join v_kind v_no v_status    

         , [bagPat kind no content, readPat status] .->. do
               v_content <- readVar content
               v_kind <- readVar kind 
               v_no <- readVar no
               v_status <- readVar status
               writeChan output $ show (v_no, v_kind, v_content)
               readCall join v_status

         , [readPat status] .->. status .=. (1::Int)
 
         , [itemPat kind, getItemPat kind res] .->. do v_kind <- readVar kind
                                                       res .=. (show v_kind)


         , [getItemPat kind res] .->. res .=. "Nothing"
         ]

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


-- testing

printOutput o = do
   b <- isEmptyChan o
   if b then return ()
    else do w <- readChan o
            putStrLn w
            printOutput o


collectResult join = do
   r :: Sync Int <- newSync
   readCall join r
   v <- waitSync r
   return ()

pack cnt join kind = do
   r <- newSync
   iterator join kind 1 r
   v <- waitSync r
   atomically $ do x <- readTVar cnt
                   writeTVar cnt (x+1)
   

test1 :: IO ()
test1 = do

  cnt <- atomically $ newTVar 0

  jStore <- newJoinStore 

  output <- newChan

  let join = Join {store = jStore, rules = bagger output}

  mapM (\no -> bag join large no emptyBag) [1..maxBagNo]

  let lNo = 15
  let mNo = 20
  let sNo = 25

  mapM (\kind -> item join kind) ([small | x <- [1..sNo]]
                               ++ [medium | x <- [1..mNo]]
                               ++ [large | x <- [1..lNo]])

  --let forkIO = id

  forkIO (pack cnt join large)
  --putStr "Large"
  forkIO (pack cnt join medium)
  --putStr "Med"
  forkIO (pack cnt join small)
  --putStr "Small"

  atomically $ do x <- readTVar cnt
                  if x == 3 then return ()
                   else retry

  collectResult join

  printOutput output