Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 109 lines (91 sloc) 3.651 kb
c0d0e90 @bos Much progress!
authored
1 {-# LANGUAGE BangPatterns, OverloadedStrings, RecordWildCards #-}
2
3 import Data.Bits ((.&.))
4 import Data.Function (on)
5 import MailRank.Functions (every)
6 import Data.Hashable (Hashable(..))
7 import qualified Data.HashMap.Strict as H
8 import Data.List (foldl')
9
10 data Link = Link {
11 sender :: {-# UNPACK #-} !Int
12 , recipient :: {-# UNPACK #-} !Int
13 } deriving (Eq, Show)
14
15 instance Hashable Link where
16 hash Link{..} = hash sender `hashWithSalt` recipient
17 {-# INLINE hash #-}
18 hashWithSalt s Link{..} =
19 s `hashWithSalt` sender `hashWithSalt` recipient
20 {-# INLINE hashWithSalt #-}
21
22 -- | This matrix maps pages to the pages they've linked to. The outer
23 -- vector is indexed by page ID, and the inner contains the ID of
24 -- every page they've linked to.
25 type OutgoingLinks = [[Int]]
26
27 -- | This matrix maps pages to the pages they've been linked from.
28 -- The outer vector is indexed by page ID, and the inner contains
29 -- the ID of every page they've received from.
30 type IncomingLinks = [[Int]]
31
32 -- | Map from page ID to the reciprocal of the number of pages
33 -- they've linked to.
34 type LinkFactors = [Double]
35
36 -- | Indices of silent pages (those that have incoming links, but no
37 -- outgoing links).
38 type Silents = [Int]
39
40 transpose :: OutgoingLinks -> (IncomingLinks, LinkFactors, Silents)
41 transpose outgoingLinks = (incomingLinks, linkFactors, silent)
42 where
43 linkFactors = map (recip . fromIntegral . length) $
44 outgoingLinks
45 silent = map fst . filter (null . snd) . imap (,) $
46 outgoingLinks
47 incomingLinks = generate outgoingLinks $ \i ->
48 maybe [] id $ H.lookup i incoming
49 where incoming = ifoldl' step H.empty outgoingLinks
50 step m0 i = foldl' (\m j -> H.insertWith (++) j [i] m) m0
51
52 data Rank = Rank {
53 rankIter :: {-# UNPACK #-} !Int
54 , rankVector :: [Double]
55 }
56
57 ranks :: IncomingLinks -> LinkFactors -> Silents -> Double
58 -> [Rank]
59 ranks incoming factors silent alpha =
60 iterate iter $ Rank 0 (replicate count (1/n))
61 where
62 iter (Rank k old0) = Rank (k+1) (map step incoming)
63 where
64 step link = h + a + i
65 where
66 h | null link = 0
67 | otherwise = alpha * backpermute old link `dot`
68 backpermute factors link
69 i = (1 - alpha) * sum old / n
70 a | null silent = 0
71 | otherwise = alpha * sum (backpermute old silent) / n
72 old | k .&. 16 == 15 = map (/ sum old0) old0
73 | otherwise = old0
74 count = length factors
75 n = fromIntegral count
76
77 rank :: OutgoingLinks -> Double -> Double -> Rank
78 rank outgoing alpha epsilon = snd . head . filter ((< epsilon * n) . fst) .
79 take 8 . every 10 . zipWith dist xs . tail $ xs
80 where
81 (incoming, factors, silent) = transpose outgoing
82 dist a b = ((distance `on` rankVector) b a, b)
83 xs = ranks incoming factors silent alpha
84 n = fromIntegral (length incoming)
85
86 distance :: [Double] -> [Double] -> Double
87 distance a b = sqrt (d `dot` d)
88 where d = zipWith (-) a b
89
90 dot :: [Double] -> [Double] -> Double
91 dot a b = sum (zipWith (*) a b)
92
93 backpermute :: [a] -> [Int] -> [a]
94 backpermute xs is = map (xs!!) is
95
96 imap :: (Int -> a -> b) -> [a] -> [b]
97 imap f = go 0
98 where go _ [] = []
99 go !i (x:xs) = f i x : go (i+1) xs
100
101 generate :: [b] -> (Int -> a) -> [a]
102 generate xs f = imap (\i _ -> f i) xs
103
104 ifoldl' :: (a -> Int -> b -> a) -> a -> [b] -> a
105 ifoldl' f z0 = go z0 0
106 where go z !i (x:xs) = let !z' = f z i x
107 in go z' (i+1) xs
108 go z _ _ = z
Something went wrong with that request. Please try again.