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

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
 

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

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)
 

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)
 

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

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;
+  }
 }

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;
+}

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}})
+    }
+  }
+
+}

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"
+*/
+}

www/index.html

@@ -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">

www/login.css

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

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();
 });

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);
   }
 

www/screen.css

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