{-# LANGUAGE DeriveDataTypeable #-}
{-|
    Module      :  Data.Number.ER.RnToRm.BisectionTree.Path
    Description :  addressing and modifying leaves
    Copyright   :  (c) Michal Konecny
    License     :  BSD3

    Maintainer  :  mik@konecny.aow.cz
    Stability   :  experimental
    Portability :  portable

    Utilities for addressing and modifying leaves of 
    binary bisection trees.
-}
module Data.Number.ER.RnToRm.BisectionTree.Path where

import qualified Data.Number.ER.RnToRm.Approx as FA
import qualified Data.Number.ER.Real.Approx as RA
import Data.Number.ER.Real.DomainBox (VariableID(..))
import Data.Number.ER.BasicTypes

import Data.Typeable
import Data.Generics.Basics
import Data.Binary
--import BinaryDerive

{-|
    A path in a binary tree.
    It is used mainly in connection with 'BisectionTree.BisectionTree'.
-}
data BisecTreePath =
     BTP_H | BTP_R BisecTreePath | BTP_L BisecTreePath
     deriving (Eq, Typeable, Data)

{- the following has been generated by BinaryDerive -}     
instance Binary BisecTreePath where
  put BTP_H = putWord8 0
  put (BTP_R a) = putWord8 1 >> put a
  put (BTP_L a) = putWord8 2 >> put a
  get = do
    tag_ <- getWord8
    case tag_ of
      0 -> return BTP_H
      1 -> get >>= \a -> return (BTP_R a)
      2 -> get >>= \a -> return (BTP_L a)
      _ -> fail "no parse"
{- the above has been generated by BinaryDerive -}     
     
instance Show BisecTreePath 
    where
    show BTP_H = ""
    show (BTP_L rest) = "L" ++ show rest
    show (BTP_R rest) = "R" ++ show rest

instance Read BisecTreePath
    where
    readsPrec p ('L' : rest) =
        case readsPrec p rest of
            [(restParsed, s)] -> [(BTP_L restParsed, s)]
            _ -> []
    readsPrec p ('R' : rest) =
        case readsPrec p rest of
            [(restParsed, s)] -> [(BTP_R restParsed, s)]
            _ -> []
    readsPrec p s = [(BTP_H, s)]

{-|
    Assuming that bisection happens at default points as defined by
    'RA.bisectDomain' and starts from the given root interval.
-}
path2dom ::
    (RA.ERIntApprox ira) =>
    ira {-^ root interval -} ->
    BisecTreePath -> 
    ira
path2dom rootdom path =
    p2d path rootdom
    where
    p2d BTP_H acc = acc
    p2d (BTP_L rest) acc = 
        p2d rest $ fst $ RA.bisectDomain Nothing $ acc
    p2d (BTP_R rest) acc = 
        p2d rest $ snd $ RA.bisectDomain Nothing $ acc
             
{-|
    A representation of a binary tree with a hole that
    can be efficiently filled.
-}
data FnZipper f
    = FnZ_H f
    | FnZ_L (FnZipper f) f
    | FnZ_R f (FnZipper f)

{-|
    Lookup a subdomain of a function according to a bisection path.
    Return the restrited function as well as a zipper that allows
    an efficient modification of the function on the looked up
    subdomain.
-}    
lookupSubdomain ::
    (FA.ERFnDomApprox box varid domra ranra fa) =>
    fa ->
    BisecTreePath ->
    (fa, FnZipper fa)
lookupSubdomain fn BTP_H = (fn, FnZ_H fn)
lookupSubdomain fn (BTP_L restPath) =
    (resFn, FnZ_L subZipper hiFn)
    where
    (resFn, subZipper) = lookupSubdomain loFn restPath
    (loFn, hiFn) = FA.bisect defaultVar Nothing fn
lookupSubdomain fn (BTP_R restPath) =
    (resFn, FnZ_R loFn subZipper)
    where
    (resFn, subZipper) = lookupSubdomain hiFn restPath
    (loFn, hiFn) = FA.bisect defaultVar Nothing fn
    
{-|
    Modify a function in its subdomain as expressed by
    the zipper.
-}
updateFnZ ::
    (FA.ERFnDomApprox box varid domra ranra fa) =>
    (FnZipper fa) {-^ a function on a larger domain and a highlighted subdomain -} ->
    fa {-^ a function of the highlighted subdomain -} ->
    fa
updateFnZ (FnZ_H _) fn = fn
updateFnZ (FnZ_L loZipper hiFn) fn =
    FA.unBisect defaultVar (loFn, hiFn)
    where
    loFn = updateFnZ loZipper fn
updateFnZ (FnZ_R loFn hiZipper) fn =
    FA.unBisect defaultVar (loFn, hiFn)
    where
    hiFn = updateFnZ hiZipper fn