hanafuda
/
server
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Card-shaped cards in client GUI, sending move but not handled on server

This commit is contained in:
Sasha 2018-05-13 18:08:12 +02:00
parent 20001ebfc5
commit 83201d5c95
14 changed files with 348 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
src/Automaton.hs
View File

@ -5,9 +5,10 @@ module Automaton (
import Data.Foldable (forM_)
import Control.Monad.Reader (asks, lift)
import qualified Data (RW(..))
import qualified Game (export, new)
import qualified Session (Status(..), T(..))
import qualified Server (get, logIn, logOut, setStatus, register)
import qualified Session (Status(..), T(..), Update)
import qualified Server (get, logIn, logOut, update, register)
import qualified App (Context(..), T, current, debug, get, server, try, update, update_)
import qualified Message (FromClient(..), T(..), broadcast, get, relay, send, sendTo, update)
@ -31,7 +32,7 @@ edges (Session.LoggedIn True) invitation@(Message.Invitation {Message.to}) = do
case Session.status session of
Session.LoggedIn True -> do
key <- asks App.key
App.update_ (Server.setStatus (Session.Answering key) to)
App.update_ (Server.update to (Data.set $ Session.Answering key :: Session.Update))
Message.broadcast $ Message.update {Message.paired = [key, to]}
(Message.relay invitation $ Message.sendTo [(to, session)])
return (Session.Waiting to)
@ -55,10 +56,13 @@ edges (Session.Answering to) message@(Message.Answer {Message.accept}) = do
else do
Message.broadcast $ Message.update {Message.alone = [key, to]}
return $ Session.LoggedIn True
App.update_ $ Server.setStatus newStatus for
App.update_ $ Server.update for (Data.set newStatus :: Session.Update)
return newStatus
_ -> (Session.LoggedIn True) `withError` "They're not waiting for your answer"
--edges (Session.Playing game) message@(Message.Play {Message.move}) = do
edges state _ =
state `withError` ("Invalid message in state " ++ show state)
@ -71,7 +75,8 @@ run = do
message <- Message.get
status <- Session.status <$> App.current
newStatus <- edges status message
asks App.key >>= App.update_ . Server.setStatus newStatus
key <- asks App.key
App.update_ $ Server.update key $ (Data.set newStatus :: Session.Update)
App.debug $ show newStatus
run

8
src/Game.hs
View File

@ -13,7 +13,7 @@ module Game (
import Data.Text (pack)
import Data.Map (Map, (!), fromList, mapKeys, mapWithKey)
import Data.Aeson (FromJSON(..), ToJSON(..), ToJSON1(..), ToJSONKey(..), genericToEncoding, genericLiftToEncoding, toEncoding1, toJSON1)
import Data.Aeson (FromJSON(..), ToJSON(..), ToJSON1(..), ToJSONKey(..), genericParseJSON, genericToEncoding, genericLiftToEncoding, toEncoding1, toJSON1)
import Data.Aeson.Types (toJSONKeyText)
import qualified JSON (defaultOptions, singleLCField)
import qualified Data (Key)
@ -42,7 +42,8 @@ instance ToJSON Hanafuda.Pack where
instance ToJSON Hanafuda.KoiKoi.Mode
instance FromJSON Hanafuda.KoiKoi.Move
instance FromJSON Hanafuda.KoiKoi.Move where
parseJSON = genericParseJSON JSON.singleLCField
instance ToJSON Hanafuda.KoiKoi.Move where
toEncoding = genericToEncoding JSON.singleLCField
@ -112,3 +113,6 @@ export key (T {keys, state}) = View {
reindex = mapKeys (keys !)
players = reindex $ Hanafuda.KoiKoi.players state
maskHand player = player {Hanafuda.Player.hand = Hanafuda.empty}
play :: Player.Key -> Hanafuda.KoiKoi.Move -> T -> T
play = undefined

2
src/Message.hs
View File

@ -33,7 +33,7 @@ data FromClient =
| Invitation {to :: Player.Key}
| LogIn {name :: Text}
| LogOut
| Game {move :: KoiKoi.Move}
| Play {move :: KoiKoi.Move}
| Ping
deriving (Generic)

16
src/Server.hs
View File

@ -4,6 +4,7 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Server (
T(..)
, disconnect
@ -12,7 +13,7 @@ module Server (
, logOut
, new
, register
, setStatus
, update
) where
import Data.Aeson (ToJSON(..), (.=), object, pairs)
@ -25,7 +26,7 @@ import Data.Text (Text)
import qualified Data (RW(..))
import qualified Game (Key, T(..))
import qualified Player (Key, T(..))
import qualified Session (Status(..), T(..))
import qualified Session (Status(..), T(..), Update)
type Names = Set Text
type Players = Map Player.Key Player.T
@ -87,6 +88,13 @@ register x server =
get :: forall a b. (Ord a, Data.RW (Map a b) T) => a -> T -> b
get key server = (Data.get server :: Map a b) ! key
set :: forall a b c. (Ord a, Data.RW (Map a b) T, Data.RW c b) => a -> c -> T -> T
set key value = update key (Data.set value :: b -> b)
update :: forall a b. (Ord a, Data.RW (Map a b) T) => a -> (b -> b) -> T -> T
update key updator =
Data.update (adjust updator key :: Map a b -> Map a b)
disconnect :: Player.Key -> T -> T
disconnect key =
Data.update (delete key :: Sessions -> Sessions) . logOut key
@ -95,7 +103,7 @@ logIn :: Text -> Player.Key -> T -> Either String T
logIn name key server =
Data.update (Set.insert name) .
Data.update (insert key $ Player.T {Player.name}) .
setStatus (Session.LoggedIn True) key <$>
update key (Data.set $ Session.LoggedIn True :: Session.Update) <$>
if name `member` names server
then Left "This name is already registered"
else Right server
@ -106,7 +114,7 @@ logOut key server =
server
(\player ->
Data.update (delete key :: Players -> Players) $
setStatus (Session.LoggedIn False) key $
update key (Data.set $ Session.LoggedIn False :: Session.Update) $
Data.update (Set.delete $ Player.name player :: Names -> Names) server)
(players server !? key)

2
src/Session.hs
View File

@ -4,6 +4,7 @@
module Session (
Status(..)
, T(..)
, Update
, open
) where
@ -29,6 +30,7 @@ data T = T {
connection :: Connection
, status :: Status
}
type Update = T -> T
instance Data.RW Status T where
get = status

27
www/sort.js → www/fun.js
View File

@ -1,8 +1,11 @@
function Sort() {
function Fun() {
return {
defaultCompare: defaultCompare,
map: map,
insert: insert,
map: map,
mapFilter: mapFilter,
isSet: isSet,
of: of
};
function insert(obj, t, compare, min, max) {
@ -30,11 +33,27 @@ function Sort() {
}
}
function map(projector, f) {
function map(mapper, f) {
return function() {
var args = Array.prototype.map.call(arguments, projector);
var args = Array.prototype.map.call(arguments, mapper);
return f.apply(null, args);
}
}
function of(o) {
return function(key) {return o[key];};
}
function mapFilter(mapper, predicate) {
return function(array) {
return array.reduce(function(accumulator, elem) {
var v = mapper(elem);
return predicate(v) ? accumulator.concat(v) : accumulator;
}, []);
};
}
function isSet(x) {
return x != undefined;
}
}

25
www/game.css Normal file
View File

@ -0,0 +1,25 @@
#game h2 {
clear: both;
}
li.card {
display: inline-block;
border-radius: 0.5em;
border: 1px solid #555;
width: 6em;
height: 10em;
float: left;
margin: 0.5em;
}
#river li.card.candidate, #hand li.card {
cursor: pointer;
}
#river li.card.candidate {
box-shadow: 0 0 0.5em 0.1em #fc0;
}
#hand li.card.selected {
margin-top: -1em;
}

98
www/game.js Normal file
View File

@ -0,0 +1,98 @@
function Game(modules) {
var sets = {
river : cardSet('river'),
hand : cardSet('hand'),
};
var selected = null;
modules.messaging.addEventListener(["NewGame"], function(o) {
o.game.river.forEach(function(cardName) {
var card = new RiverCard(cardName);
sets.river.card[card.value] = card;
sets.river.dom.appendChild(card.dom);
});
o.game.players[modules.session.getKey()].hand.forEach(function(cardName) {
var card = new HandCard(cardName);
sets.hand.card[card.value] = card;
sets.hand.dom.appendChild(card.dom);
});
});
function cardSet(id) {
return {
card: {},
dom: document.getElementById(id)
};
}
function matchingInRiver(card) {
return modules.fun.mapFilter(
modules.fun.of(sets.river.card),
modules.fun.isSet
)(modules.hanafuda.sameMonth(card));
}
function Card(name) {
this.value = modules.hanafuda.Card[name];
this.name = name;
this.dom = document.createElement('li');
this.dom.className = "card";
this.dom.textContent = name;
this.dom.addEventListener('click', this.onClick());
}
Card.prototype.onClick = function() {return function() {};};
function RiverCard() {
Card.apply(this, arguments);
this.candidate = false;
}
RiverCard.prototype.onClick = function() {
var card = this;
return function() {
if(card.candidate) {
modules.messaging.send({
tag: "Play",
move: {capture: [sets.hand.card[selected].name, card.name]}
});
}
};
};
RiverCard.prototype.setCandidate = function(yes) {
this.candidate = yes;
this.dom.classList.toggle("candidate", yes);
}
function HandCard() {
Card.apply(this, arguments);
}
HandCard.prototype.onClick = function() {
var card = this;
return function() {
if(selected != undefined) {
sets.hand.card[selected].setSelected(false);
} else {
card.play();
}
};
};
HandCard.prototype.setSelected = function(yes) {
selected = yes ? this.value : null;
this.dom.classList.toggle('selected', yes);
matchingInRiver(this.value).forEach(function(card) {card.setCandidate(yes);});
}
HandCard.prototype.play = function() {
var matching = matchingInRiver(this.value);
if(matching.length > 1) {
this.setSelected(true);
} else {
modules.messaging.send({tag: "Play", move: {play: this.name}})
}
}
}

152
www/hanafuda.js Normal file
View File

@ -0,0 +1,152 @@
function Hanafuda() {
var Flower = Object.freeze({
Pine: 0,
Plum: 1,
Cherry: 2,
Wisteria: 3,
Iris: 4,
Peony: 5,
BushClover: 6,
SusukiGrass: 7,
Chrysanthemum: 8,
Maple: 9,
Willow: 10,
Paulownia: 11
});
var Card = Object.freeze({
Pine0: 0, Pine1: 1, PinePoetry: 2, Crane: 3,
Plum0: 4, Plum1: 5, PlumPoetry: 6, BushWarbler: 7,
Cherry0: 8, Cherry1: 9, CherryPoetry: 10, CampCurtain: 11,
Wisteria0: 12, Wisteria1: 13, WisteriaRed: 14, Cuckoo: 15,
Iris0: 16, Iris1: 17, IrisRed: 18, EightPlankBridge: 19,
Peony0: 20, Peony1: 21, PeonyBlue: 22, Butterflies: 23,
BushClover0: 24, BushClover1: 25, BushCloverRed: 26, Boar: 27,
SusukiGrass0: 28, SusukiGrass1: 29, Geese: 30, FullMoon: 31,
Chrysanthemum0: 32, Chrysanthemum1: 33, ChrysanthemumBlue: 34, SakeCup: 35,
Maple0: 36, Maple1: 37, MapleBlue: 38, Deer: 39,
Lightning: 40, WillowRed: 41, Swallow: 42, RainMan: 43,
Paulownia0: 44, Paulownia1: 45, Sand: 46, Phoenix: 47
});
return {
Flower: Flower,
Card: Card,
flower: flower,
sameMonth: sameMonth
};
function flower(card) {
return Math.floor(card / 4);
}
function sameMonth(card) {
var first = 4 * flower(card);
return [0,1,2,3].map(function(i) {return first + i;});
}
/*
data Flower =
Pine
| Plum
| Cherry
| Wisteria
| Iris
| Peony
| BushClover
| SusukiGrass
| Chrysanthemum
| Maple
| Willow
| Paulownia
deriving (Eq, Ord, Enum, Show)
data Card =
Pine0 | Pine1 | PinePoetry | Crane
| Plum0 | Plum1 | PlumPoetry | BushWarbler
| Cherry0 | Cherry1 | CherryPoetry | CampCurtain
| Wisteria0 | Wisteria1 | WisteriaRed | Cuckoo
| Iris0 | Iris1 | IrisRed | EightPlankBridge
| Peony0 | Peony1 | PeonyBlue | Butterflies
| BushClover0 | BushClover1 | BushCloverRed | Boar
| SusukiGrass0 | SusukiGrass1 | Geese | FullMoon
| Chrysanthemum0 | Chrysanthemum1 | ChrysanthemumBlue | SakeCup
| Maple0 | Maple1 | MapleBlue | Deer
| Lightning | WillowRed | Swallow | RainMan
| Paulownia0 | Paulownia1 | Sand | Phoenix
deriving (Eq, Ord, Enum, Show)
flower :: Card -> Flower
flower = toEnum . (`div` 4) . fromEnum
type Monthly a = Reader Flower a
newtype Pack = Pack { unpack :: Word64 } deriving (Eq)
empty :: Pack
empty = Pack 0
packOfCards :: [Card] -> Pack
packOfCards = foldl add empty
smallest :: Pack -> Card
smallest = toEnum . countTrailingZeros . unpack
cardsOfPack :: Pack -> [Card]
cardsOfPack (Pack 0) = []
cardsOfPack p =
let c = smallest p in
c : cardsOfPack (remove p c)
instance Show Pack where
show = ("packOfCards " ++) . show . cardsOfPack
portEnum :: Enum e => (Word64 -> Int -> b) -> Pack -> e -> b
portEnum f (Pack p) = f p . fromEnum
contains :: Pack -> Card -> Bool
contains = portEnum testBit
size :: Pack -> Int
size (Pack p) = popCount p
add :: Pack -> Card -> Pack
add p = Pack . portEnum setBit p
remove :: Pack -> Card -> Pack
remove p = Pack . portEnum clearBit p
portBinary :: (Word64 -> Word64 -> Word64) -> Pack -> Pack -> Pack
portBinary operator (Pack a) (Pack b) = Pack $ operator a b
intersection :: Pack -> Pack -> Pack
intersection = portBinary (.&.)
difference :: Pack -> Pack -> Pack
difference = portBinary (\a b -> a `xor` (a .&. b))
sameMonth :: Card -> Pack
sameMonth card = Pack $ 0xf `shift` (fromEnum card .&. 0xfc)
cards :: [Card]
cards = [Pine0 .. Phoenix]
shuffle :: [a] -> IO [a]
shuffle l =
aux (length l) l
where
aux _ [] = return []
aux n (h:t) = do
cut <- randomRIO (0, n-1)
shuffled <- shuffle t
let (top, bottom) = splitAt cut shuffled
return $ top ++ h : bottom
match :: Card -> Pack -> Either String (Pack, [Card])
match card pack =
let sameMonthCards = sameMonth card `intersection` pack in
case size sameMonthCards of
0 -> Right (add pack card, [])
1 -> Right (difference pack sameMonthCards, card : cardsOfPack sameMonthCards)
_ -> Left "This card can match several others"
*/
}

7
www/index.html
View File

@ -3,15 +3,18 @@
<head>
<title>KoiKoi</title>
<script src="dom.js"></script>
<script src="sort.js"></script>
<script src="fun.js"></script>
<script src="screen.js"></script>
<script src="messaging.js"></script>
<script src="session.js"></script>
<script src="room.js"></script>
<script src="login.js"></script>
<script src="hanafuda.js"></script>
<script src="game.js"></script>
<script src="main.js"></script>
<link rel="stylesheet" href="skin.css" type="text/css"/>
<link rel="stylesheet" href="screen.css" type="text/css"/>
<link rel="stylesheet" href="login.css" type="text/css"/>
<link rel="stylesheet" href="game.css" type="text/css"/>
</head>
<body>
<div id="reception" class="on">

8
www/skin.css → www/login.css
View File

@ -1,11 +1,3 @@
body > div {
display: none;
}
body > div.on {
display: block;
}
#join, #invite {
display: none;
}

7
www/main.js
View File

@ -1,12 +1,13 @@
window.addEventListener('load', function() {
var dom = Dom();
var sort = Sort();
var fun = Fun();
var screen = Screen();
var messaging = Messaging();
var session = Session({messaging: messaging});
var room = Room({dom: dom, messaging: messaging, session: session, sort: sort});
var room = Room({dom: dom, messaging: messaging, session: session, fun: fun});
var login = Login({dom: dom, messaging: messaging, room: room, screen: screen, session: session});
var game = Game({dom: dom, messaging: messaging, session: session});
var hanafuda = Hanafuda();
var game = Game({dom: dom, fun: fun, hanafuda: hanafuda, messaging: messaging, session: session});
messaging.start();
});

9
www/room.js
View File

@ -36,7 +36,7 @@ function Room(modules) {
leave(o.from);
});
var compareKeysByLogin = modules.sort.map(function(key) {return players[key].name;}, modules.sort.defaultCompare);
var compareKeysByLogin = modules.fun.map(function(key) {return players[key].name;}, modules.fun.defaultCompare);
return {
filter: filter,
@ -53,10 +53,7 @@ function Room(modules) {
} else {
var keep = function(player) {return player.name.match(name);};
}
return sortedKeys.reduce(function(accumulator, key) {
var player = players[key];
return keep(player) ? accumulator.concat(player) : accumulator;
}, []);
return modules.fun.mapFilter(modules.fun.of(players), keep)(sortedKeys);
}
function enter(key, obj) {
@ -64,7 +61,7 @@ function Room(modules) {
var alone = obj.alone != undefined ? obj.alone : true;
var player = new Player(key, name, alone);
players[key] = player;
player.position = modules.sort.insert(key, sortedKeys, compareKeysByLogin);
player.position = modules.fun.insert(key, sortedKeys, compareKeysByLogin);
sortedKeys.splice(player.position, 0, key);
}

7
www/screen.css Normal file
View File

@ -0,0 +1,7 @@
body > div {
display: none;
}
body > div.on {
display: block;
}