packages feed

rl-satton (empty) → 0.1.0

raw patch · 13 files changed

+986/−0 lines, 13 filesdep +MonadRandomdep +basedep +binarysetup-changed

Dependencies added: MonadRandom, base, binary, containers, deepseq, directory, filepath, free, hashable, heredocs, lens, mersenne-random-pure64, monad-loops, mtl, pretty-show, process, random, rl-satton, stm, text, time, transformers, unordered-containers

Files

+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2016, Sergey Mironov++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 Sergey Mironov 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,3 @@+import Distribution.Simple+main = defaultMain+
+ examples/Main.hs view
@@ -0,0 +1,6 @@+module Main where++import Examples.Ch4_GridWorld++main = do+  gw_iter_all gw_d
+ rl-satton.cabal view
@@ -0,0 +1,103 @@+name:                rl-satton+version:             0.1.0+author:              Sergey Mironov+maintainer:          grrwlf@gmail.com+category:            Machine Learning+license:             BSD3+license-file:        LICENSE+build-type:          Simple+cabal-version:       >=1.10+copyright:           Copyright (c) 2016, Sergey Mironov+homepage:            https://github.com/grwlf/rl+synopsis:            Collection of Reinforcement Learning algorithms+description:+  rl-satton provides implementation of algorithms, described in the+  'Reinforcement Learing: An Introduction' book by Richard S. Satton and Andrew+  G. Barto. In particular, TD(0), TD(lambda), Q-learing are implemented.+  Code readability was placed above performance.++library+  default-language: Haskell2010+  hs-source-dirs:   src+  exposed-modules:+    RL.DP+    RL.MC+    RL.TD+    RL.TDl+    RL.Imports+    RL.Types+    RL.Utils+    Graphics.TinyPlot+    Control.Monad.Rnd++  default-extensions:+    LambdaCase,+    NondecreasingIndentation,+    Rank2Types,+    ViewPatterns,+    ScopedTypeVariables,+    FlexibleInstances,+    FlexibleContexts,+    DataKinds,+    RecordWildCards,+    MultiParamTypeClasses,+    FunctionalDependencies,+    TemplateHaskell,+    QuasiQuotes,+    KindSignatures,+    TupleSections,+    DeriveGeneric++  build-depends:+    base >=4.8 && <4.9,+    containers,+    mtl,+    MonadRandom,+    transformers,+    monad-loops,+    lens,+    random,+    heredocs,+    process,+    filepath,+    mersenne-random-pure64,+    stm,+    pretty-show,+    time,+    directory,+    text,+    hashable,+    binary,+    deepseq,+    free,+    unordered-containers++executable example+  default-language: Haskell2010+  hs-source-dirs:   examples+  main-is:          Main.hs+  build-depends:    base >=4.8 && <4.9,+                    rl-satton,+                    containers,+                    unordered-containers,+                    mtl++  default-extensions:+    LambdaCase,+    NondecreasingIndentation,+    Rank2Types,+    ViewPatterns,+    ScopedTypeVariables,+    FlexibleInstances,+    FlexibleContexts,+    DataKinds,+    RecordWildCards,+    MultiParamTypeClasses,+    FunctionalDependencies,+    TemplateHaskell,+    QuasiQuotes,+    KindSignatures,+    TupleSections,+    DeriveGeneric++
+ src/Control/Monad/Rnd.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+module Control.Monad.Rnd where++import Control.Monad.Identity+import Control.Monad.State.Strict+import Control.Monad.Free+import Control.Monad.Trans.Free+import Control.Monad.Trans.Free.Church as Church+import Control.Break+import System.Random+-- import Imports++class (Monad m, RandomGen g) => MonadRnd g m | m -> g where+  roll :: (g -> (a,g)) -> m a+  getGen :: m g+  putGen :: g -> m ()++getRndR :: (MonadRnd g m, Random a) => (a,a) -> m a+getRndR = roll . randomR++newtype RndT g m a = RndT { unRndT :: StateT g m a }+    deriving (Functor, Applicative, Monad, MonadTrans, MonadIO, MonadFix)++runRnd :: RndT g Identity a -> g -> (a,g)+runRnd r g = runIdentity $ runStateT (unRndT r) g++runRndT :: RndT g m a -> g -> m (a,g)+runRndT r g = runStateT (unRndT r) g++evalRndT :: (Monad m) => RndT g m a -> g -> m a+evalRndT r g = fst <$> runRndT r g++evalRndT_ r g = evalRndT r g  >> return ()++instance (Monad m, RandomGen g) => MonadRnd g (RndT g m) where+  getGen = RndT get+  putGen = RndT .  put+  roll f = RndT $ do+    g <- get+    (a,g') <- pure (f g)+    put g'+    return a++rollM :: (MonadRnd g m) => (g -> m (a, g)) -> m a+rollM mf = do+  g <- getGen+  (a,g') <- mf g+  putGen g'+  return a++instance (MonadRnd g m) => MonadRnd g (StateT s m) where+  getGen = lift getGen+  putGen = lift . putGen+  roll = lift . roll++instance (MonadRnd g m) => MonadRnd g (Break r m) where+  getGen = lift getGen+  putGen = lift . putGen+  roll = lift . roll++instance (Functor f, MonadRnd g m) => MonadRnd g (FreeT f m) where+  getGen = lift getGen+  putGen = lift . putGen+  roll = lift . roll++instance (Functor f, MonadRnd g m) => MonadRnd g (FT f m) where+  getGen = lift getGen+  putGen = lift . putGen+  roll = lift . roll++-- | Extracted from MonadRandom AS-IS+-- Sample a random value from a weighted list.  The total weight of all+-- elements must not be 0.+fromList :: (MonadRnd g m) => [(a,Rational)] -> m a+fromList [] = error "MonadRnd.fromList called with empty list"+fromList [(x,_)] = return x+fromList xs = do+  -- TODO: Do we want to be able to use floats as weights?+  -- TODO: Better error message if weights sum to 0.+  let s = (fromRational (sum (map snd xs))) :: Double -- total weight+      cs = scanl1 (\(_,q) (y,s') -> (y, s'+q)) xs       -- cumulative weight+  p <- liftM toRational $ getRndR (0.0,s)+  return . fst . head $ dropWhile (\(_,q) -> q < p) cs++-- | Sample a value from a uniform distribution of a list of elements.+uniform :: (MonadRnd g m) => [a] -> m a+uniform = Control.Monad.Rnd.fromList . fmap (flip (,) 1)+
+ src/Graphics/TinyPlot.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE QuasiQuotes #-}+module Graphics.TinyPlot where++import Control.Applicative+import Control.Concurrent+import Control.Monad+import Control.Monad.Trans+import Control.Exception+import Data.Char+import System.IO+import System.Process+import System.FilePath+import Text.Heredoc+import Text.Printf++data PlotData = PlotData {+    ps_filename :: String+  , ps_handle :: Handle+  } deriving(Show)++newData :: FilePath -> IO PlotData+newData ((-<.> ".dat") -> filename) = PlotData filename <$> openFile filename WriteMode++pushData :: (MonadIO m, Fractional num, Real num) => PlotData -> num -> num -> m ()+pushData PlotData{..} (fromRational . toRational -> x :: Double) (fromRational . toRational -> y :: Double) = liftIO $ do+  hPutStrLn ps_handle (show x ++ "\t" ++ show y) >> hFlush ps_handle++dat :: PlotData -> String+dat PlotData{..} = printf "\"%s\"" ps_filename+++data Plot = Plot {+  pl_handle :: ProcessHandle+}++spawnPlot :: String -> String -> IO Plot+spawnPlot ((-<.> ".gnuplot") -> name) plot =+  Plot <$> do+    writeFile name plot *> spawnProcess "gnuplot" [name]++withPlot :: String -> String -> IO a -> IO a+withPlot ((-<.> ".gnuplot") -> name) plot h = do+  writeFile name plot+  p <- spawnProcess "gnuplot" [name]+  r <- h `finally` terminateProcess p+  return r+++test = do+  d <- newData "plot.dat"++  spawnPlot "plot1" [heredoc|+    set xrange [0:20]+    set yrange [0:400]+    done = 0+    bind all 'd' 'done = 1'+    while(!done) {+      plot ${dat d} using 1:2 with lines+      pause 1+    }+  |]++  forM_ [0..100] $ \i@(fromInteger -> r) -> do+    when (i`mod`10 == 0) $ do+      threadDelay (10^6)+    pushData d r (r*r  / 3.2)+
+ src/RL/DP.hs view
@@ -0,0 +1,244 @@+module RL.DP where++import qualified Data.List as List+import qualified Data.Map.Strict as Map+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Set as Set+import Prelude hiding(break)++import RL.Imports++-- | Probability [0..1]+type Probability = Rational++-- | Policy+type P s a = HashMap s (Set (a,Probability))++type V s num = HashMap s num++-- FIXME: handle missing states case+diffV :: (Eq s, Hashable s, Num num) => V s num -> V s num -> num+diffV tgt src = sum (HashMap.intersectionWith (\a b -> abs (a - b)) tgt src)++-- FIXME: Convert to fold-like style eventially+-- | Dynamic Programming Problem. Parameters have the following meaning: @num@ -+-- Type of Numbers; @pr@ - the problem; @s@ - State; @a@ - Action+class (Ord s, Ord a, Fractional num, Ord num, Hashable s) =>+    DP_Problem pr s a num | pr -> s, pr -> a, pr -> num where+  dp_states :: pr -> Set s+  dp_actions :: pr -> s -> Set a+  dp_transitions :: pr -> s -> a -> Set (s, Probability)+  dp_reward :: pr -> s -> a -> s -> num+  -- FIXME: think about splitting terminal and non-terminal states+  dp_terminal_states :: pr -> Set s++action :: (DP_Problem pr s a num) => pr -> P s a -> s -> Set (a,Probability)+action pr p s = p HashMap.! s++initV :: (DP_Problem pr s a num)+  => pr -> num -> V s num+initV pr num =  HashMap.fromList $ map (\s -> (s,num)) (Set.toList $ dp_states pr)++-- | For given state, probabilities for all possible action should sum up to 1+invariant_probable_actions :: (DP_Problem pr s a num, Show s, Show a) => pr -> Bool+invariant_probable_actions pr =+  flip all (dp_states pr) $ \s ->+    flip all (dp_actions pr s) $ \a ->+      case sum (map snd (Set.toList (dp_transitions pr s a))) of+        1 -> True+        x -> error $ "Total probability of state " ++ show s ++ " action " ++ show a ++ " sum up to " ++ show x++-- | No action leads to unlisted state+invariant_closed_transition :: (DP_Problem pr s a num, Show s, Show a) => pr -> Bool+invariant_closed_transition pr =+  flip all (dp_states pr) $ \s ->+    flip all (dp_actions pr s) $ \a ->+      flip all (dp_transitions pr s a) $ \(s',p) ->+        case (Set.member s' (dp_states pr)) of+          True -> True+          False -> error $ "State " ++ show s ++ ", action " ++ show a ++ " lead to invalid state " ++ show s'++-- | Terminal states are dead ends and non-terminal states are not+invariant_no_dead_states :: (DP_Problem pr s a num, Show s, Show a) => pr -> Bool+invariant_no_dead_states pr =+  flip all (dp_states pr) $ \s ->+    case (member s (dp_terminal_states pr), Set.null (dp_actions pr s)) of+      (True,True) -> True+      (True,False) -> error $ "Terminal state " ++ show s ++ " is not dead end"+      (False,False) -> True+      (False,True) -> error $ "State " ++ show s ++ " is dead end"++-- Terminals are valid states+invariant_terminal :: (DP_Problem pr s a num, Show s, Show a) => pr -> Bool+invariant_terminal pr =+  flip all (dp_terminal_states pr) $ \st ->+    case Set.member st (dp_states pr) of+      True -> True+      False -> error $ "State " ++ show st ++ " is not a valid state"++-- Policy returns valid actions+invariant_policy_actions :: (DP_Problem pr s a num, Ord a, Show s, Show a) => P s a -> pr -> Bool+invariant_policy_actions p pr =+  flip all (dp_states pr) $ \s ->+    flip all (action pr p s) $ \(a, prob) ->+      case Set.member a (dp_actions pr s) of+        True -> True+        False -> error $ "Policy from state " ++ show s ++ " leads to invalid action " ++ show a++-- Policy return valid probabilities+invariant_policy_prob :: (DP_Problem pr s a num, Ord a, Show s, Show a) => P s a -> pr -> Bool+invariant_policy_prob p pr =+  flip all (dp_states pr) $ \s ->+    let+      as = Set.toList (action pr p s)+    in+    case sum $ map snd as of+      1 -> True+      0 | null as -> True+      x -> error $ "Policy state " ++ show s ++ " probabilities sum up to " ++ show x++invariant :: (DP_Problem pr s a num, Show s, Show a, Ord a) => pr -> Bool+invariant pr = all ($ pr) [+    invariant_probable_actions+  , invariant_closed_transition+  , invariant_terminal+  , invariant_policy_actions (uniformPolicy pr)+  , invariant_policy_prob (uniformPolicy pr)+  , invariant_no_dead_states+  ]++policy_eq :: (Eq a, DP_Problem pr s a num) => pr -> P s a -> P s a -> Bool+policy_eq pr p1 p2 = all (\s -> (action pr p1 s) == (action pr p2 s)) (dp_states pr)+++uniformPolicy :: (Ord a, DP_Problem pr s a num) => pr -> P s a+uniformPolicy pr =+  HashMap.fromList $ flip map (Set.toList (dp_states pr)) $ \s ->+    let+      as = dp_actions pr s+    in+    (s, Set.map (\a -> (a, 1%(toInteger $ length as))) as)+++data Opts num s a = Opts {+    eo_gamma :: num+  -- ^ Forgetness+  , eo_etha :: num+  -- ^ policy evaluation precision+  , eo_max_iter :: Int+  -- ^ policy evaluation iteration limit, [1..maxBound]+  } deriving(Show)++defaultOpts :: (Fractional num) => Opts num s a+defaultOpts = Opts {+    eo_gamma = 0.9+  , eo_etha = 0.1+  , eo_max_iter = 10^3+  }++data EvalState num s = EvalState {+    _es_delta :: num+  , _es_v :: V s num+  , _es_v' :: V s num+  , _es_iter :: Int+  } deriving(Show)++makeLenses ''EvalState++initEvalState :: (Fractional num) => V s num -> EvalState num s+initEvalState v = EvalState 0 v v 0++-- | Iterative policy evaluation algorithm+-- Figure 4.1, pg.86.+policy_eval :: (Monad m, DP_Problem pr s a num)+  => Opts num s a -> P s a -> V s num -> (DP pr m s a num) -> m (V s num)+policy_eval Opts{..} p v (DP pr _) = do+  let sum l f = List.sum <$> forM (Set.toList l) f++  view es_v <$> do+    flip execStateT (initEvalState v) $ loop $ do++      i <- use es_iter+      when (i > eo_max_iter-1) $ do+        break ()++      es_delta %= const 0++      forM_ (dp_states pr) $ \s -> do+        v_s <- (HashMap.!s) <$> use es_v+        v's <- do+          sum (action pr p s) $ \(a, fromRational -> pa) -> do+            (pa*) <$> do+              sum (dp_transitions pr s a) $ \(s', fromRational -> p) -> do+                v_s' <- (HashMap.!s') <$> use es_v+                pure $ p * ((dp_reward pr s a s') + eo_gamma * (v_s'))++        es_v' %= (HashMap.insert s v's)+        es_delta %= (`max`(abs (v's - v_s)))++      d <- use es_delta+      when (d < eo_etha) $ do+        break ()++      v' <- use es_v'+      es_v %= const v'++      es_iter %= (+1)++policy_action_value :: (DP_Problem pr s a num) => Opts num s a -> s -> a -> V s num -> pr -> num+policy_action_value Opts{..} s a v pr =+  List.sum $ flip map (Set.toList $ dp_transitions pr s a) $ \(s', fromRational -> p) ->+    p * ((dp_reward pr s a s') + eo_gamma * (v HashMap.! s'))++policy_improve :: (Monad m, DP_Problem pr s a num)+  => Opts num s a -> V s num -> DP pr m s a num -> m (P s a)+policy_improve o v (DP pr _) = do+  let sum l f = List.sum <$> forM (Set.toList l) f+  flip execStateT mempty $ do+    forM_ (dp_states pr) $ \s -> do+      (maxv, maxa) <- do+        foldlM (\(val,maxa) a -> do+                  pi_s <- pure $ policy_action_value o s a v pr+                  return $+                    if Set.null maxa then+                      (pi_s, Set.singleton a)+                    else+                      if pi_s > val then+                        -- GT+                        (pi_s, Set.singleton a)+                      else+                        if pi_s < val then+                          -- LT+                          (val,maxa)+                        else+                          -- EQ+                          (val, Set.insert a maxa)+               ) (0, Set.empty) (dp_actions pr s)++      let nmax = toInteger (Set.size maxa)+      modify $ HashMap.insert s (Set.map (\a -> (a,1%nmax)) maxa)++data DP pr m s a num = DP {+    dp_pr :: pr+  , dp_trace :: V s num -> P s a -> m ()+}+++policy_iteration :: (Monad m, DP_Problem pr s a num, Ord a)+  => Opts num s a -> P s a -> V s num -> (DP pr m s a num) -> m (V s num, P s a)+policy_iteration o p v dpr@(DP pr trace) = do+  let up = lift . lift+  (v', p') <-+    flip execStateT (v, p) $ do+    loop $ do+      (v,p) <- get+      v' <- up $ policy_eval o p v dpr+      p' <- up $ policy_improve o v' dpr+      up $ trace v' p'+      put (v', p')+      when (policy_eq pr p p') $ do+        break ()+  return (v',p')+++
+ src/RL/Imports.hs view
@@ -0,0 +1,100 @@++module RL.Imports (+    module Control.Arrow+  , module Control.Applicative+  , module Control.Concurrent+  , module Control.Concurrent.STM+  , module Control.Monad+  , module Control.Monad.Trans+  , module Control.Monad.State.Strict+  , module Control.Monad.Rnd+  , module Control.Break+  , module Control.Lens+  , module Control.Monad.Free.Class+  , module Control.Monad.Free.TH+  , module Control.Monad.Loops+  , module Data.Bits+  , module Data.Ratio+  , module Data.Tuple+  , module Data.Binary+  , module Data.List+  , module Data.Map.Strict+  , module Data.HashMap.Strict+  , module Data.HashSet+  , module Data.Maybe+  , module Data.Set+  , module Data.Function+  , module Data.Foldable+  , module Data.Text+  , module Data.Monoid+  , module Data.Hashable+  , module Debug.Trace+  , module Prelude+  , module System.Random+  , module System.Random.Mersenne.Pure64+  , module System.Directory+  , module Text.Printf+  , module Text.Heredoc+  , module Text.Show.Pretty+  , module Graphics.TinyPlot+  , module RL.Imports+  , module GHC.Generics+)++where++import Control.Arrow ((&&&),(***))+import Control.Applicative+import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad+import Control.Monad.Trans+import Control.Monad.State.Strict+import Control.Monad.Rnd+import Control.Break+import Control.Lens (Lens', makeLenses, (%=), (^.), view, use, uses, zoom, _1, _2, _3, _4, _5, _6)+import Control.Monad.Free.Class+import Control.Monad.Free.TH (makeFree)+import Control.Monad.Loops+import Data.Bits+import Data.Ratio+import Data.Tuple+import Data.List hiding (break)+import qualified Data.List as List+import Data.Map.Strict (Map, (!))+import qualified Data.Map.Strict as Map+import Data.Set (Set,member)+import qualified Data.Set as Set+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.HashSet (HashSet)+import Data.Maybe+import Data.Foldable+import Data.Function+import Debug.Trace hiding(traceM)+import Prelude hiding(break)+import System.Random+import System.Random.Mersenne.Pure64+import System.Directory+import Text.Printf+import Text.Heredoc+import Text.Show.Pretty+import Graphics.TinyPlot+import Data.Text (Text)+import Data.Monoid ((<>))+import Data.Hashable+import Data.Binary hiding(put,get)+import GHC.Generics (Generic)+++trace1 :: (Show a) => a -> a+trace1 a = trace (ppShow a) a++traceM :: (Monad m, Show a) => a -> m ()+traceM a = trace (ppShow a) (return ())++trace' :: (Show a) => a -> b -> b+trace' a b = trace (ppShow a) b++loopM s0 f m = iterateUntilM (not . f) m s0+
+ src/RL/MC.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE DeriveFunctor #-}+module RL.MC where++import qualified Data.HashMap.Strict as HashMap+import qualified Prelude++import RL.Imports+import RL.Types++data MC_Opts = MC_Opts {+    o_alpha :: MC_Number+  , o_maxlen :: Int+  , o_maxlen_reward :: MC_Number+} deriving (Show)++defaultOpts = MC_Opts {+    o_alpha = 0.1+  , o_maxlen = 1000+  , o_maxlen_reward = -100.0+  }++type MC_Number = Double+type Q s a = M s a MC_Number+type V s = HashMap s MC_Number++emptyQ :: MC_Number -> Q s a+emptyQ = initM++q2v :: (Bounded a, Enum a, Eq a, Hashable a, Eq s, Hashable s) => Q s a -> V s+q2v = foldMap_s (\(s,l) -> HashMap.singleton s (snd $ layer_s_max l))++-- FIXME: handle missing states case+diffV :: (Eq s, Hashable s) => V s -> V s -> MC_Number+diffV tgt src = sum (HashMap.intersectionWith (\a b -> abs ((a) - (b))) tgt src)++toV :: (Bounded a, Enum a, Eq a, Hashable a, Eq s, Hashable s) => Q s a -> V s+toV = foldMap_s (\(s,l) -> HashMap.singleton s (snd $ layer_s_max l))++class (Fractional num, Ord s, Ord a, Show s, Show a, Bounded a, Enum a) =>+    MC_Problem pr s a num | pr->s, pr->a, pr->num where+  mc_is_terminal :: pr -> s -> Bool+  mc_reward :: pr -> s -> a -> s -> num++queryQ s = HashMap.toList <$> get_s s <$> get+modifyQ s a f = modify (modify_s_a s a f)++data MC pr m s a = MC {+    mc_pr :: pr+  , mc_transition :: s -> a -> m s+}++-- | MC-ES learning algorithm, pg 5.4. Alpha-learing rate is used instead of+-- total averaging, maximum episode length is limited to make sure policy it+-- terminates+mc_es_learn :: (Monad m, Hashable s, Hashable a, MC_Problem pr s a MC_Number)+  => MC_Opts -> Q s a -> s -> a -> MC pr m s a -> m (Q s a)+mc_es_learn MC_Opts{..} q0 s0 a0 mc@(MC pr transition) = do+  flip execStateT q0 $ do++    {- Build an episode -}+    ep <- do+      view _3 <$> do+      loopM (s0,a0,[],True) (view _4) $ \(s,a,ep,_) -> do+        s' <- lift $ mc_transition mc s a+        a' <- fst . maximumBy (compare`on`snd) <$> queryQ s'+        if length ep > o_maxlen then+          return (s', a', (s,a,s',o_maxlen_reward):ep, False)+        else do+          r <- pure $ mc_reward pr s a s'+          if mc_is_terminal pr s' then+            return (s', a', (s,a,s',r):ep, False)+          else do+            return (s', a', (s,a,s',r):ep, True)++    {- Build first-visit revard map -}+    rm <- do+      fst <$> do+      flip execStateT (mempty, 0) $ do+      forM ep $ \(s,a,s',r) -> do+        modify $ \(m,g) -> (HashMap.insert (s,a) (g+r) m, g+r)++    {- Update Q -}+    forM_ (HashMap.toList rm) $ \((s,a),g) -> do+      modifyQ s a $ \q -> q + o_alpha*(g - q)++
+ src/RL/TD.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE DeriveFunctor #-}+module RL.TD where++import qualified Prelude+import qualified Data.HashMap.Strict as HashMap++import RL.Imports+import RL.Types+import RL.Utils (eps_greedy_action)++data Q_Opts = Q_Opts {+    o_alpha :: TD_Number+  , o_gamma :: TD_Number+  , o_eps :: TD_Number+} deriving (Show)++defaultOpts = Q_Opts {+    o_alpha = 0.1+  , o_gamma = 1.0+  , o_eps = 0.3+  }++type TD_Number = Double++type Q s a = M s a TD_Number++emptyQ :: TD_Number -> Q s a+emptyQ = initM++toV :: (Bounded a, Enum a, Eq a, Hashable a, Eq s, Hashable s) => Q s a -> HashMap s TD_Number+toV = foldMap_s (\(s,l) -> HashMap.singleton s (snd $ layer_s_max l))++class (Monad m, Eq s, Hashable s, Show s, Eq a, Hashable a, Enum a, Bounded a, Show a) =>+    TD_Problem pr m s a | pr -> m, pr -> s , pr -> a where+  td_is_terminal :: pr -> s -> Bool+  td_greedy :: pr -> Bool -> a -> a+  td_reward :: pr -> s -> a -> s -> TD_Number+  td_transition :: pr -> s -> a -> Q s a -> m s+  td_modify :: pr -> s -> a -> Q s a  -> m ()++queryQ s = HashMap.toList <$> get_s s <$> get+modifyQ pr s a f = modify (modify_s_a s a f) >> get >>= lift . td_modify pr s a+action pr s eps = queryQ s >>= eps_greedy_action eps (td_greedy pr)+transition pr s a = get >>= lift . td_transition pr s a++-- | Q-Learning algorithm+q_learn :: (MonadRnd g m, TD_Problem pr m s a) => Q_Opts -> Q s a -> s -> pr -> m (s, Q s a)+q_learn Q_Opts{..} q0 s0 pr = do+  flip runStateT q0 $ do+  loopM s0 (not . td_is_terminal pr) $ \s -> do+    (a,_) <- action pr s o_eps+    s' <- transition pr s a+    r <- pure $ td_reward pr s a s'+    max_qs' <- snd . maximumBy (compare`on`snd) <$> queryQ s'+    modifyQ pr s a $ \q -> q + o_alpha * (r + o_gamma * max_qs' - q)+    return s'++-- | Q-Executive algorithm. Actions are taken greedily, no learning is performed+q_exec :: (MonadRnd g m, TD_Problem pr m s a) => Q_Opts -> Q s a -> s -> pr -> m s+q_exec Q_Opts{..} q0 s0 pr = do+  flip evalStateT q0 $ do+  loopM s0 (not . td_is_terminal pr) $ \s -> do+    a <- fst . maximumBy (compare`on`snd) <$> queryQ s+    s' <- transition pr s a+    return s'+
+ src/RL/TDl.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE DeriveFunctor #-}+module RL.TDl where++import qualified Data.List as List+import qualified Data.HashMap.Strict as HashMap+import qualified Data.HashSet as HashSet++import Control.Monad.Trans.Free.Church+import RL.Imports+import RL.Types+import RL.Utils (eps_greedy_action)++data TDl_Opts = TDl_Opts {+    o_alpha :: TD_Number+  , o_gamma :: TD_Number+  , o_eps :: TD_Number+  , o_lambda :: TD_Number+  } deriving (Show)++type TD_Number = Double+type Q s a = M s a TD_Number+type Z s a = M s a TD_Number+type V s a = HashMap s (a, TD_Number)++emptyQ :: TD_Number -> Q s a+emptyQ = initM++toV :: (Bounded a, Enum a, Eq a, Hashable a, Eq s, Hashable s) => Q s a -> HashMap s TD_Number+toV = foldMap_s (\(s,l) -> HashMap.singleton s (snd $ layer_s_max l))++data TDl_State s a = TDl_State {+    _tdl_q :: Q s a+  , _tdl_z :: Z s a+  }++$(makeLenses ''TDl_State)++initialState :: Q s a -> TDl_State s a+initialState q0 = TDl_State q0 (initM 0)++class (Eq s, Hashable s, Show s, Eq a, Hashable a, Enum a, Bounded a, Show a) =>+    TDl_Problem pr m s a | pr -> m, pr -> s , pr -> a where+  td_is_terminal :: pr -> s -> Bool+  td_greedy :: pr -> Bool -> a -> a+  td_transition :: pr -> s -> a -> TDl_State s a -> m s+  td_reward :: pr -> s -> a -> s -> TD_Number+  td_modify :: pr -> s -> a -> TDl_State s a  -> m ()++queryQ s = HashMap.toList <$> get_s s <$> use tdl_q+modifyQ pr s a f = tdl_q %= modify_s_a s a f+listZ pr s a f = (list <$> use tdl_z) >>= mapM_ f >> get >>= lift . td_modify pr s a+modifyZ pr s a f = tdl_z %= modify_s_a s a f+action pr s eps = queryQ s >>= eps_greedy_action eps (td_greedy pr)+transition pr s a = get >>= lift . td_transition pr s a+getQ s a = get_s_a s a <$> use tdl_q++-- | TD(lambda) learning, aka Sarsa(lambda), pg 171+tdl_learn :: (MonadRnd g m, TDl_Problem pr m s a)+  => TDl_Opts -> Q s a -> s -> pr -> m (s, Q s a)+tdl_learn TDl_Opts{..} q0 s0 pr = do+  (view _1 *** view tdl_q) <$> do+  flip runStateT (initialState q0) $ do+    (a0,q0) <- action pr s0 o_eps+    loopM (s0,a0) (not . td_is_terminal pr . view _1) $ \(s,a) -> do+      q <- getQ s a+      s' <- transition pr s a+      r <- pure $ td_reward pr s a s'+      (a',q') <- action pr s' o_eps+      delta <- pure $ r + o_gamma * q' - q+      modifyZ pr s a (+1)+      listZ pr s a $ \(s,a,z) -> do+        modifyQ pr s a (\q -> q + o_alpha * delta * z)+        modifyZ pr s a (\z -> o_gamma * o_lambda * z)+      return (s',a')+++-- | Watkins's Q(lambda) learning algorithm, pg 174+qlw_learn :: (MonadRnd g m, TDl_Problem pr m s a)+  => TDl_Opts -> Q s a -> s -> pr -> m (s, Q s a)+qlw_learn TDl_Opts{..}  q0 s0 pr =+  (view _1 *** view tdl_q) <$> do+  flip runStateT (initialState q0) $ do+    (a0,q0) <- action pr s0 o_eps+    loopM (s0,a0,q0) (not . td_is_terminal pr . view _1) $ \(s,a,q) -> do+      s' <- transition pr s a+      r <- pure $ td_reward pr s a s'+      (a',q') <- action pr s' o_eps+      (a'',q'') <- maximumBy (compare`on`snd) <$> queryQ s'+      delta <- pure $ r + o_gamma * q'' - q+      modifyZ pr s a (+1)+      listZ pr s a $ \(s,a,z) -> do+        modifyQ pr s a (\q -> q + o_alpha * delta * z)+        modifyZ pr s a (\z -> if a' == a''+                                then o_gamma*o_lambda*z+                                else 0)+      return (s',a',q')++
+ src/RL/Types.hs view
@@ -0,0 +1,64 @@+module RL.Types where++import qualified Data.HashMap.Strict as HashMap+import qualified Data.HashSet as HashSet++import RL.Imports++type Layer a num = HashMap a num+type Storage s a num = HashMap s (Layer a num)++-- | Base container used in most of RL algorithms. @M x0 sto@ describes the+-- 2-dimentional array (`Storage` of `Layers`) where each layer containes fixed+-- number of elements. New layers are filled with the range of+-- @[minBound..maxBound]@ default values @x0@+data M s a num = M {+    x0 :: num+  , sto :: Storage s a num+  } deriving(Show)++-- | Initialises new container, set default layer value to @x@+initM :: num -> M s a num+initM x = M x HashMap.empty++mmod :: (Storage s a num -> Storage s a num) -> M s a num -> M s a num+mmod f m = m { sto = f (sto m) }++aq0 :: (Eq a, Enum a, Hashable a, Bounded a)+  => num -> HashMap a num+aq0 q0 = HashMap.fromList [(a,q0) | a <- [minBound .. maxBound]]++get_s :: (Eq a, Enum a, Hashable a, Bounded a, Eq s, Hashable s)+  => s -> M s a num -> Layer a num+get_s s (M x0 sto) = maybe (aq0 x0) (`HashMap.union` (aq0 x0)) . HashMap.lookup s $ sto++layer_s_max :: (Eq a, Enum a, Hashable a, Bounded a, Ord num)+  => Layer a num -> (a,num)+layer_s_max = maximumBy (compare`on`snd) . HashMap.toList++get_s_a :: (Eq a, Enum a, Hashable a, Bounded a, Eq s, Hashable s)+  => s -> a -> M s a num -> num+get_s_a s a (M x0 sto) = maybe x0 (maybe x0 id . HashMap.lookup a) . HashMap.lookup s $ sto++put_s :: (Eq s, Hashable s, Bounded a, Enum a, Eq a, Hashable a)+  => s -> HashMap a num -> M s a num -> M s a num+put_s s x = mmod $ HashMap.unionWith HashMap.union (HashMap.singleton s x)++put_s_a :: (Eq s, Hashable s, Bounded a, Enum a, Eq a, Hashable a)+  => s -> a -> num -> M s a num -> M s a num+put_s_a s a x = put_s s (HashMap.singleton a x)++modify_s_a :: (Eq s, Hashable s, Bounded a, Enum a, Eq a, Hashable a)+  => s -> a -> (num -> num) -> M s a num -> M s a num+modify_s_a s a f q = put_s_a s a (f (get_s_a s a q)) q++list :: M s a num -> [(s,a,num)]+list q = flip concatMap (HashMap.toList (sto q)) $ \(s,aq) -> flip map (HashMap.toList aq) $ \(a,q) -> (s,a,q)++foldMap_s :: (Eq a, Bounded a, Enum a, Hashable a, Monoid acc) => ((s,Layer a num) -> acc) -> M s a num -> acc+foldMap_s f (M x0 sto) = foldMap (f . (id *** (`HashMap.union`(aq0 x0)))) (HashMap.toList sto)++fold_s :: (Eq a, Bounded a, Enum a, Hashable a, Monoid acc) => (acc -> (s,Layer a num) -> acc) -> acc -> M s a num -> acc+fold_s f acc0 (M x0 sto) = foldl' go acc0 (HashMap.toList sto) where+  go acc (s,l) = f acc (s,l`HashMap.union`(aq0 x0))+
+ src/RL/Utils.hs view
@@ -0,0 +1,22 @@+module RL.Utils where++import qualified Control.Monad.Rnd as Rnd++import RL.Imports++-- | Return @eps@-greedy action for some state of problem @pr@. The state is+-- described with assosiated list of weighted actions @as@+eps_greedy_action :: (Fractional num, Ord num, Real num, Eq a, MonadRnd g m)+  => num -> (Bool -> a -> a) -> [(a,num)] -> m (a,num)+eps_greedy_action eps greedy as = do+  let (abest, qbest) = maximumBy (compare`on`snd) as+  let arest = filter (\x -> fst x /= abest) as+  join $ Rnd.fromList [+    swap (toRational (1.0-eps), do+      -- traceM "greedy"+      return (greedy True abest, qbest)),+    swap (toRational eps, do+      -- traceM "random"+      (r,q) <- Rnd.uniform arest+      return (greedy False r, q))+    ]