HMarkov (empty) → 1.0.0.0
raw patch · 6 files changed
+233/−0 lines, 6 filesdep +HMarkovdep +QuickCheckdep +basesetup-changed
Dependencies added: HMarkov, QuickCheck, base, lens, mtl, random, tasty, tasty-hunit, tasty-quickcheck, vector
Files
- HMarkov.cabal +34/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- src/Data/Markov/HMarkov.hs +47/−0
- src/Data/Markov/HMarkov/Helpers.hs +68/−0
- test/Spec.hs +52/−0
+ HMarkov.cabal view
@@ -0,0 +1,34 @@+name: HMarkov+version: 1.0.0.0+synopsis: Markov-generated sequences+description: Sequences generated by trained Markov models+homepage: https://github.com/swizzard/HMarkov#readme+license: BSD3+license-file: LICENSE+author: Sam Raker+maintainer: sam.raker@gmail.com+copyright: 2016 Sam Raker+category: Text+build-type: Simple+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Data.Markov.HMarkov, Data.Markov.HMarkov.Helpers+ build-depends: base >= 4.7 && < 5, lens, mtl,+ random, vector+ default-language: Haskell2010++test-suite HMarkov-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: base, HMarkov, QuickCheck, tasty, tasty-hunit,+ tasty-quickcheck, random, vector+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/swizzard/HMarkov+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Sam Raker (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Data/Markov/HMarkov.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE FlexibleContexts, TemplateHaskell #-}+module Data.Markov.HMarkov+ (+ MarkovMap(..)+ , MarkovProcess(..)+ , buildMap+ , buildProc+ , runMarkov+ , runUntil+ ) where++import Control.Lens+import Control.Monad.State+import Data.Vector as V+import System.Random+import Data.Markov.HMarkov.Helpers+++data MarkovProcess m a = MarkovProcess { _pMap :: MarkovMap a,+ _g :: StdGen,+ _lastT :: a,+ _acc :: m a }+ deriving (Show)++makeLenses ''MarkovProcess++buildMap :: (Eq a) => V.Vector a -> MarkovMap a+buildMap xs = toMarkovMap $ V.foldl (vApply updateMarkov) (initMap xs) (makeSlices xs)++buildProc :: (Eq a, MonadPlus m) => V.Vector a -> a -> StdGen -> MarkovProcess m a+buildProc xs x gen = MarkovProcess (buildMap xs) gen x mzero++runMarkov :: (Eq a, MonadPlus m) => MarkovProcess m a -> (m a, MarkovProcess m a)+runMarkov p = let (x, g') = random $ p ^. g+ lst = p ^. lastT+ new = getNext lst x $ p ^. pMap+ (acc', m) = p & acc <%~ \ac -> mplus ac $ return lst in+ (acc', m & g .~ g' & lastT .~ new)++runUntil' :: (Eq a, MonadPlus m) => (m a -> Bool) -> MarkovProcess m a -> (m a, MarkovProcess m a)+runUntil' p = runState . fix $+ \continue -> state runMarkov >>=+ \a -> if p a then pure a else continue++runUntil :: (Eq a, MonadPlus m) => (m a -> Bool) -> MarkovProcess m a -> m a+runUntil p m = fst $ runUntil' p m+
+ src/Data/Markov/HMarkov/Helpers.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE TemplateHaskell #-}+module Data.Markov.HMarkov.Helpers+ (+ vApply+ , vidx+ , ded+ , initMap+ , updateMarkov+ , makeSlices+ , nrmlz+ , sumP+ , toMarkovMap+ , pix+ , getNext+ , CountMarkovMap(..)+ , MarkovMap(..)+ ) where++import Control.Lens+import Data.Maybe+import Data.Vector as V++data CountMarkovMap a = CMarkovMap (V.Vector a) (V.Vector (V.Vector Double))++data MarkovMap a = MarkovMap { _idx :: V.Vector a,+ _mMap :: V.Vector (V.Vector Double) }+ deriving (Show)++makeLenses ''MarkovMap++vApply :: (a -> a -> b -> c) -> b -> V.Vector a -> c+vApply f x v = f (v V.! 0) (v V.! 1) x++vidx :: (Eq a) => a -> V.Vector a -> Int+vidx x v = fromJust $ V.elemIndex x v++ded :: (Eq a) => V.Vector a -> V.Vector a+ded = V.foldl f V.empty where+ f accm x = if V.elem x accm then accm else V.snoc accm x++initMap :: (Eq a) => V.Vector a -> CountMarkovMap a+initMap xs = let d = ded xs+ l = V.length xs in+ CMarkovMap d (V.replicate l (V.replicate l 0))++updateMarkov :: (Eq a) => a -> a -> CountMarkovMap a -> CountMarkovMap a+updateMarkov a b (CMarkovMap i m) = CMarkovMap i $ over (ix (vidx a i) . ix (vidx b i)) (+ 1) m++makeSlices :: V.Vector a -> V.Vector (V.Vector a)+makeSlices xs = V.map (\i -> V.slice i 2 xs) $ V.enumFromN 0 (V.length xs - 1)++nrmlz :: V.Vector Double -> V.Vector Double+nrmlz v = V.map (/ V.sum v) v++sumP :: V.Vector Double -> V.Vector Double+sumP v = fst $ V.foldl f (V.empty, 0.0) v where+ f (accm, n) a = if a > 0 then (V.snoc accm (n + a), n + a) else (V.snoc accm 0, n)++toMarkovMap :: CountMarkovMap a -> MarkovMap a+toMarkovMap (CMarkovMap ci cm) = MarkovMap ci $ V.map (sumP . nrmlz) cm++pix :: Double -> V.Vector Double -> Int+pix x = V.ifoldr f 0 where+ f i p a = if x <= p then i else a++getNext :: (Eq a) => a -> Double -> MarkovMap a -> a+getNext t x m = (m ^. idx) V.! (pix x ((m ^. mMap) V.! (vidx t $ m ^. idx)))+
+ test/Spec.hs view
@@ -0,0 +1,52 @@+module Main (main) where++import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck as QC+import Test.QuickCheck.Arbitrary++import Control.Monad (mzero)+import qualified Data.Vector as V+import qualified Data.Foldable as F+import System.Random++import Data.Markov.HMarkov+import Data.Markov.HMarkov.Helpers++main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests" [unitTests, properties]++unitTests = testGroup "unit tests"+ [ testCase "vApply" $ vApply (\a b c -> a + b + c) 3 (fl [1, 2] :: V.Vector Int) @?= 6+ , testCase "vidx" $+ vidx 1 (fl [0, 1, 2]) @?= 1+ , testCase "ded w/dupes" $ ded (fl [0, 1, 1, 2] :: V.Vector Int) @?= fl [0,1,2]+ , testCase "ded w/o dupes" $+ (ded $ fl [0, 1, 2]) @?= fl [0,1,2]+ , testCase "makeSlices" $+ (makeSlices $ fl [0, 1, 2, 3]) @?=+ (fl [(fl [0, 1]), (fl [1, 2]),+ (fl [2, 3])])+ , testCase "nrmlz" $+ (nrmlz $ fl [0.0, 2.0, 3.0]) @?=+ fl [0.0, 0.4, 0.6]+ , testCase "sumP" $ sumP (fl [0.0, 0.1, 0.1, 0.2]) @?=+ fl [0.0, 0.1, 0.2, 0.4]+ , testCase "pix end" $ pix 0.1 (fl [0.0, 0.1]) @?= 1+ , testCase "pix start" $ pix 0.1 (fl [0.1, 0.2]) @?= 0+ , testCase "pix mid" $ pix 0.2 (fl [0.1, 0.2, 0.3]) @?= 1+ , testCase "getNext" $ getNext 'a' 0.1 (MarkovMap (fl ['a', 'b'])+ (fl [fl [0.0, 0.1],+ fl [0.0, 0.0]])) @?= 'b'+ ]++properties = testGroup "properties"+ [ QC.testProperty "runMarkov yields elems from input" $+ \(NonEmpty lst) -> F.and (V.map (flip Prelude.elem (lst :: [Int])) $+ (fst $ runMarkov (bp lst)))+ ]++fl = V.fromList+bp l = buildProc (fl l) (l !! 0) (mkStdGen 0)