AERN-Net-0.2.0: tests/DemoSqrt.hs

{-|
    A simple exact real number network, computing the
    square root of 2 using the continued fraction expansion
    of sqrt(x).
-}
module Main where

import qualified Control.ERNet.Foundations.Manager as MAN
import qualified Control.ERNet.Foundations.Channel as CH
import qualified Control.ERNet.Foundations.Event.Logger as LG
import Control.ERNet.Foundations.Event.JavaScript

import Control.ERNet.Deployment.Local.Manager

import Control.ERNet.Foundations.Protocol
import Control.ERNet.Foundations.Protocol.StandardCombinators
import Control.ERNet.Foundations.Process

import Control.ERNet.Blocks.Basic
import Control.ERNet.Blocks.Control.Basic
import Control.ERNet.Blocks.Real.Basic
import Control.ERNet.Blocks.Real.Protocols

import qualified Data.Number.ER.Real.Approx as RA
import Data.Number.ER.BasicTypes

import qualified Data.Number.ER.Real.DefaultRepr as RATypes


type B = RATypes.BAP
type IRA = RATypes.IRA B
type RA = RATypes.RA B

sampleRA = (0 :: RA)

chtpR = chTIx $ chTReal sampleRA

waitTillEnd = True 
{- 
    Use the above to produce a HTML+JavaScript document for browsing the trace.
    The fixed HTML page "ernet-trace.html" imports the JavaScript file
    "ernet-trace.js", which is generated by this program.
    
    Instead, you can enable the code below for a continual textual log
    to the standard output.  This can be overwhelming but is the only
    option when the network does not terminate correctly.
-}
--waitTillEnd = False

runTheNet = runSqrtIx

main = 
    do
    RA.initialiseBaseArithmetic (0 :: RA)
    (ernetManager, _) <- MAN.new "main"
    let _ = ernetManager :: ManagerLocal
    logger <- runTheNet ernetManager waitTillEnd
    case waitTillEnd of
        True ->
            do
            events <- LG.emptyAndGetEvents logger
            writeFile "ernet-trace.js" $ constructJS events
        False ->
            LG.emptyAndDo logger $ 
                putStrLn . show

runSqrtIx ::
    (MAN.Manager man lg sIn sOut sInAnyProt sOutAnyProt) =>
    man ->
    Bool ->
    IO lg
runSqrtIx ernetManager waitTillEnd =
    MAN.runDialogue 
        ernetManager
        sqrtProcess
        sqrtSockN
        sqrtSockT
        sqrtDialogue
        waitTillEnd

sqrtDialogue makeQueryGetAnswer =
    do
    mapM doQuerySol [3..12]
    return ()
    where
    doQuerySol ix =
        do
        a <- makeQueryGetAnswer $ QAIxQ ix $ QARealQ
        let _ = [a, (QAIxA $ QARealA sampleRA)]
        return ()

sqrtSockT = chtpR
sqrtSockN = 0

sqrtProcess ::
    (CH.Channel sIn sOut sInAnyProt sOutAnyProt) =>
    ERProcess sInAnyProt sOutAnyProt
sqrtProcess =
    subnetProcess
        "SQRT"
        [] -- input sockets
        [(chtpR, resN)] -- output sockets
        -- sub-processes:
        [
         (constantProcess "A" (makeAnswerR (\ix -> RA.setMinGranularity (2 * (effIx2gran ix) + 10) (2::RA))) chtpR
         ,([],     [aN])
         )
        ,
         (passThroughProcess False "A-1" 
            id (\ _ (QAIxA (QARealA r)) -> (QAIxA $ QARealA $ (r::RA) - 1)) 
            chtpR chtpR
         ,([aN],    [aM1N])
         )
        ,
         (passThroughProcess False "X+1" 
            id (\ _ (QAIxA (QARealA r)) -> (QAIxA $ QARealA $ (r::RA) + 1)) 
            chtpR chtpR
         ,([resN],    [resP1N])
         )
        ,
         (passThroughBinaryProcess False "(A-1)/(X+1)"
            (\ qry -> (qry,qry)) 
            (\ _ ((QAIxA (QARealA num)), (QAIxA (QARealA den))) -> (QAIxA $ QARealA $ (num::RA) / den)) 
            (chtpR, chtpR) chtpR
         ,([aM1N, resP1N],    [resM1N])
         )
        ,
         (passThroughProcess False "(A-1)/(X+1) + 1" 
            id (\ _ (QAIxA (QARealA r)) -> (QAIxA $ QARealA $ (r::RA) + 1)) 
            chtpR chtpR
         ,([resM1N],    [resCycleN])
         )
        ,
         (constantProcess "[0,oo]" 
            (\(QAIxQ _ QARealQ) -> (QAIxA $ QARealA $ ((max 0 RA.bottomApprox)::RA))) chtpR
         ,([],    [resInitN])
         )
        ,
         (improverIxSimpleProcess "IMPR"
            chtpR
            (QARealA (0::RA))
         ,([resInitN, resCycleN],    [resN])
         )
        ]
    where
    resN : resInitN : resCycleN : resM1N : resP1N : aM1N : aN
        : _ = [0..]