module FRP.Reactive.Improving
(
Improving(..), exactly, before, after, minI, maxI
, batch
) where
import Data.Function (on)
import Text.Show.Functions ()
import Control.Applicative (pure,(<$>))
import Data.Unamb (unamb,asAgree,parCommute)
import Test.QuickCheck hiding (evaluate)
import Test.QuickCheck.Checkers
import Test.QuickCheck.Classes
import Test.QuickCheck.Instances.Num
data Improving a = Imp { exact :: a, compareI :: a -> Ordering }
instance Show a => Show (Improving a) where
show = ("Imp "++) . show . exact
exactly :: Ord a => a -> Improving a
exactly a = Imp a (compare a)
before :: Ord a => a -> Improving a
before x = Imp undefined comp
where
comp y | x <= y = LT
| otherwise = undefined
after :: Ord a => a -> Improving a
after x = Imp undefined comp
where
comp y | x >= y = GT
| otherwise = undefined
instance Eq a => Eq (Improving a) where
(==) = parCommute (\ u v -> u `compareI` exact v == EQ)
instance Ord a => Ord (Improving a) where
min = (result.result) fst minI
(<=) = (result.result) snd minI
max = (result.result) fst maxI
minI :: Ord a => Improving a -> Improving a -> (Improving a,Bool)
~(Imp u uComp) `minI` ~(Imp v vComp) = (Imp uMinV wComp, uLeqV)
where
uMinV = if uLeqV then u else v
uLeqV = (vComp u /= LT) `unamb` (uComp v /= GT)
wComp t = minComp `unamb` (uCt `asAgree` vCt)
where
minComp = if uLeqV then uCt else vCt
uCt = uComp t
vCt = vComp t
maxI :: Ord a => Improving a -> Improving a -> (Improving a,Bool)
~(Imp u uComp) `maxI` ~(Imp v vComp) = (Imp uMaxV wComp, uGeqV)
where
uMaxV = if uGeqV then u else v
uGeqV = (vComp u /= GT) `unamb` (uComp v /= LT)
wComp t = maxComp `unamb` (uCt `asAgree` vCt)
where
maxComp = if uGeqV then uCt else vCt
uCt = uComp t
vCt = vComp t
instance Bounded (Improving a) where
minBound = error "minBound not defined on Improving"
maxBound = Imp (error "exact maxBound")
(const GT)
result :: (b -> b') -> ((a -> b) -> (a -> b'))
result = (.)
instance (Ord a, Arbitrary a) => Arbitrary (Improving a) where
arbitrary = exactly <$> arbitrary
coarbitrary = coarbitrary . exact
instance Model (Improving a) a where model = exact
instance EqProp a => EqProp (Improving a) where
(=-=) = (=-=) `on` exact
genGE :: (Arbitrary a, Num a) => Improving a -> Gen (Improving a)
genGE i = add i <$> oneof [pure 0, positive]
add :: Num a => Improving a -> a -> Improving a
add (Imp x comp) dx = Imp (x + dx) (comp . subtract dx)
batch :: TestBatch
batch = ( "Reactive.Improving"
, concatMap unbatch
[ ordI, semanticOrdI, partial ]
)
where
ordI = ord (genGE :: Improving NumT -> Gen (Improving NumT))
semanticOrdI = semanticOrd (undefined :: Improving NumT)
partial :: TestBatch
partial = ( "Partial"
, [ ("min after" , property (minAL :: NumT -> NumT -> Bool))
, ("max before", property (maxAL :: NumT -> NumT -> Bool))
]
)
minAL :: Ord a => a -> a -> Bool
minAL x y = after x `min` after y >= exactly (x `min` y)
maxAL :: Ord a => a -> a -> Bool
maxAL x y = before x `max` before y <= exactly (x `max` y)