diff -w -B -a -d -u -b -r --new-file 20_structure/src/GameCore.hs 21_console/src/GameCore.hs

--- 20_structure/src/GameCore.hs

+++ 21_console/src/GameCore.hs

@@ -201,6 +201,21 @@

 instance Ae.ToJSON UiDrawCommand where

   toJSON = Ae.genericToJSON Ae.defaultOptions { Ae.fieldLabelModifier = renField 2 True }

+instance Ae.FromJSON UiMessage where

+  parseJSON = Ae.genericParseJSON Ae.defaultOptions { Ae.fieldLabelModifier = renField 2 True }

+

+instance Ae.FromJSON UiConfig where

+  parseJSON = Ae.genericParseJSON Ae.defaultOptions { Ae.fieldLabelModifier = renField 2 True }

+

+instance Ae.FromJSON UiConfigData where

+  parseJSON = Ae.genericParseJSON Ae.defaultOptions { Ae.fieldLabelModifier = renField 2 True }

+

+instance Ae.FromJSON UiKey where

+  parseJSON = Ae.genericParseJSON Ae.defaultOptions { Ae.fieldLabelModifier = renField 2 True }

+

+instance Ae.FromJSON UiDrawCommand where

+  parseJSON = Ae.genericParseJSON Ae.defaultOptions { Ae.fieldLabelModifier = renField 2 True }

+

 -- | drop prefix, and then lower case

 -- | renField 3 "tskBla" == "bla"

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

--- 20_structure/src/GameEngine.hs

+++ 21_console/src/GameEngine.hs

@@ -219,7 +219,7 @@

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

       let annotations = w2 ^. wdUtilBrainAnnotations 

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

-      printAnnotations annotations

+      --printAnnotations annotations

       -- Draw

       w3 <- askWorld

diff -w -B -a -d -u -b -r --new-file 20_structure/src/Gui/ConsoleGui.hs 21_console/src/Gui/ConsoleGui.hs

--- 20_structure/src/Gui/ConsoleGui.hs

+++ 21_console/src/Gui/ConsoleGui.hs

@@ -0,0 +1,203 @@

