root/hiersort/sim/Matcher.hs

-- | Matcher.hs
-- A circuit that matches tokens in its' pool and sends pairs (Pair i)
-- into processor.
--
-- 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.

-- The matcher also forwards tokens to other processors if needed.

module Matcher(matcher) where

import Data.List
import Data.Maybe

import Utils
import InterfaceTypes

import S

import Info

-------------------------------------------------------------------------------
-- Matcher function.

matcherF maxlen uplen dnWidth upWidth upPred tokens (allInTokens,(ctsu,pairsAllowed)) = (nextTokens,(((otu,otp),rtr),debInfo))
        where
                -- We're ready to receive tokens when we're not overflown.
                tokensCount = length tokens
                rtr = tokensCount < maxlen
                forceUp = tokensCount >= uplen
                -- Tokens that go up.
                (tokenSentUp,otu)
                        | ctsu = formSentUp (fromWidth upWidth) uplen upPred tokens
                        | otherwise = (tokens,[])
                -- Pairs that go to EU.
                (tokensPairSent,otp) = formPairs tokenSentUp
                -- form pairs.
                maxPairs = min dnWidth pairsAllowed
                formPairs ts = form maxPairs [] ts
                        where
                                form n acc ts
                                        | n <= 0 = (ts,reverse acc)
                                        | otherwise = case formPair upPred ts of
                                                (_,[]) -> (ts,acc)
                                                (ts',ps) -> form (n-length ps) (acc++ps) ts'
                -- Next state of sorted tokens buffer.
                nextTokens = sortBy cmpOrders' $
                        tokensPairSent++allInTokens
                cmpOrders a b = compare (msgOrder a) (msgOrder b)
                cmpOrders' a b = case (upPred a,upPred b) of
                        (False,False) -> cmpOrders a b
                        (True,_) -> GT
                        (_,True) -> LT
                noInfo = ""
                debInfo = "matcher"
                        !#      ("maxlen",maxlen)
--                      ##      ("forceUp",forceUp)
                        ##      ("tokensCount",tokensCount)
--                      ##      ("allInTokens",allInTokens)
--                      ##      ("ctsu",ctsu)
--                      ##      ("pairsAllowed",pairsAllowed)
--                      ##      ("tokens",tokens)
--                      ##      ("tokenSentUp",tokenSentUp)
--                      ##      ("otu",otu)
--                      ##      ("map upPred otu",map upPred otu)
--                      ##      ("otp",otp)
--                      ##      ("upWidth",fromWidth upWidth)
--                      ##      ("tokens",tokens)
--                      ##      ("nextTokens",nextTokens)
--                      ##      ("map upPred nextTokens",map upPred nextTokens)
                        #!      ("rtr",rtr)

-- Helpers.

-- A function to find a pair to execute.
formPair upPred tokens = tryHeadArity tokens
        where
                hostPred (_,HostTok,_,_) = True
                hostPred _               = False
                skipPred =
                        -- hostPred
                        upPred
                tryHeadArity (t@Msg {msgOrder=o0,msgArity=HdA1,msgToken=v0}:ts)
                        | skipPred t = findPair [] tokens
                        | otherwise = (ts,[(P1 v0,o0)])
                tryHeadArity _ = findPair [] tokens
                findPair acc (x0:xs@(x1:xs1)) = case arity0 of
                        A2
                                | orderEq order0 order1 ->
                                        (revacc++xs1,[(P2 v0 v1,order0)])
                                | otherwise -> findPair (x0:acc) xs
                        A1
                                | skipPred x0 -> findPair (x0:acc) xs
                                | otherwise -> (revacc++xs,[(P1 v0,order0)])
                        _ -> findPair (x0:acc) xs
                        where
                                revacc = reverse acc
                                Msg {msgOrder=order0,msgModuleAddr=modn0,msgArity=arity0,msgToken=v0} = x0
                                Msg {msgOrder=order1,msgModuleAddr=modn1,msgArity=arity1,msgToken=v1} = x1
                                --(order1,modn1,arity1,v1) = x1
                findPair acc [x0@Msg {msgOrder=order0,msgModuleAddr=modn0,msgArity=A1,msgToken=v0}]
                        | skipPred x0 =
                                (reverse (x0:acc),[])
                        | otherwise =
                                (reverse acc,[(P1 v0,order0)])
                findPair acc rest = (reverse acc++rest,[])
                orderEq a b = a == b

-- a function to split tokens into sent up and remaining.
formSentUp upWidth uplen upPred tokens =
        (reverse remains,reverse sentUp)
        where
                (sentUp,remains) = form upWidth (length tokens-uplen) [] $ reverse tokens
                -- first case: width exhausted:
                form 0 _ sendAcc remains = (sendAcc,remains)
                -- second case: empty input list.
                form _ _ sendAcc [] = (sendAcc,[])
                -- third case: we still have something to send up.
                form w diff sendAcc xs@(t:ts)
                        | diff > 0 = form (w-1) (diff-1) (t:sendAcc) ts
                        | upPred t = form (w-1) diff (t:sendAcc) ts
                        | otherwise = (sendAcc,xs)

-------------------------------------------------------------------------------
-- Matcher circuit.

matcher maxlen uplen dnWidth upWidth upPred itu itp ctsu ctsp = (otu,otp,rtr,info)
        where
                bus = loopS [] (matcherF maxlen uplen dnWidth upWidth upPred) $
                                zipS allTokens $ zipS ctsu ctsp
                allTokens = zipWithS (++) itu itp
                (resultsBus,info) = unzipS bus
                (outotp,rtr) = unzipS resultsBus
                (otu,otp) = unzipS outotp