diff --git a/src/Automaton.hs b/src/Automaton.hs index 7ae441e..88df18b 100644 --- a/src/Automaton.hs +++ b/src/Automaton.hs @@ -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 diff --git a/src/Game.hs b/src/Game.hs index 228b8c3..53b84f9 100644 --- a/src/Game.hs +++ b/src/Game.hs @@ -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 diff --git a/src/Message.hs b/src/Message.hs index fef62e1..714e26e 100644 --- a/src/Message.hs +++ b/src/Message.hs @@ -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) diff --git a/src/Server.hs b/src/Server.hs index 141b445..d389789 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -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) diff --git a/src/Session.hs b/src/Session.hs index 2195db9..37bc615 100644 --- a/src/Session.hs +++ b/src/Session.hs @@ -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 diff --git a/www/sort.js b/www/fun.js similarity index 58% rename from www/sort.js rename to www/fun.js index 6706aae..4ae0b7f 100644 --- a/www/sort.js +++ b/www/fun.js @@ -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; + } } diff --git a/www/game.css b/www/game.css new file mode 100644 index 0000000..fea1bed --- /dev/null +++ b/www/game.css @@ -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; +} diff --git a/www/game.js b/www/game.js new file mode 100644 index 0000000..68017e7 --- /dev/null +++ b/www/game.js @@ -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}}) + } + } + +} diff --git a/www/hanafuda.js b/www/hanafuda.js new file mode 100644 index 0000000..484250f --- /dev/null +++ b/www/hanafuda.js @@ -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" +*/ +} diff --git a/www/index.html b/www/index.html index e5c11b3..ffe6aa5 100644 --- a/www/index.html +++ b/www/index.html @@ -3,15 +3,18 @@ KoiKoi - + + - + + +
diff --git a/www/skin.css b/www/login.css similarity index 88% rename from www/skin.css rename to www/login.css index d716338..9c43de9 100644 --- a/www/skin.css +++ b/www/login.css @@ -1,11 +1,3 @@ -body > div { - display: none; -} - -body > div.on { - display: block; -} - #join, #invite { display: none; } diff --git a/www/main.js b/www/main.js index 5645660..424dd0a 100644 --- a/www/main.js +++ b/www/main.js @@ -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(); }); diff --git a/www/room.js b/www/room.js index 6dc74fa..250d996 100644 --- a/www/room.js +++ b/www/room.js @@ -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); } diff --git a/www/screen.css b/www/screen.css new file mode 100644 index 0000000..68535fc --- /dev/null +++ b/www/screen.css @@ -0,0 +1,7 @@ +body > div { + display: none; +} + +body > div.on { + display: block; +}