diff -w -B -a -d -u -b -r --new-file 19_story/src/GameEngine.hs 20_structure/src/GameEngine.hs

--- 19_story/src/GameEngine.hs

+++ 20_structure/src/GameEngine.hs

@@ -2,6 +2,8 @@

 {-# LANGUAGE NoImplicitPrelude #-}

 {-# LANGUAGE OverloadedStrings #-}

 {-# LANGUAGE MultiWayIf #-}

+{-# LANGUAGE FlexibleInstances #-}

+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

 module GameEngine where

@@ -20,8 +22,10 @@

 import qualified System.Random as Rnd

 import           Control.Lens (at, _1, (^.), (.~), (%~))

 import qualified Control.Arrow as Ar

+import           Control.Monad.Trans (lift)

+import           Control.Monad.Reader (ask, runReaderT, ReaderT, MonadReader, MonadTrans)

 import           Control.Monad.Writer.Strict (runWriter)

-import           Control.Concurrent.STM (atomically, readTVar, newTVar, modifyTVar', TVar)

+import           Control.Concurrent.STM (atomically, readTVar, writeTVar, newTVar, modifyTVar', TVar)

 import qualified Memory as M

 import           GameCore

@@ -33,8 +37,13 @@

 import qualified UtilityBrain as UB

+

+----------------------------------------------------------------------------------------------------------------

+-- L0 Hosting

+----------------------------------------------------------------------------------------------------------------

 runGame :: (Levels -> Level) -> IO ()

-runGame getLevel = Host.runHost (manageConnection getLevel)

+runGame getLevel = 

+  Host.runHost $ manageConnection getLevel

 manageConnection :: (Levels -> Level) -> Host.Connection -> IO ()

@@ -45,26 +54,223 @@

     Just ("init", cmdData) -> do

       std <- Rnd.getStdGen

-      case initialiseConnection conn cmdData std getLevel of

+      case initialiseConnection conn cmdData std getLevel of -- initialiseConnection is L3

         Right world -> do

-          worldV <- atomically $ newTVar world

-          sendConfig conn $ world ^. wdConfig

-          runConnection worldV

+          app <- atomically $ AppState <$> newTVar conn <*> newTVar world

+

+          -- Start the AppT pipeline

+          runReaderT (unAppT $ initialiseConfig >> startGame) app

+

         Left e ->

-          sendError conn e

+          runReaderT (sendHostError e) conn

     _ ->

       pass

+----------------------------------------------------------------------------------------------------------------

-  where

-    runConnection worldV = 

-      forever $ do

+

+

+

+----------------------------------------------------------------------------------------------------------------

+-- L1 App (orchestration)

+----------------------------------------------------------------------------------------------------------------

+data AppState = AppState { appConnection :: !(TVar Host.Connection)

+                         , appWorld :: !(TVar World)

+                         } 

+

+newtype AppT m a = AppT { unAppT :: ReaderT AppState m a 

+                        } deriving (Functor, Applicative, Monad, MonadReader AppState, MonadTrans)

+

+askApp :: (AppState -> TVar a) -> AppT IO a

+askApp getter = do

+  app <- ask

+  lift . atomically . readTVar $ getter app

+

+modifyApp :: (AppState -> TVar a) -> (a -> a) -> AppT IO ()

+modifyApp getter modify' = do

+  app <- ask

+  lift . atomically $ modifyTVar' (getter app) modify'

+----

+

+initialiseConfig :: AppT IO ()

+initialiseConfig = do

+  conn <- askApp appConnection

+  world <- askApp appWorld

+  app <- ask

+  lift $ runReaderT (sendConfig $ world ^. wdConfig) (conn, appWorld app)

+  

+

+startGame :: AppT IO ()

+startGame = do

+  app <- ask

+  conn <- askApp appConnection

+

+  lift . forever $ do

         t <- conn ^. conReceiveText

+    r <- runReaderT (handleCommand t) (conn, appWorld app)

+

+    case r of

+      Nothing -> pass

+      Just e -> putText e

+----------------------------------------------------------------------------------------------------------------

+

+

+  

+----------------------------------------------------------------------------------------------------------------

+-- L2 (bridge / external services)

+----------------------------------------------------------------------------------------------------------------

+class (Monad m) => MonadHost m where

+  receiveHostText :: m Text

+  sendHostData :: Text -> m ()

+  sendHostLog :: Text -> m ()

+  sendHostError :: Text -> m ()

+  sendHostUiConfig :: UiConfigData -> m ()

+  compressData :: Text -> m BSL.ByteString

+

+  --default implementation

+  sendHostLog err = sendHostData $ Ae.encodeText $ UiMessage "log" err

+  sendHostError err = sendHostData $ Ae.encodeText $ UiMessage "error" err

+  sendHostUiConfig config = sendHostData . Ae.encodeText $ UiConfig "config" config

+  compressData = pure . Bz.compress . BSL.fromStrict . TxtE.encodeUtf8 

+

+instance MonadHost (ReaderT (Host.Connection, TVar World) IO) where

+  receiveHostText = do

+    (conn, _) <- ask

+    lift $ conn ^. conReceiveText

+

+  sendHostData t = do

+    (conn, _) <- ask

+    lz <- compressData t

+    lift $ conn ^. conSendData $ lz

+

+instance MonadHost (ReaderT Host.Connection IO) where

+  receiveHostText = do

+    conn <- ask

+    lift $ conn ^. conReceiveText

+

+  sendHostData t = do

+    conn <- ask

+    lz <- compressData t

+    lift $ conn ^. conSendData $ lz

+

+

+class (Monad m) => MonadWorld m where

+  askWorld :: m World

+  putWorld :: World -> m ()

+  modifyWorld :: (World -> World) -> m ()

+  debugPrint :: Text -> m ()

+

+instance MonadWorld (ReaderT (Host.Connection, TVar World) IO) where

+  askWorld = do

+    (_, wt) <- ask

+    w <- lift . atomically $ readTVar wt

+    pure w

+    

+  putWorld w = do

+    (_, wt) <- ask

+    lift . atomically $ writeTVar wt w

+

+  modifyWorld fn = do

+    (_, wt) <- ask

+    lift . atomically $ modifyTVar' wt fn

+  

+  debugPrint = putText

+

+-------------------

+

+

+handleCommand :: (MonadHost m, MonadWorld m) => Text -> m (Maybe Text)

+handleCommand t = 

         case parseCommand t of

-          Nothing -> putText $ "error parsing: " <> t

-          Just (cmd, cmdData) -> runCmd conn worldV cmd cmdData

+    Nothing -> pure . Just $ "error parsing: " <> t

+    Just (cmd, cmdData) -> do

+      runCmd cmd cmdData

+      pure Nothing

+

+

+runCmd :: (MonadHost m, MonadWorld m) => Text -> [Text] -> m ()

+runCmd cmd cmdData = 

+  case cmd of

+    "redraw" -> 

+      case parseScreenSize cmdData of

+        Nothing -> sendHostError "missing / invalid screen size"

+        Just (sx, sy) -> do

+          updatePlayer (plScreenSize .~ (sx, sy))

+          world <- askWorld

+          sendHostData $ Ae.encodeText (drawAndSend world)

+          sendHostLog "draw"

+    "key" -> do

+      -- Handle the key press

+      modifyWorld (\w ->

+                     -- Do the actions as if they will succeed

+                     let pendingWorld = runActions w $ handleKey w cmdData in

+                     -- Apply, if the move is allowed

+                     -- Cost is hard-coded to 100 for now, this will be fixed later

+                     playerMoving 100 pendingWorld w

+                  )

+

+      -- Get the updated world

+      w2 <- askWorld

+

+      -- Handle the annotations

+      -- This is not terribly pretty as its doing a select for update, but its good enough for debugging

+      -- the annotation code can be removed once everything is working

+      let annotations = w2 ^. wdUtilBrainAnnotations 

+      modifyWorld (\w -> w & wdUtilBrainAnnotations .~ [])

+      printAnnotations annotations

+

+      -- Draw

+      w3 <- askWorld

+      sendHostData $ Ae.encodeText (drawAndSend w3)

+

+    _ ->

+      sendHostError $ "Unknown command: " <> cmd

+

+  where

+    updatePlayer f = modifyWorld (\w -> w & wdPlayer %~ f)

+

+    printAnnotations as = do

+      debugPrint ""

+      debugPrint ""

+      debugPrint ""

+      debugPrint ""

+      debugPrint "***** Utility Annotations **************"

+      traverse_ printAnnotation as

+      debugPrint "****************************************"

+      debugPrint ""

+

+    printAnnotation (e, assess, top)  = do

+      debugPrint ""

+      debugPrint $ "-----------------------" <> show e

+      debugPrint "  -- assess --"

+      debugPrint . Txt.intercalate "\n" $ showEntries <$> assess

+      debugPrint ""

+      debugPrint "  -- top --"

+      debugPrint . Txt.intercalate "\n" $ showEntries <$> top

+      debugPrint "-----------------------"

+

+    showEntries :: UtilAnnotationEntry -> Text

+    showEntries e =

+      case e of

+        UeAt a -> "    At: " <> a

+        UeSelectTopNone n -> "    No utils: " <> n

+        UeSelectTopAbove f  -> "    Top above: " <> showF f

+        UeSelectTopOne val n i d -> "    Select top one: " <> n <> ", impulse=" <> show i <> ", score=" <> showF val <> "," <> d

+        UeNote n -> "    Note: " <> n

+

+  

+sendConfig :: (MonadHost m) => Config -> m ()

+sendConfig config =

+  sendHostData . Ae.encodeText $ UiConfig "config" (buildConfig config)

+

+----------------------------------------------------------------------------------------------------------------

+

+

+----------------------------------------------------------------------------------------------------------------

+-- L3 (Business logic, pure code only)

+----------------------------------------------------------------------------------------------------------------

     parseCommand :: Text -> Maybe (Text, [Text])

     parseCommand t =

       case Txt.splitOn "|" t of

@@ -162,91 +367,6 @@

             }

-runCmd :: Host.Connection -> TVar World -> Text -> [Text] -> IO ()

-runCmd conn worldV cmd cmdData = 

-  case cmd of

-    "redraw" -> 

-      case parseScreenSize cmdData of

-        Nothing -> sendError conn "missing / invalid screen size"

-        Just (sx, sy) -> do

-          updatePlayer (plScreenSize .~ (sx, sy))

-          w <- atomically $ readTVar worldV

-          drawAndSend w

-          sendLog conn "draw"

-      

-    "key" -> do

-      -- Handle the key press

-      atomically $ modifyTVar' worldV (\w ->

-                                         -- Do the actions as if they will succeed

-                                         let pendingWorld = runActions w $ handleKey w cmdData in

-                                         -- Apply, if the move is allowed

-                                         -- Cost is hard-coded to 100 for now, this will be fixed later

-                                         playerMoving 100 pendingWorld w

-                                      )

-      -- Get the updated world

-      w2 <- atomically $ readTVar worldV

-

-      -- Handle the annotations

-      -- This is not terribly pretty as its doing a select for update, but its good enough for debugging

-      -- the annotation code can be removed once everything is working

-      let annotations = w2 ^. wdUtilBrainAnnotations 

-      atomically $ modifyTVar' worldV (\w -> w & wdUtilBrainAnnotations .~ [])

-      printAnnotations annotations

-

-      -- Draw

-      drawAndSend w2

-

-    _ ->

-      sendError conn $ "Unknown command: " <> cmd

-

-  where

-    updatePlayer f = atomically $ modifyTVar' worldV (\w -> w & wdPlayer %~ f)

-

-    printAnnotations as = do

-      putText ""

-      putText ""

-      putText ""

-      putText ""

-      putText "***** Utility Annotations **************"

-      traverse_ printAnnotation as

-      putText "****************************************"

-      putText ""

-

-    printAnnotation (e, assess, top)  = do

-      putText ""

-      putText $ "-----------------------" <> show e

-      putText "  -- assess --"

-      putText . Txt.intercalate "\n" $ showEntries <$> assess

-      putText ""

-      putText "  -- top --"

-      putText . Txt.intercalate "\n" $ showEntries <$> top

-      putText "-----------------------"

-

-    showEntries :: UtilAnnotationEntry -> Text

-    showEntries e =

-      case e of

-        UeAt a -> "    At: " <> a

-        UeSelectTopNone n -> "    No utils: " <> n

-        UeSelectTopAbove f  -> "    Top above: " <> showF f

-        UeSelectTopOne val n i d -> "    Select top one: " <> n <> ", impulse=" <> show i <> ", score=" <> showF val <> "," <> d

-        UeNote n -> "    Note: " <> n

-

-  

-sendLog :: Host.Connection -> Text -> IO ()

-sendLog conn err =

-  sendData conn $ Ae.encodeText $ UiMessage "log" err

-

-

-sendError :: Host.Connection -> Text -> IO ()

-sendError conn err =

-  sendData conn $ Ae.encodeText $ UiMessage "error" err

-

-

-sendConfig :: Host.Connection -> Config -> IO ()

-sendConfig conn config =

-  sendData conn . Ae.encodeText $ UiConfig "config" (buildConfig config)

-

-

 buildConfig :: Config -> UiConfigData

 buildConfig cfg =

   UiConfigData { udKeys = buildKeys (cfg ^. cfgKeys)

@@ -258,12 +378,6 @@

     buildKey (s, a) = UiKey s a

-sendData :: Host.Connection -> Text -> IO ()

-sendData conn t = do

-  let lz = Bz.compress . BSL.fromStrict . TxtE.encodeUtf8 $ t

-  conn ^. conSendData $ lz

-

-

 parseScreenSize :: [Text] -> Maybe (Int, Int)

 parseScreenSize cmd = do

   (tx, ty) <- case cmd of

@@ -275,15 +389,14 @@

   pure (x, y)

-drawAndSend :: World -> IO ()

-drawAndSend world = do

-  let layers = drawTilesForPlayer world (world ^. wdMap) 

+drawAndSend :: World -> UiDrawCommand

+drawAndSend world = 

+  let layers = drawTilesForPlayer world (world ^. wdMap) in

-  let cmd = Ae.encodeText UiDrawCommand { drCmd = "draw"

+  UiDrawCommand { drCmd = "draw"

                                         , drScreenWidth = world ^. wdPlayer ^. plScreenSize ^. _1

                                         , drMapData = mkDrawMapData <<$>> (Map.toList <$> layers)

                                         }

-  sendData (world ^. wdPlayer ^. plConn) cmd

   where

     mkDrawMapData :: (PlayerPos, Tile) -> (Int, Int, Int)

diff -w -B -a -d -u -b -r --new-file 19_story/src/GameHost.hs 20_structure/src/GameHost.hs

--- 19_story/src/GameHost.hs

+++ 20_structure/src/GameHost.hs

@@ -1,6 +1,8 @@

 {-# LANGUAGE TemplateHaskell #-}

 {-# LANGUAGE NoImplicitPrelude #-}

 {-# LANGUAGE OverloadedStrings #-}

+{-# LANGUAGE FlexibleInstances #-}

+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

 module GameHost ( runHost

                 , Connection(..)

@@ -18,6 +20,9 @@

 import qualified Network.Wai.Handler.WebSockets as WaiWs

 import qualified Network.WebSockets as WS

+----------------------------------------------------------------------------------------------------------------

+-- L0 Hosting

+----------------------------------------------------------------------------------------------------------------

 data Connection = Connection { _conSendData :: BSL.ByteString -> IO ()

                              , _conReceiveText :: IO Text

                              }

@@ -55,11 +61,12 @@

 wsapp :: (Connection -> IO ()) -> WS.ServerApp

-wsapp startHost pending = do

+wsapp runConnection pending = do

   conn <- WS.acceptRequest pending

   WS.forkPingThread conn 30

-  startHost Connection { _conSendData = WS.sendBinaryData conn

+  let h = Connection { _conSendData = WS.sendBinaryData conn

                        , _conReceiveText = WS.receiveData conn

                        }

-

+  runConnection h

+----------------------------------------------------------------------------------------------------------------