{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-|
    Module      :  Numeric.AERN.Basics.Interval.RefinementOrder
    Description :  interval instances of refinement-ordered structures 
    Copyright   :  (c) Michal Konecny, Jan Duracz
    License     :  BSD3

    Maintainer  :  mikkonecny@gmail.com
    Stability   :  experimental
    Portability :  portable
    
    Interval instances of refinement-ordered structures.
    
    This is a hidden module reexported via its parent.
-}
module Numeric.AERN.Basics.Interval.RefinementOrder where

import Prelude hiding (EQ, LT, GT)

import Numeric.AERN.Basics.Effort 
import Numeric.AERN.Basics.PartialOrdering

import Numeric.AERN.Basics.Interval.Basics
import Numeric.AERN.Basics.Interval.Mutable
import Numeric.AERN.Basics.Interval.NumericOrder

import qualified Numeric.AERN.Basics.NumericOrder as NumOrd
import qualified Numeric.AERN.Basics.RefinementOrder as RefOrd

import Numeric.AERN.Basics.Mutable

import Numeric.AERN.Misc.List

import Test.QuickCheck

import Data.Maybe

instance 
    (NumOrd.PartialComparison e) => 
    (RefOrd.PartialComparison (Interval e))
    where
    type RefOrd.PartialCompareEffortIndicator (Interval e) = 
        NumOrd.PartialCompareEffortIndicator e 
    pCompareDefaultEffort (Interval l r) = 
        NumOrd.pCompareDefaultEffort l
    pCompareEff effort (Interval l1 r1) (Interval l2 r2) =
            case (c l1 l2, c r1 r2) of
                (Just EQ, Just EQ) -> Just EQ
                (Just LT, Just GT) -> Just LT  
                (Just LT, Just EQ) -> Just LT  
                (Just EQ, Just GT) -> Just LT  
                (Just GT, Just LT) -> Just GT  
                (Just GT, Just EQ) -> Just GT  
                (Just EQ, Just LT) -> Just GT  
                (Just _, Just _) -> Just NC  
                _ -> Nothing
            where
            c = NumOrd.pCompareEff effort 
        

instance (NumOrd.HasExtrema e) => (RefOrd.HasTop (Interval e))
    where
    top = Interval NumOrd.greatest NumOrd.least
    
instance (NumOrd.HasExtrema e) => (RefOrd.HasBottom (Interval e))
    where
    bottom = Interval NumOrd.least NumOrd.greatest

instance (NumOrd.HasExtrema e) => (RefOrd.HasExtrema (Interval e))

instance (NumOrd.RoundedLatticeEffort e, NumOrd.PartialComparison e) 
    => RefOrd.OuterRoundedBasisEffort (Interval e)
    where
    type RefOrd.PartialJoinOutEffortIndicator (Interval e) = 
        (NumOrd.MinmaxEffortIndicator e, NumOrd.PartialCompareEffortIndicator e) 
    partialJoinOutDefaultEffort (Interval l r) =
        (NumOrd.minmaxDefaultEffort l, NumOrd.pCompareDefaultEffort l)
    
instance 
    (NumOrd.RoundedLattice e, NumOrd.PartialComparison e) => 
    RefOrd.OuterRoundedBasis (Interval e) 
    where
    partialJoinOutEff (effortMinmax, effortComp) (Interval l1 r1) (Interval l2 r2) = 
            case l <=? r of
                Just True -> Just $ Interval l r
                _ -> Nothing
            where
            (<=?) = NumOrd.pLeqEff effortComp
            l = NumOrd.maxDnEff effortMinmax l1 l2
            r = NumOrd.minUpEff effortMinmax r1 r2

instance (NumOrd.RoundedLatticeEffort e, NumOrd.PartialComparison e) 
    => RefOrd.InnerRoundedBasisEffort (Interval e)
    where
    type RefOrd.PartialJoinInEffortIndicator (Interval e) = 
        (NumOrd.MinmaxEffortIndicator e, NumOrd.PartialCompareEffortIndicator e) 
    partialJoinInDefaultEffort (Interval l r) =
        (NumOrd.minmaxDefaultEffort l, NumOrd.pCompareDefaultEffort l)

instance 
    (NumOrd.RoundedLattice e, NumOrd.PartialComparison e) => 
    RefOrd.InnerRoundedBasis (Interval e)
    where
    partialJoinInEff (effortMinmax, effortComp) (Interval l1 r1) (Interval l2 r2) = 
            case l <=? r of
                Just True -> Just $ Interval l r
                _ -> Nothing
            where
            (<=?) = NumOrd.pLeqEff effortComp
            l = NumOrd.maxUpEff effortMinmax l1 l2
            r = NumOrd.minDnEff effortMinmax r1 r2

instance 
    (NumOrd.RoundedLattice e, NumOrd.PartialComparison e)
    => 
    (RefOrd.RoundedBasis (Interval e)) 

