summaryrefslogtreecommitdiff
path: root/src/Db.hs
blob: caeaf77715359ad74e8a2c352c97c2d696895439 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
{-# LANGUAGE OverloadedStrings #-}
module Db where

import System.FilePath ((<.>), splitExtension)
import Data.List (nub, sort, sortBy, isPrefixOf)
import Control.Monad
import Data.Maybe (catMaybes)
import Data.Yaml
import Text.Parsec.Error
import Text.ParserCombinators.Parsec.Prim
import Text.BibTeX.Parse
import Text.BibTeX.Entry as E
import qualified Data.Aeson as A
import qualified Data.Map as M

import Util

-- |A MAC protocol/algorithm
data Protocol = Protocol {
    -- |Short protocol name, usually its abbreviation
      pname :: String
    -- |Long protocol name
    , plongname :: Maybe String
    -- |Free-text protocol description
    , pdescription :: Maybe String
    -- |List of publication references describing this protocol
    , pref :: [String]
    -- |Feature references of this protocol
    , pfeatures :: M.Map String (Maybe String)
    -- |List of references to other protocols, usually from the paper’s
    -- “related work” section
    , prelated :: [String]
    -- |Relevance of this protocol, calculated (pun intended)
    , prank :: Float
    } deriving Show

-- |A MAC protocol feature
data Feature = Feature {
    -- |Referenceable name
      fname :: String
    -- |Its description
    , fdescription :: Maybe String
    } deriving Show

-- |The whole database
data Database = Database {
    -- |Key-value pair for each protocol
      dalgos :: M.Map String Protocol
    -- |Global list of available features
    , dfeatures :: M.Map String Feature
    -- |Global list of available publications
    , dpublications :: [T]
    } deriving Show

instance FromJSON Protocol where
    parseJSON (Object v) = Protocol
        <$> v .: "name"
        <*> v .:? "longname"
        <*> v .:? "description"
        <*> v .:? "ref" .!= []
        <*> v .:? "features" .!= M.empty
        <*> v .:? "related" .!= []
        <*> return 0
    parseJSON _          = mzero

instance FromJSON Feature where
    parseJSON (Object v) = Feature
        <$> v .: "name"
        <*> v .:? "description"
    parseJSON _          = mzero

instance FromJSON Database where
    parseJSON (Object v) = Database
        <$> v .: "algos"
        <*> v .: "features"
        <*> pure []
    parseJSON _          = mzero

-- |Find publication with identifier `ident`
findPublication db ident = safeHead $ filter (\x -> ident == E.identifier x) $ dpublications db

-- |Get a list of all publications referenced by proto @p@
protoPublications db p = map (findPublication db) (pref p)

-- |Find all referenced features’ names
referencedFeatures db = nub $ sort $ concat $ map (M.keys . pfeatures) $ M.elems $ dalgos db

-- |Get all features at `level`, starting with 0
getFeaturesByLevel db level = M.filterWithKey (\k v -> countDots k == level) $ dfeatures db
    where
        countDots = length . filter ((==) '.')

-- |Get features by `base` feature
getFeaturesByBase db base = M.filterWithKey (\k v -> (base ++ ".") `isPrefixOf` k) $ dfeatures db

-- |Get number of algorithms in database
algorithmCount db = M.size $ dalgos db

split :: (Eq a) => a -> [a] -> [[a]]
split delim s = let (a, b:bs) = span (/= delim) s in a:split delim bs

-- |Get base of feature
getFeatureBase :: String -> String
getFeatureBase feature = head $ split '.' feature

minMaxPublicationYears db = (firstyear, lastyear)
    where
        pubyears = catMaybes $ map (lookup "year" . E.fields) $ dpublications db
        firstyear = foldr min (head pubyears) (tail pubyears)
        lastyear = foldr max (head pubyears) (tail pubyears)

-- |Read protocol and bib database from file
readDb :: String -> IO Database
readDb f = do
    yamlres <- decodeFileEither f
    --print yamlres
    let
        (Right yamldb) = yamlres
        (basename, _) = splitExtension f
    bibres <- parseFromFile file (basename <.> "bib")
    --print bibres
    let (Right bibdb) = bibres
    return $ calcRank $ yamldb { dpublications = bibdb }

-- |Protocol rank/popularity, uses the pagerank algorithm
calcRank db =
    let
        initalgos = M.mapWithKey initial $ dalgos db
        n = fromIntegral $ M.size $ dalgos db
        d = 0.85
        initial ident p = p { prank = 1.0/n }
        -- Get all incoming references
        pincoming algos ident = filter (\(_, x) -> ident `elem` prelated x) $ M.toList algos
        -- Calculate new rank for p
        modify algos ident p = p { prank = (1-d)/n + d*sum (map inrank (pincoming algos ident)) }
        -- Incoming rank for p
        inrank (_, p) = prank p / fromIntegral (length (prelated p))
        absdiff :: M.Map String Protocol -> (String, Protocol) -> Float
        absdiff b (ident, p) = abs (prank (b M.! ident) - prank p)
        rankdiff :: M.Map String Protocol -> M.Map String Protocol -> Float
        rankdiff a b = 1/n * M.foldlWithKey (\x ident p -> x + absdiff b (ident, p)) 0 a
        iterateUntil fiter fcmp a = let b = fiter a in if fcmp a b then iterateUntil fiter fcmp b else b
        run algos = M.mapWithKey (modify algos) algos
        stop prevalgos algos = rankdiff prevalgos algos > 0.00001
    in db { dalgos = (iterateUntil run stop initalgos) }