Ticket #7211: genstats-simplepatterns.hs

File genstats-simplepatterns.hs, 5.5 KB (added by bartavelle, 23 months ago)

Faulty program.

Line 
1module Main (main) where
2
3import Data.List
4import Control.Monad
5import qualified Data.Map as Map
6import System.Environment
7import System.IO
8import qualified Data.HashMap.Strict as HM
9import Data.Hashable
10import Text.Read
11
12import System.Posix.Process
13
14{- mkv types -}
15data GenType = R | M0 | M1 | M2
16    deriving (Show, Ord, Eq, Read)
17
18data MkvState a = NoState | OneState !a | TwoState !a !a
19    deriving (Show, Ord, Eq, Read)
20
21data LvlState a = LvlState !Int !(MkvState a)
22    deriving (Show, Ord, Eq, Read)
23
24data InnerKey a = Raw | Mkv0 !a | Mkv1 !a !a | Mkv2 !a !a !a | Init0 !a | Init1 !a !a
25    deriving (Show, Ord, Eq, Read)
26
27type InnerStat a = HM.HashMap (InnerKey a) Int
28
29data PatternType = Upper | Lower | Numeric | Special | All
30    deriving (Show, Ord, Eq, Read)
31
32data Stats = Stats
33    !(Map.Map PatternType (InnerStat Char))
34    !(InnerStat PatternType)
35    deriving (Show, Read)
36
37instance (Read k, Read b, Hashable k, Eq k) => Read (HM.HashMap k b) where
38    readPrec = parens $ prec 10 $ do
39        Ident "fromList" <- lexP
40        xs <- readPrec
41        return (HM.fromList xs)
42    readListPrec = readListPrecDefault
43
44instance Hashable a => Hashable (InnerKey a) where
45    hash Raw = 0
46    hash (Mkv0  x)      = hash x
47    hash (Mkv1  x y)    = (hash x) + (hash y)*257
48    hash (Mkv2  x y z)  = (hash x) + (hash y)*257 + (hash z)*79
49    hash (Init0 x)      = hash x + 709
50    hash (Init1 x y)    = (hash x) + (hash y)*257 + 709
51
52instance Hashable a => Hashable (MkvState a) where
53    hash NoState = 0
54    hash (OneState x) = hash x
55    hash (TwoState x y) = (hash x) + (hash y)*257
56
57instance Hashable a => Hashable (LvlState a) where
58    hash (LvlState i s) = (hash s)*499 + (fromIntegral i)
59
60instance Hashable PatternType where
61    hash Upper   = 0
62    hash Lower   = 1
63    hash Numeric = 2
64    hash Special = 3
65    hash All     = 4
66
67gmkv0 :: (Hashable a, Eq a) => [a] -> InnerStat a -> InnerStat a
68gmkv0 !n !e = foldl' (\ !mp !x -> HM.insertWith (+) (Mkv0 x) 1 mp) e n
69gmkv1 :: (Hashable a, Eq a) => [a] -> InnerStat a -> InnerStat a
70gmkv1 !n !e = foldl' (\ !mp (!x,!y) -> HM.insertWith (+) (Mkv1 x y) 1 mp) e (zip n (tail n))
71gmkv2 :: (Hashable a, Eq a) => [a] -> InnerStat a -> InnerStat a
72gmkv2 !n !e = foldl' (\ !mp (!x,!y,!z) -> HM.insertWith (+) (Mkv2 x y z) 1 mp) e (zip3 n (tail n) (tail (tail n)))
73gini0 :: (Hashable a, Eq a) => [a] -> InnerStat a -> InnerStat a
74gini0 !(n:_) !e = HM.insertWith (+) (Init0 n) 1 e
75gini0 _ !e = e
76gini1 :: (Hashable a, Eq a) => [a] -> InnerStat a -> InnerStat a
77gini1 !(m:n:_) !e = HM.insertWith (+) (Init1 m n) 1 e
78gini1 _ !e = e
79
80getPattern :: Char -> PatternType
81getPattern x | (x >= 'a' && x <= 'z') = Lower
82             | (x >= 'A' && x <= 'Z') = Upper
83             | (x >= '0' && x <= '9') = Numeric
84             | otherwise              = Special
85
86breakpatterns :: String -> [(PatternType, String)]
87breakpatterns "" = []
88breakpatterns cs = (curpattern, curpart) : breakpatterns rs
89    where
90        curpattern = getPattern (head cs)
91        (curpart, rs) = break (\x -> getPattern x /= curpattern) cs
92
93--getipatterns :: Map.Map PatternType (InnerStat Char) -> (PatternType, String) -> Map.Map PatternType (InnerStat Char)
94getipatterns :: Map.Map PatternType (InnerStat Char) -> (PatternType, String) -> Map.Map PatternType (InnerStat Char)
95getipatterns !curmap (!curtype, !curstr) = let
96    !curstat = case Map.lookup curtype curmap of
97        Just x  -> x
98        Nothing -> HM.empty
99    !i0 = gmkv0 curstr curstat
100    !i1 = gmkv1 curstr i0
101    !i2 = gmkv2 curstr i1
102    !i3 = gini0 curstr i2
103    !i4 = gini1 curstr i3
104    !out = Map.insert curtype i4 curmap
105    in out
106
107addlinestat :: Stats -> String -> Stats
108addlinestat !(Stats patmkv topmkv) !curline = newstats
109    where
110    !linepatterns = breakpatterns curline :: [(PatternType, String)]
111    !patterns = map (\(!ptype, !str) -> (ptype, str)) linepatterns :: [(PatternType, String)]
112    !onlyptype = map fst patterns   :: [PatternType]
113    !t0 = gmkv0 onlyptype topmkv    :: InnerStat PatternType
114    !t1 = gmkv1 onlyptype t0        :: InnerStat PatternType
115    !t2 = gmkv2 onlyptype t1        :: InnerStat PatternType
116    !t3 = gini0 onlyptype t2        :: InnerStat PatternType
117    !t4 = gini1 onlyptype t3        :: InnerStat PatternType
118    !ntopmkv = t4                   :: InnerStat PatternType
119    !npatmkv = foldl' getipatterns patmkv linepatterns :: Map.Map PatternType (InnerStat Char)
120    !newstats = Stats npatmkv ntopmkv
121
122calcstats :: [String] -> Stats
123calcstats = foldl' addlinestat $! Stats Map.empty HM.empty
124
125downgrade' :: (Show a) => InnerKey a -> Either (MkvState a) (MkvState a)
126downgrade' (Mkv0 _    ) = Right NoState
127downgrade' (Mkv1 x _  ) = Right $ OneState x
128downgrade' (Mkv2 x y _) = Right $ TwoState x y
129downgrade' (Init0 _   ) = Left NoState
130downgrade' (Init1 x _ ) = Left $ OneState x
131downgrade' (_         ) = Right NoState
132
133-- computes log
134gl :: (Eq a, Hashable a, Show a) => InnerStat a -> InnerStat a
135gl mp = let
136    totals = HM.fromListWith (+) $! map (\(x,l) -> (downgrade' x,l)) $! HM.toList mp
137    calclog (k,x) =
138        let ctotal = fromIntegral $! totals HM.! (downgrade' $! k) :: Double
139            r = truncate $! -10 * (log ((fromIntegral x)/ctotal))
140        in if r==0
141            then (k,1)
142            else (k,r)
143    in HM.fromList $! map calclog $! HM.toList mp
144
145main :: IO ()
146main = do
147    (dico:stats:_) <- getArgs
148    getProcessID >>= print
149    fh <- openFile dico ReadMode
150    hSetBinaryMode fh True
151    (Stats p t) <- liftM (calcstats . lines) (hGetContents fh)
152    let !llogstats = Stats (Map.map gl p) (gl t)
153    writeFile stats (show llogstats)