Highlight next transitions

1 files changed, 14 insertions, 3 deletions

diff --git a/Handler/Home.hs b/Handler/Home.hs
index 0ee0882..a0eb24f 100644
--- a/Handler/Home.hs
+++ b/Handler/Home.hs
@@ -3,8 +3,10 @@ module Handler.Home where
 
 import Import
 
-import qualified Data.Text as T
 import Data.Aeson
+import qualified Data.Text as T
+import qualified Data.Map.Strict as Map
+import Data.Maybe (fromMaybe)
 import Text.Julius
 import Yesod.WebSockets
 import Turing.Examples
@@ -12,7 +14,7 @@ import Turing.Machine
 
 data Cmd = Beginning | Backward | Forward | Poll | MHello | MSub deriving Read
 
-data UpdM = UpdTape String | UpdTrans String | Stop
+data UpdM = UpdTape String | UpdTrans String | Stop | Bold Int
 -- instance FromJSON UpdM where
 --   parseJSON (Object v) = cons =<< (v .: "type")
 --     where cons :: String -> Parser UpdM
@@ -24,6 +26,7 @@ instance ToJSON UpdM where
                      UpdTape s -> ("tape"::String, s)
                      UpdTrans s -> ("trans", s)
                      Stop -> ("stop", "")
+                     Bold n -> ("bold", show n)
 
 wsTuring :: WebSocketsT Handler ()
 wsTuring = startMachine mHello defaultConfig
@@ -35,9 +38,10 @@ wsTuring = startMachine mHello defaultConfig
           defaultConfig = mkConfig . map charToSym $  "_"
           evalLoop m ic [] = evalLoop m ic [ic]
           evalLoop m ic cfgs@(c:cs) = do
+            sendTextData . encode $ Bold transRow
             sendTextData . encode . UpdTape . show $ c
             cmd <- receiveData
-            case (read . T.unpack $ cmd) of
+            case read . T.unpack $ cmd of
               Beginning -> evalLoop m ic [ic]
               Backward -> evalLoop m ic cs
               Forward -> case step c (delta m) of
@@ -47,6 +51,13 @@ wsTuring = startMachine mHello defaultConfig
               Poll -> evalLoop m ic cfgs
               MHello -> startMachine mHello defaultConfig
               MSub -> startMachine mSub mSubConfig
+            where transRow = fIdx (state c, tape c !! pos c) (Map.toList (trans m))
+                  fIdx y xs = fromMaybe (-1) (fIdx' y xs)
+                  fIdx' _ [] = Nothing
+                  fIdx' (st1,sym1) (((st2,sym2),_):xs) =
+                    if st1 == st2 && (sym1 == sym2 || sym2 == SymWild)
+                    then Just 0
+                    else fmap (+1) (fIdx' (st1,sym1) xs)
 
 getHomeR :: Handler Html
 getHomeR = do