diff --git a/hahp-example/Main.hs b/hahp-example/Main.hs --- a/hahp-example/Main.hs +++ b/hahp-example/Main.hs @@ -3,6 +3,7 @@ import Data.Time import HAHP.Algorithm import HAHP.Data +import HAHP.Generator import HAHP.Reporting import HAHP.Sample.Config1 import HAHP.Sample.Config2 @@ -19,8 +20,10 @@ --, (sampleAHPConfig2, sampleAlternatives2) --, (sampleAHPConfig3, sampleAlternatives3) --, (smeConfig, smeAlternatives) - (leaderChoiceTree, leaderChoiceAlternatives) - , (carChoiceTree, carChoiceAlternatives) + --, (leaderChoiceTree, leaderChoiceAlternatives) + --, (carChoiceTree, carChoiceAlternatives) + generateDataSet $ GeneratorParameters True 3 3 100 + ,generateDataSet $ GeneratorParameters False 3 3 100 ] time <- getCurrentTime @@ -28,5 +31,5 @@ putStrLn "" mapM_ (putStrLn . simpleAHPSummary) inputDataSets -simpleAHPSummary :: (AHPTree, [Alternative]) -> String -simpleAHPSummary (ahpTree, alts) = simpleSummary $ simpleAHP ahpTree alts +simpleAHPSummary :: AHPDataSet -> String +simpleAHPSummary dataSet = simpleSummary . simpleAHP $ dataSet diff --git a/hahp.cabal b/hahp.cabal --- a/hahp.cabal +++ b/hahp.cabal @@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: hahp -version: 0.1.2 +version: 0.1.3 synopsis: Analytic Hierarchy Process description: Analytic Hierarchy Process implementation. license: AGPL-3 @@ -22,7 +22,7 @@ library -- other-modules: -- other-extensions: - build-depends: base >=4.7 && <5 , containers, hmatrix, parallel, time + build-depends: base >=4.7 && <5 , containers, hmatrix, parallel, random, time hs-source-dirs: src default-language: Haskell2010 exposed-modules: @@ -31,6 +31,7 @@ HAHP.Algorithm.PriorityVector HAHP.Algorithm.Ranking HAHP.Data + HAHP.Generator HAHP.Reporting HAHP.Sample.Config1 HAHP.Sample.Config2 @@ -40,6 +41,7 @@ HAHP.Sample.SquareMatrixError HAHP.Validation.Alternatives HAHP.Validation.Tree + HAHP.Validation.Unique executable hahp-example main-is: Main.hs diff --git a/src/HAHP/Algorithm.hs b/src/HAHP/Algorithm.hs --- a/src/HAHP/Algorithm.hs +++ b/src/HAHP/Algorithm.hs @@ -14,18 +14,18 @@ -- |This function is a quick way to rank a set of alternatives with AHP algorithm. -- This function call everithing required to configure an execute AHP process. -- If something goes wrong, an error is raised. -simpleAHP :: AHPTree - -> [Alternative] - -> (AHPTree, [Alternative], [TreeError], [AlternativesError]) -simpleAHP ahpTree alts = +simpleAHP :: AHPDataSet + -> (AHPDataSet, [TreeError], [AlternativesError]) +simpleAHP inputDataSet = if null inputTreeErrors && null altsErrors - then (completeTree, ranking, treeErrors, []) - else (ahpTree, alts, inputTreeErrors ++ treeErrors, altsErrors) - where initializedTree = initAHP ahpTree - (completeTree, ranking) = rankAlternatives initializedTree alts + then (processedDataSet, treeErrors, []) + else (inputDataSet, inputTreeErrors ++ treeErrors, altsErrors) + where (ahpTree, alts) = inputDataSet + initializedTree = initAHP ahpTree + processedDataSet = rankAlternatives (initializedTree, alts) --- inputTreeErrors = validateInputAHPTree ahpTree - altsErrors = validateAlternatives ahpTree alts + altsErrors = validateAlternatives inputDataSet treeErrors = if null inputTreeErrors then validateAHPTree initializedTree else [] @@ -38,13 +38,12 @@ -- * Part 2 = dynamic part -rankAlternatives :: AHPTree - -> [Alternative] - -> (AHPTree, [Alternative]) -rankAlternatives ahpTree alts = (rankedAhpTree, reverse sortedRankedAlternatives) - where ranks = concat . toLists . fromJust $ alternativesPriority rankedAhpTree +rankAlternatives :: AHPDataSet + -> AHPDataSet +rankAlternatives (ahpTree, alts) = (rankedAhpTree, sortedRankedAlternatives) + where ranks = concat . toLists . fromJust . alternativesPriority $ rankedAhpTree rankedAhpTree = computeTreeAlternativesPriorities alts ahpTree - sortedRankedAlternatives = map fst . sortOn' snd $ zip alts ranks + sortedRankedAlternatives = reverse . map fst . sortOn' snd $ zip alts ranks -- | Sort a list by comparing the results of a key function applied to each -- element. @sortOn f@ is equivalent to @sortBy . comparing f@, but has the diff --git a/src/HAHP/Algorithm/Consistency.hs b/src/HAHP/Algorithm/Consistency.hs --- a/src/HAHP/Algorithm/Consistency.hs +++ b/src/HAHP/Algorithm/Consistency.hs @@ -3,6 +3,7 @@ computeTreeConsistencies ) where +import Control.Parallel.Strategies import HAHP.Data import Numeric.LinearAlgebra.HMatrix @@ -13,7 +14,7 @@ case ahpTree of (AHPTree _ prefMat _ _ _ children) -> ahpTree { consistencyValue = Just $ matrixConsistency prefMat - , children = map computeTreeConsistencies children + , children = parMap rseq computeTreeConsistencies children } AHPLeaf {} -> ahpTree diff --git a/src/HAHP/Algorithm/PriorityVector.hs b/src/HAHP/Algorithm/PriorityVector.hs --- a/src/HAHP/Algorithm/PriorityVector.hs +++ b/src/HAHP/Algorithm/PriorityVector.hs @@ -4,6 +4,7 @@ priorityVector ) where +import Control.Parallel.Strategies import HAHP.Data import Numeric.LinearAlgebra.HMatrix @@ -12,7 +13,8 @@ case ahpTree of (AHPTree _ prefMat _ _ _ children) -> ahpTree { childrenPriority = Just $ priorityVector prefMat - , children = map computeTreePriorityVectors children + , children = parMap rseq computeTreePriorityVectors children + --, children = map computeTreePriorityVectors children } AHPLeaf {} -> ahpTree diff --git a/src/HAHP/Algorithm/Ranking.hs b/src/HAHP/Algorithm/Ranking.hs --- a/src/HAHP/Algorithm/Ranking.hs +++ b/src/HAHP/Algorithm/Ranking.hs @@ -1,5 +1,6 @@ module HAHP.Algorithm.Ranking where +import Control.Parallel.Strategies import Data.List import qualified Data.Map as M import Data.Maybe @@ -25,14 +26,14 @@ computeChildrenTreeAlternativesPriorities :: [Alternative] -> AHPTree -> AHPTree computeChildrenTreeAlternativesPriorities alts ahpTree = ahpTree { - children = map (computeTreeAlternativesPriorities alts) (children ahpTree) + children = parMap rseq (computeTreeAlternativesPriorities alts) (children ahpTree) } -- * Computation function agregatePriorities :: AHPTree -> PriorityVector agregatePriorities ahpTree = catChildVectors <> childPriorities - where childVectors = map (fromJust . alternativesPriority) (children ahpTree) + where childVectors = parMap rseq (fromJust . alternativesPriority) (children ahpTree) catChildVectors = foldl1 (|||) childVectors childPriorities = fromJust . childrenPriority $ ahpTree @@ -43,8 +44,9 @@ buildAlternativePairwiseMatrix :: AHPTree -> [Alternative] -> Matrix Double buildAlternativePairwiseMatrix ahpTree alts = (length alts >< length alts) matrix - where vals = map (selectIndValue (name ahpTree)) alts + where vals = parMap rseq (selectIndValue (name ahpTree)) alts cartesianProduct = [(x, y) | x <- vals, y <- vals] + -- matrix = parMap rseq operator cartesianProduct matrix = map operator cartesianProduct operator = if maximize ahpTree -- `uncurry` permit the use of an operator on a pair diff --git a/src/HAHP/Data.hs b/src/HAHP/Data.hs --- a/src/HAHP/Data.hs +++ b/src/HAHP/Data.hs @@ -3,6 +3,16 @@ import Data.Map (Map) import Numeric.LinearAlgebra.HMatrix +-- * Data set macro type + +type AHPDataSet = (AHPTree, [Alternative]) + +data GeneratorParameters = GeneratorParameters { randomSize :: Bool + , maxTreeLevels :: Int + , maxLevelChildren :: Int + , maxAlternatives :: Int + } + -- * AHP tree definition data AHPTree = AHPTree { name :: String diff --git a/src/HAHP/Generator.hs b/src/HAHP/Generator.hs new file mode 100644 --- /dev/null +++ b/src/HAHP/Generator.hs @@ -0,0 +1,75 @@ +module HAHP.Generator where + +import Data.List (insert) +import Data.Map (empty, singleton, fromList) +import HAHP.Data +import Numeric.LinearAlgebra.Data (ident, (><)) +import System.IO.Unsafe +import System.Random + +-- * Data set generator + +generateDataSet :: GeneratorParameters + -> AHPDataSet +generateDataSet params = (ahpTree, alternatives) + where ahpTree = generateAHPTree params + alternatives = generateAlternatives params ahpTree + +-- * AHP tree generator + +generateAHPTree :: GeneratorParameters + ->AHPTree +generateAHPTree params = generateAHPTree' params levels [] + where levels = if randomSize params + then unsafeRandomRIO (1, maxTreeLevels params) + else maxTreeLevels params + +generateAHPTree' :: GeneratorParameters + -> Int + -> [Int] + -> AHPTree +generateAHPTree' params maxlevels parentIndexes = if (length parentIndexes) + 1 >= maxlevels + then AHPLeaf treeName True Nothing + else AHPTree { name = treeName + , preferenceMatrix = generateMatrix (childNum) + , consistencyValue = Nothing + , childrenPriority = Nothing + , alternativesPriority = Nothing + , children = children + } + where treeName = if null parentIndexes + then "Global Objective" + else "Node " ++ (concatMap (\x -> show x ++ ".") parentIndexes) + childNum = if randomSize params + then unsafeRandomRIO (1, maxLevelChildren params) + else maxLevelChildren params + children = take childNum $ map (\x -> generateAHPTree' params maxlevels (parentIndexes ++ [x])) [1..] + +generateMatrix :: Int + -> PairwiseMatrix +generateMatrix size = (size> AHPTree + -> [Alternative] +generateAlternatives params ahpTree = take altsNum randomAlts + where altsNum = if randomSize params + then unsafeRandomRIO (1, maxAlternatives params) + else maxAlternatives params + inds = map name . getTreeLeaves $ ahpTree + randomAlts = map (generateAlternative inds) [1..] + +generateAlternative :: [IndicatorName] + -> Int + -> Alternative +generateAlternative indNames index = Alternative name values + where name = "Alternative " ++ show index + values = fromList $ zip indNames randomValues + randomValues = unsafePerformIO . sequence . replicate (length indNames) . randomRIO $ (1, 100) + +-- * Tools + +unsafeRandomRIO :: (Random a) => (a, a) -> a +unsafeRandomRIO range = unsafePerformIO . randomRIO $ range diff --git a/src/HAHP/Reporting.hs b/src/HAHP/Reporting.hs --- a/src/HAHP/Reporting.hs +++ b/src/HAHP/Reporting.hs @@ -21,9 +21,9 @@ ] -- | Print a simple report about an AHP tree and ranking result -simpleSummary :: (AHPTree, [Alternative], [TreeError], [AlternativesError]) -- ^ AHP tree, some alternatives and the result of tree validation +simpleSummary :: (AHPDataSet, [TreeError], [AlternativesError]) -- ^ AHP tree, some alternatives and the result of tree validation -> String -- ^ Report build from input -simpleSummary (ahpTree, alts, treeErrors, altsErrors) = treeSummary ++ altSummary ++ errorSummary ++ "\\newpage \n" +simpleSummary ((ahpTree, alts), treeErrors, altsErrors) = treeSummary ++ altSummary ++ errorSummary ++ "\\newpage \n" where treeSummary = showConfiguration ahpTree altSummary = showAlternatives alts errorSummary = showErrors treeErrors altsErrors diff --git a/src/HAHP/Sample/CarChoice.hs b/src/HAHP/Sample/CarChoice.hs --- a/src/HAHP/Sample/CarChoice.hs +++ b/src/HAHP/Sample/CarChoice.hs @@ -1,7 +1,7 @@ module HAHP.Sample.CarChoice where -import Data.Map -import HAHP.Data +import Data.Map +import HAHP.Data import Numeric.LinearAlgebra.HMatrix carChoiceTree :: AHPTree diff --git a/src/HAHP/Sample/LeaderChoice.hs b/src/HAHP/Sample/LeaderChoice.hs --- a/src/HAHP/Sample/LeaderChoice.hs +++ b/src/HAHP/Sample/LeaderChoice.hs @@ -1,7 +1,7 @@ module HAHP.Sample.LeaderChoice where -import Data.Map -import HAHP.Data +import Data.Map +import HAHP.Data import Numeric.LinearAlgebra.HMatrix leaderChoiceTree :: AHPTree diff --git a/src/HAHP/Validation/Alternatives.hs b/src/HAHP/Validation/Alternatives.hs --- a/src/HAHP/Validation/Alternatives.hs +++ b/src/HAHP/Validation/Alternatives.hs @@ -6,44 +6,39 @@ import HAHP.Data import HAHP.Validation.Unique -validateAlternatives :: AHPTree - -> [Alternative] +validateAlternatives :: AHPDataSet -> [AlternativesError] -validateAlternatives ahpTree alts = validate' ahpTree alts testsList +validateAlternatives dataSet = validate' dataSet testsList -validate' :: AHPTree - -> [Alternative] - -> [AHPTree -> [Alternative] -> Maybe AlternativesError] +validate' :: AHPDataSet + -> [AHPDataSet -> Maybe AlternativesError] -> [AlternativesError] -validate' ahpTree alts checks = catMaybes $ parMap rseq (\check -> check ahpTree alts) checks +validate' dataSet checks = catMaybes $ parMap rseq (\check -> check dataSet) checks -testsList :: [AHPTree -> [Alternative] -> Maybe AlternativesError] +testsList :: [AHPDataSet -> Maybe AlternativesError] testsList = [ noAlternativesTest , alternativesUnicityTest , indicatorsValuesExistenceTest ] -noAlternativesTest :: AHPTree - -> [Alternative] +noAlternativesTest :: AHPDataSet -> Maybe AlternativesError -noAlternativesTest _ alts = +noAlternativesTest (_, alts) = if not . null $ alts then Nothing else Just NoAlternativesError -alternativesUnicityTest :: AHPTree - -> [Alternative] +alternativesUnicityTest :: AHPDataSet -> Maybe AlternativesError -alternativesUnicityTest _ alts = +alternativesUnicityTest (_, alts) = if null repeatedAlternativesNames then Nothing else Just AlternativesUnicityError {repeatedAlternativesNames = repeatedAlternativesNames} where repeatedAlternativesNames = repeated . map altName $ alts -indicatorsValuesExistenceTest :: AHPTree - -> [Alternative] +indicatorsValuesExistenceTest :: AHPDataSet -> Maybe AlternativesError -indicatorsValuesExistenceTest ahpTree alts = +indicatorsValuesExistenceTest (ahpTree, alts) = if null errors then Nothing else Just IndicatorsValuesExistenceError { indValuesErrors = errors} diff --git a/src/HAHP/Validation/Unique.hs b/src/HAHP/Validation/Unique.hs new file mode 100644 --- /dev/null +++ b/src/HAHP/Validation/Unique.hs @@ -0,0 +1,30 @@ +module HAHP.Validation.Unique where + +--import Data.List.Unique +import Data.List (group, sort, sortBy) + +-- * Unique + +-- TO REMOVE +-- https://hackage.haskell.org/package/Unique-0.4.2/docs/src/Data-List-Unique.html#repeated + +sg :: Ord a => [a] -> [[a]] +sg = group . sort + +filterByLength :: Ord a => (Int -> Bool) -> [a] -> [[a]] +filterByLength p = filter (p . length) . sg + +-- | 'repeated' finds only the elements that are present more than once in the list. Example: +-- +-- > repeated "foo bar" == "o" + +repeated :: Ord a => [a] -> [a] +repeated = repeatedBy (>1) + +-- | The repeatedBy function behaves just like repeated, except it uses a user-supplied equality predicate. +-- +-- > repeatedBy (>2) "This is the test line" == " eist" + +repeatedBy :: Ord a => (Int -> Bool) -> [a] -> [a] +repeatedBy p = map head . filterByLength p +