diff --git a/HaVSA.cabal b/HaVSA.cabal --- a/HaVSA.cabal +++ b/HaVSA.cabal @@ -1,7 +1,7 @@ -- cabal configure --prefix=$HOME --user -- cabal build name: HaVSA -version: 0.1 +version: 0.1.0.1 synopsis: description: category: AI @@ -17,6 +17,9 @@ logict >= 0.4.2 && < 0.5 Exposed-modules: AI.VersionSpaces + Other-modules: AI.Examples, + AI.LogicHelpers + ghc-options: -Wall hs-source-dirs: src @@ -24,6 +27,8 @@ Main-Is: Main.hs hs-source-dirs: tests, src + Other-modules: AI.Tests, + AI.VersionSpaceTests Build-Depends: base >= 4 && < 6, logict >= 0.4.2 && < 0.5, diff --git a/src/AI/Examples.hs b/src/AI/Examples.hs new file mode 100644 --- /dev/null +++ b/src/AI/Examples.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE TypeSynonymInstances, FunctionalDependencies, MultiParamTypeClasses #-} +module AI.Examples where + + +import AI.VersionSpaces +import AI.LogicHelpers (choices, fairInts, observeAll) + +import GHC.Real (infinity) + +-- | Version space that learns fixed or relative +-- offsets into an input region: +sizeVS :: VersionSpace Int Int +sizeVS = (VS intHs) `union` (intFromRatTr $ VS ratHs) + +-- | Transform to adapt Rational VSs to Integral VSs +intFromRatTr :: VersionSpace Rational Rational -> VersionSpace Int Int +intFromRatTr = Tr fromIntegral fromIntegral round + +-- | Define a rectangle type to simplify the syntax and add semantics: +data Rectangle = Rect {x_coord :: Int, + y_coord :: Int, + width :: Int, + height :: Int + } deriving (Show, Eq) + +-- | Define a 2-D Region type, also to add semantics and simplify syntax. +type Region1D = (Int, Int) + +-- | Rectangle VS learns rectangles contained in a rectangular region. +-- This is simply a join of two 1-D regions, wrapped in a transform. +rectangleVS :: VersionSpace Rectangle Rectangle +rectangleVS = rectTr $ region1d `join` region1d + where + rectTr = Tr decompose decompose compose + compose ((x, w), (y, h)) = Rect x y w h + decompose (Rect x y w h) = ((x, w), (y, h)) + +-- | The core components of RectangleVS: (1-D regions) +region1d :: VersionSpace Region1D Region1D +region1d = sizeVS `join` sizeVS -- offset and width. + +-- | Hypothesis space of constant int functions. This is a bit +-- wastefull, since the bounds collapse to be equal on one +-- example. However, it serves as an example of a BSR representation +-- that may be instructive to others. +intHs :: BSR (Int, Int) i Int +intHs = BSR { storage = (minBound :: Int, maxBound :: Int) + , narrow = narrowIntHs + , hypos = hyposIntHs + } + +narrowIntHs :: BSR (Int, Int) i Int -> i -> Int -> BSR (Int, Int) i Int +narrowIntHs EmptyBSR _ _ = EmptyBSR +narrowIntHs (BSR (l, u) f g) _ exOut + | exOut < l || u < exOut = EmptyBSR + | otherwise = BSR (exOut, exOut) f g + +hyposIntHs :: BSR (Int, Int) i Int -> [(i -> Int)] +hyposIntHs EmptyBSR = [] +hyposIntHs (BSR (l,u) _ _) = [\_-> y | y <- observeAll $ fairInts l u] + +-- | Hypothesis space of ratio functions. +ratHs :: BSR (Rational, Rational) Rational Rational +ratHs = BSR { storage = (-infinity, infinity) + , narrow = narrowRatHs + , hypos = hyposRatHs + } + +narrowRatHs :: BSR (Rational, Rational) Rational Rational + -> Rational + -> Rational + -> BSR (Rational, Rational) Rational Rational +narrowRatHs EmptyBSR _ _ = EmptyBSR +narrowRatHs bsr@(BSR (n, d) f g) exIn exOut + | d == infinity = bsr { storage = (exOut, exIn) } + | exOut / exIn == n / d = bsr + | otherwise = EmptyBSR + + +-- | exOut < l || u < exOut = EmptyBSR + -- | otherwise = BSR (exOut, exOut) f g + +-- | TODO ERC: pull in the code that uses Logic to intercalate values from 0. +hyposRatHs :: BSR (Rational, Rational) Rational Rational -> [Rational -> Rational] +hyposRatHs EmptyBSR = [] +-- | TODO ERC: this is not correct.. +hyposRatHs (BSR (n, d) _ _) | d == infinity = [\_-> y | y <- [n .. d]] + | n == 0 = [\_ -> 0] + | otherwise = [\x -> x * (n / d)] diff --git a/src/AI/LogicHelpers.hs b/src/AI/LogicHelpers.hs new file mode 100644 --- /dev/null +++ b/src/AI/LogicHelpers.hs @@ -0,0 +1,34 @@ +module AI.LogicHelpers ( + fairInts + , choices + , absMinVal + , module Control.Monad.Logic + ) where + +import Control.Monad.Logic +import Data.Function (on) + +choices :: MonadPlus m => [a] -> m a +choices = msum . map return + +-- | Generates all @Int@ values in the specified range, inclusive, +-- steadily increasing in absolute value. +fairInts :: Int -> Int -> Logic Int +fairInts a b = return start `mplus` (choices (sTail $ mkList start (max a b)) `interleave` + choices (sTail $ mkList start (min a b))) + where start = absMinVal a b + sTail [] = [] + sTail xs@(x:_) = tail xs + mkList s e = if s > e + then [s, pred s..e] + else [s..e] + +-- | Find the value with minimum absolute value in the range @[a b]@ +absMinVal :: Int -> Int -> Int +absMinVal a b = case (compare `on` signum) a b of + LT -> 0 -- signs are different, so 0 is in the range. + EQ -> case (compare `on` abs) a b of + LT -> a + EQ -> a + GT -> b + GT -> 0 -- signs are different, so 0 is in the range. diff --git a/tests/AI/Tests.hs b/tests/AI/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/AI/Tests.hs @@ -0,0 +1,103 @@ +module AI.Tests where + +import AI.VersionSpaces +import AI.Examples +import AI.LogicHelpers + +import Control.Monad (liftM4, liftM2, liftM) +import Data.List + +import Control.Monad.Logic + +import Test.Framework (defaultMain, testGroup) +-- import Test.Framework.Providers.HUnit +-- import Test.HUnit +import Test.Framework.Providers.QuickCheck (testProperty) + +import Test.QuickCheck + +tests = testGroup "LogicHelpers tests" [ + testGroup "absMinVal properties" [ + testProperty "same sign GT" prop_absMinVal_sameSignGt + , testProperty "same sign LT" prop_absMinVal_sameSignLt + , testProperty "zero-span" prop_absMinVal_span0 + ] + , testGroup "fairInts properties" [ + testProperty "associate" prop_fairInts_associate + , testProperty "unique" prop_fairInts_unique + ] + ] + +prop_absMinVal_sameSignGt :: Int -> Int -> Property +prop_absMinVal_sameSignGt x y = + x > 0 && y > 0 ==> absMinVal x y == min x y + +prop_absMinVal_sameSignLt :: Int -> Int -> Property +prop_absMinVal_sameSignLt x y = + x < 0 && y < 0 ==> absMinVal x y == max x y + +prop_absMinVal_span0 :: Int -> Int -> Property +prop_absMinVal_span0 x y = + signum x /= signum y ==> absMinVal x y == 0 + +prop_fairInts_associate :: Int -> Int -> Property +prop_fairInts_associate x y = + abs (x - y) < 10000 ==> -- stop the tests before they get huge + (observeAll $ fairInts x y) == (observeAll $ fairInts y x) + +prop_fairInts_unique :: Int -> Int -> Property +prop_fairInts_unique x y = + abs (x - y) < 10000 ==> -- stop the tests before they get huge + let ints = (observeAll $ fairInts x y) + in nub ints == ints + + +-- | threw an @*** Exception: Ratio.%: zero denominator@ initially. +checkSizes = let screen800 = Rect 0 0 800 600 + example = (Rect 0 0 80 60) + rvs = train rectangleVS screen800 example + -- this is not yet demanded, because the condition + -- fails too soon: + results = runVS rvs screen800 + in + -- Only 0,0,80x60 is valid, but it can be generated two ways: + (length results == 2) && + (results!!0 == example) && + (results!!1 == example) + +-- arbitraryBSR :: BSR a i o => Gen a +-- arbitraryBSR = oneof [AnyInt, AnyRat] + +-- instance Arbitrary (VersionSpace i o) where +-- arbitrary = sized arbitraryVS + +-- arbitraryVS :: Int -> Gen (VersionSpace i o) +-- arbitraryVS n | n <= 0 = liftM VS arbitraryBSR +-- | otherwise = oneof [ liftM2 join (arbitraryVS n/2) (arbitraryVS n/2) +-- , liftM2 union (arbitraryVS n/2) (arbitraryVS n/2) +-- -- we should reduce the tr size a bit, but halving it may be excessive. +-- , liftM4 tr (return id) (return id) (return id) (arbitraryVS n/2) +-- ] + + +-- Quickcheck property ideas: +-- +-- * every hypotheses is consistent with some training input, or no hypotheses exist: +-- case hypotheses (train v i o) of +-- Empty -> True +-- hs -> map (\f -> f i) hs == take (length hs) $ repeat o +-- +-- * Hypotheses sets shrink monotonically: +-- length $ hypotheses v >= length $ hypotheses $ train v i o +-- +-- * Joining two version spaces results in hypotheses that are the cross product of the inputs. +-- (even if some are Empty) +-- let l1 = length $ hypotheses v1 +-- l2 = length $ hypotheses v2 +-- in l1 * l2 == length $ hypotheses $ join v1 v2 +-- +-- * Unioning two version spaces is additive in the size of the hypotheses. +-- let l1 = length $ hypotheses v1 +-- l2 = length $ hypotheses v2 +-- in l1 + l2 == length $ hypotheses $ union v1 v2 +-- diff --git a/tests/AI/VersionSpaceTests.hs b/tests/AI/VersionSpaceTests.hs new file mode 100644 --- /dev/null +++ b/tests/AI/VersionSpaceTests.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE RankNTypes #-} +module AI.VersionSpaceTests where + +import AI.VersionSpaces +import AI.Examples + +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck (testProperty) + +-- import Test.QuickCheck +import Test.HUnit ( (@=?), Assertion ) + +tests :: Test +tests = testGroup "VersionSpace tests" [ + testCase "Union empties" test_emptyUnion1 + , testCase "Union Empty foo == id" test_emptyUnion2 + , testCase "Union foo Empty == id" test_emptyUnion3 + , testCase "Join Empty foo == Empty" test_emptyJoin1 + , testCase "Join foo Empty == Empty" test_emptyJoin2 + , testCase "Tr doesn't generate hypotheses" test_emptyTRisEmpty + , testProperty "Tr id id id is 'id'" prop_IDtransform + ] + +-- | Check that the union operator on Empty version spaces behaves as expected. +test_emptyUnion1 :: Assertion +test_emptyUnion1 = length [] @=? length (hypotheses $ union Empty Empty) + +test_emptyUnion2 :: Assertion +test_emptyUnion2 = length (hypotheses constIdVS) @=? length (hypotheses $ union Empty constIdVS) + +test_emptyUnion3 :: Assertion +test_emptyUnion3 = length (hypotheses constIdVS) @=? length (hypotheses $ union constIdVS Empty) + +-- | Check that the join operator on Empty version spaces behaves as expected. +test_emptyJoin1 :: Assertion +test_emptyJoin1 = length [] @=? length (hypotheses $ join emptyVS constIdVS) + +test_emptyJoin2 :: Assertion +test_emptyJoin2 = length [] @=? length (hypotheses $ join constIdVS emptyVS) + +test_emptyTRisEmpty :: Assertion +test_emptyTRisEmpty = 0 @=? length (hypotheses $ tr id id id emptyVS) + +prop_IDtransform :: Int -> Int -> Int -> Bool +prop_IDtransform x y z = let vs = VS intHs + vsTr = tr id id id vs + -- | Train and execute a versionspace on the inputs: + eval vs = runVS (train vs x y) z + types = (x :: Int, y :: Int, z :: Int) + in eval vs == eval vsTr + +-- | This is necessary to make the type checker happy in some cases. +emptyVS :: VersionSpace Int Int +emptyVS = Empty + +-- | Version space that always returns @id@ +constIdVS :: VersionSpace Int Int +constIdVS = VS $ BSR { storage = undefined + , narrow = \bsr _ _ -> bsr + , hypos = \_ -> [id] + }