rl-satton 0.1.2.3 → 0.1.2.4
raw patch · 14 files changed
+1234/−1 lines, 14 files
Files
- examples/Examples.hs +4/−0
- examples/Examples/Ch4_Gambler.hs +120/−0
- examples/Examples/Ch4_GridWorld.hs +129/−0
- examples/Examples/Ch4_GridWorld/DP.hs +45/−0
- examples/Examples/Ch4_GridWorld/MC.hs +81/−0
- examples/Examples/Ch4_GridWorld/Rules.hs +102/−0
- examples/Examples/Ch4_GridWorld/TD.hs +77/−0
- examples/Examples/Ch4_GridWorld/TDl.hs +108/−0
- examples/Examples/Ch6_Cliff.hs +13/−0
- examples/Examples/Ch6_Cliff/Rules.hs +77/−0
- examples/Examples/Ch6_Cliff/TD.hs +64/−0
- examples/Examples/Ch6_Cliff/TDl.hs +105/−0
- examples/Examples/TickTackToe.hs +295/−0
- rl-satton.cabal +14/−1
+ examples/Examples.hs view
@@ -0,0 +1,4 @@+module Examples where++import Examples.Ch4_GridWorld as RL+import Examples.Ch6_Cliff as RL
+ examples/Examples/Ch4_Gambler.hs view
@@ -0,0 +1,120 @@+{-|+ - This module relies on older version of library and thus couldn't be+ - compailed.+ -+ - FIXME: update the Gambler module+ --}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}++module Examples.Ch4_Gambler where++import Control.Applicative+import Control.Monad+import Control.Monad.Trans+import qualified Data.List as List+import Data.Map.Strict (Map, (!))+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Ratio+import Text.Printf+import Debug.Trace++import Types as RL+import DP as RL++data Bet = Bet {+ bet_amount :: Int+ }+ deriving(Show, Eq, Ord)++data Game num = Game {+ game_win_score :: Int+ }+ deriving(Show)++data Gambler = Gambler {+ g_pocket :: Int+ }+ deriving(Show, Eq, Ord)+++instance (Fractional num, Ord num) => DP_Problem num Game Gambler Bet where++ rl_states Game{..} =+ Set.fromList [Gambler pocket | pocket <- [0..game_win_score]]++ rl_actions Game{..} Gambler{..} =+ if g_pocket >= game_win_score || g_pocket <= 0 then+ Set.empty+ else+ let+ border = g_pocket `min` (game_win_score - g_pocket)+ in+ Set.fromList [Bet x | x <- [1..border]]++ rl_transitions Game{..} Gambler{..} Bet{..} =+ Set.fromList [+ (Gambler (g_pocket - bet_amount), 6%10)+ , (Gambler (g_pocket + bet_amount), 4%10)]++ rl_reward Game{..} _ _ Gambler{..} =+ if g_pocket >= game_win_score then+ 1+ else+ 0++ rl_terminal_states Game{..} = Set.fromList [ Gambler 0, Gambler game_win_score ]++thegame :: Game Rational+thegame = Game 100+++example_4_3 :: forall num . (Fractional num, Ord num, Real num) => Game num -> IO ()+example_4_3 thegame =+ let+ showValPolicy :: (StateVal num Gambler, GenericPolicy Gambler Bet) -> String+ showValPolicy (v@StateVal{..}, GenericPolicy{..}) =+ unlines $+ flip map (Map.toAscList v_map `zip` Map.toAscList _p_map) $ \((_, vs) , (s@Gambler{..}, set)) ->+ let+ actmap = List.sortOn (\(p,a)-> a) $ Set.toList set++ show_actmap =+ let+ d :: Bet -> Double+ d a = fromRational $ toRational $ stateval v s a+ in+ List.intercalate "," $+ flip map actmap $ \(a@Bet{..},p) -> show bet_amount ++ " (" ++ (printf "%2.5f" (d a)) ++ ")"++ (Bet{..}, mx)+ | null actmap = (Bet 0, 0)+ | otherwise = head $ actmap+ show_vs = printf "% 2.5f" (fromRational $ toRational vs :: Double)+ in+ (printf ("%02d: ") g_pocket) ++ (replicate bet_amount '#') ++ show bet_amount ++ " " ++ show_vs ++ " " ++ show_actmap++ debugState :: (StateVal num Gambler, GenericPolicy Gambler Bet) -> IO ()+ debugState = putStrLn . showValPolicy++ opts :: EvalOpts num s a+ opts = defaultOpts {+ eo_max_iter = 1+ , eo_gamma = 1.0+ , eo_etha = 0.00001+ -- , eo_debug = const $ return ()+ }++ stateval :: (DP_Problem num Game s a) => StateVal num s -> s-> a -> num+ stateval v s a = policy_action_value thegame s a opts v++ in do+ (v,p) <- policy_iteraton thegame (uniformGenericPolicy thegame) (zero_sate_values thegame) opts+ debugState (v,p)+
+ examples/Examples/Ch4_GridWorld.hs view
@@ -0,0 +1,129 @@+module Examples.Ch4_GridWorld (+ module Examples.Ch4_GridWorld+ ) where+++import qualified Data.List as List+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Set as Set++import RL.Types+import RL.Imports+import RL.DP as DP+import RL.TD as TD+import RL.TDl as TDl+import RL.MC as MC++import Examples.Ch4_GridWorld.Rules as Rules+import Examples.Ch4_GridWorld.DP as DP+import Examples.Ch4_GridWorld.MC as MC+import Examples.Ch4_GridWorld.TD as TD+import Examples.Ch4_GridWorld.TDl as TDl++gw :: GW Rational+gw = GW (4,4) (Set.fromList [(0,0),(3,3)])++gw_d :: GW Double+gw_d = GW (4,4) (Set.fromList [(0,0),(3,3)])++gw2 :: GW num+gw2 = GW (2,1) (Set.fromList [(1,0)])+++data S = S {+ st_i :: Integer+ , st_q :: TD.Q Point Action+ , st_tdl :: TDl.Q Point Action+ , st_qlw :: TDl.Q Point Action+ , st_mc :: MC.Q Point Action+ }+++-- | Run 4 different learning algorithms on a simple GridWorld problem. Output+-- learning progress to a gnuplot window+gw_iter_all :: GW Double -> IO ()+gw_iter_all gw =+ let+ {- Number of iterations -}+ cnt = 5000+ {- Epsilon-greedy policy -}+ eps = 0.01+ {- Learning rate -}+ alpha = 0.1++ oq = Q_Opts {+ o_alpha = alpha+ , o_gamma = 1.0+ , o_eps = eps+ }++ otdl = TDl_Opts {+ o_alpha = alpha+ , o_gamma = 1.0+ , o_eps = eps+ , o_lambda = 0.8+ }++ omc = MC_Opts {+ o_alpha = alpha+ , o_maxlen = 200+ , o_maxlen_reward = -1000+ }++ oqlw = otdl++ q0 = TD.emptyQ 0+ tdl0 = TDl.emptyQ 0+ qlw0 = TDl.emptyQ 0+ mc0 = MC.emptyQ 0++ g0 = pureMT 33++ in do+ (v_dp, p_dp) <- DP.gw_iter_dp gw++ dq <- newData "q"+ dtdl <- newData "tdl"+ dqlw <- newData "qlw"+ dmc <- newData "mc"++ withPlot "plot1" [heredoc|+ set grid back ls 102+ set xrange [0:${show cnt}]+ set yrange [-20:20]+ set terminal x11 1 noraise+ done = 0+ bind all 'd' 'done = 1'+ while(!done) {+ plot ${dat dq} using 1:2 with lines, ${dat dtdl} using 1:2 with lines, ${dat dqlw} using 1:2 with lines, ${dat dmc} using 1:2 with lines+ pause 1+ }+ |] $ do++ flip evalRndT_ g0 $ do+ flip execStateT (S 0 q0 tdl0 qlw0 mc0) $ do+ loop $ do+ s0 <- Rules.arbitraryState gw+ a0 <- uniform [minBound..maxBound]+ s@S{..} <- get++ (_, q') <- do+ q_learn oq st_q s0 $ TD_GW gw $ \s a q -> return ()++ (_, tdl') <- do+ tdl_learn otdl st_tdl s0 $ TDl_GW gw $ \s a q -> return ()++ (_, qlw') <- do+ qlw_learn oqlw st_qlw s0 $ TDl_GW gw $ \s a q -> return ()++ (mc') <- do+ mc_es_learn omc st_mc s0 a0 $ MC gw $ \s a -> return $ Rules.transition gw s a++ liftIO $ putStrLn $ "Loop i = " <> show st_i+ liftIO $ pushData dq (fromInteger st_i) (DP.diffV (TD.toV q') v_dp)+ liftIO $ pushData dtdl (fromInteger st_i) (DP.diffV (TD.toV tdl') v_dp)+ liftIO $ pushData dqlw (fromInteger st_i) (DP.diffV (TD.toV qlw') v_dp)+ liftIO $ pushData dmc (fromInteger st_i) (DP.diffV (MC.toV mc') v_dp)++ put s{st_i = st_i + 1, st_q = q' , st_tdl = tdl', st_qlw = qlw', st_mc = mc' }+
+ examples/Examples/Ch4_GridWorld/DP.hs view
@@ -0,0 +1,45 @@+module Examples.Ch4_GridWorld.DP (+ module Examples.Ch4_GridWorld.DP+ ) where++import qualified Data.List as List+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Set as Set++import RL.Imports+import RL.DP as DP++import Examples.Ch4_GridWorld.Rules as GW++instance (Fractional num, Ord num) => DP_Problem (GW num) Point Action num where+ dp_states gw = GW.states gw+ dp_actions gw s = GW.actions gw s+ dp_transitions gw s a = Set.fromList [(GW.transition gw s a,1%1)]+ dp_reward gw s a s' = -1+ dp_terminal_states gw = gw_exits gw++-- | Evaluate random policy with DP method+gw_evalRandom_dp :: (DP_Problem (GW num) Point Action num) => GW num -> IO (V Point num)+gw_evalRandom_dp gw =+ let+ opts = defaultOpts{eo_max_iter=300, eo_gamma=1, eo_etha = 0.001}+ p0 = uniformPolicy gw+ v0 = initV gw 0+ in do+ policy_eval opts p0 v0 (DP gw $ \a b -> return ())++-- | Calculate Best policy, print its value function+gw_iter_dp :: (DP_Problem (GW num) Point Action num) => GW num -> IO (V Point num, P Point Action)+gw_iter_dp gw =+ let+ opts = defaultOpts{eo_max_iter=300, eo_gamma=1, eo_etha = 0.001}+ p0 = uniformPolicy gw+ v0 = initV gw 0+ in do+ policy_iteration opts p0 v0 (DP gw $ \a b -> return ())++-- | Calculate and show value function of random policy+gw_showRandom_dp gw = do+ v <- gw_evalRandom_dp gw+ showV gw (HashMap.toList v)+
+ examples/Examples/Ch4_GridWorld/MC.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE QuasiQuotes #-}+module Examples.Ch4_GridWorld.MC where++import qualified Data.List as List+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Set as Set+-- import qualified Control.Monad. as Set++import Control.Monad.Except++import RL.Types+import RL.Imports+import RL.MC as MC++import Examples.Ch4_GridWorld.Rules(GW(..), Point, Action)+import qualified Examples.Ch4_GridWorld.Rules as Rules+import qualified Examples.Ch4_GridWorld.DP as DP++instance (Fractional num, Real num, Ord num) => MC_Problem (GW num) Point Action num where+ mc_is_terminal = Rules.isTerminal+ mc_reward gw s a s' = -1++-- | Uniform random policy iteration with MC alg+gw_iter_mc :: GW MC_Number -> IO ()+gw_iter_mc gw =+ let++ o = MC.defaultOpts {+ o_alpha = 0.1+ }++ cnt = 20*10^3+ g0 = pureMT 33 -- Initial RNG+ q0 = MC.emptyQ 0 -- Initial Q table++ st_q :: Lens' (a,b,c) a+ st_q = _1+ st_i :: Lens' (a,b,c) b+ st_i = _2+ st_len :: Lens' (a,b,c) c+ st_len = _3++ in do+ {- Reference StateVal -}+ (v_dp, p_dp) <- DP.gw_iter_dp gw++ Rules.withLearnPlot cnt $ \d ->++ flip evalRndT_ g0 $ do+ flip execStateT (q0,0,0) $ do+ loop $ do++ s0 <- Rules.arbitraryState gw+ a0 <- uniform [minBound..maxBound]++ i <- use st_i+ q <- use st_q+ st_len %= const 0++ mq <-+ runExceptT $ do+ mc_es_learn o q s0 a0 $ MC gw $ \s a -> do+ st_len %= (+1)+ l <- use st_len+ when (l > 200) $ do+ throwError $ "Episode is too long"+ return $ Rules.transition gw s a++ case mq of++ Right q' -> do+ liftIO $ putStrLn $ "Loop i = " <> show i+ liftIO $ Rules.showV gw (HashMap.toList $ MC.toV q')+ liftIO $ pushData d i (MC.diffV (MC.toV q') v_dp)+ st_i %= (+1)+ st_q %= const q'++ Left err -> do+ liftIO $ putStrLn $ "Skipping episode due to error: " <> err+ return ()+
+ examples/Examples/Ch4_GridWorld/Rules.hs view
@@ -0,0 +1,102 @@+{-|+ Satton, 'Reinforcement Learning: The Introduction', pg.86, Example 4.1: GridWorld+-}++{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+module Examples.Ch4_GridWorld.Rules where++import qualified Data.List as List+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set++import RL.Types+import RL.Imports+import RL.DP++type Point = (Int,Int)++data Action = L | R | U | D+ deriving(Show, Eq, Ord, Enum, Bounded, Generic, Hashable)++data GW num = GW {+ gw_size :: (Int,Int),+ gw_exits :: Set (Int,Int)+ } deriving(Show)++showAction :: Action -> String+showAction a =+ case a of+ L->"<"+ R->">"+ U->"^"+ D->"v"++showActions :: Set Action -> String+showActions = concat . map showAction . List.sort . Set.toList++states :: GW num -> Set Point+states (GW (sx,sy) _) = Set.fromList [(x,y) | x <- [0..sx-1], y <- [0..sy-1]]++actions :: GW num -> Point -> Set Action+actions (GW (sx,sy) exits) s =+ case Set.member s exits of+ True -> Set.empty+ False -> Set.fromList [minBound..maxBound]++transition :: GW num -> Point -> Action -> Point+transition (GW (sx,sy) exits) (x,y) a =+ let+ check (x',y') =+ if x' >= 0 && x' < sx && y' >= 0 && y' < sy then+ (x',y')+ else+ (x,y)+ in+ case a of+ L -> check (x-1,y)+ R -> check (x+1,y)+ U -> check (x,y-1)+ D -> check (x,y+1)++showV :: (MonadIO m, Real num) => GW num -> [(Point, num)] -> m ()+showV (GW (sx,sy) _) v = liftIO $ do+ forM_ [0..sy-1] $ \y -> do+ forM_ [0..sx-1] $ \x -> do+ case List.lookup (x,y) v of+ Just v -> do+ printf "%-2.3f " ((fromRational $ toRational v) :: Double)+ Nothing -> do+ printf " ? "+ printf "\n"++-- TODO: remove recursion+arbitraryState :: MonadRnd g m => GW t -> m Point+arbitraryState gw@GW{..} = do+ let (sx,sy) = gw_size+ x <- getRndR (0,sx-1)+ y <- getRndR (0,sy-1)+ case isTerminal gw (x,y) of+ True -> arbitraryState gw+ False -> return (x,y)+++isTerminal :: GW num -> Point -> Bool+isTerminal GW{..} p = p `Set.member` gw_exits++withLearnPlot :: Show a => a -> (PlotData -> IO b) -> IO b+withLearnPlot cnt f = do+ d <- newData "learnRate"+ withPlot "plot1" [heredoc|+ set grid back ls 102+ set xrange [0:${show cnt}]+ set yrange [-20:20]+ set terminal x11 1 noraise+ done = 0+ bind all 'd' 'done = 1'+ while(!done) {+ plot ${dat d} using 1:2 with lines+ pause 1+ }+ |] (f d)+
+ examples/Examples/Ch4_GridWorld/TD.hs view
@@ -0,0 +1,77 @@+module Examples.Ch4_GridWorld.TD (+ gw_iter_q+ , TD_GW(..)+ ) where++import qualified Data.HashMap.Strict as HashMap+import qualified Data.Set as Set+import qualified Data.Map as Map+import qualified Prelude++import RL.Types hiding (Q, q2v)+import RL.Imports+import RL.Types as TD+import RL.TD as TD+import RL.DP as DP++import Examples.Ch4_GridWorld.Rules(GW(..), Point, Action)+import qualified Examples.Ch4_GridWorld.Rules as Rules+import qualified Examples.Ch4_GridWorld.DP as DP++data TD_GW m = TD_GW {+ gw :: GW TD_Number+ , gw_trace :: Point -> Action -> Q Point Action -> m ()+ }++instance (Monad m) => TD_Problem (TD_GW m) m Point Action where+ td_is_terminal TD_GW{..} p = Rules.isTerminal gw p+ td_greedy TD_GW{..} best = id+ td_reward TD_GW{..} s a s' = -1+ td_transition TD_GW{..} s a q = return (Rules.transition gw s a)+ td_modify TD_GW{..} s a q = gw_trace s a q++showV gw v = Rules.showV gw (HashMap.toList v)++gw_iter_q :: GW TD_Number -> IO ()+gw_iter_q gw =+ let+ -- Q options+ o = Q_Opts {+ o_alpha = 0.1+ , o_gamma = 1.0+ , o_eps = 0.3+ }++ q0 = TD.emptyQ 0 -- Initial Q table+ g0 = pureMT 33 -- Initial RNG+ cnt = 20*10^3++ st_q :: Lens' (a,b) a+ st_q = _1+ st_i :: Lens' (a,b) b+ st_i = _2+ in do++ {- Reference StateVal -}+ (v_dp, p_dp) <- DP.gw_iter_dp gw++ Rules.withLearnPlot cnt $ \d -> do+ flip evalRndT_ g0 $ do+ flip execStateT (q0,0) $ do+ loop $ do+ s0 <- Rules.arbitraryState gw+ i <- use st_i+ q <- use st_q++ (s',q') <-+ q_learn o q s0 $ TD_GW gw $ \s a q -> do+ i <- use st_i+ when (i >= cnt) $ do+ break ()++ liftIO $ putStrLn $ "Loop i = " <> show i+ liftIO $ showV gw (TD.toV q')+ liftIO $ pushData d i (DP.diffV (TD.toV q') v_dp)+ st_i %= (+1)+ st_q %= const q'+
+ examples/Examples/Ch4_GridWorld/TDl.hs view
@@ -0,0 +1,108 @@+module Examples.Ch4_GridWorld.TDl (+ gw_iter_tdl+ , gw_iter_qlw+ , TDl_GW(..)+ ) where++import qualified Prelude+import qualified Data.HashMap.Strict as HashMap++import RL.Imports+import RL.Types+import RL.TDl as TDl++import Examples.Ch4_GridWorld.Rules (GW(..), Point, Action)+import qualified Examples.Ch4_GridWorld.Rules as Rules++data TDl_GW m = TDl_GW {+ gw :: GW TD_Number+ , gw_trace :: Point -> Action -> Q Point Action -> m ()+ }++instance (Monad m) => TDl_Problem (TDl_GW m) m Point Action where+ td_is_terminal TDl_GW{..} p = Rules.isTerminal gw p+ td_greedy TDl_GW{..} best = id+ td_reward TDl_GW{..} s a s' = -1+ td_transition TDl_GW{..} s a st = return (Rules.transition gw s a)+ td_modify TDl_GW{..} s a st = gw_trace s a (st^.tdl_q)++showV gw v = Rules.showV gw (HashMap.toList v)++gw_iter_tdl :: GW TD_Number -> IO ()+gw_iter_tdl gw =+ let+ o = TDl_Opts {+ o_alpha = 0.1+ , o_gamma = 1.0+ , o_eps = 0.3+ , o_lambda = 0.8+ }++ q0 = TDl.emptyQ 0 -- Initial Q table+ g0 = pureMT 33 -- Initial RNG+ cnt = 20*10^3 :: Integer++ st_q :: Lens' (a,b) a+ st_q = _1+ st_i :: Lens' (a,b) b+ st_i = _2+ in do++ flip evalRndT_ g0 $ do+ flip execStateT (q0,0) $ do+ loop $ do+ s0 <- Rules.arbitraryState gw+ i <- use st_i+ q <- use st_q++ (s',q') <-+ tdl_learn o q s0 $ TDl_GW gw $ \s a q -> do+ i <- use st_i+ when (i >= cnt) $ do+ break ()++ liftIO $ putStrLn $ "Loop i = " <> show i+ liftIO $ showV gw (TDl.toV q')+ st_i %= const (i+1)+ st_q %= const q'+++gw_iter_qlw :: GW TD_Number -> IO ()+gw_iter_qlw gw =+ let+ o = TDl_Opts {+ o_alpha = 0.1+ , o_gamma = 1.0+ , o_eps = 0.3+ , o_lambda = 0.5+ }++ q0 = TDl.emptyQ 0 -- Initial Q table+ g0 = pureMT 33 -- Initial RNG+ cnt = 20*10^3 :: Integer++ st_q :: Lens' (a,b) a+ st_q = _1+ st_i :: Lens' (a,b) b+ st_i = _2+ in do++ flip evalRndT_ g0 $ do+ flip execStateT (q0,0) $ do+ loop $ do+ s0 <- Rules.arbitraryState gw+ i <- use st_i+ q <- use st_q++ (s',q') <-+ qlw_learn o q s0 $ TDl_GW gw $ \s a q -> do+ i <- use st_i+ when (i >= cnt) $ do+ break ()++ liftIO $ putStrLn $ "Loop i = " <> show i+ liftIO $ showV gw (TDl.toV q')+ st_i %= const (i+1)+ st_q %= const q'++
+ examples/Examples/Ch6_Cliff.hs view
@@ -0,0 +1,13 @@+module Examples.Ch6_Cliff (+ module Examples.Ch6_Cliff+ , module Examples.Ch6_Cliff.TD+ , module Examples.Ch6_Cliff.TDl+ ) where++import Examples.Ch6_Cliff.Rules+import Examples.Ch6_Cliff.TD+import Examples.Ch6_Cliff.TDl++cw :: CW+cw = CW (8,4)+
+ examples/Examples/Ch6_Cliff/Rules.hs view
@@ -0,0 +1,77 @@+{-|+ Satton, 'Reinforcement Learning: The Introduction', pg.145, Example 6.6: Cliff Walking+-}++{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+module Examples.Ch6_Cliff.Rules where++import qualified Data.List as List+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set++import RL.Imports+import RL.Types++type Point = (Int,Int)++data Action = L | R | U | D+ deriving(Show, Eq, Ord, Enum, Bounded, Generic, Hashable)++showAction :: Action -> String+showAction = \case { L->"<" ; R->">" ; U->"^" ; D->"v" ; }++data CW = CW {+ cw_size :: (Int,Int)+ } deriving(Show)+++exits (CW (sx,sy)) = (sx-1,sy-1)++transition (CW (sx,sy)) (x,y) a =+ let+ check (x',y') =+ if x' >= 0 && x' < sx && y' >= 0 && y' < sy then+ if (y' == sy-1) && (x' /= 0) && (x' /= sx-1) then+ ((0,sy-1), True)+ else+ ((x',y'), False)+ else+ ((x,y), False)+ in+ case a of+ L -> check (x-1,y)+ R -> check (x+1,y)+ U -> check (x,y-1)+ D -> check (x,y+1)++reward cw s a s' = if fall then -100 else -1 where+ (s'', fall) = transition cw s a++showActionTable :: (MonadIO m, Fractional num, Real num) => CW -> [(Point,(Action, num))] -> m ()+showActionTable pr@(CW (sx,sy)) at = liftIO $ do+ forM_ [0..sy-1] $ \y -> do+ forM_ [0..sx-1] $ \x -> do+ case List.lookup (x,y) at of+ Nothing -> do+ printf "% 4s " "?"+ Just (a,_) -> do+ printf "% 4s " (showAction a)+ printf "\n"++showV :: (MonadIO m, Real num) => CW -> [(Point, num)] -> m ()+showV (CW (sx,sy)) v = liftIO $ do+ forM_ [0..sy-1] $ \y -> do+ forM_ [0..sx-1] $ \x -> do+ case List.lookup (x,y) v of+ Just v -> do+ printf "%-2.1f " ((fromRational $ toRational v) :: Double)+ Nothing -> do+ printf " ? "+ printf "\n"++pickState :: MonadRnd g m => CW -> m Point+pickState (CW (sx,sy)) = do+ uniform $ (0,sy-1) : [(x,y) | x <- [0..sx-1], y <- [0..sy-2] ]+
+ examples/Examples/Ch6_Cliff/TD.hs view
@@ -0,0 +1,64 @@+module Examples.Ch6_Cliff.TD (cw_iter_q) where++import qualified Prelude+import qualified Data.HashMap.Strict as HashMap++import RL.Imports+import RL.Types as TD+import RL.TD as TD++import Examples.Ch6_Cliff.Rules(CW(..), Point, Action)+import qualified Examples.Ch6_Cliff.Rules as Rules++data TD_CW m = TD_CW {+ cw :: CW+ , cw_trace :: Point -> Action -> Q Point Action -> m ()+ }++instance (Monad m) => TD_Problem (TD_CW m) m Point Action where+ td_is_terminal TD_CW{..} p = (p == Rules.exits cw)+ td_greedy TD_CW{..} best = id+ td_reward TD_CW{..} = Rules.reward cw+ td_transition TD_CW{..} s a q = return (fst $ Rules.transition cw s a)+ td_modify TD_CW{..} s a q = cw_trace s a q++showV gw v = Rules.showV gw (HashMap.toList v)++cw_iter_q :: CW -> IO ()+cw_iter_q cw =+ let+ -- Q options+ o = Q_Opts {+ o_alpha = 0.1+ , o_gamma = 1.0+ , o_eps = 0.7+ }++ q0 = TD.emptyQ 0 -- Initial Q table+ g0 = pureMT 33 -- Initial RNG+ cnt = 20*10^3++ st_q :: Lens' (a,b) a+ st_q = _1+ st_i :: Lens' (a,b) b+ st_i = _2+ in do++ flip evalRndT_ g0 $ do+ flip execStateT (q0,0) $ do+ loop $ do+ s0 <- Rules.pickState cw+ i <- use st_i+ q <- use st_q++ (s',q') <-+ q_learn o q s0 $ TD_CW cw $ \s a q -> do+ i <- use st_i+ when (i >= cnt) $ do+ break ()++ liftIO $ putStrLn $ "Loop i = " <> show i+ liftIO $ showV cw (TD.toV q')+ st_i %= const (i+1)+ st_q %= const q'+
+ examples/Examples/Ch6_Cliff/TDl.hs view
@@ -0,0 +1,105 @@+module Examples.Ch6_Cliff.TDl (+ cw_iter_tdl+ , cw_iter_qlw+ ) where++import qualified Prelude+import qualified Data.HashMap.Strict as HashMap++import RL.Imports+import RL.TDl as TDl++import Examples.Ch6_Cliff.Rules(CW(..), Point, Action)+import qualified Examples.Ch6_Cliff.Rules as Rules++data TD_CW m = TD_CW {+ cw :: CW+ , cw_trace :: Point -> Action -> Q Point Action -> m ()+ }++instance (Monad m) => TDl_Problem (TD_CW m) m Point Action where+ td_is_terminal TD_CW{..} p = (p == Rules.exits cw)+ td_greedy TD_CW{..} best = id+ td_reward TD_CW{..} = Rules.reward cw+ td_transition TD_CW{..} s a st = return (fst $ Rules.transition cw s a)+ td_modify TD_CW{..} s a st = cw_trace s a (st^.tdl_q)++showV gw v = Rules.showV gw (HashMap.toList v)++cw_iter_tdl :: CW -> IO ()+cw_iter_tdl cw =+ let+ o = TDl_Opts {+ o_alpha = 0.1+ , o_gamma = 1.0+ , o_eps = 0.7+ , o_lambda = 0.8+ }++ q0 = TDl.emptyQ 0 -- Initial Q table+ g0 = pureMT 33 -- Initial RNG+ cnt = 20*10^3 :: Integer++ st_q :: Lens' (a,b) a+ st_q = _1+ st_i :: Lens' (a,b) b+ st_i = _2+ in do++ flip evalRndT_ g0 $ do+ flip execStateT (q0,0) $ do+ loop $ do+ s0 <- Rules.pickState cw+ i <- use st_i+ q <- use st_q++ (s',q') <-+ tdl_learn o q s0 $ TD_CW cw $ \s a q -> do+ i <- use st_i+ when (i >= cnt) $ do+ break ()++ liftIO $ putStrLn $ "Loop i = " <> show i+ liftIO $ showV cw (TDl.toV q')+ st_i %= const (i+1)+ st_q %= const q'+++cw_iter_qlw :: CW -> IO ()+cw_iter_qlw cw =+ let+ o = TDl_Opts {+ o_alpha = 0.1+ , o_gamma = 1.0+ , o_eps = 0.7+ , o_lambda = 0.8+ }++ q0 = TDl.emptyQ 0 -- Initial Q table+ g0 = pureMT 33 -- Initial RNG+ cnt = 20*10^3 :: Integer++ st_q :: Lens' (a,b) a+ st_q = _1+ st_i :: Lens' (a,b) b+ st_i = _2+ in do++ flip evalRndT_ g0 $ do+ flip execStateT (q0,0) $ do+ loop $ do+ s0 <- Rules.pickState cw+ i <- use st_i+ q <- use st_q++ (s',q') <-+ qlw_learn o q s0 $ TD_CW cw $ \s a q -> do+ i <- use st_i+ when (i >= cnt) $ do+ break ()++ liftIO $ putStrLn $ "Loop i = " <> show i+ liftIO $ showV cw (TDl.toV q')+ st_i %= const (i+1)+ st_q %= const q'+
+ examples/Examples/TickTackToe.hs view
@@ -0,0 +1,295 @@+{-|+ - This module relies on older version of library and thus couldn't be+ - compailed.+ -+ - FIXME: update the TickTackToe module+ --}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE PartialTypeSignatures #-}+module TickTackToe where++import Imports+import qualified Data.List as List+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Prelude hiding(break)++import Util+import Monad+import Types+import MC.Types as MC+import MC.ES++data Cell = X | O | E+ deriving(Show,Read,Eq,Ord)++showCell X = "X"+showCell O = "O"+showCell E = " "++type Player = Cell++nextPlayer X = O+nextPlayer O = X+nextPlayer E = error "nextPlayer: result for E is undefined"++data Board = Board {+ bo_cells :: Map (Int,Int) Cell+ , bo_wins :: Player+ , bo_term :: Bool+} deriving(Show,Read,Ord,Eq)++type Action = (Int,Int)++board_ny = 3+board_nx = 3+(.+) (a,b) (c,d) = (a+c,b+d)+(.*) x (a,b) = (x*a,x*b)+board_inside (x,y) = x >=0 && x < board_nx && y >=0 && y < board_ny+board_winsize = 3+board_points = [(x,y) | x<-[0..board_nx-1], y<-[0..board_ny-1]]+board_dirs = [(0,1),(1,0),(1,1),(1,-1)]+board_rows = filter ( and . map board_inside ) $ [ map (\x -> p .+ (x .* d)) [0..board_winsize-1] | p <- board_points, d <- board_dirs]+board_wincheck = Map.fromList [ (p,filter (p`elem`) board_rows) | p <- board_points ]++at :: Board -> Action -> Cell+at Board{..} a = fromMaybe E (Map.lookup a bo_cells)++set a c Board{..} = Board (Map.insert a c bo_cells)++move :: Board -> Player -> Action -> Board+move b@Board{..} p a =+ case bo_term of+ False ->+ let+ bo_cells' = Map.insert a p bo_cells+ bo_last' = boardFree b == [a]+ bo_winner' = or $ flip map (board_wincheck ! a) $ \r {-row-} ->+ all (==p) (flip map r $ (\ a -> fromMaybe E $ Map.lookup a bo_cells'))+ in+ Board bo_cells' (if bo_winner' then p else E) (bo_last' || bo_winner')+ True -> error $ "move called on terminal board"++emptyBoard :: Board+emptyBoard = Board Map.empty E False++boardFree :: Board -> [Action]+boardFree Board{..} = board_points \\ (Map.keys bo_cells)++-- FIXME: eliminate potantional forever loop+randomBoard :: (RandomGen g) => Player -> g -> (Board, g)+randomBoard p g =+ let+ check ((_,b,True),g') = (b,g')+ check ((_,_,False),g') =+ -- trace "randomBoard diverged" $+ randomBoard p g'+ in do+ check $+ flip runRnd g $ do+ flip execStateT (X, emptyBoard, True) $ do+ loop $ do+ nmoves <- (+ case p of+ X -> Monad.uniform $ filter even [0 .. board_nx*board_ny-1]+ O -> Monad.uniform $ filter odd [0 .. board_nx*board_ny-1])+ forM_ [1..nmoves] $ \m -> do+ player <- use _1+ board <- use _2+ let b's = filter (not . bo_term) $ map (move board player) (boardFree board)+ case null b's of+ True -> do+ _3 %= const False+ break ()+ False -> do+ b' <- Monad.uniform b's+ _1 %= nextPlayer+ _2 %= const b'+ break ()++showBoard :: (MonadIO m) => Board -> m ()+showBoard b =+ liftIO $ do+ putStrLn ".---."+ forM_ [0..board_ny-1] $ \y -> do+ putStr "|"+ forM_ [0..board_nx-1] $ \x -> do+ putStr $ showCell (b `at` (x,y))+ putStrLn "|"+ putStrLn ".---."++showRandomBoard :: _ -> IO ()+showRandomBoard seed = showBoard $ fst $ randomBoard X (pureMT seed)++showEpisode :: (Show num, MonadIO m, MC_Problem num T Board Action) => T num -> Episode Board Action -> m ()+showEpisode pr@T{..} e = do+ let es = episode_forward e+ showBoard $ view _1 $ head es+ forM_ es $ \(b,a,b') -> do+ liftIO $ putStrLn $ show a+ showBoard b'+ let (b,a,b') = head (episode_backward e)+ liftIO $ putStrLn $ "Player " ++ show t_player ++ " R " ++ show (mc_reward pr b a b')++-- | TickTackToe => T+data T num = T {+ t_vals :: Map Player (Q num Board Action)+ , t_player :: Player+} deriving(Show,Read)++bestAction :: (Fractional num, Ord num, RandomGen g)+ => T num -> Board -> Player -> g -> Maybe (Action, g)+bestAction T{..} b p g =+ let+ macts = Map.lookup b $ view q_map $ t_vals ! p+ in+ case macts of+ Just as -> Just (fst $ maximumBy (compare `on` (current . snd)) (Map.toList as), g)+ Nothing ->+ case boardFree b of+ [] -> Nothing+ x -> Just $ flip runRnd g $ Monad.uniform x+++instance (Fractional num, Real num, Ord num) => MC_Problem num T Board Action where++ mc_state_nonterm T{..} = randomBoard t_player++ mc_actions T{..} = Set.fromList . boardFree++ mc_transition t@T{..} b a g =+ let+ {- Applying action -}+ b' = move b t_player a+ in+ case bo_term b' of+ True ->+ {- Win -}+ ((b', True), g)+ False ->+ let+ p' = nextPlayer t_player+ in+ case bestAction t b' p' g of+ Nothing ->+ {- Draw -}+ ((b', True), g)+ Just (a',g') ->+ {- Make opponent's move according to their current state-value -}+ let+ b'' = move b' p' a'+ in+ {- Next|Loose -}+ ((b'', bo_term b''), g')++ mc_reward T{..} b a b' =+ if bo_term b' then+ if | bo_wins b' == t_player -> 1+ | bo_wins b' == E -> 0+ | otherwise -> -1+ else+ 0+++instance (Fractional num, Real num, Ord num, Show num) => MC_Problem_Show num T Board Action++t0 = T {+ t_vals = Map.fromList [+ (X,emptyQ),+ (O,emptyQ)+ ],+ t_player = O+ }+++t1 = T {+ t_vals = Map.fromList [+ (X,emptyQ),+ (O,emptyQ)+ ],+ t_player = X+ }+++example :: (Show num, Fractional num, Ord num, Real num) => T num -> IO ()+example pr = do++ flip evalStateT ((0,0,0),pr) $ do++ loop $ do++ pr@T{..} <- use _2++ _1 %= const (0,0,0)++ let+ g = pureMT 33++ o = (MC.defaultOpts $ ES_Ext {+ eo_debug = \e@Episode{..} ES_State{..} -> do+ let winner = bo_wins (episodeFinal e)+ if | winner == t_player -> do+ _1 . _1 %= (+1)+ | winner == E -> do+ _1 . _2 %= (+1)+ | winner == (nextPlayer t_player) -> do+ _1 . _3 %= (+1)+ when (0 == _ess_iter `mod` 100) $ do+ score <- use _1+ traceM (t_player, _ess_iter, score, sizeQ _ess_q)++ when (0 == _ess_iter `mod` 1000) $ do+ showEpisode pr e+ }) {+ o_max_iter = 10000+ }++ s = MC.ES.initialState (t_vals ! t_player) emptyGenericPolicy++ (s',g') <- MC.ES.policy_iteraton pr o s g++ let pr' = pr{+ t_vals = Map.insert t_player (_ess_q s') t_vals+ , t_player = nextPlayer t_player+ }++ _2 %= const pr'++ save "game" "data/TickTackToe" (show pr')+++load :: forall num . (Show num, Read num, Fractional num, Ord num, Real num) => FilePath -> IO (T num)+load fp = do+ contents <- readFile fp+ return (read contents)++simulate :: (Show num, Fractional num, Ord num, Real num) => T num -> IO ()+simulate t = do+ flip evalStateT (X, emptyBoard) $ do+ loop $ do+ (player,board) <- get+ let (action, nmax) = maximumBy (compare `on` (current . snd)) $ Map.toList ((_q_map ((t_vals t) ! player)) ! board)+ let board' = move board player action+ liftIO $ do+ showBoard board+ putStrLn $ "Player is " ++ show player ++ "; Move is " ++ show action ++ " Learned " ++ show (avg_n nmax)+ when (bo_term board') $ do+ liftIO $ do+ showBoard board'+ putStrLn $ show (bo_wins board')+ break ()+ _1 %= nextPlayer+ _2 %= const board'+++++
rl-satton.cabal view
@@ -1,5 +1,5 @@ name: rl-satton-version: 0.1.2.3+version: 0.1.2.4 author: Sergey Mironov maintainer: grrwlf@gmail.com category: Machine Learning@@ -80,6 +80,19 @@ default-language: Haskell2010 hs-source-dirs: examples main-is: Main.hs+ other-modules: Examples+ Examples.Ch4_Gambler+ Examples.Ch4_GridWorld+ Examples.Ch4_GridWorld.DP+ Examples.Ch4_GridWorld.MC+ Examples.Ch4_GridWorld.Rules+ Examples.Ch4_GridWorld.TD+ Examples.Ch4_GridWorld.TDl+ Examples.Ch6_Cliff+ Examples.Ch6_Cliff.Rules+ Examples.Ch6_Cliff.TD+ Examples.Ch6_Cliff.TDl+ Examples.TickTackToe build-depends: base >=4.8 && <5, rl-satton, containers,