rlglue (empty) → 0.2.2.0
raw patch · 11 files changed
+1285/−0 lines, 11 filesdep +basedep +binarydep +bytestringsetup-changed
Dependencies added: base, binary, bytestring, data-binary-ieee754, exceptions, network, network-simple, parsec, random, transformers
Files
- LICENSE +202/−0
- Setup.hs +2/−0
- rlglue.cabal +51/−0
- src/RL_Glue/Agent.hs +131/−0
- src/RL_Glue/Environment.hs +122/−0
- src/RL_Glue/Example/SkeletonAgent.hs +38/−0
- src/RL_Glue/Example/SkeletonEnvironment.hs +50/−0
- src/RL_Glue/Example/SkeletonExperiment.hs +82/−0
- src/RL_Glue/Experiment.hs +116/−0
- src/RL_Glue/Network.hs +317/−0
- src/RL_Glue/TaskSpec.hs +174/−0
+ LICENSE view
@@ -0,0 +1,202 @@++ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright [yyyy] [name of copyright owner]++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ rlglue.cabal view
@@ -0,0 +1,51 @@+name: rlglue+version: 0.2.2.0+synopsis: A Haskell codec for RL-Glue.+description: A codec to allow Haskell programs to interact with reinforcement learning+ programs using the RL_Glue protocol.+license: Apache-2.0+license-file: LICENSE+author: Richard Alex Hofer+maintainer: rhofer@alumni.cmu.edu+-- copyright: +category: Codec+build-type: Simple+-- extra-source-files: +cabal-version: >=1.10+source-repository head+ type: git+ location: git://github.com/rhofour/rlglue-haskell-codec.git++library+ exposed-modules: RL_Glue.Network, RL_Glue.Experiment, RL_Glue.Environment, RL_Glue.Agent,+ RL_Glue.TaskSpec+ other-modules: Paths_rlglue+ -- other-extensions: + build-depends: base >=4.7 && <4.8, network-simple, transformers, exceptions, binary, bytestring,+ data-binary-ieee754, parsec, network+ hs-source-dirs: src+ default-language: Haskell2010++executable skeleton-experiment+ Main-is: SkeletonExperiment.hs+ build-depends: base >=4.7 && <4.8, network-simple, transformers, exceptions, binary, bytestring,+ data-binary-ieee754, network+ -- other-modules:+ hs-source-dirs: src, src/RL_Glue/Example+ default-language: Haskell2010++executable skeleton-environment+ Main-is: SkeletonEnvironment.hs+ build-depends: base >=4.7 && <4.8, network-simple, transformers, exceptions, binary, bytestring,+ data-binary-ieee754, network+ -- other-modules:+ hs-source-dirs: src, src/RL_Glue/Example+ default-language: Haskell2010++executable skeleton-agent+ Main-is: SkeletonAgent.hs+ build-depends: base >=4.7 && <4.8, network-simple, transformers, exceptions, binary, bytestring,+ data-binary-ieee754, random, network+ -- other-modules: + hs-source-dirs: src, src/RL_Glue/Example+ default-language: Haskell2010
+ src/RL_Glue/Agent.hs view
@@ -0,0 +1,131 @@+module RL_Glue.Agent (+ Agent(Agent), loadAgentDebug, loadAgent+ ) where++import Control.Monad (unless)+import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.State.Lazy+import Data.Binary.Get+import Data.Binary.Put+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Data.Version (showVersion)+import Data.Word+import Network.Simple.TCP+import System.Exit++import Paths_rlglue (version)+import RL_Glue.Network++data Agent a = Agent+ { onAgentInit :: BS.ByteString -> StateT a IO ()+ , onAgentStart :: Observation -> StateT a IO Action+ , onAgentStep :: (Reward, Observation) -> StateT a IO Action+ , onAgentEnd :: Reward -> StateT a IO ()+ , onAgentCleanup :: StateT a IO ()+ , onAgentMessage :: BS.ByteString -> StateT a IO BS.ByteString+ }++loadAgent :: Agent a -> a -> IO ()+loadAgent = loadAgentDebug 0++loadAgentDebug :: Int -> Agent a -> a -> IO ()+loadAgentDebug debugLvl agent initState =+ let + func (sock, addr) =+ do+ -- Initial setup+ putStrLn $ "RL-Glue Haskell Agent Codec (Version " ++ showVersion version ++ ")"+ let bs = runPut (putWord32be kAgentConnection >> putWord32be (0 :: Word32))+ sendLazy sock bs++ -- Run event loop+ evalStateT (eventLoop agent sock debugLvl) initState+ in+ glueConnect func++eventLoop :: Agent a -> Socket -> Int -> StateT a IO ()+eventLoop agent sock debugLvl = do+ x <- lift $ runMaybeT (getAgentState sock)+ case x of+ Nothing -> do+ lift $ putStrLn "Error: Failed to receive state."+ lift $ exitWith (ExitFailure 1)+ Just (state, size) ->+ unless (state == kRLTerm) $ do+ handleState sock agent state debugLvl+ eventLoop agent sock debugLvl++handleState :: Socket -> Agent a -> Word32 -> Int -> StateT a IO ()+handleState sock agent state debugLvl+ | state == kAgentInit = do+ lift $ unless (debugLvl < 1) $ putStrLn "kAgentInit received"+ taskSpec <- lift $ getStringOrDie "Error: Could not get task spec" sock+ onAgentInit agent taskSpec+ let packedMsg = runPut (+ putWord32be kAgentInit >>+ putWord32be 0)+ sendLazy sock packedMsg+ | state == kAgentStart = do+ lift $ unless (debugLvl < 1) $ putStrLn "kAgentStart received"+ obs <- lift $ getObservationOrDie sock+ action <- onAgentStart agent obs+ let size = sizeOfAction action+ let packedMsg = runPut (+ putWord32be kAgentStart >>+ putWord32be (fromIntegral size) >>+ putAction action)+ sendLazy sock packedMsg+ | state == kAgentStep = do+ lift $ unless (debugLvl < 1) $ putStrLn "kAgentStep received"+ rewardObs <- lift $ getRewardObservationOrDie sock+ action <- onAgentStep agent rewardObs+ let size = sizeOfAction action+ let packedMsg = runPut (+ putWord32be kAgentStep >>+ putWord32be (fromIntegral size) >>+ putAction action)+ sendLazy sock packedMsg+ | state == kAgentEnd = do+ lift $ unless (debugLvl < 1) $ putStrLn "kAgentEnd received"+ reward <- lift $ getRewardOrDie sock+ onAgentEnd agent reward+ let packedMsg = runPut (+ putWord32be kAgentEnd >>+ putWord32be 0)+ sendLazy sock packedMsg+ | state == kAgentCleanup = do+ lift $ unless (debugLvl < 1) $ putStrLn "kAgentCleanup received"+ onAgentCleanup agent+ let packedMsg = runPut (+ putWord32be kAgentCleanup >>+ putWord32be 0)+ sendLazy sock packedMsg+ | state == kAgentMessage = do+ lift $ unless (debugLvl < 1) $ putStrLn "kAgentMessage received"+ msg <- lift $ getStringOrDie "Error: Could not read message" sock+ resp <- onAgentMessage agent msg+ let packedMsg = runPut (+ putWord32be kAgentMessage >>+ if BS.null resp+ then putWord32be 4 >> putWord32be 0+ else + putWord32be (fromIntegral $ 4 + BS.length resp) >>+ putString resp)+ sendLazy sock packedMsg+ | state == kRLTerm = + lift $ unless (debugLvl < 1) $ putStrLn "kRLTerm received"+ | otherwise = do+ lift $ putStrLn $ "Error: Unknown state: " ++ show state+ lift $ exitWith (ExitFailure 1)++getAgentState :: Socket -> MaybeT IO (Word32, Word32)+getAgentState sock = do+ bs <- MaybeT $ recv sock (4*2)+ return $ runGet parseBytes (LBS.fromStrict bs)+ where+ parseBytes = do+ envState <- getWord32be+ dataSize <- getWord32be+ return (envState, dataSize)
+ src/RL_Glue/Environment.hs view
@@ -0,0 +1,122 @@+module RL_Glue.Environment (+ Environment(Environment), loadEnvironment+ ) where++import Control.Monad (unless)+import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.State.Lazy+import Data.Binary.Get+import Data.Binary.Put+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Data.Version (showVersion)+import Data.Word+import Network.Simple.TCP+import System.Exit++import Paths_rlglue (version)+import RL_Glue.Network++data Environment a = Environment+ { onEnvInit :: StateT a IO BS.ByteString+ , onEnvStart :: StateT a IO Observation+ , onEnvStep :: Action -> StateT a IO (Terminal, Reward, Observation)+ , onEnvCleanup :: StateT a IO ()+ , onEnvMessage :: BS.ByteString -> StateT a IO BS.ByteString+ }++loadEnvironment :: Environment a -> a -> IO ()+loadEnvironment env initState =+ let + func (sock, addr) =+ do+ -- Initial setup+ putStrLn ("RL-Glue Haskell Environment Codec (Version " ++ showVersion version ++ ")")+ let bs = runPut (putWord32be kEnvironmentConnection >> putWord32be (0 :: Word32))+ sendLazy sock bs++ -- Run event loop+ evalStateT (eventLoop env sock) initState+ in+ glueConnect func++eventLoop :: Environment a -> Socket -> StateT a IO ()+eventLoop env sock = do+ x <- lift $ runMaybeT (getEnvState sock)+ case x of+ Nothing -> do+ lift $ putStrLn "Error: Failed to receive state."+ lift $ exitWith (ExitFailure 1)+ Just (state, size) ->+ unless (state == kRLTerm) $ do+ handleState sock env state+ eventLoop env sock++handleState :: Socket -> Environment a -> Word32 -> StateT a IO ()+handleState sock env state+ | state == kEnvInit = do+ taskSpec <- onEnvInit env+ let packedMsg = runPut (+ putWord32be kEnvInit >>+ putWord32be (fromIntegral (4 + BS.length taskSpec)) >>+ putString taskSpec)+ sendLazy sock packedMsg+ | state == kEnvStart = do+ obs <- onEnvStart env+ let size = sizeOfObs obs+ let packedMsg = runPut (+ putWord32be kEnvStart >>+ putWord32be (fromIntegral size) >>+ putObservation obs)+ sendLazy sock packedMsg+ | state == kEnvStep = do+ x <- lift $ runMaybeT (getAction sock)+ case x of+ Nothing -> lift $ do+ putStrLn "Error: Could not read action over network"+ exitWith (ExitFailure 1)+ Just action -> do+ terminalRewardObs <- onEnvStep env action+ let size = sizeOfRewardObs terminalRewardObs+ let packedMsg = runPut (+ putWord32be kEnvStep >>+ putWord32be (fromIntegral size) >>+ putTerminalRewardObs terminalRewardObs)+ sendLazy sock packedMsg+ | state == kEnvCleanup = do+ onEnvCleanup env+ let packedMsg = runPut (+ putWord32be kEnvCleanup >>+ putWord32be 0)+ sendLazy sock packedMsg+ | state == kEnvMessage = do+ x <- lift $ runMaybeT (getString sock)+ case x of+ Nothing -> lift $ do+ putStrLn "Error: Could not read message"+ exitWith (ExitFailure 1)+ Just msg' -> do+ resp <- onEnvMessage env msg'+ let packedMsg = runPut (+ putWord32be kEnvMessage >>+ if BS.null resp+ then putWord32be 4 >> putWord32be 0+ else + putWord32be (fromIntegral $ 4 + BS.length resp) >>+ putString resp)+ sendLazy sock packedMsg+ | state == kRLTerm = lift $ return ()+ | otherwise = do+ lift $ putStrLn $ "Error: Unknown state: " ++ show state+ lift $ exitWith (ExitFailure 1)++getEnvState :: Socket -> MaybeT IO (Word32, Word32)+getEnvState sock = do+ bs <- MaybeT $ recv sock (4*2)+ return $ runGet parseBytes (LBS.fromStrict bs)+ where+ parseBytes = do+ envState <- getWord32be+ dataSize <- getWord32be+ return (envState, dataSize)
+ src/RL_Glue/Example/SkeletonAgent.hs view
@@ -0,0 +1,38 @@+module Main where++import Control.Monad.Trans.Class+import Control.Monad.Trans.State.Lazy+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import System.Exit+import System.Random++import RL_Glue.Agent+import RL_Glue.Network++main = loadAgent (Agent onInit onStart onStep onEnd onCleanup onMessage) ()++onInit :: BS.ByteString -> StateT () IO ()+onInit taskSpec = return ()++onStart :: Observation -> StateT () IO Action+onStart obs = do+ dir <- lift $ getStdRandom (randomR (0,1))+ return (Action $ RLAbstractType [dir] [] BS.empty)++onStep :: (Reward, Observation) -> StateT () IO Action+onStep (reward, obs) = do+ dir <- lift $ getStdRandom (randomR (0,1))+ return (Action $ RLAbstractType [dir] [] BS.empty)++onEnd :: Reward -> StateT () IO ()+onEnd reward = return ()++onCleanup :: (StateT () IO ())+onCleanup = return ()++onMessage :: BS.ByteString -> StateT () IO BS.ByteString+onMessage msg =+ return $ BSC.pack $ if msg == BSC.pack "what is your name?"+ then "my name is skeleton_agent, Haskell edition!"+ else "I don't know how to respond to your message"
+ src/RL_Glue/Example/SkeletonEnvironment.hs view
@@ -0,0 +1,50 @@+module Main where++import Control.Monad.Trans.Class+import Control.Monad.Trans.State.Lazy+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import System.Exit++import RL_Glue.Environment+import RL_Glue.Network++main = loadEnvironment (Environment onInit onStart onStep onCleanup onMsg) 10++onInit :: StateT Int IO BS.ByteString+onInit = + lift $ return $ BSC.pack "VERSION RL-Glue-3.0 PROBLEMTYPE episodic DISCOUNTFACTOR 1.0 OBSERVATIONS INTS (0 20) ACTIONS INTS (0 1) REWARDS (-1.0 1.0) EXTRA skeleton_environment(Haskell) by Richard Hofer."++onStart :: StateT Int IO Observation+onStart = do+ put 10+ return (Observation (RLAbstractType [10] [] BS.empty))++onStep :: Action -> StateT Int IO (Terminal, Reward, Observation)+onStep (Action (RLAbstractType (dir:_) _ _)) = do+ case dir of+ 0 -> modify (subtract 1)+ 1 -> modify (+1)+ _ -> lift $ do+ putStrLn "Error: non-binary direction received"+ exitWith (ExitFailure 1)+ state <- get+ handleState state+ where+ handleState x+ | x <= 0 = do+ put 0+ return (1, -1, Observation (RLAbstractType [0] [] BS.empty))+ | x >= 20 = do+ put 20+ return (1, 1, Observation (RLAbstractType [20] [] BS.empty))+ | otherwise = return (0, 0, Observation (RLAbstractType [x] [] BS.empty))++onCleanup :: StateT Int IO ()+onCleanup = return ()++onMsg :: BS.ByteString -> StateT Int IO BS.ByteString+onMsg msg =+ return $ BSC.pack $ if msg == BSC.pack "what is your name?"+ then "my name is skeleton_environment, Haskell edition!"+ else "I don't know how to respond to your message"
+ src/RL_Glue/Example/SkeletonExperiment.hs view
@@ -0,0 +1,82 @@+module Main where++import Control.Monad (unless)+import Control.Monad.Trans.Class+import Control.Monad.Trans.State.Lazy+import qualified Data.ByteString as BS+import Data.Binary.Put+import Network.Simple.TCP++import RL_Glue.Experiment+import RL_Glue.Network++main = runExperiment doExperiments++doExperiments :: (Socket, SockAddr) -> IO ()+doExperiments (sock, addr) =+ do+ taskSpec <- initExperiment sock+ putStrLn ("Sent task spec: " ++ show taskSpec)++ putStrLn "\n----------Sending some sample messages----------"+ resp <- sendAgentMessageStr sock "what is your name?"+ putStrLn ("Agent responded to \"what is your name?\" with: " ++ show resp)++ resp <- sendAgentMessageStr sock "If at first you don't succeed; call it version 1.0"+ putStrLn ("Agent responded to \"If at first you don't succeed; call it version 1.0?\" with: " ++ show resp)++ resp <- sendEnvMessageStr sock "what is your name?"+ putStrLn ("Environment responded to \"what is your name?\" with: " ++ show resp)++ resp <- sendEnvMessageStr sock "If at first you don't succeed; call it version 1.0"+ putStrLn ("Environment responded to \"If at first you don't succeed; call it version 1.0?\" with: " ++ show resp)++ putStrLn "\n----------Running a few episodes----------"++ evalStateT+ (do+ prettyRunEpisode sock 100+ prettyRunEpisode sock 100+ prettyRunEpisode sock 100+ prettyRunEpisode sock 100+ prettyRunEpisode sock 100+ prettyRunEpisode sock 1+ -- Run one without a limit+ prettyRunEpisode sock 0) 1+ cleanupExperiment sock++ putStrLn "\n----------Stepping through an episode----------"+ taskSpec <- initExperiment sock++ -- Start an episode+ (Observation (RLAbstractType o _ _), Action (RLAbstractType a _ _)) <- startEpisode sock+ putStrLn $ "First observation and action were: " ++ show (head o) ++ " and: " ++ show (head a)++ -- Step until episode ends+ loopUntil $ do+ (_, _, _, terminal) <- stepEpisode sock+ return (terminal > 0)++ putStrLn "\n----------Summary----------"+ totalSteps <- getNumSteps sock+ totalReward <- getReturn sock+ putStrLn $ "It ran for " ++ show totalSteps ++ " steps, total reward was: " ++ show totalReward++ cleanupExperiment sock++prettyRunEpisode :: Socket -> Int -> StateT Int IO ()+prettyRunEpisode sock steps =+ do+ terminal <- lift $ runEpisode sock steps+ totalSteps <- lift $ getNumSteps sock+ totalReward <- lift $ getReturn sock++ episodeNum <- get+ lift $ putStrLn $ "Episode " ++ show episodeNum ++ "\t " ++ show totalSteps ++ " steps \t" +++ show totalReward ++ " total reward\t" ++ show terminal ++ " natural end"+ modify (+1)++loopUntil :: IO Bool -> IO ()+loopUntil f = do+ x <- f+ unless x (loopUntil f)
+ src/RL_Glue/Experiment.hs view
@@ -0,0 +1,116 @@+module RL_Glue.Experiment (+ runExperiment, initExperiment, cleanupExperiment, runEpisode, startEpisode,+ stepEpisode, getNumSteps, getNumEpisodes, getReturn+ ) where++import Control.Monad.Trans.Maybe+import Data.Binary.Get+import Data.Binary.IEEE754+import Data.Binary.Put+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Data.Version (showVersion)+import Data.Word+import Network.Simple.TCP+import System.Exit++import Paths_rlglue (version)+import RL_Glue.Network++runExperiment :: ((Socket, SockAddr) -> IO ()) -> IO ()+runExperiment func =+ let + func' (sock, addr) =+ do+ putStrLn ("RL-Glue Haskell Experiment Codec (Version " ++ showVersion version ++ ")")+ let bs = runPut (putWord32be kExperimentConnection >> putWord32be (0 :: Word32))+ sendLazy sock bs++ -- Actually do things+ func (sock, addr)+ in+ glueConnect func'++initExperiment :: Socket -> IO BS.ByteString+initExperiment sock =+ do+ doCallWithNoParams sock kRLInit+ taskSpec <- runMaybeT (getString sock)+ case taskSpec of+ Nothing -> do+ putStrLn "Error: Could not read task spec"+ exitWith (ExitFailure 1)+ Just x -> return x++cleanupExperiment :: Socket -> IO ()+cleanupExperiment sock = doCallWithNoParams sock kRLCleanup++runEpisode :: Socket -> Int -> IO Int+runEpisode sock stepLimit =+ do+ let + packedMsg = + runPut (+ putWord32be kRLEpisode >>+ putWord32be (fromIntegral kIntSize) >>+ putWord32be (fromIntegral stepLimit))+ sendLazy sock packedMsg+ confirmState sock kRLEpisode+ respBs <- recv sock 4+ case respBs of+ Nothing -> do+ putStrLn "Error: Could not read episode status from network"+ exitWith (ExitFailure 1)+ Just x -> return $ fromIntegral $ runGet getWord32be (LBS.fromStrict x)++startEpisode :: Socket -> IO (Observation, Action)+startEpisode sock =+ do+ doCallWithNoParams sock kRLStart+ x <- runMaybeT (do+ obs <- getObservation sock+ act <- getAction sock+ return (obs, act))+ case x of+ Nothing -> do+ putStrLn "Error: Could not start episode over network"+ exitWith (ExitFailure 1)+ Just x' -> return x'++stepEpisode :: Socket -> IO (Reward, Observation, Action, Terminal)+stepEpisode sock =+ do+ doCallWithNoParams sock kRLStep+ let parseBytes = do+ terminal <- getWord32be+ reward <- getFloat64be+ return (fromIntegral terminal, reward)+ x <- runMaybeT (do+ bs <- MaybeT $ recv sock (4+8)+ let (terminal, reward) = runGet parseBytes (LBS.fromStrict bs)+ obs <- getObservation sock+ act <- getAction sock+ return (reward, obs, act, terminal))+ case x of+ Nothing -> do+ putStrLn "Error: Could not step episode over network"+ exitWith (ExitFailure 1)+ Just x' -> return x'+ where++getNetworkValue :: Word32 -> (Socket -> MaybeT IO a) -> String -> Socket -> IO a+getNetworkValue byte f errMsg sock =+ do+ doCallWithNoParams sock byte+ x <- runMaybeT (f sock)+ case x of+ Nothing -> do+ putStrLn errMsg+ exitWith (ExitFailure 1)+ Just x' -> return x'++getNumSteps = getNetworkValue kRLNumSteps getInt "Error: Could not read number of steps from network."++getNumEpisodes = getNetworkValue kRLNumEpisodes getInt "Error: Could not read number of episodes from network."++getReturn = getNetworkValue kRLReturn getDouble "Error: Could not read return from network."
+ src/RL_Glue/Network.hs view
@@ -0,0 +1,317 @@+{-# LANGUAGE ScopedTypeVariables #-}++module RL_Glue.Network (+ -- * Magic numbers+ -- ** Connection types+ kExperimentConnection, kAgentConnection, kEnvironmentConnection,+ -- ** Agent+ kAgentInit, kAgentStart, kAgentStep, kAgentEnd, kAgentCleanup, kAgentMessage,+ -- ** Environment+ kEnvInit, kEnvStart, kEnvStep, kEnvCleanup, kEnvMessage,+ -- ** Experiment+ kRLInit, kRLStart, kRLStep, kRLCleanup, kRLReturn, kRLNumSteps,+ kRLNumEpisodes, kRLEpisode, kRLAgentMessage, kRLEnvMessage,+ -- ** Other+ kRLTerm,+ -- * Other constants+ kLocalHost, kDefaultPort, kRetryTimeout,+ kDefaultBufferSize, kIntSize, kDoubleSize, kCharSize,+ -- * Data types+ RLAbstractType(RLAbstractType), Action(Action), Observation(Observation),+ Reward, Terminal,+ -- * sizeOf functions+ sizeOfObs, sizeOfAction, sizeOfRewardObs,+ -- * Get network objects+ getObservation, getObservationOrDie, getAction, getRewardOrDie,+ getRewardObservation, getRewardObservationOrDie,+ getInt, getDouble, getString, getStringOrDie,+ -- * Put network objects+ putObservation, putAction, putTerminalRewardObs, putString,+ -- * Network functions+ glueConnect, doCallWithNoParams, confirmState,+ sendAgentMessage, sendAgentMessageStr,+ sendEnvMessage, sendEnvMessageStr+ ) where++import Control.Exception+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe+import Data.Binary.Get+import Data.Binary.IEEE754+import Data.Binary.Put+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.Lazy as LBS+import Data.Word+import Network.Simple.TCP+import Network.Socket (socketPort)+import System.Environment+import System.Exit+import System.IO.Error++-- Connection types+kExperimentConnection = 1 :: Word32+kAgentConnection = 2 :: Word32+kEnvironmentConnection = 3 :: Word32++-- Agent+kAgentInit = 4 :: Word32+kAgentStart = 5 :: Word32+kAgentStep = 6 :: Word32+kAgentEnd = 7 :: Word32+kAgentCleanup = 8 :: Word32+kAgentMessage = 10 :: Word32++-- Environment+kEnvInit = 11 :: Word32+kEnvStart = 12 :: Word32+kEnvStep = 13 :: Word32+kEnvCleanup = 14 :: Word32+kEnvMessage = 19 :: Word32++-- Experiment+kRLInit = 20 :: Word32+kRLStart = 21 :: Word32+kRLStep = 22 :: Word32+kRLCleanup = 23 :: Word32+kRLReturn = 24 :: Word32+kRLNumSteps = 25 :: Word32+kRLNumEpisodes = 26 :: Word32+kRLEpisode = 27 :: Word32+kRLAgentMessage = 33 :: Word32+kRLEnvMessage = 34 :: Word32++-- Other+kRLTerm = 35 :: Word32++kLocalHost = "127.0.0.1"+kDefaultPort = "4096"+kRetryTimeout = 2 -- Currently unused++kDefaultBufferSize = 4096+kIntSize = 4+kDoubleSize = 8+kCharSize = 1++-- Data types+data RLAbstractType = RLAbstractType [Int] [Double] BS.ByteString+ deriving Show+newtype Action = Action RLAbstractType deriving Show+newtype Observation = Observation RLAbstractType deriving Show+type Reward = Double+type Terminal = Int++-- Abstract type functions+orDie :: (a -> MaybeT IO c) -> String -> a -> IO c+orDie f err x = do+ maybeY <- runMaybeT (f x)+ case maybeY of+ Nothing -> do+ putStrLn err+ exitWith (ExitFailure 1)+ Just y -> return y++sizeOfType :: RLAbstractType -> Int+sizeOfType (RLAbstractType ints doubles bs) =+ kIntSize * (3 + length ints) + kDoubleSize * length doubles + kCharSize * BS.length bs++sizeOfObs :: Observation -> Int+sizeOfObs (Observation absType) = sizeOfType absType++sizeOfAction :: Action -> Int+sizeOfAction (Action absType) = sizeOfType absType++sizeOfRewardObs :: (Terminal, Reward, Observation) -> Int+sizeOfRewardObs (_, _, obs) =+ kIntSize + kDoubleSize + sizeOfObs obs++getAbstractType :: Socket -> MaybeT IO RLAbstractType+getAbstractType sock =+ do+ bs1 <- recvExactly sock (3*4)+ let (numInts, numDoubles, numChars) = runGet parseBytes1 (LBS.fromStrict bs1)+ let size = numInts*kIntSize + numDoubles*kDoubleSize + numChars*kCharSize+ bs2 <- recvExactly sock size+ return $ runGet (parseBytes2 numInts numDoubles numChars) (LBS.fromStrict bs2)+ where+ parseBytes1 = do+ numInts <- getWord32be+ numDoubles <- getWord32be+ numChars <- getWord32be+ return (fromIntegral numInts, fromIntegral numDoubles, fromIntegral numChars)+ parseBytes2 numInts numDoubles numChars = do+ ints <- replicateM (fromIntegral numInts) getWord32be+ doubles <- replicateM (fromIntegral numDoubles) getFloat64be+ chars <- getByteString (fromIntegral numChars)+ return (RLAbstractType (map fromIntegral ints) doubles chars)++getObservation :: Socket -> MaybeT IO Observation+getObservation sock = do+ absType <- getAbstractType sock+ return $ Observation absType++getObservationOrDie :: Socket -> IO Observation+getObservationOrDie = orDie getObservation "Error: Could not get observation"++getAction :: Socket -> MaybeT IO Action+getAction sock = do+ absType <- getAbstractType sock+ return $ Action absType++getRewardOrDie :: Socket -> IO Reward+getRewardOrDie = orDie getDouble "Error: Could not get reward"++getRewardObservation :: Socket -> MaybeT IO (Reward, Observation)+getRewardObservation sock = do+ reward <- getDouble sock+ obs <- getObservation sock+ return (reward, obs)++getRewardObservationOrDie :: Socket -> IO (Reward, Observation)+getRewardObservationOrDie = orDie getRewardObservation "Error: Could not get reward and observation"++putAbstractType :: RLAbstractType -> Put+putAbstractType (RLAbstractType ints doubles bs) = do+ let numInts = fromIntegral $ length ints+ let numDoubles = fromIntegral $ length doubles+ let numChars = fromIntegral $ BS.length bs+ putWord32be numInts+ putWord32be numDoubles+ putWord32be numChars+ mapM_ (putWord32be . fromIntegral) ints+ mapM_ putFloat64be doubles+ putByteString bs++putObservation :: Observation -> Put+putObservation (Observation absType) = putAbstractType absType++putAction :: Action -> Put+putAction (Action absType) = putAbstractType absType++putTerminalRewardObs :: (Terminal, Reward, Observation) -> Put+putTerminalRewardObs (terminal, reward, Observation absType) = do+ putWord32be (fromIntegral terminal)+ putFloat64be reward+ putAbstractType absType++-- Actually connect+glueConnect :: forall r. ((Socket, SockAddr) -> IO r) -> IO r+glueConnect func =+ do+ host <- catchJust+ (\e -> if isDoesNotExistError e then Just () else Nothing)+ (getEnv "RLGLUE_HOST")+ (\_ -> return kLocalHost)+ port <- catchJust+ (\e -> if isDoesNotExistError e then Just () else Nothing)+ (getEnv "RLGLUE_PORT")+ (\_ -> return kDefaultPort)+ let func' :: (Socket, SockAddr) -> IO r+ func' (sock, addr) = do+ clientPort <- socketPort sock+ putStrLn $ "Connecting to " ++ show addr ++ " on port " ++ show clientPort ++ "..."+ x <- func (sock, addr)+ putStrLn ("Disconnecting from " ++ show addr ++ "...")+ return x+ connect host port func'++-- Send/Recv helper functions+doCallWithNoParams :: Socket -> Word32 -> IO ()+doCallWithNoParams sock x =+ do+ let bs = runPut (putWord32be x >> putWord32be (0 :: Word32))+ sendLazy sock bs+ confirmState sock x++doStandardRecv :: Socket -> MaybeT IO (Word32, Word32)+doStandardRecv sock =+ do+ bs <- recvExactly sock (2*4)+ return $ runGet parseBytes (LBS.fromStrict bs)+ where+ parseBytes = do+ glueState <- getWord32be+ dataSize <- getWord32be+ return (glueState, dataSize)++getInt :: Socket -> MaybeT IO Int+getInt sock =+ do+ bs <- recvExactly sock kIntSize+ return . fromIntegral $ runGet getWord32be (LBS.fromStrict bs)++getDouble :: Socket -> MaybeT IO Double+getDouble sock =+ do+ bs <- recvExactly sock kDoubleSize+ return $ runGet getFloat64be (LBS.fromStrict bs)++getString :: Socket -> MaybeT IO BS.ByteString+getString sock =+ do+ length <- getInt sock+ recvExactly sock (length * kCharSize)++getStringOrDie :: String -> Socket -> IO BS.ByteString+getStringOrDie = orDie getString++putString :: BS.ByteString -> Put+putString bs = do+ putWord32be (fromIntegral (BS.length bs))+ putByteString bs++recvExactly :: Socket -> Int -> MaybeT IO BS.ByteString+recvExactly sock nBytes = do+ maybeBs <- MaybeT $ recv sock nBytes+ let len = BS.length maybeBs+ if len == nBytes + then return maybeBs+ else do+ remainingBs <- recvExactly sock (nBytes - len)+ return $ BS.append maybeBs remainingBs++-- Other functions+confirmState :: Socket -> Word32 -> IO ()+confirmState sock exptState =+ do+ x <- runMaybeT (doStandardRecv sock)+ case x of+ Nothing -> do+ putStrLn "Failed to receive state. Exiting..."+ exitWith (ExitFailure 1)+ Just (state, size) -> unless (state == exptState) $ do+ putStrLn $ "State " ++ show state ++ " doesn't match expected state " +++ show exptState ++ ". Exiting..."+ exitWith (ExitFailure 1)++sendMessage :: Word32 -> Socket -> BS.ByteString -> IO BS.ByteString+sendMessage selByte sock msg =+ do+ let + packedMsg = + runPut (+ putWord32be selByte >>+ putWord32be (fromIntegral (4 + BS.length msg)) >>+ putWord32be (fromIntegral (BS.length msg)) >>+ putByteString msg)+ sendLazy sock packedMsg+ confirmState sock selByte + resp <- runMaybeT (getString sock)+ case resp of+ Nothing -> do+ putStrLn "Error: Could not read response from agent message"+ exitWith (ExitFailure 1)+ Just x -> return x++sendAgentMessage :: Socket -> BS.ByteString -> IO BS.ByteString+sendAgentMessage = sendMessage kRLAgentMessage++sendAgentMessageStr :: Socket -> String -> IO BS.ByteString+sendAgentMessageStr sock msg = sendAgentMessage sock (BSC.pack msg)++sendEnvMessage :: Socket -> BS.ByteString -> IO BS.ByteString+sendEnvMessage = sendMessage kRLEnvMessage++sendEnvMessageStr :: Socket -> String -> IO BS.ByteString+sendEnvMessageStr sock msg = sendEnvMessage sock (BSC.pack msg)
+ src/RL_Glue/TaskSpec.hs view
@@ -0,0 +1,174 @@+module RL_Glue.TaskSpec (+ -- * Task Spec data types+ TaskSpec(TaskSpec), ProblemType(Episodic, Continuing, OtherProblemType),+ DiscountFactor, AbsDataType(AbsDataType), IntsBounds, DoublesBounds,+ NumChars, DataBounds, RewardBounds,+ -- ** Bounds+ LowBound(LowBound, NegInf, LBUnspec), UpBound(UpBound, PosInf, UBUnspec),+ -- * Parsing functions+ toTaskSpec, toTaskSpecOrDie, parseTaskSpec+ ) where++import Control.Monad+import qualified Data.ByteString as BS+import Text.Parsec+import Text.Parsec.ByteString+import System.Exit++-- Datatype definitions+data TaskSpec = TaskSpec ProblemType DiscountFactor AbsDataType AbsDataType RewardBounds String+ deriving (Show)++data ProblemType = Episodic | Continuing | OtherProblemType String+ deriving (Show)++type DiscountFactor = Double++data AbsDataType = AbsDataType IntsBounds DoublesBounds NumChars+ deriving (Show)+type IntsBounds = [DataBounds Int]+type DoublesBounds = [DataBounds Double]+type NumChars = Int+type DataBounds a = (LowBound a, UpBound a)+data LowBound a = LowBound a | NegInf | LBUnspec+ deriving (Show)+data UpBound a = UpBound a | PosInf | UBUnspec+ deriving (Show)++type RewardBounds = DataBounds Double++-- Parsing functions+toTaskSpec :: BS.ByteString -> Either ParseError TaskSpec+toTaskSpec = parse parseTaskSpec "(network)"++toTaskSpecOrDie :: BS.ByteString -> IO TaskSpec+toTaskSpecOrDie str = either (\x -> print x >> exitFailure) return (toTaskSpec str)++parseTaskSpec = do+ parseVersion+ spaces+ probType <- parseProblemType+ spaces+ discountFactor <- parseDiscountFactor+ spaces+ obs <- parseObservations+ spaces+ act <- parseActions+ spaces+ reward <- parseRewards+ spaces+ extra <- parseExtra+ return $ TaskSpec probType discountFactor obs act reward extra++parseVersion = do+ -- We currently only parse version 3.0+ string "VERSION"+ spaces+ string "RL-Glue-3.0"++parseProblemType = do+ string "PROBLEMTYPE"+ spaces+ probTypeStr <- many (letter <|> digit)+ return $ case probTypeStr of+ "episodic" -> Episodic+ "continuing" -> Continuing+ _ -> OtherProblemType probTypeStr++parseDiscountFactor = do+ string "DISCOUNTFACTOR"+ spaces+ numStr <- many1 (digit <|> char '.')+ return $ read numStr++parseObservations = do+ string "OBSERVATIONS"+ spaces+ parseAbsDataType++parseActions = do+ string "ACTIONS"+ spaces+ parseAbsDataType++parseRewards = do+ string "REWARDS"+ spaces+ char '('+ lower <- parseLB+ spaces+ upper <- parseUB+ char ')'+ return (lower, upper)++parseExtra = do+ string "EXTRA"+ spaces+ many anyChar++parseAbsDataType :: Parsec BS.ByteString () AbsDataType+parseAbsDataType = do+ intObsType <- parseIntsBounds+ doubleObsType <- parseDoublesBounds+ charObsType <- parseNumChars+ return $ AbsDataType intObsType doubleObsType charObsType++parseRepeatable :: Parsec BS.ByteString () a -> Parsec BS.ByteString () [a]+parseRepeatable parser =+ try (do+ times <- liftM read $ many1 digit+ spaces+ x <- parser+ return $ replicate times x)+ <|> liftM (: []) parser++parseIntsBounds :: Parsec BS.ByteString () IntsBounds+parseIntsBounds = try (do+ string "INTS"+ parseInnerBounds) <|> return []++parseDoublesBounds :: Parsec BS.ByteString () DoublesBounds+parseDoublesBounds = try (do+ string "DOUBLES"+ parseInnerBounds) <|> return []++parseInnerBounds :: Read a => Parsec BS.ByteString () [DataBounds a]+parseInnerBounds = do+ spaces+ xs <- many (do+ x <- parseAbsDataTypeTuple+ spaces+ return x)+ return $ concat xs++parseAbsDataTypeTuple :: Read a => Parsec BS.ByteString () [DataBounds a]+parseAbsDataTypeTuple = do+ char '('+ x <- parseRepeatable parseBoundsTuple+ char ')'+ return x++parseBoundsTuple :: Read a => Parsec BS.ByteString () (DataBounds a)+parseBoundsTuple = do+ lb <- parseLB+ spaces+ ub <- parseUB+ return (lb, ub)++parseLB :: Read a => Parsec BS.ByteString () (LowBound a)+parseLB = + liftM (LowBound . read) (many1 $ char '-' <|> char '.' <|> digit) <|> + (string "NEGINF" >> return NegInf) <|>+ (string "UNSPEC" >> return LBUnspec)++parseUB :: Read a => Parsec BS.ByteString () (UpBound a)+parseUB = + liftM (UpBound . read) (many1 $ char '-' <|> char '.' <|> digit) <|> + (string "POSINF" >> return PosInf) <|>+ (string "UNSPEC" >> return UBUnspec)++parseNumChars :: Parsec BS.ByteString () NumChars+parseNumChars = try (do+ string "CHARCOUNT"+ spaces+ liftM read (many1 digit)) <|> return 0