mirror of
https://github.com/monadicsystems/okapi.git
synced 2024-11-30 10:29:07 +03:00
Reorganize code
This commit is contained in:
Rashad Gover
parent
c3225cd452
commit
970bdf34f1
@ -1,9 +1,13 @@
|
||||
{-# LANGUAGE StrictData #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Chess where
|
||||
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Lucid
|
||||
import Data.Text
|
||||
import Control.Monad
|
||||
|
||||
data PieceType
|
||||
= Pawn
|
||||
@ -16,31 +20,46 @@ data PieceType
|
||||
|
||||
data PieceColor = White | Black deriving (Eq, Show)
|
||||
|
||||
type Piece = (PieceColor, PieceType)
|
||||
newtype Piece = Piece { unPiece :: (PieceColor, PieceType) }
|
||||
|
||||
wPawn = (White, Pawn)
|
||||
instance ToHtml Piece where
|
||||
toHtml (Piece (White, Pawn)) = "♙"
|
||||
toHtml (Piece (Black, Pawn)) = "♟"
|
||||
toHtml (Piece (White, Knight)) = "♘"
|
||||
toHtml (Piece (Black, Knight)) = "♞"
|
||||
toHtml (Piece (White, Rook)) = "♖"
|
||||
toHtml (Piece (Black, Rook)) = "♜"
|
||||
toHtml (Piece (White, Bishop)) = "♗"
|
||||
toHtml (Piece (Black, Bishop)) = "♝"
|
||||
toHtml (Piece (White, Queen)) = "♕"
|
||||
toHtml (Piece (Black, Queen)) = "♛"
|
||||
toHtml (Piece (White, King)) = "♔"
|
||||
toHtml (Piece (Black, King)) = "♚"
|
||||
toHtmlRaw = toHtml
|
||||
|
||||
wKnight = (White, Knight)
|
||||
wPawn = Piece (White, Pawn)
|
||||
|
||||
wRook = (White, Rook)
|
||||
wKnight = Piece (White, Knight)
|
||||
|
||||
wBishop = (White, Bishop)
|
||||
wRook = Piece (White, Rook)
|
||||
|
||||
wQueen = (White, Queen)
|
||||
wBishop = Piece (White, Bishop)
|
||||
|
||||
wKing = (White, King)
|
||||
wQueen = Piece (White, Queen)
|
||||
|
||||
bPawn = (Black, Pawn)
|
||||
wKing = Piece (White, King)
|
||||
|
||||
bKnight = (Black, Knight)
|
||||
bPawn = Piece (Black, Pawn)
|
||||
|
||||
bRook = (Black, Rook)
|
||||
bKnight = Piece (Black, Knight)
|
||||
|
||||
bBishop = (Black, Bishop)
|
||||
bRook = Piece (Black, Rook)
|
||||
|
||||
bQueen = (Black, Queen)
|
||||
bBishop = Piece (Black, Bishop)
|
||||
|
||||
bKing = (Black, King)
|
||||
bQueen = Piece (Black, Queen)
|
||||
|
||||
bKing = Piece (Black, King)
|
||||
|
||||
data File
|
||||
= FileA
|
||||
@ -64,138 +83,96 @@ data Rank
|
||||
| Rank8
|
||||
deriving (Eq, Show, Ord)
|
||||
|
||||
type Position = (File, Rank)
|
||||
newtype Position = Position { unPosition :: (File, Rank) } deriving (Eq, Ord)
|
||||
|
||||
a1 = (FileA, Rank1)
|
||||
|
||||
a2 = (FileA, Rank2)
|
||||
|
||||
a3 = (FileA, Rank3)
|
||||
|
||||
a4 = (FileA, Rank4)
|
||||
|
||||
a5 = (FileA, Rank5)
|
||||
|
||||
a6 = (FileA, Rank6)
|
||||
|
||||
a7 = (FileA, Rank7)
|
||||
|
||||
a8 = (FileA, Rank8)
|
||||
|
||||
b1 = (FileB, Rank1)
|
||||
|
||||
b2 = (FileB, Rank2)
|
||||
|
||||
b3 = (FileB, Rank3)
|
||||
|
||||
b4 = (FileB, Rank4)
|
||||
|
||||
b5 = (FileB, Rank5)
|
||||
|
||||
b6 = (FileB, Rank6)
|
||||
|
||||
b7 = (FileB, Rank7)
|
||||
|
||||
b8 = (FileB, Rank8)
|
||||
|
||||
c1 = (FileC, Rank1)
|
||||
|
||||
c2 = (FileC, Rank2)
|
||||
|
||||
c3 = (FileC, Rank3)
|
||||
|
||||
c4 = (FileC, Rank4)
|
||||
|
||||
c5 = (FileC, Rank5)
|
||||
|
||||
c6 = (FileC, Rank6)
|
||||
|
||||
c7 = (FileC, Rank7)
|
||||
|
||||
c8 = (FileC, Rank8)
|
||||
|
||||
d1 = (FileD, Rank1)
|
||||
|
||||
d2 = (FileD, Rank2)
|
||||
|
||||
d3 = (FileD, Rank3)
|
||||
|
||||
d4 = (FileD, Rank4)
|
||||
|
||||
d5 = (FileD, Rank5)
|
||||
|
||||
d6 = (FileD, Rank6)
|
||||
|
||||
d7 = (FileD, Rank7)
|
||||
|
||||
d8 = (FileD, Rank8)
|
||||
|
||||
e1 = (FileE, Rank1)
|
||||
|
||||
e2 = (FileE, Rank2)
|
||||
|
||||
e3 = (FileE, Rank3)
|
||||
|
||||
e4 = (FileE, Rank4)
|
||||
|
||||
e5 = (FileE, Rank5)
|
||||
|
||||
e6 = (FileE, Rank6)
|
||||
|
||||
e7 = (FileE, Rank7)
|
||||
|
||||
e8 = (FileE, Rank8)
|
||||
|
||||
f1 = (FileF, Rank1)
|
||||
|
||||
f2 = (FileF, Rank2)
|
||||
|
||||
f3 = (FileF, Rank3)
|
||||
|
||||
f4 = (FileF, Rank4)
|
||||
|
||||
f5 = (FileF, Rank5)
|
||||
|
||||
f6 = (FileF, Rank6)
|
||||
|
||||
f7 = (FileF, Rank7)
|
||||
|
||||
f8 = (FileF, Rank8)
|
||||
|
||||
g1 = (FileG, Rank1)
|
||||
|
||||
g2 = (FileG, Rank2)
|
||||
|
||||
g3 = (FileG, Rank3)
|
||||
|
||||
g4 = (FileG, Rank4)
|
||||
|
||||
g5 = (FileG, Rank5)
|
||||
|
||||
g6 = (FileG, Rank6)
|
||||
|
||||
g7 = (FileG, Rank7)
|
||||
|
||||
g8 = (FileG, Rank8)
|
||||
|
||||
h1 = (FileH, Rank1)
|
||||
|
||||
h2 = (FileH, Rank2)
|
||||
|
||||
h3 = (FileH, Rank3)
|
||||
|
||||
h4 = (FileH, Rank4)
|
||||
|
||||
h5 = (FileH, Rank5)
|
||||
|
||||
h6 = (FileH, Rank6)
|
||||
|
||||
h7 = (FileH, Rank7)
|
||||
|
||||
h8 = (FileH, Rank8)
|
||||
a1 = Position (FileA, Rank1)
|
||||
a2 = Position (FileA, Rank2)
|
||||
a3 = Position (FileA, Rank3)
|
||||
a4 = Position (FileA, Rank4)
|
||||
a5 = Position (FileA, Rank5)
|
||||
a6 = Position (FileA, Rank6)
|
||||
a7 = Position (FileA, Rank7)
|
||||
a8 = Position (FileA, Rank8)
|
||||
b1 = Position (FileB, Rank1)
|
||||
b2 = Position (FileB, Rank2)
|
||||
b3 = Position (FileB, Rank3)
|
||||
b4 = Position (FileB, Rank4)
|
||||
b5 = Position (FileB, Rank5)
|
||||
b6 = Position (FileB, Rank6)
|
||||
b7 = Position (FileB, Rank7)
|
||||
b8 = Position (FileB, Rank8)
|
||||
c1 = Position (FileC, Rank1)
|
||||
c2 = Position (FileC, Rank2)
|
||||
c3 = Position (FileC, Rank3)
|
||||
c4 = Position (FileC, Rank4)
|
||||
c5 = Position (FileC, Rank5)
|
||||
c6 = Position (FileC, Rank6)
|
||||
c7 = Position (FileC, Rank7)
|
||||
c8 = Position (FileC, Rank8)
|
||||
d1 = Position (FileD, Rank1)
|
||||
d2 = Position (FileD, Rank2)
|
||||
d3 = Position (FileD, Rank3)
|
||||
d4 = Position (FileD, Rank4)
|
||||
d5 = Position (FileD, Rank5)
|
||||
d6 = Position (FileD, Rank6)
|
||||
d7 = Position (FileD, Rank7)
|
||||
d8 = Position (FileD, Rank8)
|
||||
e1 = Position (FileE, Rank1)
|
||||
e2 = Position (FileE, Rank2)
|
||||
e3 = Position (FileE, Rank3)
|
||||
e4 = Position (FileE, Rank4)
|
||||
e5 = Position (FileE, Rank5)
|
||||
e6 = Position (FileE, Rank6)
|
||||
e7 = Position (FileE, Rank7)
|
||||
e8 = Position (FileE, Rank8)
|
||||
f1 = Position (FileF, Rank1)
|
||||
f2 = Position (FileF, Rank2)
|
||||
f3 = Position (FileF, Rank3)
|
||||
f4 = Position (FileF, Rank4)
|
||||
f5 = Position (FileF, Rank5)
|
||||
f6 = Position (FileF, Rank6)
|
||||
f7 = Position (FileF, Rank7)
|
||||
f8 = Position (FileF, Rank8)
|
||||
g1 = Position (FileG, Rank1)
|
||||
g2 = Position (FileG, Rank2)
|
||||
g3 = Position (FileG, Rank3)
|
||||
g4 = Position (FileG, Rank4)
|
||||
g5 = Position (FileG, Rank5)
|
||||
g6 = Position (FileG, Rank6)
|
||||
g7 = Position (FileG, Rank7)
|
||||
g8 = Position (FileG, Rank8)
|
||||
h1 = Position (FileH, Rank1)
|
||||
h2 = Position (FileH, Rank2)
|
||||
h3 = Position (FileH, Rank3)
|
||||
h4 = Position (FileH, Rank4)
|
||||
h5 = Position (FileH, Rank5)
|
||||
h6 = Position (FileH, Rank6)
|
||||
h7 = Position (FileH, Rank7)
|
||||
h8 = Position (FileH, Rank8)
|
||||
|
||||
data Board = Board {boardState :: Map Position Piece, boardHighlights :: [Position]}
|
||||
|
||||
instance ToHtml Board where
|
||||
toHtml (Board state highlights) = do
|
||||
div_ [class_ "grid grid-cols-8 grid-rows-8 gap-0 h-full w-full border-2 border-black"] $ do
|
||||
let blackSquareClass_ = class_ "flex items-center justify-center bg-gray-700 aspect-square"
|
||||
whiteSquareClass_ = class_ "flex items-center justify-center bg-gray-200 aspect-square"
|
||||
forM_
|
||||
([(x, y) | x <- [1 .. 8], y <- [1 .. 8]])
|
||||
( \(n, m) ->
|
||||
div_
|
||||
[ id_ $ tShow n <> tShow m
|
||||
, if odd n
|
||||
then (if odd m then whiteSquareClass_ else blackSquareClass_)
|
||||
else (if odd m then blackSquareClass_ else whiteSquareClass_)
|
||||
]
|
||||
$ maybe "" toHtml (Map.lookup (xyToPosition (n, m)) state)
|
||||
)
|
||||
toHtmlRaw = toHtml
|
||||
|
||||
tShow :: Show a => a -> Text
|
||||
tShow = pack . show
|
||||
|
||||
startingBoard :: Board
|
||||
startingBoard = Board (Map.fromList $ whiteFront <> whiteBack <> blackFront <> blackBack) []
|
||||
where
|
||||
@ -239,3 +216,28 @@ startingBoard = Board (Map.fromList $ whiteFront <> whiteBack <> blackFront <> b
|
||||
(g8, bKnight),
|
||||
(h8, bRook)
|
||||
]
|
||||
|
||||
xyToPosition :: (Int, Int) -> Position
|
||||
xyToPosition (x, y) = Position (intToFile y, intToRank (9 - x))
|
||||
where
|
||||
intToFile :: Int -> File
|
||||
intToFile 1 = FileA
|
||||
intToFile 2 = FileB
|
||||
intToFile 3 = FileC
|
||||
intToFile 4 = FileD
|
||||
intToFile 5 = FileE
|
||||
intToFile 6 = FileF
|
||||
intToFile 7 = FileG
|
||||
intToFile 8 = FileH
|
||||
intToFile _ = Prelude.error "No File for that Int exists"
|
||||
|
||||
intToRank :: Int -> Rank
|
||||
intToRank 1 = Rank1
|
||||
intToRank 2 = Rank2
|
||||
intToRank 3 = Rank3
|
||||
intToRank 4 = Rank4
|
||||
intToRank 5 = Rank5
|
||||
intToRank 6 = Rank6
|
||||
intToRank 7 = Rank7
|
||||
intToRank 8 = Rank8
|
||||
intToRank _ = Prelude.error "No Rank for that Int exists"
|
||||
|
||||
@ -15,12 +15,6 @@
|
||||
|
||||
module Main where
|
||||
|
||||
--as TVar
|
||||
|
||||
-- import Control.Monad.Trans.State
|
||||
|
||||
-- import qualified Control.Monad.State.Class as State
|
||||
|
||||
import Chess
|
||||
import Control.Applicative
|
||||
import Control.Concurrent
|
||||
@ -76,6 +70,8 @@ newtype WaitPool = WaitPool {unWaitPool :: Set Text} -- todo: Add timestamp
|
||||
|
||||
newtype ConfirmedPool = ConfirmedPool {unConfirmedPool :: Set Text}
|
||||
|
||||
data Player = Player {playerName :: Text} deriving (Eq, Show, Generic, FromForm)
|
||||
|
||||
type MonadApp m =
|
||||
( Monad m,
|
||||
MonadReader Env m,
|
||||
@ -85,7 +81,8 @@ type MonadApp m =
|
||||
main :: IO ()
|
||||
main = do
|
||||
print "Running chess app"
|
||||
let newEnvTVar :: IO (TVar Env)
|
||||
let
|
||||
newEnvTVar :: IO (TVar Env)
|
||||
newEnvTVar = do
|
||||
eventSource <- Okapi.newEventSource
|
||||
newTVarIO $ Env (WaitPool mempty) (ConfirmedPool mempty) mempty eventSource
|
||||
@ -94,15 +91,62 @@ main = do
|
||||
hoistApp envTVar app = runReaderT (runApp app) envTVar
|
||||
|
||||
envTVar <- newEnvTVar
|
||||
slaveThreadID <- SlaveThread.fork $
|
||||
forever $ do
|
||||
SlaveThread.fork $ forever $ do
|
||||
threadDelay 1000000
|
||||
confirmer envTVar
|
||||
matchmaker envTVar
|
||||
Okapi.runOkapi (hoistApp envTVar) 3000 chess
|
||||
killThread slaveThreadID
|
||||
|
||||
-- readIORef :: IORef a -> IO a
|
||||
confirmer :: TVar Env -> IO ()
|
||||
confirmer = sendConfirmMessages
|
||||
where
|
||||
sendConfirmMessages :: TVar Env -> IO ()
|
||||
sendConfirmMessages envRef = do
|
||||
waitPool <- unWaitPool <$> atomically (readWaitPool envRef)
|
||||
if Set.null waitPool
|
||||
then pure ()
|
||||
else do
|
||||
eventSource <- atomically $ readEventSource envRef
|
||||
forM_ (Set.toList waitPool) (sendConfirmMessage eventSource)
|
||||
|
||||
sendConfirmMessage :: EventSource -> Text -> IO ()
|
||||
sendConfirmMessage eventSource playerName = Okapi.sendEvent eventSource $ Event (Just $ "confirm-" <> playerName) Nothing ""
|
||||
|
||||
matchmaker :: TVar Env -> IO ()
|
||||
matchmaker = tryNewMatch
|
||||
where
|
||||
tryNewMatch :: TVar Env -> IO ()
|
||||
tryNewMatch envRef = do
|
||||
confirmedPool <- unConfirmedPool <$> atomically (readConfirmedPool envRef)
|
||||
if Set.size confirmedPool >= 2 -- at least 2 players confirmed
|
||||
then do
|
||||
let p1 = Set.elemAt 0 confirmedPool -- get p1
|
||||
p2 = Set.elemAt 1 confirmedPool -- get p2
|
||||
atomically $ deletePlayerFromWaitPool envRef p1 -- delete p1 from pool
|
||||
atomically $ deletePlayerFromWaitPool envRef p2 -- delete p2 from pool
|
||||
atomically $ modifyMatches (Set.insert $ Match (p1, p2)) envRef -- add new match
|
||||
eventSource <- atomically $ readEventSource envRef
|
||||
sendStartEvents eventSource p1 p2
|
||||
else pure ()
|
||||
|
||||
sendStartEvents :: EventSource -> Text -> Text -> IO ()
|
||||
sendStartEvents eventSource p1Name p2Name = do
|
||||
let event1 = Event (Just $ "start-" <> p1Name) Nothing $ renderBS $ toHtml startingBoard
|
||||
event2 = Event (Just $ "start-" <> p2Name) Nothing $ renderBS $ toHtml startingBoard
|
||||
Okapi.sendEvent eventSource event1
|
||||
Okapi.sendEvent eventSource event2
|
||||
|
||||
addPlayerToWaitPool :: TVar Env -> Text -> STM ()
|
||||
addPlayerToWaitPool envRef playerName = modifyWaitPool (WaitPool . Set.insert playerName . unWaitPool) envRef
|
||||
|
||||
addPlayerToConfirmedPool :: TVar Env -> Text -> STM ()
|
||||
addPlayerToConfirmedPool envRef playerName = modifyConfirmedPool (ConfirmedPool . Set.insert playerName . unConfirmedPool) envRef
|
||||
|
||||
deletePlayerFromWaitPool :: TVar Env -> Text -> STM ()
|
||||
deletePlayerFromWaitPool envRef playerName = modifyWaitPool (WaitPool . Set.delete playerName . unWaitPool) envRef
|
||||
|
||||
deletePlayerFromConfirmedPool :: TVar Env -> Text -> STM ()
|
||||
deletePlayerFromConfirmedPool envRef playerName = modifyConfirmedPool (ConfirmedPool . Set.delete playerName . unConfirmedPool) envRef
|
||||
|
||||
readFromEnvTVar :: (Env -> a) -> TVar Env -> STM a
|
||||
readFromEnvTVar f envTVar = do
|
||||
@ -121,8 +165,6 @@ readMatches = readFromEnvTVar envMatches
|
||||
readEventSource :: TVar Env -> STM EventSource
|
||||
readEventSource = readFromEnvTVar envEventSource
|
||||
|
||||
-- atomicModifyIORef' :: IORef a -> (a -> (a, b)) -> IO b
|
||||
|
||||
modfyEnvTVar :: (Env -> Env) -> TVar Env -> STM ()
|
||||
modfyEnvTVar f envTVar = modifyTVar' envTVar f
|
||||
|
||||
@ -135,58 +177,6 @@ modifyConfirmedPool f = modfyEnvTVar (\env -> env {envConfirmedPool = f $ envCon
|
||||
modifyMatches :: (Set Match -> Set Match) -> TVar Env -> STM ()
|
||||
modifyMatches f = modfyEnvTVar (\env -> env {envMatches = f $ envMatches env})
|
||||
|
||||
-- atomicWriteIORef :: IORef a -> a -> IO ()
|
||||
|
||||
confirmer :: TVar Env -> IO ()
|
||||
confirmer = sendConfirmMessages
|
||||
where
|
||||
sendConfirmMessages :: TVar Env -> IO ()
|
||||
sendConfirmMessages envRef = do
|
||||
-- threadDelay 100000000
|
||||
waitPool <- unWaitPool <$> atomically (readWaitPool envRef)
|
||||
-- print $ "Wait pool size: " <> (show $ Set.size waitPool)
|
||||
if Set.null waitPool
|
||||
then pure () -- print "Wait pool is empty"
|
||||
else do
|
||||
-- print "Sending confirm messages"
|
||||
eventSource <- atomically $ readEventSource envRef
|
||||
-- waitPool' <- readWaitPool envRef
|
||||
forM_ (Set.toList waitPool) (sendConfirmMessage eventSource)
|
||||
|
||||
sendConfirmMessage :: EventSource -> Text -> IO ()
|
||||
sendConfirmMessage eventSource playerName = Okapi.sendEvent eventSource $ Event (Just $ "confirm-" <> playerName) Nothing ""
|
||||
|
||||
matchmaker :: TVar Env -> IO ()
|
||||
matchmaker = tryNewMatch
|
||||
where
|
||||
tryNewMatch :: TVar Env -> IO ()
|
||||
tryNewMatch envRef = do
|
||||
-- threadDelay 100000000
|
||||
-- print "Starting matchmaker"
|
||||
confirmedPool <- unConfirmedPool <$> atomically (readConfirmedPool envRef)
|
||||
-- print $ "Confirm pool size: " <> (show $ Set.size confirmedPool)
|
||||
if Set.size confirmedPool >= 2 -- at least 2 players confirmed
|
||||
then do
|
||||
-- print "Starting match"
|
||||
let p1 = Set.elemAt 0 confirmedPool -- get p1
|
||||
p2 = Set.elemAt 1 confirmedPool -- get p2
|
||||
atomically $ modifyConfirmedPool (ConfirmedPool . Set.delete p1 . unConfirmedPool) envRef -- delete p1 from pool
|
||||
atomically $ modifyConfirmedPool (ConfirmedPool . Set.delete p2 . unConfirmedPool) envRef -- delete p2 from pool
|
||||
atomically $ modifyMatches (Set.insert $ Match (p1, p2)) envRef -- add new match
|
||||
eventSource <- atomically $ readEventSource envRef
|
||||
sendStartEvent eventSource p1 p2
|
||||
else pure () -- print "Confirmed pool is less than 2"
|
||||
|
||||
sendStartEvent :: EventSource -> Text -> Text -> IO ()
|
||||
sendStartEvent eventSource p1Name p2Name = do
|
||||
let event1 = Event (Just $ "start-" <> p1Name) Nothing $ renderBS $ toHtml startingBoard
|
||||
event2 = Event (Just $ "start-" <> p2Name) Nothing $ renderBS $ toHtml startingBoard
|
||||
Okapi.sendEvent eventSource event1
|
||||
Okapi.sendEvent eventSource event2
|
||||
|
||||
-- renderStrict :: ToHtml a => a -> BS.ByteString
|
||||
-- renderStrict = LBS.toStrict . renderBS . toHtmlRaw
|
||||
|
||||
newtype Wrap a = Wrap a
|
||||
|
||||
instance ToHtml a => ToHtml (Wrap a) where
|
||||
@ -238,174 +228,6 @@ instance ToHtml Home where
|
||||
div_ [id_ "content"] "Hello"
|
||||
toHtmlRaw = toHtml
|
||||
|
||||
missingCard_ :: Term arg result => arg -> result
|
||||
missingCard_ = term "missing-card"
|
||||
|
||||
intToFile :: Int -> File
|
||||
intToFile 1 = FileA
|
||||
intToFile 2 = FileB
|
||||
intToFile 3 = FileC
|
||||
intToFile 4 = FileD
|
||||
intToFile 5 = FileE
|
||||
intToFile 6 = FileF
|
||||
intToFile 7 = FileG
|
||||
intToFile 8 = FileH
|
||||
intToFile _ = Prelude.error "No File for that Int exists"
|
||||
|
||||
intToRank :: Int -> Rank
|
||||
intToRank 1 = Rank1
|
||||
intToRank 2 = Rank2
|
||||
intToRank 3 = Rank3
|
||||
intToRank 4 = Rank4
|
||||
intToRank 5 = Rank5
|
||||
intToRank 6 = Rank6
|
||||
intToRank 7 = Rank7
|
||||
intToRank 8 = Rank8
|
||||
intToRank _ = Prelude.error "No Rank for that Int exists"
|
||||
|
||||
-- positionToXY :: Position -> (Int, Int)
|
||||
-- positionToXY (file, rank) = (fromEnum file, 9 - fromEnum rank)
|
||||
|
||||
xyToPosition :: (Int, Int) -> Position
|
||||
xyToPosition (x, y) = (intToFile y, intToRank (9 - x))
|
||||
|
||||
instance ToHtml Piece where
|
||||
toHtml (White, Pawn) = "♙"
|
||||
toHtml (Black, Pawn) = "♟"
|
||||
toHtml (White, Knight) = "♘"
|
||||
toHtml (Black, Knight) = "♞"
|
||||
toHtml (White, Rook) = "♖"
|
||||
toHtml (Black, Rook) = "♜"
|
||||
toHtml (White, Bishop) = "♗"
|
||||
toHtml (Black, Bishop) = "♝"
|
||||
toHtml (White, Queen) = "♕"
|
||||
toHtml (Black, Queen) = "♛"
|
||||
toHtml (White, King) = "♔"
|
||||
toHtml (Black, King) = "♚"
|
||||
toHtmlRaw = toHtml
|
||||
|
||||
tShow :: Show a => a -> Text
|
||||
tShow = pack . show
|
||||
|
||||
instance ToHtml Board where
|
||||
toHtml (Board state highlights) = do
|
||||
-- link_ [id_ "style", rel_ "stylesheet", href_ "https://the.missing.style", hxSwapOob_ "true", hxSwap_ "outerHTML"]
|
||||
div_ [class_ "grid grid-cols-8 grid-rows-8 gap-0 h-full w-full border-2 border-black"] $ do
|
||||
let blackSquareClass_ = class_ "flex items-center justify-center bg-gray-700 aspect-square"
|
||||
whiteSquareClass_ = class_ "flex items-center justify-center bg-gray-200 aspect-square"
|
||||
forM_
|
||||
([(x, y) | x <- [1 .. 8], y <- [1 .. 8]])
|
||||
( \(n, m) ->
|
||||
div_
|
||||
[ id_ $ tShow n <> tShow m
|
||||
, if odd n
|
||||
then (if odd m then whiteSquareClass_ else blackSquareClass_)
|
||||
else (if odd m then blackSquareClass_ else whiteSquareClass_)
|
||||
]
|
||||
-- $ "♖"
|
||||
-- $ toHtml $ show n
|
||||
-- "BB"
|
||||
$ maybe "" toHtml (Map.lookup (xyToPosition (n, m)) state)
|
||||
)
|
||||
|
||||
-- tr_ [] $ do
|
||||
-- th_ [] ""
|
||||
-- th_ [] "a"
|
||||
-- th_ [] "b"
|
||||
-- th_ [] "c"
|
||||
-- th_ [] "d"
|
||||
-- th_ [] "e"
|
||||
-- th_ [] "f"
|
||||
-- th_ [] "g"
|
||||
-- th_ [] "h"
|
||||
-- tr_ [] $ do
|
||||
-- th_ [] "8"
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- tr_ [] $ do
|
||||
-- th_ [] "7"
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- tr_ [] $ do
|
||||
-- th_ [] "6"
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- tr_ [] $ do
|
||||
-- th_ [] "5"
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- tr_ [] $ do
|
||||
-- th_ [] "4"
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- tr_ [] $ do
|
||||
-- th_ [] "3"
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- tr_ [] $ do
|
||||
-- th_ [] "2"
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- tr_ [] $ do
|
||||
-- th_ [] "1"
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
-- td_ [] ""
|
||||
toHtmlRaw = toHtml
|
||||
|
||||
addPlayerToWaitPool :: TVar Env -> Text -> STM ()
|
||||
addPlayerToWaitPool envRef playerName = modifyWaitPool (WaitPool . Set.insert playerName . unWaitPool) envRef
|
||||
|
||||
addPlayerToConfirmedPool :: TVar Env -> Text -> STM ()
|
||||
addPlayerToConfirmedPool envRef playerName = modifyConfirmedPool (ConfirmedPool . Set.insert playerName . unConfirmedPool) envRef
|
||||
|
||||
data JoinedPool = JoinedPool Text
|
||||
|
||||
instance ToHtml JoinedPool where
|
||||
@ -416,20 +238,14 @@ instance ToHtml JoinedPool where
|
||||
h4_ $ toHtml $ "Hello, " <> name <> ". Finding an opponent..."
|
||||
toHtmlRaw = toHtml
|
||||
|
||||
-- data Confirmed = Confirmed Text
|
||||
|
||||
-- instance ToHtml Confirmed where
|
||||
-- toHtml (Confirmed name) = do
|
||||
-- div_ [sseSwap_ ["start-"<>name]] $ do
|
||||
-- h4_ $ toHtml $ ("Connection confirmed. I'm finding you an opponent now..." :: Text)
|
||||
-- toHtmlRaw = toHtml
|
||||
|
||||
sseConnect_ :: Text -> Attribute
|
||||
sseConnect_ = makeAttribute "sse-connect"
|
||||
|
||||
sseSwap_ :: [Text] -> Attribute
|
||||
sseSwap_ messageNames = makeAttribute "sse-swap" $ Data.Text.intercalate "," messageNames
|
||||
|
||||
-- API
|
||||
|
||||
chess :: Okapi Result
|
||||
chess = home <|> register <|> stream <|> confirm
|
||||
|
||||
@ -447,8 +263,6 @@ register = do
|
||||
liftIO $ atomically $ addPlayerToWaitPool envRef playerName
|
||||
okLucid [] $ JoinedPool playerName
|
||||
|
||||
data Player = Player {playerName :: Text} deriving (Eq, Show, Generic, FromForm)
|
||||
|
||||
stream :: Okapi Result
|
||||
stream = do
|
||||
get
|
||||
@ -463,15 +277,7 @@ confirm = do
|
||||
Okapi.seg "confirm"
|
||||
playerName <- queryParam "player"
|
||||
envRef <- ask
|
||||
liftIO $ atomically $ modifyWaitPool (WaitPool . Set.delete playerName . unWaitPool) envRef
|
||||
liftIO $ atomically $ addPlayerToConfirmedPool envRef playerName
|
||||
liftIO $ SlaveThread.fork $ do
|
||||
atomically $ deletePlayerFromWaitPool envRef playerName
|
||||
atomically $ addPlayerToConfirmedPool envRef playerName
|
||||
noContent []
|
||||
|
||||
authorize = undefined
|
||||
|
||||
-- do
|
||||
-- authHeaderValue <- Okapi.auth
|
||||
-- jwtSecret <- read @Text
|
||||
-- case extractToken authHeaderValue >>= verifyToken jwtSecret of
|
||||
-- Nothing -> Okapi.error401 [] ""
|
||||
-- Just userID -> pure userID
|
||||
|
||||
Loading…
Reference in New Issue
Block a user