diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,1 @@ +I declare this package as public domain diff --git a/NearContextAlgebra.cabal b/NearContextAlgebra.cabal new file mode 100644 --- /dev/null +++ b/NearContextAlgebra.cabal @@ -0,0 +1,75 @@ +-- Initial NearContextAlgebra.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +-- The name of the package. +name: NearContextAlgebra + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: Context Algebra of near + +-- A longer description of the package. +description: Model of the concept near influenced by several contexts + +-- The license under which the package is +license: BSD3 + +-- The file containing the license text. +license-file: LICENSE +-- license: + +-- The package author(s). +author: juergenhah + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: hahn@geoinfo.tuwien.ac.at + +-- A copyright notice. +-- copyright: + +category: math + +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a +-- README. +-- extra-source-files: + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.10 + + +executable NearContextAlgebra + -- .hs or .lhs file containing the Main module. + main-is: Main.hs + + -- Modules included in this executable, other than Main. + other-modules: NearContext, + NearModel, + NearExemplar + + -- LANGUAGE extensions used by modules in this package. + other-extensions: FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances, DeriveGeneric, InstanceSigs + + -- Other library packages from which modules are imported. + build-depends: ContextAlgebra >=0.1 && <0.2 + , QuickCheck >= 2.6 + , base >=4.7 && <4.8 + , containers >=0.5 && <0.6 + , lattices >=1.3 && <1.4 + , multiset >=0.3 && <0.4 + + -- Directories containing source files. + hs-source-dirs: src + + -- Base language which the package is written in. + default-language: Haskell2010 + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-| +Module : Main +Description : Main module for the model of the exemplars (NearExemplar module) of the concept near influenced by several contexts (NearContext module). Including algebraic test +Maintainer : hahn@geoinfo.tuwien.ac.at +Stability : beta + +Use case of the context algebra for the concept near and the contexts: walking, driving, uphill +-} +module Main where +import ContextLattice +import Model + +import NearContext +import NearExemplar +import NearModel + +-- needed for the function meet +import Algebra.Lattice +-- needed for the algebraic tests +import qualified Data.List as L +import Test.QuickCheck + +-- | print a use case of the model +main = do + putStrLn "Model of the concept near influenced by contexts" + print ctxOne + putStrLn "+++ ALGEBRAIC TESTS FOR CONTEXT LATTICE +++++++" + putStrLn "Idempotency tests:" + testIdemProperty + putStrLn "Commutativity tests:" + testCommProperty + putStrLn "Associativity tests:" + testAssocProperty + putStrLn "+++++++++++++++ MODEL A USE CASE ++++++++++++++" + refineNear + + +refineNear :: IO() +refineNear = do + putStrLn "somebody is looking for a near restaurant, by quering an information retrieval engine" + putStrLn "the problem for the IR is which distance is meant by near" + putStrLn "our model is able to interpret the concept 'near' influenced by several context" + putStrLn "in this situation no context is given, the model can calculate probability values for given distances (exemplars)" + print $ probAllExemplars4Context ctxOne M50 allExperiences + putStrLn "\nthe most probable distance is now: the distance with the highest probability" + print . getMostProbableExemplar . probAllExemplars4Context ctxOne M50 $ allExperiences + putStrLn "+++++++++++++++ adding a CONTEXT +++++++++++++++" + putStrLn "\nfrom a sensor we get context information that the user is walking, therefore the model is able to refine the concept near and influence it with the context near" + print $ probAllExemplars4Context (ctxOne `meet` ctxWalking) M50 allExperiences + putStrLn "the most probable distance is now: the distance with the highest probability" + print . getMostProbableExemplar . probAllExemplars4Context (ctxOne `meet` ctxWalking) M50 $ allExperiences + putStrLn "+++++++++++++++ adding a CONTEXT +++++++++++++++" + putStrLn "\nfrom LIDAR data we know that the user is walking uphill, what can also refine the concept" + print $ probAllExemplars4Context (ctxOne `meet` ctxWalking `meet` ctxUphill) M50 allExperiences + putStrLn "\n the most probable exemplar influenced by the contexts: walking and uphill" + print . getMostProbableExemplar . probAllExemplars4Context (ctxOne `meet` ctxWalking `meet` ctxUphill) M50 $ allExperiences + putStrLn "+++++++++++++++ SUMMARY +++++++++++++++" + putStrLn "\n To summarize, the typicality has changes without context:" + print . getMostProbableExemplar . probAllExemplars4Context ctxOne M50 $ allExperiences + putStrLn "\n influenced by the context walking to:" + print . getMostProbableExemplar . probAllExemplars4Context (ctxOne `meet` ctxWalking) M50 $ allExperiences + putStrLn "\n further refined and influenced by the context walking uphill, the most typical exemplar is:" + print . getMostProbableExemplar . probAllExemplars4Context (ctxOne `meet` ctxWalking `meet` ctxUphill) M50 $ allExperiences + +-- * test algebraic properties +-- | Idempotency test, prints the input values and the result +-- +-- @ +-- Context c `meet` Context c == Context c +-- @ +testIdemPropertyPrinted = verboseCheck (propIdempotent :: Context Transportation -> Bool) + +-- | Idempotency test, prints the result +-- +-- @ +-- Context c `meet` Context c == Context c +-- @ +testIdemProperty = quickCheck (propIdempotent :: Context Transportation -> Bool) + + +-- | Commutative test,prints the input values and the result +-- +-- @ +-- Context x meet Context y == Context y meet Context x +-- @ +testCommPropertyPrinted = verboseCheck (propCommutative :: Context Transportation -> Context Transportation -> Bool) + +-- | Commutative test, prints the result +-- +-- @ +-- Context x meet Context y == Context y meet Context x +-- @ +testCommProperty = quickCheck (propCommutative :: Context Transportation -> Context Transportation -> Bool) + + +-- | Associative test, prints the input values and the result +-- +-- @ +-- Context x `meet` (Context y `meet` Context z) == (Context x `meet` Context y) `meet` Context z +-- @ +testAssocPropertyPrinted = verboseCheck (propAssociative ::Context Transportation -> Context Transportation -> Context Transportation-> Bool) + +-- | Associative test, prints the result +-- +-- @ +-- Context x `meet` (Context y `meet` Context z) == (Context x `meet` Context y) `meet` Context z +-- @ +testAssocProperty = quickCheck (propAssociative ::Context Transportation -> Context Transportation -> Context Transportation-> Bool) + + +-- * functionality of the model + +-- | get all experiences for the context walking +-- +-- >>> printExperiences experiencesWalking +-- (6*)Exp (Ctx [Walking]) 450 m +-- | +-- +--(4*)Exp (Ctx [Walking]) 150 m +-- | | +-- | +--(2*)Exp (Ctx [Walking]) 100 m +-- | | +-- | +--(6*)Exp (Ctx [Walking]) 300 m +-- | +-- +--(3*)Exp (Ctx [Walking,Uphill]) 100 m +-- | +-- +--(1*)Exp (Ctx [Walking]) 5000 m +-- | | +-- | +--(4*)Exp (Ctx [Walking]) 1000 m +-- | | +-- | +--(4*)Exp (Ctx [Walking,Uphill]) 50 m +-- | +-- +--(2*)Exp (Ctx [Walking,Uphill]) 150 m +-- | +-- +--| +-- | +-- +--(1*)Exp (Ctx [Walking,Uphill]) 300 m +experiencesWalking = lambda ctxWalking allExperiences + + +-- | get all experiences for the context driving +-- +-- >>> printExperiences experiencesDriving +-- (2*)Exp (Ctx [Driving,Uphill]) 100 m +-- | +-- +--(1*)Exp (Ctx [Driving]) 450 m +-- | | +-- | +--(3*)Exp (Ctx [Driving]) 150 m +-- | | | +-- | | +--(1*)Exp (Ctx [Driving]) 100 m +-- | | | +-- | | +--(1*)Exp (Ctx [Driving]) 300 m +-- | | +-- | +--(2*)Exp (Ctx [Driving]) 5000 m +-- | | +-- | +--(2*)Exp (Ctx [Driving]) 1000 m +-- | | +-- | +--(2*)Exp (Ctx [Driving]) 10000 m +-- | +-- +--(6*)Exp (Ctx [Driving,Uphill]) 450 m +-- | +-- +--(1*)Exp (Ctx [Driving,Uphill]) 150 m +-- | | +-- | +--| +-- | | +-- | +--(5*)Exp (Ctx [Driving,Uphill]) 300 m +-- | +-- +--(8*)Exp (Ctx [Driving,Uphill]) 5000 m +-- | +-- +--(7*)Exp (Ctx [Driving,Uphill]) 1000 m +-- | +-- +--(5*)Exp (Ctx [Driving,Uphill]) 10000 m +experiencesDriving = lambda ctxDriving allExperiences + + +-- | prints the experiences form the resulting context of driving uphill and driving +-- +-- >>> printExperiences experiencesDrivingUphill +-- (6*)Exp (Ctx [Driving,Uphill]) 450 m +-- | +-- +--(1*)Exp (Ctx [Driving,Uphill]) 150 m +-- | | +-- | +--(2*)Exp (Ctx [Driving,Uphill]) 100 m +-- | | +-- | +--(5*)Exp (Ctx [Driving,Uphill]) 300 m +-- | +-- +--(8*)Exp (Ctx [Driving,Uphill]) 5000 m +-- | +-- +--(7*)Exp (Ctx [Driving,Uphill]) 1000 m +-- | +-- +--(5*)Exp (Ctx [Driving,Uphill]) 10000 m +experiencesDrivingUphill = lambda (ctxDrivingUphill `meet` ctxDriving) allExperiences + + +-- | sum the experiences for the context one +sumExp4Contexts ::((BoundedMeetSemiLattice TransportationContext))=> [([Transportation],Int)] +sumExp4Contexts= zipWith (\sum ctx -> (ctx,sum)) s c + where s = map ((amountExperiences . flip lambda allExperiences). Ctx) c + c = extractContext ctxOne diff --git a/src/NearContext.hs b/src/NearContext.hs new file mode 100644 --- /dev/null +++ b/src/NearContext.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-| +Module : NearContext +Description : declares all data types to represent the contexts used in the near example +Maintainer : hahn@geoinfo.tuwien.ac.at +Stability : beta + +Models the contexts of the concept near +-} +module NearContext (Transportation(..),TransportationContext(..), universe, top, arbitrary) where + +import ContextLattice + +import Algebra.Enumerable +import Algebra.Lattice +import qualified Data.List as L +import Test.QuickCheck + + +-- * the context type used to model the concept near +-- | this data type represents all contexts that are used in the near model, make sure to derive all the type classes +data Transportation = + -- | constructor represents the context walking + Walking + -- | constructor represents the context driving + | Driving + -- | constructor for the context uphill + | Uphill + deriving (Show,Eq,Ord,Enum,Bounded) + +-- | type synonym +type TransportationContext = Context Transportation + +-- | to provide the model with the function universe we make an instance of Enumerable from the Algebra.Enumerable module +instance Enumerable Transportation where + -- | returns all contexts, needs the type classes Bounded and Enum to work + -- + -- >>> universe ::[Transportation] + -- [Walking,Driving,Uphill] + universe = universeBounded + +-- | also the wrapped type has to be an instance of Enumerable +instance Enumerable TransportationContext where + + -- | returns all TransportationContexts + -- + -- >>> universe ::[TransportationContext] + -- [Ctx [Walking],Ctx [Driving],Ctx [Walking,Driving],Ctx [Uphill],Ctx [Walking,Uphill],Ctx [Driving,Uphill],Ctx [Walking,Driving,Uphill]] + universe = tail. L.map Ctx . L.subsequences $ (universe::[Transportation]) + +-- | the context type forms a lattice with a upper bound that can be retrieved by the function top +instance BoundedMeetSemiLattice TransportationContext where + + -- | returns the contexts active in the upper contexts, what means no context is active, synonym for one in my thesis + -- + -- >>> top ::TransportationContext + -- One [Ctx [Walking],Ctx [Driving],Ctx [Walking,Driving],Ctx [Uphill],Ctx [Walking,Uphill],Ctx [Driving,Uphill],Ctx [Walking,Driving,Uphill]] + top = One (universe::[Context Transportation]) + + + + + + + diff --git a/src/NearExemplar.hs b/src/NearExemplar.hs new file mode 100644 --- /dev/null +++ b/src/NearExemplar.hs @@ -0,0 +1,50 @@ +{-| +Module : NearExemplar +Description : declares the exemplars used for the near Model +License : GPL-3 +Maintainer : hahn@geoinfo.tuwien.ac.at +Stability : Declares + +Includes all data types and functions needed by the near Model module. +The exemplars are represented by a data type deriving some type classes. +-} +module NearExemplar where +-- | This data defines the exemplars that are handled by the model +-- be sure to have for all of these frequency values. +-- The data type must derive following type classes: +-- (Show, Eq, Ord, Enum,Bounded) +data Exemplar = + -- | represents the fifty metres exemplar + M50 + -- | represents the 100 metres exemplar + | M100 + -- | represents the 150 metres exemplar + | M150 + -- | represents the 300 metres exemplar + | M300 + -- | represents the 450 metres exemplar + | M450 + -- | represents the 450 metres exemplar + | M1000 + -- | represents the 5000 metres exemplar + | M5000 + -- | represents the 10.000 metres exemplar + | M10000 + deriving (Eq, Ord, Enum,Bounded) + +-- | returns a list of the exemplars +-- +-- >>> exemplars +-- [M50,M100,M150,M300,M450,M1000,M5000,M10000] +exemplars = enumFromTo minBound $ maxBound `asTypeOf` M50 + +-- | pretty print for the Exemplar type +instance Show Exemplar where + show M50 = "50 m" + show M100 = "100 m" + show M150 = "150 m" + show M300 = "300 m" + show M450 = "450 m" + show M1000= "1000 m" + show M5000 = "5000 m" + show M10000 = "10000 m" diff --git a/src/NearModel.hs b/src/NearModel.hs new file mode 100644 --- /dev/null +++ b/src/NearModel.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-| +Module : NearModel +Description : declaring all functions +License : GPL-3 +Maintainer : hahn@geoinfo.tuwien.ac.at +Stability : Declares + +define most functions and frequency values +-} +module NearModel (allExperiences, ctxOne, ctxWalking, ctxDriving, ctxUphill + , ctxWalkingDriving, ctxWalkingUphill, ctxDrivingUphill + , ctxWalkingDrivingUphill, ctxZero) where + +import ContextLattice +import Model +import NearContext +import NearExemplar + +import Algebra.Lattice +import qualified Data.MultiSet as Mset +import Test.QuickCheck + +-- | instance declaration for the transportation context +-- , needed to have the functions: lambda, mu and the meet present +instance InterpretationModel TransportationContext Exemplar + + + +-- * frequencies for contexts and exemplars +-- | list of observation frequencies for a particular context, the order equals the order of the exemplars +-- +-- >>> zipWith (\exe frq-> (exe,frq)) exemplars frqWalking +-- [(50 m,0),(100 m,2),(150 m,4),(300 m,6),(450 m,6),(1000 m,4),(5000 m,1),(10000 m,0)] +frqWalking= [0,2,4,6,6,4,1,0] +frqUphill= [0,2,3,0,0,1,1,0] +frqDriving= [0,1,3,1,1,2,2,2] +frqWalkingUphill= [4,3,2,1,0,0,0,0] +frqDrivingUphill= [0,2,1,5,6,7,8,5] +frqWalkingDriving= [0,0,0,0,0,0,0,0] +frqWalkingDrivingUphill= [0,0,0,0,0,0,0,0] + +-- * wrap the basic types into the context type +-- | context type for walking +-- +-- >>> ctxWalking +-- Ctx [Walking] +ctxWalking = Ctx [Walking] +ctxDriving = Ctx [Driving] +ctxUphill = Ctx [Uphill] + +-- | example of an combined context of walking and uphill +-- +-- >>> ctxWalkingUphill +-- Ctx [Walking, Uphill] +ctxWalkingUphill = Ctx [Walking, Uphill] +ctxDrivingUphill = Ctx [Driving, Uphill] +ctxWalkingDriving = Ctx [Walking, Driving] +ctxWalkingDrivingUphill = Ctx [Walking,Driving,Uphill] + +-- | top element of the lattice, equals the One context +-- +-- >>> ctxOne +-- One [Ctx [Walking],Ctx [Driving],Ctx [Walking,Driving],Ctx [Uphill],Ctx [Walking,Uphill],Ctx [Driving,Uphill],Ctx [Walking,Driving,Uphill]] +ctxOne = top :: Context Transportation + +-- | bottom element of the lattice, equals the Zero context +-- +-- >>> ctxZero +-- Zero +ctxZero = Zero :: Context Transportation + + +-- | produce a generator for the input contexts, this values are used by quickCheck +instance Arbitrary (Context Transportation) where + -- | represents a list of all possible contexts + arbitrary = elements [ ctxOne, ctxWalking, ctxDriving, ctxUphill + , ctxWalkingDriving, ctxWalkingUphill, ctxDrivingUphill + , ctxWalkingDrivingUphill, ctxZero] + + +-- * initialization of experiences +-- | creates a multiset including all exemplars and frequency values for the context walking +-- +-- >>> printExperiences walkingExperiences +-- (6*)Exp (Ctx [Walking]) 450 m +-- | +-- +--(4*)Exp (Ctx [Walking]) 150 m +-- | | +-- | +--(2*)Exp (Ctx [Walking]) 100 m +-- | | +-- | +--(6*)Exp (Ctx [Walking]) 300 m +-- | +-- +--(1*)Exp (Ctx [Walking]) 5000 m +-- | +-- +--(4*)Exp (Ctx [Walking]) 1000 m +-- | +-- +--| +expWalking = createExperiencesForContext ctxWalking exemplars frqWalking + +-- | creates the multiset for the context uphill +-- +-- >>> printExperiences expUphill +-- (3*)Exp (Ctx [Uphill]) 150 m +-- | +-- +--(2*)Exp (Ctx [Uphill]) 100 m +-- | +-- +--(1*)Exp (Ctx [Uphill]) 5000 m +-- | +-- +--(1*)Exp (Ctx [Uphill]) 1000 m +-- | +-- +--| +expUphill = createExperiencesForContext ctxUphill exemplars frqUphill + +-- | creates the multiset for the context driving +-- +-- >>> printExperiences expDriving +-- (1*)Exp (Ctx [Driving]) 450 m +-- | +-- +--(3*)Exp (Ctx [Driving]) 150 m +-- | | +-- | +--(1*)Exp (Ctx [Driving]) 100 m +-- | | +-- | +--(1*)Exp (Ctx [Driving]) 300 m +-- | +-- +--(2*)Exp (Ctx [Driving]) 5000 m +-- | +-- +--(2*)Exp (Ctx [Driving]) 1000 m +-- | +-- +--(2*)Exp (Ctx [Driving]) 10000 m +expDriving = createExperiencesForContext ctxDriving exemplars frqDriving + +expWalkingUphill = createExperiencesForContext ctxWalkingUphill exemplars frqWalkingUphill +expDrivingUphill = createExperiencesForContext ctxDrivingUphill exemplars frqDrivingUphill +expWalkingDriving = createExperiencesForContext ctxWalkingDriving exemplars frqWalkingDriving +expWalkingDrivingUphill= createExperiencesForContext ctxWalkingDrivingUphill exemplars frqWalkingDrivingUphill + + +-- | resulting multiset including all experiences for all contexts +-- +-- >>> printExperiences allExperiences +-- (1*)Exp (Ctx [Driving]) 450 m +-- | +-- +--(6*)Exp (Ctx [Walking]) 450 m +-- | | +-- | +--(4*)Exp (Ctx [Walking]) 150 m +-- | | | +-- | | +--(2*)Exp (Ctx [Walking]) 100 m +-- | | | +-- | | +--(6*)Exp (Ctx [Walking]) 300 m +-- | | +-- | +--(1*)Exp (Ctx [Walking,Uphill]) 300 m +-- | | +-- | +--(1*)Exp (Ctx [Walking]) 5000 m +-- | | | +-- | | +--(4*)Exp (Ctx [Walking]) 1000 m +-- | | | +-- | | +--(3*)Exp (Ctx [Walking,Uphill]) 100 m +-- | | | +-- | | +--(4*)Exp (Ctx [Walking,Uphill]) 50 m +-- | | | +-- | | +--(2*)Exp (Ctx [Walking,Uphill]) 150 m +-- | | +-- | +--(3*)Exp (Ctx [Driving]) 150 m +-- | | +-- | +--(1*)Exp (Ctx [Driving]) 100 m +-- | | +-- | +--(1*)Exp (Ctx [Driving]) 300 m +-- | +-- +--(6*)Exp (Ctx [Driving,Uphill]) 450 m +-- | +-- +--(2*)Exp (Ctx [Driving,Uphill]) 100 m +-- | | +-- | +--(2*)Exp (Ctx [Driving]) 5000 m +-- | | | +-- | | +--(2*)Exp (Ctx [Driving]) 1000 m +-- | | | +-- | | +--(2*)Exp (Ctx [Driving]) 10000 m +-- | | +-- | +--(1*)Exp (Ctx [Driving,Uphill]) 150 m +-- | | +-- | +--| +-- | | +-- | +--(5*)Exp (Ctx [Driving,Uphill]) 300 m +-- | +-- +--(3*)Exp (Ctx [Uphill]) 150 m +-- | +-- +--(8*)Exp (Ctx [Driving,Uphill]) 5000 m +-- | | +-- | +--(7*)Exp (Ctx [Driving,Uphill]) 1000 m +-- | | +-- | +--(5*)Exp (Ctx [Driving,Uphill]) 10000 m +-- | | +-- | +--| +-- | | +-- | +--(2*)Exp (Ctx [Uphill]) 100 m +-- | +-- +--(1*)Exp (Ctx [Uphill]) 5000 m +-- | +-- +--(1*)Exp (Ctx [Uphill]) 1000 m +-- | +-- +-- +allExperiences = Mset.unions [expWalking + ,expUphill + ,expDriving + ,expWalkingUphill + ,expDrivingUphill + ,expWalkingDriving + ,expWalkingDrivingUphill] + + + +