diff --git a/HaVSA.cabal b/HaVSA.cabal new file mode 100644 --- /dev/null +++ b/HaVSA.cabal @@ -0,0 +1,41 @@ +-- cabal configure --prefix=$HOME --user +-- cabal build +name: HaVSA +version: 0.1 +synopsis: +description: +category: AI +license: BSD3 +License-file: LICENSE +author: Rogan Creswick +maintainer: creswick@gmail.com +Cabal-Version: >=1.8.0.6 +build-type: Simple + +Library + Build-depends: base >= 4 && < 6, + logict >= 0.4.2 && < 0.5 + + Exposed-modules: AI.VersionSpaces + ghc-options: -Wall + hs-source-dirs: src + +Executable tests + Main-Is: Main.hs + hs-source-dirs: tests, + src + + Build-Depends: base >= 4 && < 6, + logict >= 0.4.2 && < 0.5, + QuickCheck >= 1.1 && < 2, + HUnit >= 1.2.2 && < 1.2.3, + test-framework >= 0.3.3 && < 0.4, + test-framework-quickcheck >= 0.2.7 && < 0.3, + test-framework-hunit >= 0.2.6 && < 0.3 + + ghc-options: -Wall + + +source-repository head + type: git + location: git://github.com/creswick/HaVSA.git diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2011, Eugene Rogan Creswick +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + +Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +Neither the name of Eugene Rogan Creswick nor the names of his +contributors may be used to endorse or promote products derived from +this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,18 @@ +import Distribution.Simple +main = defaultMain + +-- import Distribution.Simple +-- import System.Cmd (system) +-- import System.Exit +-- import System + +-- ghcCmd = "ghc --make -odir dist/build -hidir dist/build -idist/build:src src/Unit.hs -main-is Unit.runTests -o unit" + +-- main :: IO () +-- main = defaultMainWithHooks (simpleUserHooks { runTests = quickCheck } ) +-- where +-- quickCheck _ _ _ _ = do ec <- system $ ghcCmd +-- case ec of +-- ExitSuccess -> system "./unit" +-- _ -> return ec +-- return () diff --git a/src/AI/VersionSpaces.hs b/src/AI/VersionSpaces.hs new file mode 100644 --- /dev/null +++ b/src/AI/VersionSpaces.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE GADTs, TypeSynonymInstances, FunctionalDependencies, MultiParamTypeClasses #-} +module AI.VersionSpaces where + +import Control.Arrow ((***)) + +-- | Representation of a traditional version space, as described by +-- Hirsh: Hirsh, H.: 1991, 'Theoretical Underpinnings of Version +-- Spaces'. In: Proceedings of the Twelfth International Joint +-- Conference on Artificial Intelligence. pp. 665–670. +data BSR a i o = EmptyBSR + | BSR { storage :: a + , narrow :: BSR a i o -> i -> o -> BSR a i o + , hypos :: BSR a i o -> [i -> o] + } + +-- | Renders a BSR to a string to show whether the BSR is empty or +-- not. Additional details place undesirable restrictions on the +-- state storage. +showBSR :: BSR a i o -> String +showBSR EmptyBSR = "Empty" +showBSR (BSR _ _ _) = "non-empty" + +-- | Union two versionspaces, generating a third. +union :: VersionSpace a b -> VersionSpace a b -> VersionSpace a b +union Empty y = y +union x Empty = x +union x y = Union x y + +-- | Join two versionspaces, generating a third. +join :: (Eq b, Eq d) => VersionSpace a b -> VersionSpace c d -> VersionSpace (a, c) (b, d) +join Empty _ = Empty +join _ Empty = Empty +join x y = Join x y + +-- | Transform a version space to mutate the input and/or output types. +-- Transforms require that three functions be specified: +-- +-- [@i -> a@] Transform the input of the resulting version space to the input of the initial versionspace. +-- +-- [@o -> b@] Transform the output of the initial versionspace into the output of the resulting versionspace. +-- +-- [@b -> o@] Transform the output of the /resulting/ versionspace +-- into the output of the /initial/ versionspace. This is necessary +-- to support training: the training examples will be in terms of the +-- resulting versionspace, so the output must be transformed back +-- into the terms of the initial versionspace. +tr :: (Eq b) => (i -> a) -> (o -> b) -> (b -> o) -> VersionSpace a b -> VersionSpace i o +tr _ _ _ Empty = Empty +tr tin tout fout vs = Tr tin tout fout vs + +-- | Version Space algebraic operators: +data VersionSpace i o where + -- The empty, or collapsed versionspace. + Empty :: VersionSpace i o + -- A basic leaf versionspace, this just wraps a 'BSR' + VS :: BSR a i o -> VersionSpace i o + -- The Join of two versionspaces. This should not be used directly, rather, use the 'join' function. + Join :: (Eq d, Eq b) => VersionSpace a b -> VersionSpace c d -> VersionSpace (a, c) (b, d) + -- The union of two versionspaces. This should not be used directly, rather, use the 'union' function. + Union :: VersionSpace a b -> VersionSpace a b -> VersionSpace a b + -- The transform of two versionspaces. This should not be used directly, rather, use the 'tr' function. + Tr :: (Eq b) => (i -> a) -> (o -> b) -> (b -> o) -> VersionSpace a b -> VersionSpace i o + +-- | Serializes a versionspace to a human-readable string, for certain values of 'human'. +showVS :: VersionSpace i o -> String +showVS Empty = "Empty" +showVS (VS hs) = showBSR hs +showVS (Union vs1 vs2) = "["++showVS vs1++" U "++showVS vs2++"]" +showVS (Join vs1 vs2) = "["++showVS vs1++" |><| "++showVS vs2++"]" +showVS (Tr _ _ _ vs) = "[TR "++showVS vs++"]" + +-- | Train a version space, reducing the set of valid hypotheses. We +-- handle the Empty VS cases prior to the corresponding non-empty +-- cases because the Empties are simplifying cases, so logic can be +-- short-circuited by collapsing parts of the hierarchy before +-- recursing. +train :: (Eq o) => VersionSpace i o -> i -> o -> VersionSpace i o +train Empty _ _ = Empty +train (VS b) i o = case (narrow b) b i o of + EmptyBSR -> Empty + bsr -> VS bsr + +-- | The join of an empty VS with any other VS is empty. +train (Join Empty _) _ _ = Empty +train (Join _ Empty) _ _ = Empty +train (Join vs1 vs2) (i1,i2) (o1, o2) = join (train vs1 i1 o1) (train vs2 i2 o2) + +-- | Unioning a VS with an empty VS is just the non-empty VS. +train (Union vs1 Empty) _ _ = vs1 +train (Union Empty vs2) _ _ = vs2 +train (Union vs1 vs2) i o = union (train vs1 i o) (train vs2 i o) + +-- | Any transform on an empty VS is just an empty VS. +train (Tr _ _ _ Empty) _ _ = Empty +train (Tr tin tout fout innerVS) i o = tr tin tout fout trainedVS + where trainedVS = train innerVS (tin i) (tout o) + +-- | Retrieve the valid hypotheses for a version space. +hypotheses :: VersionSpace i o -> [(i -> o)] -- could be i -> [o] +hypotheses Empty = [] +hypotheses (VS hs) = (hypos hs) hs +hypotheses (Join vs1 vs2) = zipWith (***) (hypotheses vs1) (hypotheses vs2) +hypotheses (Union vs1 vs2) = hypotheses vs1 ++ hypotheses vs2 +hypotheses (Tr fin _ fout vs) = map (\x->fout . x . fin) $ hypotheses vs + +-- | Runs all valid hypotheses from the version space +-- on the specified input. +runVS :: VersionSpace a b -> a -> [b] +runVS vs input = map (\x->x $ input) $ hypotheses vs + +{- + +Notes regarding error-tolerance: + + * The Similar function happens at the narrowing stage - I think this +can be done in the narrow fun. on BSR. However, this assumes that +user error on different aspects of the input is independent of the +other aspects of error in the same way that the components of the +trained hypotheses are independent. + + * The Aggregate function operates on sets of hypotheses. It +converts a set of hypotheses into a new, potentially smaller, set of +hypotheses. It could probably do better if it could use the +demonstrations to determine the best aggregation. I don't think +Aggregation can happen solely at the leaves (although it may be +worthwhile to aggregate at that level). Rather, I think it may be +necessary to aggregate on higher-evel types. + + This might not be a problem though, since the only reasons I can +think of to aggregate at a higher level are due to dependencies +between sibling version spaces. + +-} diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,11 @@ +module Main where + +import qualified AI.Tests as LogicHelpers +import qualified AI.VersionSpaceTests as VersionSpaces + +import Test.Framework ( defaultMain ) + +main :: IO () +main = defaultMain [ LogicHelpers.tests + , VersionSpaces.tests + ]