Split Main.hs

Replace tabs with spaces. No functional changes.

1 files changed, 129 insertions, 0 deletions

diff --git a/src/Db.hs b/src/Db.hs
new file mode 100644
index 0000000..8f6fdba
--- /dev/null
+++ b/src/Db.hs
@@ -0,0 +1,129 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Db where
+
+import System.FilePath ((<.>), splitExtension)
+import Data.List (nub, sort, sortBy, isPrefixOf)
+import Control.Monad
+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
+
+-- |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) }
+