instance
    (NumOrd.RoundedLatticeInPlace e, NumOrd.PartialComparison e) =>
    (RefOrd.OuterRoundedBasisInPlace (Interval e))
    where
    partialJoinOutInPlaceEff (effortMinmax, effortComp) 
            (MInterval resLM resRM) (MInterval l1M r1M) (MInterval l2M r2M) =
        do
        NumOrd.maxDnInPlaceEff effortMinmax resLM l1M l2M
        NumOrd.minUpInPlaceEff effortMinmax resRM r1M r2M
        l <- unsafeReadMutable resLM
        r <- unsafeReadMutable resRM
        let (<=?) = NumOrd.pLeqEff effortComp
        case l <=? r of
            Just True -> return True
            _ -> return False
        
instance
    (NumOrd.RoundedLatticeInPlace e, NumOrd.PartialComparison e) =>
    (RefOrd.InnerRoundedBasisInPlace (Interval e))
    where
    partialJoinInInPlaceEff (effortMinmax, effortComp) 
            (MInterval resLM resRM) (MInterval l1M r1M) (MInterval l2M r2M) =
        do
        NumOrd.maxUpInPlaceEff effortMinmax resLM l1M l2M
        NumOrd.minDnInPlaceEff effortMinmax resRM r1M r2M
        l <- unsafeReadMutable resLM
        r <- unsafeReadMutable resRM
        let (<=?) = NumOrd.pLeqEff effortComp
        case l <=? r of
            Just True -> return True
            _ -> return False

instance 
    (NumOrd.RoundedLatticeInPlace e, NumOrd.PartialComparison e) 
    => 
    (RefOrd.RoundedBasisInPlace (Interval e)) 


instance 
    (NumOrd.RoundedLatticeEffort e) => 
    (RefOrd.OuterRoundedLatticeEffort (Interval e)) 
    where
    type RefOrd.JoinMeetOutEffortIndicator (Interval e) = 
        NumOrd.MinmaxEffortIndicator e
    joinmeetOutDefaultEffort (Interval l r) =
        NumOrd.minmaxDefaultEffort l 

instance 
    (NumOrd.RoundedLattice e) => 
    (RefOrd.OuterRoundedLattice (Interval e)) 
    where
    joinOutEff effort (Interval l1 r1) (Interval l2 r2) =
            Interval l r
            where
            l = NumOrd.maxDnEff effort l1 l2
            r = NumOrd.minUpEff effort r1 r2
    meetOutEff effort (Interval l1 r1) (Interval l2 r2) =
            Interval l r
            where
            l = NumOrd.minDnEff effort l1 l2
            r = NumOrd.maxUpEff effort r1 r2

instance 
    (NumOrd.RoundedLatticeEffort e) => 
    (RefOrd.InnerRoundedLatticeEffort (Interval e)) 
    where
    type RefOrd.JoinMeetInEffortIndicator (Interval e) = 
        NumOrd.MinmaxEffortIndicator e
    joinmeetInDefaultEffort (Interval l r) =
        NumOrd.minmaxDefaultEffort l 

instance 
    (NumOrd.RoundedLattice e) => 
    (RefOrd.InnerRoundedLattice (Interval e)) 
    where
    joinInEff effort (Interval l1 r1) (Interval l2 r2) =
            Interval l r
            where
            l = NumOrd.maxUpEff effort l1 l2
            r = NumOrd.minDnEff effort r1 r2
    meetInEff effort (Interval l1 r1) (Interval l2 r2) =
            Interval l r
            where
            l = NumOrd.minUpEff effort l1 l2
            r = NumOrd.maxDnEff effort r1 r2

instance 
    (NumOrd.RoundedLattice e, NumOrd.PartialComparison e) => 
    (RefOrd.RoundedLattice (Interval e))

instance
    (NumOrd.RoundedLatticeInPlace e) =>
    (RefOrd.OuterRoundedLatticeInPlace (Interval e))
    where
    joinOutInPlaceEff effort 
            (MInterval resLM resRM) (MInterval l1M r1M) (MInterval l2M r2M) =
        do
        NumOrd.maxDnInPlaceEff effort resLM l1M l2M
        NumOrd.minUpInPlaceEff effort resRM r1M r2M
    meetOutInPlaceEff effort 
            (MInterval resLM resRM) (MInterval l1M r1M) (MInterval l2M r2M) =
        do
        NumOrd.minDnInPlaceEff effort resLM l1M l2M
        NumOrd.maxUpInPlaceEff effort resRM r1M r2M

instance
    (NumOrd.RoundedLatticeInPlace e) =>
    (RefOrd.InnerRoundedLatticeInPlace (Interval e))
    where
    joinInInPlaceEff effort 
            (MInterval resLM resRM) (MInterval l1M r1M) (MInterval l2M r2M) =
        do
        NumOrd.maxUpInPlaceEff effort resLM l1M l2M
        NumOrd.minDnInPlaceEff effort resRM r1M r2M
    meetInInPlaceEff effort 
            (MInterval resLM resRM) (MInterval l1M r1M) (MInterval l2M r2M) =
        do
        NumOrd.minUpInPlaceEff effort resLM l1M l2M
        NumOrd.maxDnInPlaceEff effort resRM r1M r2M

