HaVSA 0.1 → 0.1.0.1
raw patch · 5 files changed
+294/−1 lines, 5 files
Files
- HaVSA.cabal +6/−1
- src/AI/Examples.hs +89/−0
- src/AI/LogicHelpers.hs +34/−0
- tests/AI/Tests.hs +103/−0
- tests/AI/VersionSpaceTests.hs +62/−0
HaVSA.cabal view
@@ -1,7 +1,7 @@ -- cabal configure --prefix=$HOME --user -- cabal build name: HaVSA-version: 0.1+version: 0.1.0.1 synopsis: <Project description> description: <Project 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,
+ src/AI/Examples.hs view
@@ -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)]
+ src/AI/LogicHelpers.hs view
@@ -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.
+ tests/AI/Tests.hs view
@@ -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+--
+ tests/AI/VersionSpaceTests.hs view
@@ -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]+ }