detrospector (empty) → 0.1

raw patch · 10 files changed

+393/−0 lines, 10 filesdep +basedep +binarydep +bytestringsetup-changed

Dependencies added: base, binary, bytestring, cmdargs, containers, hashable, hashmap, mwc-random, text, zlib

Files

• Detrospector/Main.hs +58/−0
• Detrospector/Modes.hs +21/−0
• Detrospector/Modes/Neolog.hs +42/−0
• Detrospector/Modes/Run.hs +17/−0
• Detrospector/Modes/Train.hs +46/−0
• Detrospector/Types.hs +126/−0
• LICENSE +26/−0
• Setup.hs +4/−0
• detrospector.cabal +47/−0
• detrospector.hs +6/−0

@@ -0,0 +1,58 @@+{-# OPTIONS_GHC+    -fno-warn-missing-fields #-}+module Detrospector.Main(main) where++import Detrospector.Modes++import qualified Detrospector.Modes.Train  as M+import qualified Detrospector.Modes.Run    as M+import qualified Detrospector.Modes.Neolog as M++import qualified System.Console.CmdArgs as Arg+import           System.Console.CmdArgs((+=),Annotate((:=)))++modes :: Annotate Arg.Ann+modes  = Arg.modes_  [train,run,neolog]+      += Arg.program "detrospector"+      += Arg.summary "detrospector: Markov chain text generator"+      += Arg.help    "Build and run Markov chains for text generation"+  where++  train = Arg.record Train{}+    [ num := 4+          += Arg.help "Number of characters lookback"+    , out := error "Must specify output chain"+          += Arg.typFile+          += Arg.help "Write chain to this file" ]+    += Arg.help "Train a Markov chain from standard input"+  +  run = Arg.record Run{}+    [ chain := error "Must specify input chain"+            += Arg.argPos 0+            += Arg.typ "CHAIN_FILE" ]+    += Arg.help "Generate random text"+  +  neolog = Arg.record Neolog{}+    [ chain    := error "Must specify input chain"+               += Arg.argPos 0+               += Arg.typ "CHAIN_FILE"+    , wordFile := "/usr/share/dict/words" --FIXME: platform?+               += Arg.typFile+               += Arg.explicit += Arg.name "w" += Arg.name "words"+               += Arg.help "List of real words, to be ignored"+    , minLen   := 5+               += Arg.explicit += Arg.name "m" += Arg.name "min"+               += Arg.help "Minimum length of a word"+    , maxLen   := 20+               += Arg.explicit += Arg.name "n" += Arg.name "max"+               += Arg.help "Maximum length of a word" ]+    += Arg.help "Invent new words not found in a dictionary"++dispatch :: Mode -> IO ()+dispatch m = case m of+  Train {} -> M.train  m+  Run   {} -> M.run    m+  Neolog{} -> M.neolog m++main :: IO ()+main = Arg.cmdArgs_ modes >>= dispatch

@@ -0,0 +1,21 @@+{-# LANGUAGE+    DeriveDataTypeable #-}+module Detrospector.Modes(Mode(..), ModeFun) where++import Data.Typeable(Typeable)+import Data.Data    (Data    )++data Mode+  = Train   { num      :: Int+            , out      :: FilePath }++  | Run     { chain    :: FilePath }++  | Neolog  { chain    :: FilePath+            , minLen   :: Int+            , maxLen   :: Int+            , wordFile :: FilePath }++  deriving (Show, Typeable, Data)++type ModeFun = Mode -> IO ()

@@ -0,0 +1,42 @@+{-# LANGUAGE+    NamedFieldPuns+  , BangPatterns #-}+module Detrospector.Modes.Neolog(neolog) where++import Detrospector.Types+import Detrospector.Modes++import Data.Char+import Control.Applicative+import qualified Data.HashSet      as HS+import qualified Data.Text.Lazy    as Txt+import qualified Data.Text.Lazy.IO as Txt++-- Generate neologisms.+go :: Mode -> Chain -> RNG -> IO ()+go Neolog{minLen,maxLen,wordFile} c@(Chain n _) g+  = getWords >>= loop where++  getWords = (HS.fromList . map (listToQueue . Txt.unpack) . Txt.lines)+    <$> Txt.readFile wordFile++  loop !wd = do+    xs  <- fmap toLower <$> make emptyQ emptyQ+    wdd <- if (qLength xs >= minLen) && HS.notMember xs wd+      then putStrLn (queueToList xs) >> return (HS.insert xs wd)+      else return wd+    loop wdd++  make !xs !s | qLength xs >= maxLen = return xs+              | otherwise = do+      (x,h) <- pick c s g+      -- give up if we don't use all history+      if (h == qLength s) && isAlpha x+        then make (xs `qSnoc` x) (shift n x s)+        else return xs++go _ _ _ = error "impossible: wrong mode passed to neolog"++neolog :: ModeFun+neolog m@Neolog{chain} = withChain chain $ go m+neolog _ = error "impossible: wrong mode passed to neolog"

@@ -0,0 +1,17 @@+{-# LANGUAGE+    NamedFieldPuns #-}+module Detrospector.Modes.Run(run) where++import Detrospector.Types+import Detrospector.Modes++go :: Chain -> RNG -> IO ()+go c@(Chain n _) g = loop emptyQ where+    loop s = do+      (x,_) <- pick c s g+      putChar x+      loop $! shift n x s++run :: ModeFun+run Run{chain} = withChain chain go+run _ = error "impossible: wrong mode passed to run"

@@ -0,0 +1,46 @@+{-# LANGUAGE+    NamedFieldPuns+  , BangPatterns  #-}+module Detrospector.Modes.Train(train) where++import Detrospector.Types+import Detrospector.Modes++import System.IO+import qualified Data.Text         as TS+import qualified Data.Text.Lazy    as TL+import qualified Data.Text.Lazy.IO as TL+import qualified Data.HashMap      as H+import qualified Data.IntMap       as IM+import qualified Data.Sequence     as S+import qualified Data.Foldable     as F++-- foldl' with progress dots+progFold :: (a -> b -> a) -> a -> [b] -> IO a+progFold f = go where+  go !v []     = return v+  go !v (x:xs) = putChar '.' >> go (f v x) xs++-- Build a Markov chain with n-Char history from some input text.+train :: ModeFun+train Train{num,out} = do+  hSetBuffering stdout NoBuffering+  ys <- TL.getContents+  putStr "Calculating"+  (_,h) <- progFold (TS.foldl' roll) (emptyQ,H.empty) $ TL.toChunks ys+  putStrLn "done."+  writeChain out . Chain num $ H.map cumulate h where++  roll (!s,!h) x+    = (shift num x s, F.foldr (H.alter $ ins x) h $ S.tails s)++  ins x Nothing  = Just $! sing x+  ins x (Just v) = Just $! incr x v++  sing x = IM.singleton (fromEnum x) 1++  incr x = IM.alter f $ fromEnum x where+    f Nothing  = Just 1+    f (Just v) = Just $! (v+1)++train _ = error "impossible: wrong mode passed to train"

@@ -0,0 +1,126 @@+{-# LANGUAGE+    ViewPatterns+  , PatternGuards #-}+{-# OPTIONS_GHC+  -fno-warn-orphans #-}+module Detrospector.Types(+    FreqTable+  , PickTable+  , cumulate+  , RNG+  , Queue, emptyQ, listToQueue, queueToList, qLength, qSnoc+  , shift+  , Chain(..), pick+  , withChain, writeChain) where++import Data.Maybe+import Data.List+import Control.Applicative+import qualified Data.HashMap           as H+import qualified Data.Hashable          as H+import qualified Data.IntMap            as IM+import qualified System.Random.MWC      as RNG+import qualified Data.Sequence          as S+import qualified Data.Foldable          as F+import qualified Data.Binary            as Bin+import qualified Data.ByteString.Lazy   as BSL+import qualified Codec.Compression.GZip as Z++-- This table records character frequency;+-- each Int key is the codepoint of a Char.+type FreqTable = IM.IntMap Int++-- A table for efficiently sampling a finite+-- discrete distribution of Char.+--+-- To sample from (PickTable n im):+-- * Pick random k from [0,n) uniformly+-- * Take value of first key > k+data PickTable = PickTable Int (IM.IntMap Char)+  deriving (Show)++cumulate :: FreqTable -> PickTable+cumulate t = PickTable r $ IM.fromList ps where+  (r,ps) = mapAccumR f 0 $ IM.assocs t+  f ra (x,n) = let rb = ra+n in (rb, (rb, toEnum x))++type RNG = RNG.GenIO++-- Sample from a PickTable.+sample :: PickTable -> RNG -> IO Char+sample (PickTable t im) g = do+  k <- (`mod` t) <$> RNG.uniform g+  case IM.split k im of+    -- last key in im is t, and we know k < t+    -- therefore the right list cannot be empty+    (_, IM.toList -> ((_,x):_)) -> return x+    _ -> error "impossible"++type Queue a = S.Seq a++emptyQ :: Queue a+emptyQ = S.empty++listToQueue :: [a] -> Queue a+listToQueue = S.fromList++queueToList :: Queue a -> [a]+queueToList = F.toList++qLength :: Queue a -> Int+qLength = S.length++qSnoc :: Queue a -> a -> Queue a+qSnoc = (S.|>)++-- Enqueue at one side while dropping from the other+shift :: Int -> a -> Queue a -> Queue a+shift n x q+  | S.length q < n          = q S.|> x+  | (_ S.:< s) <- S.viewl q = s S.|> x+  | otherwise               = q S.|> x++-- The Markov chain itself.+-- (Chain n hm) maps subsequences of up to n Chars to finite+-- Char distributions represented by PickTables in hm.+data Chain = Chain Int (H.HashMap (Queue Char) PickTable)+  deriving (Show)++-- Pick from a chain according to history.  Returns a character+-- and the amount of history actually used.+pick :: Chain -> Queue Char -> RNG -> IO (Char, Int)+pick (Chain _ h) s g = do x <- sample pt g; return (x,hn) where+  (pt, hn) = get s++  -- assumption: map is nonempty for empty key+  get  t = fromMaybe (get $ qTail t) look where+    qTail (S.viewl -> (_ S.:< r)) = r+    qTail _ = error "qTail: empty queue"+    look = do x <- H.lookup t h; return (x, S.length t)++-- orphan instance: make Seq hashable+instance (H.Hashable a) => H.Hashable (S.Seq a) where+  {-# SPECIALIZE instance H.Hashable (S.Seq Char) #-}+  hash = F.foldl' (\acc h -> acc `H.combine` H.hash h) 0++-- orphan instance: Binary serialization of HashMap+instance (Bin.Binary k, Bin.Binary v, H.Hashable k, Ord k)+       => Bin.Binary (H.HashMap k v) where+  put = Bin.put . H.assocs+  get = H.fromList <$> Bin.get+  +instance Bin.Binary PickTable where+  put (PickTable n t) = Bin.put (n,t)+  get = uncurry PickTable <$> Bin.get++instance Bin.Binary Chain where+  put (Chain n h) = Bin.put (n,h)+  get = uncurry Chain <$> Bin.get++withChain :: FilePath -> (Chain -> RNG -> IO a) -> IO a+withChain p f = do+  ch <- (Bin.decode . Z.decompress) <$> BSL.readFile p+  RNG.withSystemRandom $ f ch++writeChain :: FilePath -> Chain -> IO ()+writeChain out = BSL.writeFile out . Z.compress . Bin.encode

@@ -0,0 +1,26 @@+Copyright (c) Keegan McAllister 2010++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his 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 AUTHORS 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.

@@ -0,0 +1,4 @@+#! /usr/bin/runhaskell++import Distribution.Simple+main = defaultMain

@@ -0,0 +1,47 @@+name:                detrospector+version:             0.1+license:             BSD3+license-file:        LICENSE+synopsis:            Markov chain text generator+category:            Text, Natural Language Processing+author:              Keegan McAllister <mcallister.keegan@gmail.com>+maintainer:          Keegan McAllister <mcallister.keegan@gmail.com>+build-type:          Simple+cabal-version:       >=1.2+description:+  The `detrospector' program generates random text conforming to the general+  style and diction of a given source document.  It associates each+  `k'-character substring of the source document with a probability+  distribution for the next character.  These distributions are used to+  iteratively pick new characters for output.  In other words, it samples a+  Markov chain derived from the source document.+  .+  Run `detrospector' `-?' for usage information.  The program has several+  modes.  It can generate random text, or invent individual random words which+  are not found in a dictionary.  These modes require a chain file, which is+  built from a source document in another mode.+  .+  Design goals include speed and full Unicode support.  I welcome suggestions+  and patches regarding any aspect of this program.++executable detrospector+  main-is:       detrospector.hs+  other-modules:+    Detrospector.Main+    Detrospector.Types+    Detrospector.Modes+    Detrospector.Modes.Train+    Detrospector.Modes.Run+    Detrospector.Modes.Neolog+  build-depends:+    base       >= 3 && < 5,+    containers >= 0.3,+    text       >= 0.8,+    zlib       >= 0.5,+    bytestring >= 0.9,+    binary     >= 0.5,+    cmdargs    >= 0.6,+    mwc-random >= 0.8,+    hashable   >= 1.0,+    hashmap    >= 1.1+  ghc-options: -Wall

@@ -0,0 +1,6 @@+module Main(main) where++import qualified Detrospector.Main as D++main :: IO ()+main = D.main