instance (NumOrd.ArbitraryOrderedTuple e) => RefOrd.ArbitraryOrderedTuple (Interval e) where
   type RefOrd.Area (Interval e) = NumOrd.Area e
   areaWhole (Interval l r) = NumOrd.areaWhole l
   arbitraryTupleInAreaRelatedBy area = 
       arbitraryIntervalTupleInAreaRefinementRelatedBy (Just area)
   arbitraryTupleRelatedBy = 
       arbitraryIntervalTupleInAreaRefinementRelatedBy Nothing

arbitraryIntervalTupleInAreaRefinementRelatedBy maybeArea indices thinIndices constraints =
    case endpointGens of 
        [] -> Nothing
        _ -> Just $
            do
            gen <- elements endpointGens
            endpointTuple <- gen
            return $ endpointsToIntervals endpointTuple
    where
    endpointGens =
        case maybeArea of
            (Just area) ->
                catMaybes $
                   map (NumOrd.arbitraryTupleInAreaRelatedBy area endpointIndices)
                       endpointConstraintsVersions
            Nothing ->
                catMaybes $
                   map (NumOrd.arbitraryTupleRelatedBy endpointIndices) 
                       endpointConstraintsVersions
    endpointIndices = 
        concat $ map (\ix -> [(ix,-1), (ix,1)]) indices
    endpointsToIntervals [] = []
    endpointsToIntervals (l : r : rest) =
        (Interval l r) : (endpointsToIntervals rest)
    endpointConstraintsVersions =
--        unsafePrintReturn 
--        ("arbitraryIntervalTupleRelatedBy:"
--         ++ "\n indices = " ++ show indices 
--         ++ "\n constraints = " ++ show constraints 
--         ++ "\n endpointIndices = " ++ show endpointIndices 
--         ++ "\n endpointConstraintsVersions = "
--        ) $
        map ((++ thinnessConstraints) . concat) $ 
            combinations $ map intervalConstraintsToEndpointConstraints constraints
    thinnessConstraints = map (\ix -> (((ix,-1),(ix,1)),[EQ])) thinIndices
    intervalConstraintsToEndpointConstraints :: 
        ((ix, ix), [PartialOrdering]) -> [[(((ix,Int), (ix,Int)), [PartialOrdering])]]
    intervalConstraintsToEndpointConstraints ((ix1, ix2),rels) =
        concat $ map forEachRel rels
        where
        endpoints1Comparable = [(((ix1,-1),(ix1, 1)), [EQ,LT,LEE,GT,GEE])]
        endpoints2Comparable = [(((ix2,-1),(ix2, 1)), [EQ,LT,LEE,GT,GEE])]
        endpointsComparable = endpoints1Comparable ++ endpoints2Comparable
        forEachRel EQ = -- both endpoints agree 
            [[(((ix1,-1),(ix2,-1)), [EQ]), (((ix1,1),(ix2,1)), [EQ])]]
        forEachRel GT =  
            -- the interval ix1 is indide ix2, but not equal
            [
                endpointsComparable ++
                [(((ix1,-1),(ix2,-1)), [GT, GEE])] ++ 
                [(((ix1,1),(ix2,1)), [EQ, LT, LEE])]
            ]
            ++
            [
                endpointsComparable ++
                [(((ix1,-1),(ix2,-1)), [EQ, GT, GEE])] ++ 
                [(((ix1,1),(ix2,1)), [LT, LEE])]
            ]
        forEachRel LT =  
            -- the interval ix2 is indide ix1, but not equal
            [
                endpointsComparable ++
                [(((ix2,-1),(ix1,-1)), [GT, GEE])] ++ 
                [(((ix2,1),(ix1,1)), [EQ, LT, LEE])]
            ]
            ++
            [
                endpointsComparable ++
                [(((ix2,-1),(ix1,-1)), [EQ, GT, GEE])] ++ 
                [(((ix2,1),(ix1,1)), [LT, LEE])]
            ]
        forEachRel NC =
            -- either some pair of endpoints is NC:
            [ endpointsComparable ++ [(((ix1,side1), (ix2, side2)),[NC])]  
               | side1 <- [-1,1], side2 <- [-1,1]
            ]
            ++
            -- or the interval ix1 is to the left of ix2
            [
                endpointsComparable ++
                [(((ix1,-1),(ix2,-1)), [LT, LEE]), 
                 (((ix1,1),(ix2,1)), [LT,LEE])]
            ]
            ++
            -- or the interval ix2 is to the left of ix1
            [
                endpointsComparable ++
                [(((ix2,-1),(ix1,-1)), [LT, LEE]), 
                 (((ix2,1),(ix1,1)), [LT,LEE])]
            ]
        forEachRel _ = []