+{-# OPTIONS_GHC -fno-warn-type-defaults #-}

+{-# LANGUAGE NoImplicitPrelude #-}

+{-# LANGUAGE OverloadedStrings #-}

+{-# LANGUAGE LambdaCase #-}

+{-# LANGUAGE TypeApplications #-}

+{-# LANGUAGE FlexibleInstances #-}

+{-# LANGUAGE DeriveGeneric #-}

+

+module Gui.ConsoleGui (runGui) where

+

+import           Protolude

+import qualified Data.Map.Strict as Map

+import qualified Data.Text as Txt

+import qualified Data.Text.Encoding as TxtE

+import qualified Data.Aeson as Ae

+import qualified Data.ByteString.Lazy as BSL

+import qualified Codec.Compression.BZip as Bz

+import qualified System.IO as IO

+import qualified System.Console.ANSI as A

+import qualified System.Console.Terminal.Size as Sz

+import           Control.Exception.Safe (throwString)

+import qualified Network.Socket as Sock

+import qualified Network.WebSockets as WS

+

+import qualified GameCore as GC

+

+

+sendCommand :: WS.Connection -> Text -> IO ()

+sendCommand = WS.sendTextData

+

+receiveCommand :: WS.Connection -> IO Text

+receiveCommand conn = do

+  compressed <- WS.receiveData conn

+  pure . TxtE.decodeUtf8 . BSL.toStrict $ Bz.decompress compressed

+

+close :: WS.Connection -> IO ()

+close conn = WS.sendClose conn ("" :: Text)

+

+

+

+runGui :: IO ()

+runGui = do

+  IO.hSetEcho stdin False

+  IO.hSetBuffering stdin IO.NoBuffering

+  IO.hSetBuffering stdout IO.NoBuffering

+  

+  Sock.withSocketsDo $ WS.runClient "localhost" 61492 "/" app

+

+  where

+    app :: WS.Connection -> IO ()

+    app conn = do

+      (x, y) <- getSize

+      runConnection conn x y 

+

+

+

+

+runConnection :: WS.Connection -> Int -> Int -> IO ()

+runConnection conn x y = do

+  sendCommand conn $ "init|" <> show x <> "|" <> show y <> ""

+  void $ forkIO (runKeys conn)

+  void loop

+  close conn

+

+  where

+    loop = do

+      cmd <- receiveCommand conn

+      handleCommand conn cmd

+      loop

+

+

+

+runKeys :: WS.Connection -> IO ()

+runKeys conn = do

+  key <- getKey >>= \case

+       "k"      -> pure "Move:up"

+       "\ESC[A" -> pure "Move:up"

+

+       "j"      -> pure "Move:down"

+       "\ESC[B" -> pure "Move:down"

+

+       "l"      -> pure "Move:right"

+       "\ESC[C" -> pure "Move:right"

+

+       "h"      -> pure "Move:left"

+       "\ESC[D" -> pure "Move:left"

+

+       _        -> pure ""

+  

+  sendCommand conn $ "key|" <> key

+  runKeys conn

+

+-- | https://stackoverflow.com/questions/23068218/haskell-read-raw-keyboard-input

+getKey :: IO [Char]

+getKey = reverse <$> getKey' ""

+  where getKey' chars = do

+          char <- IO.getChar

+          more <- IO.hReady stdin

+          (if more then getKey' else return) (char:chars)

+

+

+

+

+handleCommand :: WS.Connection -> Text -> IO ()

+handleCommand conn cmd' =

+  case Ae.eitherDecode (BSL.fromStrict . TxtE.encodeUtf8 $ cmd') :: Either [Char] CommandWrapper of

+    Left e -> throwString e

+    Right cmd ->

+     case cmd of

+         CommandWrapper "log" -> pass

+         CommandWrapper "error" -> pass

+         CommandWrapper "config" -> handleConfig conn cmd'

+         CommandWrapper "draw" -> handleDraw conn cmd'

+         _ -> throwString . Txt.unpack $ "Unknown command: " <> cmd'

+

+

+handleConfig :: WS.Connection -> Text -> IO ()

+handleConfig conn cmd' =

+  case Ae.eitherDecode (BSL.fromStrict . TxtE.encodeUtf8 $ cmd') :: Either [Char] GC.UiConfig of

+    Left e -> throwString e

+    Right _cmd -> do

+      (w,h) <- getSize

+      sendCommand conn $ "redraw|" <> show w <> "|" <> show h

+      pass

+

+

+

+

+handleDraw :: WS.Connection -> Text -> IO ()

+handleDraw _conn cmd' =

+  case Ae.eitherDecode (BSL.fromStrict . TxtE.encodeUtf8 $ cmd') :: Either [Char] GC.UiDrawCommand of

+    Left e -> throwString e

+    Right cmd -> do

+      (width, height) <- getSize

+      

+      let l1 = (\(x, y, i) -> ((x, y), i)) <<$>> GC.drMapData cmd

+      let layers = Map.unions . reverse $ Map.fromList <$> l1

+

+      A.setSGR [A.Reset]

+      A.clearScreen

+      A.hideCursor

+

+      A.setCursorPosition 0 0

+      let (t, s) = tileFromId 4113

+      let blankLine = Txt.replicate width t

+      A.setSGR s

+      traverse_ putText $ replicate height blankLine

+      traverse_ drawTile $ Map.toList layers

+      A.setSGR [A.Reset]

+

+  where

+    drawTile :: ((Int, Int), Int) -> IO ()

+    drawTile ((x, y), tid) = do

+      A.setCursorPosition y x

+      let (t, s) = tileFromId tid

+      A.setSGR s

+      putStr t

+

+      

+

+

+getSize :: IO (Int, Int)

+getSize =

+  Sz.size @ Int >>= \case

+    Nothing -> throwString "unable to get screen size"

+    Just (Sz.Window w h) -> pure (min 50 w, min 20 h)

+

+      

+

+-- | https://github.com/globalcitizen/zomia/blob/master/USEFUL-UNICODE.md

+tileFromId :: Int -> (Text, [A.SGR])

+tileFromId 4113 = (" ", []) -- " " -- E.Blank

+tileFromId 2615 = ("⌺", [A.SetColor A.Foreground A.Vivid A.Green]) -- "'" -- E.Door

+tileFromId 2115 = ("⊠", [A.SetColor A.Foreground A.Vivid A.Red]) -- "+" -- E.DoorClosed

+tileFromId  914 = ("█", [A.SetColor A.Foreground A.Dull A.White]) -- "#" -- E.Wall

+tileFromId  803 = ("Ӧ", [A.SetColor A.Foreground A.Vivid A.Cyan]) -- "@" -- E.Player

+tileFromId 2503 = ("⍾", [A.SetColor A.Foreground A.Dull A.Magenta]) -- "B" -- E.Bug

+tileFromId 3804 = ("ຯ", [A.SetColor A.Foreground A.Vivid A.Magenta]) -- "S" -- E.Snake

+tileFromId 4311 = ("░", [A.SetColor A.Foreground A.Dull A.White]) -- "░" -- E.Dark

+tileFromId 5644 = ("ᝐ", [A.SetColor A.Foreground A.Dull A.Green]) -- ">" -- E.Stairs

+tileFromId 1646 = ("☁", [A.SetColor A.Foreground A.Dull A.White]) -- "d" -- E.PotionDark

+tileFromId  846 = ("☀", [A.SetColor A.Foreground A.Vivid A.Yellow]) -- "l" -- E.PotionLight

+tileFromId 5445 = ("ዋ", [A.SetColor A.Foreground A.Dull A.Green]) -- "k" -- E.Key

+tileFromId _    = ("?", [])

+

+

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

+data CommandWrapper = CommandWrapper

+                      { coCmd :: !Text

+                      } deriving (Generic, Show)

+

+

+instance Ae.FromJSON CommandWrapper where

+  parseJSON = Ae.genericParseJSON Ae.defaultOptions { Ae.fieldLabelModifier = renField 2 True }

+

+

+-- | drop prefix, and then lower case

+-- | renField 3 "tskBla" == "bla"

+renField :: Int -> Bool -> [Char] -> [Char]

+renField drp toLower =

+  Txt.unpack . (if toLower then mkLower else identity) . Txt.drop drp . Txt.pack

+  where

+    mkLower t = Txt.toLower (Txt.take 1 t) <> Txt.drop 1 t

diff -w -B -a -d -u -b -r --new-file 20_structure/app/Main.hs 21_console/app/Main.hs

--- 20_structure/app/Main.hs

+++ 21_console/app/Main.hs

@@ -6,6 +6,7 @@

 import           Protolude 

 import qualified Data.Text.IO as Txt

+import qualified Gui.ConsoleGui as Con

 import qualified GameCore as GC

 import qualified GameEngine as GE

 import qualified Levels.Level01 as L01

@@ -11,11 +12,16 @@

 import qualified Levels.Level01 as L01

 import qualified Levels.Level02 as L02

+

 main :: IO ()

 main = do

   map01 <- Txt.readFile "worlds/simple.csv"

   map02 <- Txt.readFile "worlds/level02.csv"

-  GE.runGame (getLevel map01 map02)

+  void . forkIO $ GE.runGame (getLevel map01 map02)

+  putText "Press enter to start the GUI"

+  void Txt.getLine

+  Con.runGui

+

 getLevel :: Text -> Text -> GC.Levels -> GC.Level

 getLevel map01 _ GC.Levels01 = L01.mkLevel map01