--
-- INFOB3CC Concurrency
-- Practical 1: IBAN calculator
--
-- http://ics.uu.nl/docs/vakken/b3cc/assessment.html
--
module IBAN (

  Mode(..), Config(..),
  count, list, search

) where

import Control.Concurrent
import Crypto.Hash.SHA1
import Data.Atomics                                       ( readForCAS, casIORef, peekTicket,Ticket )
import Data.IORef
import Data.List                                          ( elemIndex )
import Data.Word
import Data.Maybe                                         ( fromJust )
import System.Environment
import System.IO
import Data.ByteString.Char8                              ( ByteString )
import qualified Data.ByteString                          as B
import qualified Data.ByteString.Char8                    as B8


-- -----------------------------------------------------------------------------
-- 0. m-test
-- -----------------------------------------------------------------------------

digits :: Int -> [Int]
digits n
        | n<10 = [n]
        | otherwise = n `mod` 10 : digits (n `div` 10)

-- Perform the m-test on 'number'
mtest :: Int -> Int -> Bool
mtest m number = finalSum `mod` m==0
        where finalSum =  sum $ zipWith (*) (digits number) [1..]
        
  -- Implement the m-test here!


-- -----------------------------------------------------------------------------
-- 1. Counting mode (3pt)
-- -----------------------------------------------------------------------------

--count' :: Int -> Int -> Int -> Int
--count' m b e    | b==e = 0
--                | mtest m b = 1+count' m (b+1) e
--                | otherwise = count' m (b+1) e
--


--TODO: zet indentation goed
countSection :: IORef Int -> Int -> Int -> Int -> IO()
countSection ioref b e m =
        sequence_ $ map f  [b..(e-1)]
        where
                f number  | mtest m number = do addValue ioref 1
                          | otherwise = return ()
sectionBorder :: Int -> Int -> Int -> Int -> Int
sectionBorder b e n i = (min nHigh i)* (s+1) + (max 0 (i-nHigh))*s + b
        where
                --Here we try to find the section this thread
                --has to go through. We want that the sections
                --to be divided as equally as possible between
                --the threads and that there are no gaps or
                --overlap. Often it won't be possible to divide
                --it into equal sections. Some section will be
                --of size s and some sections will be of size
                --s+1. We denote nLow as te amount of sections
                --that have size s and nHigh as the amount of
                --sections with size s+1. Note that nHigh+nLow=n
                --and we have the following equation
                --
                --nLow*s+nHigh*(s+1) = e-b+1
                --
                --This we can rewrite as
                --
                --n*s+nHigh = e-b +1
                --
                --hence
                s = (e-b) `div` n
                nHigh = e-b-n*s
                nLow = n-nHigh

addValue' :: IORef Int -> Ticket Int -> Int -> IO()
addValue' ioref ticket value = 
        do      (success, current) <- casIORef ioref ticket ((peekTicket ticket)+value)
                if success then return () else addValue' ioref current value

addValue:: IORef Int -> Int -> IO()
addValue ioref value = do       t <- readForCAS ioref
                                addValue' ioref t value

countTread :: IORef Int -> Int -> (Int, Int) -> Int -> Int -> IO()
countTread ioref m (b,e) n i = do
        countSection ioref bSec eSec m
        where
                bSec = sectionBorder b e n i
                eSec = sectionBorder b e n (i+1)
                
        

count :: Config -> IO Int
count config = do
        ioref <- newIORef 0
        forkThreads n (countTread ioref m (b,e) n)
        readIORef ioref
        where 
                b = cfgLower config
                e = cfgUpper config
                m = cfgModulus config
                n = cfgThreads config


-- -----------------------------------------------------------------------------
-- 2. List mode (3pt)
-- -----------------------------------------------------------------------------

--listSection :: IORef a -> Int -> Int -> Int -> IO()
--listSection ioref b e m =
--        foldr f 0 [b..(e-1)]
--        where
--                f number sum    | mtest m number = do   addValue ioref 1
--                                                        putStrLn  
--                                | otherwise = return ()
--listThread :: IORef Int -> Int -> (Int, Int) -> Int -> Int -> IO()
--listThread ioref m (b,e) n i = do
--        listSection ioref bSec eSec m
--        where
--
--                bSec = sectionBorder b e n i
--                eSec = sectionBorder b e n (i+1)
--

listSection :: Handle -> MVar Int -> Int -> Int -> Int -> IO()
listSection handle mvar b e m=
        sequence_ $ map f [b..(e-1)]
        where
                f number | mtest m number = do  count <- takeMVar mvar
                                                hPutStrLn handle $ show (count+1) ++ " " ++ show number
                                                putMVar mvar (count+1)
                         | otherwise = return ()

listThread :: Handle -> MVar Int -> Int -> (Int, Int) -> Int -> Int -> IO()
listThread handle mvar m (b,e) n i = do
        listSection handle mvar bSec eSec m
        where
                bSec = sectionBorder b e n i
                eSec = sectionBorder b e n (i+1)

