{-----------------------------------------------------------------
 
  (c) 2009 Markus Dittrich 
 
  This program is free software; you can redistribute it 
  and/or modify it under the terms of the GNU General Public 
  License Version 3 as published by the Free Software Foundation. 
 
  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License Version 3 for more details.
 
  You should have received a copy of the GNU General Public 
  License along with this program; if not, write to the Free 
  Software Foundation, Inc., 59 Temple Place - Suite 330, 
  Boston, MA 02111-1307, USA.

--------------------------------------------------------------------}

-- | input file parser 
module InputParser ( input_parser
                   , parse_events 
                   , parse_reaction
                   ) where

-- imports
import Control.Monad
import qualified Data.Map as M
import Prelude
import TokenParser


-- local imports
import ExtraFunctions
import GenericModel
import RpnData
import RpnParser

-- import Debug.Trace


-- | main parser entry point
input_parser :: CharParser ModelState ModelState
input_parser = whiteSpace 
{-               *> many ( choice [ try parse_parameter_def
                                , try parse_molecule_def
                                , try parse_reaction_def
                                , try parse_event_def
                                ])-}
               *> parse_parameter_def
               *> optional (try parse_variable_def)
               *> parse_molecule_def
               *> parse_reaction_def
               *> optional (try parse_event_def)
               *> optional parse_output_def 
               *> eof
               >> getState
            <?> "main parser"



-- | parser for variable definitions
parse_variable_def :: CharParser ModelState ()
parse_variable_def = join ( updateState <$> insert_variables <$>
                            parse_def_block "variables" (many parse_variable) ) 
                  <?> "variable definition block" 

  where
    insert_variables :: [(String, MathExpr)] -> ModelState -> ModelState
    insert_variables theVars state = state { variables = M.fromList theVars }


-- | parser for a single variable definition
parse_variable :: CharParser ModelState (String, MathExpr)
parse_variable = tuple_it <$> ((try parse_variable_name) )
                 <*> (symbol "=" *> parse_variable_definition)
              <?> "variable definition"
  
  where
    tuple_it one two = (one, two)


-- | parser for variable name
parse_variable_name :: CharParser ModelState String
parse_variable_name = identifier 
                   <?> "variable name"


-- | parse the definition for a variable
parse_variable_definition :: CharParser ModelState MathExpr
parse_variable_definition =  (try parse_constant_expression)
                             <|> (braces parse_function_expression)
                         <?> "variable value"


-- | parser for output definitions
parse_output_def :: CharParser ModelState ()
parse_output_def = join ( updateState <$> insert_output_request <$>
                         parse_def_block "output" (parse_output_list) ) 
               <?> "event definitions" 

  where
    insert_output_request :: [String] -> ModelState -> ModelState
    insert_output_request outDataList state = state { outputRequest = outDataList }


-- | parse the list with variables or molecules to be punched to the 
-- output file
parse_output_list :: CharParser ModelState [String]
parse_output_list = brackets (commaSep parse_variable_name)


-- | parser for event definitions
parse_event_def :: CharParser ModelState ()
parse_event_def = join ( updateState <$> insert_events <$>
                         parse_def_block "events" (many parse_events) ) 
               <?> "event definitions" 

  where
    insert_events :: [Event] -> ModelState -> ModelState
    insert_events newEvents state = state { events = newEvents }



-- | parser for individual events
parse_events :: CharParser ModelState Event
parse_events = Event <$> (parse_trigger) <*> (reservedOp "=>" *> parse_actions)
            <?> "reaction event"



-- | parser for an event trigger
parse_trigger :: CharParser ModelState 
                 ([EventTriggerPrimitive], [EventTriggerCombinator])
parse_trigger = braces parse_trigger_expressions
             <?> "event trigger block"



-- | parse a list of trigger expressions
parse_trigger_expressions :: CharParser ModelState 
                             ([EventTriggerPrimitive], [EventTriggerCombinator])
