I ported the Lisp Tic Tac Toe code from Chapter 1. to Haskell. The original code repo is down for some reason.I believe I have completely rewritten that in Haskell (Less functional than one would expect ). It is being tested. But I have doubts about how the learning algorithm learns. I see this type of result from my code which is the equivalent of the 'run' function in the book.Played 100 times 43.5  0.435Played 100 times 46.0  0.46Played 100 times 42.0  0.42Played 100 times 41.0  0.41numruns and playrepeatedly in my code are the equivalent of runs in the Lisp example.There are two players, X and O. Since I write some log files I can see that Player X wins many times. I thought eventually Player O will observe, learn and start winning. Since I am yet to run the algorithm hundreds of times, I don't see Player O winning. Please point out anything wrong in my assumption.My code compiles and prints the result, so trivial bugs aren't there, I think. But gameplan, my largest function, could have a bug or two, but I'm not sure.Can anyone review from the perspective of improving the learning of the algorithm? There may be a code bug that prevents it from learning properly.Please ignore Haskell Gloss code. That was used to view the board, so it's useless now.  module ReinforcementLearning whereimport Control.Monad.Stateimport qualified Data.Map as Mapimport Control.Applicativeimport Graphics.Glossimport Data.Array.IOimport Control.Monad.Readerimport System.Randomimport Data.Listimport Control.Exceptionimport System.IO.Error import Text.Printfimport Debug.Traceimport System.IOfun :: Map.Map String Intfun = Map.emptystore :: String -> Int-> State (Map.Map String Int) ()store x value = do  fun <- get  put (Map.insert x value fun)retrieve :: String -> State (Map.Map String Int) (Maybe (Int))retrieve roworcolumn = do  fun <- get  return (Map.lookup roworcolumn fun) getrow = do {store row 1; retrieve row}  getcolumn = do {store column 1; retrieve column}  getboardsize = do              let x = (runState getrow fun) in             let y = (runState getcolumn fun) in                (Just (*) <*> (fst x)  <*>  (fst y) )magicsquare :: [Int]magicsquare = [2,9,4,7,5,4,7,5,4] data BoardState = BoardState { xloc :: [Int],                               oloc :: [Int],                               index :: Int                             }  deriving (Show)translationaccumulator ::   [Int] -> [Int] -> [(Float,Float)] -> [Picture] -> [Picture]translationaccumulator  [] _ _ ys = reverse ystranslationaccumulator  _ []  _ ys = reverse ystranslationaccumulator  (head1:xs1) (head:xs) angle  ys = let (a,b) = (angle !!(head - 1)) in                                                            let (c,d) = (angle  !!(head1 - 1)) in                                                              translationaccumulator xs1 xs angle ( ((translate a b) $                                                                                                 drawx ) : ((translate c d) $                                                                                                 drawo ):ys)drawBoard :: BoardState -> PicturedrawBoard (BoardState xloc oloc index)=  Pictures $ [ translate x y $ rectangleWire 90 90| x<-[0,90..180], y<-[0,90..180] ] ++ (translationaccumulator xloc oloc [(0,180),(90,180),(180,180),(0,90),(90,90),(180,90),(0,0),(90,0),(180,0)] [])drawx :: Picturedrawx = color green $ rotate 45 $        pictures [rectangleWire 1 45, rectangleWire  45 1] drawo :: Picturedrawo = color rose $ thickCircle 25 2powersof2  :: [Int]  powersof2  =  [ 2 ^ i | i <- [0..8]]createarray :: IO ( IOArray Int Double)createarray =  do {                       arr <- newArray (0,512*512) (-1.0);                       return arr                  }addVal :: Int -> [Int] -> [Int]addVal i [] = []addVal i (x:xs) = x * 512: addVal i xsstateindex :: [Int] -> [Int] -> Intstateindex xloc oloc = sum (map (2^) xloc)                       + sum [2^n | n <- (addVal 512 oloc)]type ArrayAccess = ReaderT  (IOArray Int Double)  IO type ArrayWriteAccess = ReaderT  (IOArray Int Double)  IO() readvalue ::  Int -> ArrayAccess  Double  readvalue x    = do   a <- ask  b <- liftIO( readArray a x);      return bwritevalue ::  Int -> Double -> ArrayWriteAccess   writevalue x y   = do   a <- ask  liftIO( writeArray a x y)    -- Test array accessesreadfromarray = do { a <- createarray; liftIO (runReaderT (readvalue 1) a) }writetoarray = do { a <- createarray; liftIO (runReaderT (writevalue 1 2) a) }logs      ::  String -> IO ()logs  message = withFile c:/Git/game.log AppendMode (\ fd -> hPrint fd message )logsresult      ::  String -> IO ()logsresult  message = withFile c:/Git/learning.log AppendMode (\ fd -> hPrint fd message )playero ::  String -> IO ()playero message = withFile c:/Git/playero.log AppendMode (\ fd -> hPrint fd message )showstate :: BoardState -> IO ()showstate (BoardState xloc oloc index) = display (InWindow Reinforcement Learning (530,530) (220,220)) (greyN 0.5)  (drawBoard (BoardState xloc oloc index) )data Player = X | O deriving ShowisX :: Player -> BoolisX X = TrueisX O = False type StateValue sv = StateT BoardState IO svappend :: Int -> [Int] -> [Int]append elem l = if elem == 0 then l else l ++ [elem]readthevalue :: ( IOArray Int Double) -> Int -> IO Doublereadthevalue a index =  liftIO (runReaderT (readvalue index ) a) writethevalue :: ( IOArray Int Double) -> Int -> Double -> IO ()writethevalue a index value =  liftIO (runReaderT (writevalue index value) a)  nextstate :: Player -> BoardState -> Int -> BoardState-- nextstate  player (BoardState xloc oloc index) move= traceShowId $  BoardState newx newo newindex wherenextstate  player (BoardState xloc oloc index) move=  BoardState newx newo newindex where  newx = if isX player then (append move xloc) else xloc  newo = if isX player then (append move oloc) else oloc  newindex = stateindex newx newomagicnumber :: [Int]-> Intmagicnumber l = sum $ ([magicsquare !! (x-1) | x <- l, x > 0])nextvalue :: (String -> IO()) -> Player -> Int -> ( IOArray Int Double) -> BoardState-> IO (BoardState,IOArray Int Double) nextvalue log player move a ( BoardState xloc oloc index) =  do  let newstate = (nextstate player ( BoardState xloc oloc index) move)  x <- catch (readthevalue a (ReinforcementLearning.index newstate))(\(SomeException e) -> printf Reading [%d} in Next value index >> print e >> throwIO e)  log $ printf Move is [%d] Value from value table is %f move x  log $ (show player)  log $ show (ReinforcementLearning.xloc newstate)  log $ show (ReinforcementLearning.oloc newstate)  if (x == -1.0)  then if ((magicnumber (ReinforcementLearning.xloc newstate)) == 15)       then do            (writethevalue a (ReinforcementLearning.index newstate) 0)            log $ printf Magic number is %d. Player X wins (magicnumber  (ReinforcementLearning.xloc newstate))            return (newstate,a)       else if ((magicnumber (ReinforcementLearning.oloc newstate)) == 15)            then do                 (writethevalue a  (ReinforcementLearning.index newstate) 1)                 playero $ printf Magic number is %d. Player O wins (magicnumber  (ReinforcementLearning.oloc newstate))                 return (newstate,a)            else if ((length (ReinforcementLearning.oloc newstate))+(length (ReinforcementLearning.xloc newstate)) == 9)            then do                 playero $ printf Sume of Length of states is 9                 (writethevalue a  (ReinforcementLearning.index newstate) 0)                 return (newstate,a)            else do                 (writethevalue a  (ReinforcementLearning.index newstate) 0.5)                 return (newstate,a)  else return (newstate,a)--   Returns a list of unplayed locationspossiblemoves :: BoardState -> [Int]possiblemoves (BoardState xloc oloc index) =  let xs =  [1,2,3,4,5,6,7,8,9] in    (xs \\ xloc) \\ olocdebug :: IO Int -> IO Intdebug value = do  x <- value  return x--   Returns one of the unplayed locations, selected at randomrandommove ::  BoardState -> IO Intrandommove state =   let possibles = possiblemoves state in    case possibles of      [] -> return 0      p -> debug $ fmap (p !! ) $ randomRIO(0, length p - 1)      -- p ->  fmap (p !! ) $ randomRIO(0, length p - 1)update :: ( IOArray Int Double) -> BoardState -> BoardState -> IO ( IOArray Int Double)update a state newstate = do  valueofstate <- readthevalue a (ReinforcementLearning.index state)  valueofnewstate <- readthevalue a (ReinforcementLearning.index newstate)  let finalvalue = valueofstate + ( 0.5 *  (valueofnewstate - valueofstate)) in  --  This is the learning rule    writethevalue a (ReinforcementLearning.index state) finalvalue  return arandombetween :: IO Doublerandombetween = do  r1 <-  randomRIO(0, 1.0)  return r1terminalstatep :: (String -> IO()) ->( IOArray Int Double) -> Int -> IO Boolterminalstatep log a x = do  y <-  catch ( readthevalue a x) (\(SomeException e) ->  print e >> printf Read in terminalstep throws exception >> throwIO e)  let result = (y == fromIntegral( round y))  do {    log $ printf Terminal Step - Value is %f y;    return result    }greedymove ::  (String -> IO()) ->( IOArray Int Double) ->Player -> BoardState -> IO (Int,IOArray Int Double)greedymove log a player state =   let possibles = possiblemoves state in    case possibles of      [] -> return (0, a)      p  -> let bestvalue = -1.0 in              let bestmove = 0 in                choosebestmove a p bestvalue bestmove                where                  choosebestmove arr [] bestvalue1 bestmove1 = return (0,a)                  choosebestmove arr (x:xs) bestvalue1 bestmove1 = do                    (nv,b) <- nextvalue logs player x arr state                    xvalue <-  catch (readthevalue b (ReinforcementLearning.index (nv)))(\(SomeException e) -> printf Reading [%d} in greedy move x >> print e >> throwIO e)                    case compare bestvalue1 xvalue of                      LT -> choosebestmove b xs xvalue x;                      GT -> return (bestmove1,b)                      EQ -> return (bestmove1,b)randomgreedy :: (String -> IO()) ->Double -> Int -> Int -> Intrandomgreedy log r1 rm gm = if (r1 < 0.01)                            then rm                            else gmgameplan :: (String -> IO()) ->( IOArray Int Double) -> BoardState -> BoardState -> IO (IOArray Int Double,BoardState,Double) gameplan log a state newstate = do   r1 <- randombetween;  initialvalue <- readthevalue  a 0  result <- (terminalstatep log a (ReinforcementLearning.index newstate));    case result of      True -> do        b <- update a state newstate        valueofnewstate <- catch (readthevalue b (ReinforcementLearning.index newstate)) (\(SomeException e) -> print e >> mapM_ (putStr . show) [ (ReinforcementLearning.index newstate)]>> throwIO e)        log $ printf Gameplan returns(True branch) %f\n  valueofnewstate        return (b,newstate,valueofnewstate)      False -> do        rm <- randommove newstate        (gm,c) <- greedymove log a O newstate        log $ printf Greedy Move is %d \n  gm        valueofnewstate <-  catch (readthevalue c (ReinforcementLearning.index newstate)) (\(SomeException e) -> print e >> mapM_ (putStr . show) [ (ReinforcementLearning.index newstate)]>> throwIO e)        -- if (gm == 0)        --   then do        --   return(c,newstate,valueofnewstate)        --   else do        (nv,d) <- nextvalue logs O (randomgreedy log r1 rm gm) c newstate        d' <- if r1 < 0.01 then return d else update d state nv        result1 <- (terminalstatep log d' (ReinforcementLearning.index nv));        valueofnewstate1 <-  catch (readthevalue d' (ReinforcementLearning.index nv)) (\(SomeException e) -> print e >> mapM_ (putStr . show) [ (ReinforcementLearning.index nv)]>> throwIO e)        if (length (possiblemoves nv) == 0)          then          return (d',nv,valueofnewstate1)          else if result1               then do               log $ printf Gameplan returns(False branch) %f\n  valueofnewstate1               return (d',nv,valueofnewstate1)               else do               r <- randommove newstate               (nv1,d1') <- nextvalue logs X r d' newstate               gameplan log d1' newstate (nv1)--   Plays 1 game against the random player. Also learns and prints.--    :X moves first and is random.  :O learnsgame ::  (String -> IO()) ->BoardState  -> BoardState -> IOArray Int Double -> IO (IOArray Int Double,BoardState,Double) game log state newstate a  = do  log $ Call game  (newa, state, result )<-  gameplan log a state newstate  return (newa, state, result )playntimes :: IOArray Int Double -> (String -> IO()) ->Int -> IO (IOArray Int Double)-- playntimes log n = do a <- createarray;playntimes a log n = do writethevalue a 0 0.5                        r <- (randommove (BoardState [] [] 0))                        playtime  a (BoardState [] [] 0) (nextvalue logs X r a (BoardState [] [] 0)) n 0 r                          where                            playtime :: IOArray Int Double -> BoardState -> IO (BoardState,IOArray Int Double) -> Int -> Double -> Int -> IO (IOArray Int Double)                            playtime newa s ns n acc r                              | n == 0 = do logsresult $ printf Played 100 times %f  %f  acc (acc/100.0)                                            return newa                              | n > 0 = do                                  (boardstate, b) <- ns                                   (newa, state, result )<- game logs s  boardstate b;                                   log $ printf Game returns %f\n result                                  r1 <- randommove (BoardState [] [] 0)                                  playtime newa (BoardState [] [] 0) (nextvalue logs X  r1 newa (BoardState [] [] 0)) (n - 1) (acc + result) r1numruns :: IOArray Int Double ->Int -> Int -> Int -> IO()numruns a n bins binsize    | n == 0 = printf \nPlayed numruns times  | n > 0 = do      arr <- newArray (0,bins) 0;      b <- playrepeatedly a arr n bins binsize      numruns b (n -1) bins binsizeplayrepeatedly ::  IOArray Int Double ->IOArray Int Double -> Int -> Int -> Int -> IO(IOArray Int Double)playrepeatedly a arr numrun numbins binsize = do  loop a 0 binsize    where      loop a i bs        | i == numbins = let x = numrun                             y = numbins                             z = binsize in                           loop1 a x 0 y z         | i < numbins = do            v <- readthevalue arr i             writethevalue arr i (v+1)            b <- playntimes a logs bs;            loop b (i+1) bs        where         loop1 a x j y z = if j < y                              then do                              fv <- readthevalue arr j                              printf  Runs %f Final Value %f Binsize %d Numruns %d \n (fv / fromIntegral( z * x)) fv z x                              loop1 a x (j+1) y z                              else                              return amain =  do   p <- createarray   ReinforcementLearning.numruns p 1 1 100   return ()I have updated another version that reuses the array that the algorithm uses to store the learnt values. I mean that this array is now returned and reused. I don't see any major improvement, though.playntimes log n = do a <- createarray;
Reinforcement learning example (chap. 1) from Sutton's book
haskell;lisp;machine learning
gameplanrevised :: (String -> IO()) ->( IOArray Int Double) -> BoardState -> BoardState -> IO (IOArray Int Double,BoardState,Double) gameplanrevised log a state newstate = do                         exploremove a state newstate                          where                            exploremove :: ( IOArray Int Double) -> BoardState -> BoardState ->IO (IOArray Int Double,BoardState,Double)                            exploremove a state newstate =                              do                                r <- randombetween;                                let em = exploratorymove r in                                  do                                    result <- (terminalstatep log a (ReinforcementLearning.index newstate));                                    case result of                                      True -> do                                        b <- update a state newstate                                        valueofnewstate <- catch (readthevalue b (ReinforcementLearning.index newstate)) (\(SomeException e) -> print e >> mapM_ (putStr . show) [ (ReinforcementLearning.index newstate)]>> throwIO e)                                        return (b,newstate,valueofnewstate)                                      False -> do                                        if em                                          then do                                            rm <- randommove newstate                                            (nv,d) <- nextvalue logs O rm a newstate                                            result1 <- (terminalstatep log d (ReinforcementLearning.index nv));                                            valueofnewstate1 <-  catch (readthevalue d (ReinforcementLearning.index nv)) (\(SomeException e) -> print e >> mapM_ (putStr . show) [ (ReinforcementLearning.index nv)]>> throwIO e)                                            if result1                                              then do                                              return (d,nv,valueofnewstate1)                                              else do                                              r1 <- randommove nv                                              (ns,na) <- nextvalue logs X r1 d nv                                              exploremove na nv ns                                           else do                                            (gm,c) <- greedymove log a O newstate                                            (nv',d') <- nextvalue logs O gm c newstate                                            d'' <- update d' state nv'                                            result2 <- (terminalstatep log d'' (ReinforcementLearning.index nv'));                                            valueofnewstate2 <-  catch (readthevalue d'' (ReinforcementLearning.index nv')) (\(SomeException e) -> print e >> mapM_ (putStr . show) [ (ReinforcementLearning.index nv')]>> throwIO e)                                            if result2                                              then do                                              return (d'',nv',valueofnewstate2)                                              else do                                              r1 <- randommove nv'                                              (ns,na) <- nextvalue logs X r1 d'' nv'                                              exploremove na nv' ns This is the main function - 'gameplan' in the question - that was error prone. The function is recursive. There are two players, X and O who play the board game. So for each game of 'tictactoe', Player X gets the first chance and this player always makes a random move.  If Player X wins the game ends. Another game starts.If Player X doesn't win, Player O gets a chance. O is smarter because O either makes a greedy move or a random move. If O wins its learning rate is accumulated and the next game starts. 'nextvalue' in the original question accumulates the rate. Rewards differ based on the result of the game.After I fixed this function the learning rate improved. Sometimes O wins 70% of the time.So I think I have answered it to my satisfaction. The code works well even though it has to improve its learning rate more.I think Player O should become unbeatable and should win almost all the games. 