list :: Handle -> Config -> IO ()
list handle config = do 
        mvar <- newMVar 0
        forkThreads n (listThread handle mvar m (b,e) n)
        where 
                b = cfgLower config
                e = cfgUpper config
                m = cfgModulus config
                n = cfgThreads config




-- -----------------------------------------------------------------------------
-- 3. Search mode (4pt)
-- -----------------------------------------------------------------------------

chunkSize= 100

data Range = Range Int Int
       deriving (Show, Eq)

dummyRange = Range -1 -1

data Queue a = Queue (MVar (List a)) (MVar (List a))
type List a = MVar (Item a)
data Item a = Item a (List a)

newQueue :: IO (Queue Range)
newQueue = do
 hole <- newEmptyMVar
 dummy <- newMVar (Item (dummyRange) hole)
 readLock <- newMVar dummy
 writeLock <- newMVar hole
 return (Queue readLock writeLock)

enqueue :: a -> Queue a -> IO()
enqueue x (Queue _ writeLock) = 
        do
                writeEnd <- takeMVar writeLock
                --putStrLn (show x)
                newWriteEnd <- newEmptyMVar
                putMVar writeEnd (Item x newWriteEnd)
                putMVar writeLock newWriteEnd
dequeue :: Queue Range -> IO (Maybe Range)
dequeue queue@(Queue readLock _) =
        do
                readEnd <- takeMVar readLock
                Item x newReadEnd <- takeMVar readEnd
                if x==dummyRange then do 
                        enqueue x queue 
                        putMVar readLock newReadEnd
                        return Nothing
                else do 
                        putMVar readLock newReadEnd
                        return x


searchThread :: Int -> IORef Int -> Queue Range -> ByteString -> MVar Int -> Int -> IO()
searchThread m amountToDo queue query number _ = do
                                        amToDo <- readIORef amountToDo
                                        notFound <- isEmptyMVar number 
                                        if (notFound && amToDo/=0) then 
                                                searchThread' m amountToDo queue query number 
                                        else 
                                                return ()


searchRange :: Int -> ByteString -> MVar Int -> Range -> IO()
searchRange m query searchNumber (Range start end) = sequence_ (map checkAcountnumber [start..(end-1)])
        where
                checkAcountnumber number | mtest m number && checkHash query (show number) = putMVar searchNumber number 
                                         | otherwise  = pure ()
                                        
searchThread' :: Int -> IORef Int -> Queue Range -> ByteString ->MVar Int -> IO()
searchThread' m amountToDo queue query searchNumber =
        do
                maybeRange <- dequeue queue
                if maybeRange == Nothing then do return () else 
                    (do
                        oldrange@(Range start end) <- dequeue queue
                        let searchrange | end-start > chunkSize = Range start (start+chunkSize)
                                        | otherwise             = oldrange
                        if end-start > chunkSize then do
                                enqueue (Range (start+chunkSize) ((start+chunkSize+end)`div` 2)) queue
                                enqueue (Range ((start+chunkSize+end)`div` 2) end) queue
                                addValue amountToDo 1
                        else do 
                                addValue amountToDo (-1)
                        sequence_ queueActions
                        searchRange m  query searchNumber searchrange
                        searchThread m amountToDo queue query searchNumber 0)
                        
        

search :: Config -> ByteString -> IO (Maybe Int)
search config query = 
        do
                queue <- newQueue
                amountToDo <- newIORef 1
                enqueue (Range b e) queue
                searchNumber <- newEmptyMVar
                forkThreads n (searchThread m amountToDo  queue query searchNumber)
                --searchRange m query searchNumber (Range b e)
                tryTakeMVar searchNumber
        where 
                b = cfgLower config
                e = cfgUpper config
                m = cfgModulus config
                n = cfgThreads config


-- -----------------------------------------------------------------------------
-- Starting framework
-- -----------------------------------------------------------------------------

data Mode = Count | List | Search ByteString
  deriving Show

data Config = Config
  { cfgLower   :: !Int
  , cfgUpper   :: !Int
  , cfgModulus :: !Int
  , cfgThreads :: !Int
  }
  deriving Show

-- Evaluates a term, before continuing with the next IO operation.
--
evaluate :: a -> IO ()
evaluate x = x `seq` return ()

-- Forks 'n' threads. Waits until those threads have finished. Each thread
-- runs the supplied function given its thread ID in the range [0..n).
--
forkThreads :: Int -> (Int -> IO ()) -> IO ()
forkThreads n work = do
  -- Fork the threads and create a list of the MVars which
  -- per thread tell whether the work has finished.
  finishVars <- mapM work' [0 .. n - 1]
  -- Wait on all MVars
  mapM_ takeMVar finishVars
  where
    work' :: Int -> IO (MVar ())
    work' index = do
      var <- newEmptyMVar
      _   <- forkOn index (work index >> putMVar var ())
      return var

-- Checks whether 'value' has the expected hash.
--
checkHash :: ByteString -> String -> Bool
checkHash expected value = expected == hash (B8.pack value)