parse_trigger_expressions = combine_it <$> parse_single_trigger_expression 
                            <*> (many parse_boolean_trigger_expression)
                         <?> "event trigger"
  
  where
    combine_it e = foldr (\(x,y) (u,v) -> (x:u,y:v) ) ([e],[])



-- | parse a single trigger expression
parse_single_trigger_expression :: CharParser ModelState EventTriggerPrimitive
parse_single_trigger_expression = 
  EventTriggerPrimitive <$> parse_infix_to_rpn <*> parse_relational
                        <*> parse_infix_to_rpn
                               <?> "single event trigger expression"



-- | parse a single trigger expression prefixed with a && or ||
parse_boolean_trigger_expression :: CharParser ModelState 
                                    (EventTriggerPrimitive, EventTriggerCombinator)
parse_boolean_trigger_expression = 
  tuple_it <$> parse_boolean_combinator <*> parse_single_trigger_expression
                                <?> "boolean trigger expression"

  where
    tuple_it a b = (b,a)



-- | parse a boolean combinator (&& or ||)
parse_boolean_combinator :: CharParser ModelState EventTriggerCombinator
parse_boolean_combinator = try parse_AND <|> parse_OR
                        <?> "boolean combinator"
 


-- | parse an && combinator
parse_AND :: CharParser ModelState EventTriggerCombinator
parse_AND = symbol "&&" *> (pure AndCombinator)
          <?> "&&"
  


-- | parse an || combinator
parse_OR :: CharParser ModelState EventTriggerCombinator
parse_OR = symbol "||" *> (pure OrCombinator)
        <?> "||"



-- | parse a relational expression and return its associated
-- binary function
parse_relational :: CharParser ModelState (Double -> Double -> Bool)
parse_relational =  try ( reservedOp ">=" >> pure (>=) )
                <|> try ( reservedOp "<=" >> pure (<=) )
                <|> try ( reservedOp "==" >> pure (==) )
                <|> ( reservedOp ">" >> pure (>) )
                <|> ( reservedOp "<" >> pure (<) )
                <?> "relational expression"



-- | parser for an event action
parse_actions :: CharParser ModelState [EventAction]
parse_actions = braces parse_action_expressions
            <?> "event action block"



-- | parser for a list of action expressions
parse_action_expressions :: CharParser ModelState [EventAction]
parse_action_expressions = 
  parse_single_action_expression `sepEndBy` semi 
                       <?> "event action expression"


-- | parser for a single event action expression
parse_single_action_expression :: CharParser ModelState EventAction
parse_single_action_expression = EventAction <$> 
  (molname) <*> (reservedOp "=" *> parse_function_expression)
                              <?> "single event action expression"



-- | parser for simulation parameters
parse_parameter_def :: CharParser ModelState ()
parse_parameter_def = parse_def_block "parameters" (many parse_parameters) 
                      *> pure ()
                   <?> "parameter definitions"



-- | parse the individual parameters
parse_parameters :: CharParser ModelState ()
parse_parameters = parse_time
                <|> parse_outputFile
                <|> parse_outputBuffer
                <|> parse_outputFreq
                <|> parse_systemVol
                <?> "time, outputBuffer, systemVol, outputFreq,\
                    \outputFile"



-- | parse the simulation time specs
parse_time :: CharParser ModelState ()
parse_time = join (updateState <$> insert_time 
                   <$> (reserved "time" *> reservedOp "=" 
                        *> parse_number))
  
  where
    insert_time t state = state { maxTime = t }



-- | parse the value of the simulated system volume
parse_systemVol :: CharParser ModelState ()
parse_systemVol = join (updateState <$> insert_volume
                       <$> (reserved "systemVol" *> reservedOp "="
                           *> (parse_positive_number
                             <|> parse_systemVol_nil )))
               <?> "system volume"

  where
    -- needed to avoid monomorphism warning
    parse_systemVol_nil :: CharParser ModelState Double
    parse_systemVol_nil = reserved "nil" *> pure (-1.0)

    insert_volume vol state = state { systemVol = vol }



