-- | DFLSystem.hs
--
-- A whole sorting DFL system assembler and executor with auxiliary circuit.
--
-- Copytight (C) 2007, 2008 Serguey Zefirov
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 3, or (at your option)
-- any later version.
-- See file COPYING or visit http://www.gnu.org/licenses for details.


module DFLSystem(
		dflSystemRunner
	) where

import System.IO

import qualified Que as Q
import Info
import S
import Presorter
import Config

-------------------------------------------------------------------------------
-- Infinite FIFO with two inputs.
--
-- This is the only part of sorting DFL system which does not limit the size
-- of data contained within.

fifoF outWidth (maxql,que) ((token1,token2),cts) =
#ifdef	DEBUG
	((max maxql queLen,nextQue),(out,debinfo))
#else
	((max maxql queLen,nextQue),out)
#endif
	where
		addQ xs = Q.appends xs
		(out,que0)
			| cts = Q.take outWidth que
			| otherwise = ([],que)
		que1 = addQ token1 que0
		que2 = addQ token2 que1
		queLen = Q.size que
		nextQue = que2
		noinfo = ""
		debinfo = "FIFO"
			!# ("input tokens",(token1,token2))
			## ("cts",cts)
			## ("out token",out)
--			## ("start que",que)
--			## ("end que",nextQue)
			## ("que length",queLen)
			#! ("maxql",maxql)

fifo outWidth tokens1 tokens2 cts =
#ifdef	DEBUG
	(out,info)
#else
	out
#endif
	where
#ifdef	DEBUG
		(out,info) = unzipS $
			loopS (0,Q.empty) (fifoF outWidth) $ zipS (zipS tokens1 tokens2) cts
#else
		out = loopS (0,Q.empty) (fifoF outWidth) $ zipS (zipS tokens1 tokens2) cts
#endif

-------------------------------------------------------------------------------
-- DFL system compiled into single block.
-- Parametrized by processor used.

dflSystem procWidth proc inTokens =
#ifdef	DEBUG
	(hostTokens,info)
#else
	(hostTokens)
#endif
	where
		hostTokens = mapS onlyHost procOutTokens
		procTokens = mapS onlyProc procOutTokens
		onlyHost' (t)
			| isNotToHost t = []
			| otherwise     = [t]
		onlyProc' (t)
			| isNotToHost t = [t]
			| otherwise     = []
		onlyHost ts = concatMap onlyHost' ts
		onlyProc ts = concatMap onlyProc' ts
#ifdef	DEBUG
		(procInTokens,fifoInfo) = fifo procWidth inTokens procTokens procCTS
		(procOutTokens,procCTS,procInfo) = proc procInTokens (constS True)
		info = combineInfos [
				 fifoInfo
				,procInfo
			]
#else
		(procInTokens) = fifo procWidth inTokens procTokens procCTS
		(procOutTokens,procCTS,procInfo) = proc procInTokens (constS True)
#endif

-------------------------------------------------------------------------------
-- Runner of the DFL system.

dflSystemRunner config proc (matcher,tokens,hostTokensCount) =
	run 0 maxWait hostTokensCount (toList hostTokens) (toList info)
	where
		debFlag = cfgDebug config
		debShow
			| debFlag = putStrLn
			| otherwise = const $ return ()
		maxWait = cfgMaxWait config
		parametrizedProc = proc matcher
		procWidth = getHierProcWidth config
		takeBy n [] = []
		takeBy n xs = let (h,t) = splitAt n xs in h:takeBy n t
		fromHost = fromListS [] 	$ takeBy procWidth tokens
#ifdef	DEBUG
		(hostTokens,info) = dflSystem procWidth parametrizedProc fromHost
#else
		hostTokens = dflSystem procWidth parametrizedProc fromHost
		info = constS ""
#endif
		run tc _    0        _      _ = putStrLn $ "Total "++show tc++" ticks."
		run tc 0    _        _      _ = putStrLn "Timeout!"
		run tc wait tokCount (t:ts) (i:is) = do
			putStrLn $ "Tick "++show tc++"(remains "++show tokCount++")"++": "++show t
			debShow    i
--			hFlush stdout
			run (tc+1) wait' tokCount' ts is
			where
				wait' = wait - 1
				tokCount' = case t of
					[] -> tokCount
					_  -> tokCount-length t