diff options
Diffstat (limited to 'Handler/Home.hs')
| -rw-r--r-- | Handler/Home.hs | 17 |
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 |