-- | parse the name of the output file 
-- accepts paths but will NOT create any of the parents
parse_outputFile :: CharParser ModelState ()
parse_outputFile = join (updateState <$> insert_filename
                     <$> (reserved "outputFile" *> reservedOp "="
                          *> parse_filename ))

  where
    insert_filename aName state = state { outfileName = aName }



-- | parse a filename
parse_filename :: CharParser ModelState String
parse_filename = stringLiteral




-- | parse the output iteration specification if present
parse_outputBuffer :: CharParser ModelState ()
parse_outputBuffer = join (updateState <$> insert_outputBuffer
                     <$> (reserved "outputBuffer" *> reservedOp "="
                             *> integer ))

  where
    insert_outputBuffer i state = state { outputBufferSize = i }



-- | parse the output iteration specification if present
parse_outputFreq :: CharParser ModelState ()
parse_outputFreq = join (updateState <$> insert_outputFreq
                        <$> (reserved "outputFreq" *> reservedOp "="
                             *> integer ))

  where
    insert_outputFreq i state = state { outputFreq = i }



-- | parser for molecule definitions
parse_molecule_def :: CharParser ModelState ()
parse_molecule_def = join ( updateState <$> insert_molecules <$> 
                            parse_def_block "molecules" (many parse_molecules)) 
                  <?> "molecule definitions"

  where
    insert_molecules :: [(String, Int)] -> ModelState -> ModelState
    insert_molecules theMols state = 
      state { molCount = M.fromList theMols }



-- | parse a molecule name and the number of molecules of this type
parse_molecules :: CharParser ModelState (String,Int)
parse_molecules = make_molecule <$> (try molname) <*> (symbol "=" *> integer)
                <?> "molecule expression"
  where
    make_molecule mol aCount = (mol,fromInteger aCount)


-- | parser for a molecule name 
-- A molecule name can consist of letters and numbers but has to 
-- start with a letter. The following keywords are reserved
molname :: CharParser ModelState String
molname = identifier
       <?> "molecule name" 


-- | parser for reaction definitions
parse_reaction_def :: CharParser ModelState ()
parse_reaction_def = join ( updateState <$> insert_reactions <$>
                            parse_def_block "reactions" (many parse_reaction) ) 
                  <?> "reaction definitions"
  
  where
    insert_reactions :: [Reaction] -> ModelState -> ModelState
    insert_reactions reacts state = state { reactions = reacts }



-- | parser for a single reaction specification of the type
-- aA + bB + cC + .... -> n1P1 + n2P2 + ......   : rate :
-- NOTE: In order to convert the reaction rates (if requested
--       by the user) we also need to extract the system
--       volume)
parse_reaction :: CharParser ModelState Reaction
parse_reaction = setup_reaction 
                 <$> (parse_react_prod <* reservedOp "->") 
                 <*> parse_react_prod 
                 <*> parse_rate_expression
                 <*> (getState 
                      >>= \(ModelState {systemVol = vol}) -> pure vol)  
  where
    -- | set up a Reaction data structure from the parsed reaction
    setup_reaction r p cin vol = 
      let 
        action  = create_react r p
        hFactor = create_hFact r 
        theRate = if (vol < 0.0) -- no rate conversion for 
                    then cin     -- systemVol = nil
                    else convert_rate cin (M.size r) vol
      in 
        Reaction { rate     = theRate
                 , actors   = hFactor
                 , reaction = action
                 }


    -- | convert reaction propensities into rates if requested
    -- by the user. For constants we simply multiply, for
    -- rate functions we push the neccessary conversion onto
    -- the stack
    convert_rate theConst@(Constant c) order volume =
      case order of
        1 -> theConst
        _ -> Constant $ c/(avogadroNum * volume^(order-1))

    convert_rate theFunc@(Function stack) order volume =
      case order of
        1 -> theFunc
        _ -> let mult = 1.0/(avogadroNum * volume^(order-1)) in
               Function . RpnStack $ (toList stack) 
                                     ++ [Number mult,BinFunc (*)]



    -- | create the list holding the molecule number changes for 
    -- this reactioni. If the net change in molecule number is
    -- zero ( a nop) we remove the action.
    create_react r p = let 
                         reacts = M.map (*(-1)) r 
                       in
                         M.assocs . snd . M.partition (==0)
                          $ M.unionWith (+) reacts p
      


    -- | create the list containing the h factors
    -- WARNING/FIXME: Currently, things are ill defined if the number 
    -- of molecules for species A is below the stoichiometric reactant
    -- coefficient; i.e. if #A = 2 then 3A -> ... does not make sense
    create_hFact :: (M.Map String Int) -> [(String, Double -> Double)]
    create_hFact     = create_hFact_h [] . M.assocs  
    
      where
        create_hFact_h acc [] = acc
        create_hFact_h acc ((k,v):xs) = 
          let 
            v_int = fromIntegral v :: Double
          in
            create_hFact_h ((k,\x -> (1.0/v_int) 
              * generate_lambda v_int x):acc) xs

            where
              generate_lambda :: Double -> Double -> Double
              generate_lambda 1 x   = x
              generate_lambda n x   = (x-n+1) * generate_lambda (n-1) x   


-- | parse list of reactants/products of reaction
-- we expect to parse a stream that looks like
-- n_1 R1 + n_2 R2 + n_3 R3 + .....
-- If n_i is missing we assume it is 1.0
parse_react_prod :: CharParser ModelState (M.Map String Int)
parse_react_prod = (reserved "nil" *> pure (M.empty))
                <|> (M.fromList <$> 
                        ((make_tuple <$> option 1 integer <*> try molname) 
                         `sepBy` reservedOp "+") )
                <?> "reactant or product list"
  
  where
    make_tuple x y = (y, fromInteger x)



-- | parse a number, can be used with 'many' and other parser
-- combinators; integers are automatically promoted to double
parse_number :: CharParser ModelState Double
parse_number = converter <$> naturalOrFloat
            <?> "signed integer or double"
  where
    converter val = case val of
                      Left i  -> (fromInteger i)
                      Right x -> x



-- | parse a positive number, can be used with 'many' and other 
-- parser combinators; integers are automatically promoted to double
parse_positive_number :: CharParser ModelState Double
parse_positive_number = naturalOrFloat 
  >>= \num -> case num of
                Left ival  -> if (ival > 0)
                                then return (fromInteger ival)
                                else pzero
                Right dval -> if (dval > 0)
                                then return dval
                                else pzero

  <?> "unsigned integer or double"         



-- | parser for a def block structure
parse_def_block :: String -> CharParser ModelState a 
                -> CharParser ModelState a
parse_def_block blockName parser = 

  between (reserved "def" *> reserved blockName )
          (reserved "end")
          (parser)
  <?> "parameter definitions"



-- | parse a simple rate expression
-- FIXME: We can not re-use parse_expression below 
-- since currently the order of function/constant parsing 
-- has to be reversed otherwise rates are always parsed
-- as trivial Functions. 
parse_rate_expression :: CharParser ModelState MathExpr
parse_rate_expression = (try (lineToken parse_constant_expression))
                        <|> (lineToken (braces parse_function_expression)) 
                     <?> "constant or function expression"

  where
    lineToken = between (symbol "|") (symbol "|") 


-- | parser for a simple rate constant expression
parse_constant_expression :: CharParser ModelState MathExpr
parse_constant_expression = Constant <$> parse_number
                         <?> "rate constant" 



-- | parser for a rate function
parse_function_expression :: CharParser ModelState MathExpr
parse_function_expression = Function <$> parse_infix_to_rpn
                         <?> "rate function"