Interactive code snippets not yet available for SoH 2.0, see our Status of of School of Haskell 2.0 blog post

Websockets Reactive Game of Score

UPDATE: The Haskell websockets server is still the same, but for the front ends of applications, I no longer use React. The front end technology that works best for me is cycle.js along with the monads demonstrated at http://schalk.net:3035.

The Haskell Websockets version of the Game of Score is running on a Digital Ocean 'droplet', accessable from Game of Score. It is not very user friendly and the underlying code front end code is a mess. I crammed a lot of functionality into React.

The new interactive demonstration is running online at JS-monads-stable. The code is at Repository. The back end is a modified Wai Websockets server. I am very pleased with it and don't forsee ever going back to Node.js.

This tutorial and the more recent one running at http://schalk.net:3055 show how readily Wai Websockets can serve as a backend to a fairly complex web application. It has performed flawlessly and been easy to modify and maintain.

Before I go any further, I want to share some information about running my Haskell applications online. I found a simple way to upload compiled Haskell files to a host that does not have GHC, Cabal, Stack or any such thing installed, and see the applications running online. Before I came accross Digital Solutions, my Google searches found cases of people doing all sorts of intricate, convoluted things to deploy Haskell applications. AWS hosting worked, but I didn't have the freedom I now enjoy and I didn't like working in the midst of their complex environment. Now, I ssh or ftp into my Ubuntu 14.04 "droplet" hosted by Digital Ocean and do whatever I want. Lots of advice is available in case I want to tighten security. Encripted websockes messages are a good idea. AWS forces you to encrypt. Digital Ocean does nothing more than unobrusively recommend that you encript websockets messages, and provides information about how to do it.

When I have a new application, I assign it a port number, say 3055, in Main.hs. Then I ssh into my droplet, create a directory, and put a file in /etc/init such as:

start on startup
chdir /home/u/domains/js-monads-stable
start on runlevel [2345]
exec /home/u/domains/js-monads-stable/server

If I an updating an existing application or starting it for the first time, I use Filezilla to upload the binary created by "stack build", then I ssh into the droplet to run "chmod +x server" on the uploaded binary. Finally, I run "sudo initctl restart js-monads-stable" or "sudo reboot 0". All done. I go to schalk.net:3055 in a browser to verify that my application is updated.

You can try Digital Ocean free of charge by using this link Digital Ocean. I might get a credit at Digital Ocean if you subscribe, but that is not why I am suggesting this. The last time I checked, there were no free trial offers at Digital Ocean and using a link such as the one aboved appeared to be the only way to try Digital Ocean for free.

As mentioned above, the server is a modified Wai Websockets server. Specifically, is a modification of the code used in the Wai-Websockets Example, which is written in literate Haskell. I use TMVar instead of a plain MVar; I don't use literate Haskell; and, of course, I added some application-specific code. The state list is defined as follows:

type Name = Text
type Score = Int
type Group = Text
type Client = (Name, Score, Group, WS.Connection)
type ServerState = [Client]

It is instantiated in main with:

newServerState :: ServerState
newServerState = []

main :: IO ()
main = do
    state <- atomically $ newTMVar newServerState
    . . .

This is identical to the ServerState used in JS-monads-stable, only JS-monads-stable Client has one more parameter. Explanations and demonstrations can be found at JS-monads-stable and Repository.

The following sections probably provide more information than you want, but for what they are worth, here are several glimpses at various features of the Game of Score application. Some familiarity with React might make parts of the front-end code more comprehensible. I don't adhere to recommended React best practice. I recommend Cycle.js. I you just want to see the Haskell part of this presentation, just skim the front-end discussion to get an idea of what the server is doing.

Requiring players to use the result of a prior computation.

In the game of Score, players roll four dice and try to make the number '20' in two or three stages using addition, subtraction, multiplication, division, and concatenation. This is a cumulative process, always using the results of prior computations. After the first computation, two of the original die remain along with the result of the computation. Now say the roll was [4,5,3,9] and the first computation was 3 + 8 = 11. The choices for the next computation are now [4,5,11]. I made the result of the first computation red and displayed a message saying the player must use the red number in order to score a point in the current round. I needed to make sure that computing 4 * 5 = 20 would not increase the player's score. A player would have to use '12' in order to score a point in this round.The player could, however, run 4 + 5 = 9, yielding [11,9], and then 11 + 9 = 20, scoring one point.

In order to assure use of a prior result, I created a state element named 'test' with an initial vlue of 'false' along with an element named 'resPrevious' to hold the result of each computation. The two numbers selected in the second round are placed in an array which is tested for the presence of 'resPrevious'. The Boolean result is assigned to 'test'. After the first computation, the code shown two code snippets down from here is run.

DES_ws sends four messages to the server. 'gr' is the player's group, which ultimately decides which players see a scoreboard update. The if statement tests for a result of '20' (or a player-defined goal; '20' is the default); test === true, meaning the prior result was used; and 'score', which tests whether the player clicked score to start a ten-second countdown.

The value of 'test' is set in 'calc()', the calculation function, with the following code:

    let resP = this.state.resPrevious;
    let ar5 = [mes0,mes2];
    let test = (resP === mes0 || resP === mes2);

'mes0' and 'mes2' are the currently selected numbers. They arrive at 'calc()' as arguments.

calc() calls a function named 'comp' with five arguments. Setting state with setState during number selection requires the use of callbacks to make sure values are timely updated. If, for example, I were to select the number held in message1 and just call 'setState({message1: ''}), when I got to comp(), this.state.message1 would still have its old value. Here is the code for selecting the left-most number:

  handleB40 = () => {
    let name = this.state.name;
    let group = this.state.group;
    let num = this.state.message1;
    if (this.state.mes0 === 'Number') {
      this.setState({message1: '', mes0: num}, function() {
        DES_ws.send(`CQ#$42,${group},${name},${num}`);
      })
    }
    else if (this.state.mes2 === 'Number') {
      this.setState({message1: '', mes2: num}, function() {
        DES_ws.send(`DQ#$42,${group},${name},${num}`);
        if (this2.state.mes1 !== 'Operator') {
          this.calc(this2.state.mes0, this.state.mes1, num);
        }
      })
    }
  }

If a number and operator have already been selected, handleB40 calls calc():

  calc (mes0,mes1,mes2) { 
    let that = this;
    let res = 0;
    let delay = this.delay;
    let n = this.state.N;
    let resP = this.props.resPrevious;
    let ar5 = [mes0,mes2];
    let test = (resP === mes0 || resP === mes2);
    switch (mes1) {
      case "+": that.comp( parseFloat(mes0) + parseFloat(mes2),mes0,mes1,mes2,test );
      break;
      case "-": that.comp( parseFloat(mes0) - parseFloat(mes2),mes0,mes1,mes2,test );
      break;
      case "*": that.comp( parseFloat(mes0) * parseFloat(mes2),mes0,mes1,mes2,test );;
      break;
      case "/": that.comp( parseFloat(mes0) / parseFloat(mes2),mes0,mes1,mes2,test );
      break;t
      case "Concat": that.comp( parseFloat(mes0+""+mes2),mes0,mes1,mes2,test );
      break;
      default : 'operator not selected';
    }
  }
  }

calc() calls comp():

  comp (result,mes0,mes1,mes2,test) {
    let str = `${mes0} ${mes1} ${mes2} = ${result}`;
    this.props.resPrevious = result.toString();
    let w1 = this.state.message1;
    let w2 = this.state.message2;
    let w3 = this.state.message3;
    let w4 = this.state.message4;
    let startArray = [w1, w2, w3, w4, result];
    this.newNums(result,str,test,startArray);
  }
  ```
  And comp() calls newNums():

```js
  newNums = (result,str,test,numbers) => {
newNums (result,str,test,numbers) {
    let j = 0;
    let gr = this.state.group;
    let ar = [];
    let clock = '';
    let name = this.state.name;
    let impossibleClicker = this.state.impossibleClicker;
    let interruptClicker = this.state.interruptClicker;
    let interrupt = this.state.interrupt;
    let test2 = this.state.score || this.state.impossible;
    let goal = 1*(this.state.goal); // '1*' and '==' is technically overkill, but seems like insurance.

    for (let k in numbers) {
        if (numbers[k] !== "" && numbers[k] !== undefined) {
        ar[j] = numbers[k];
        j += 1;
      }
    }
    if (j === 3) {
      DES_ws.send(`FQ#$42,${gr},${name},${str}`);
      DES_ws.send(`CE#$42,${gr},${name},${ar[0]},${ar[1]},${ar[2]},`);
      this.setState({message: 'You must use the number with the yellow background in order to score in this round.'});
      this.mouse[2] = 'yellow';
      if (test2) {
        DES_ws.send( `CK#$42,${gr},${name},10` );
      }
      else {
        DES_ws.send( `CK#$42,${gr},${name},Did not click SCORE!` );
      }
    }
    else if (j === 2) {
      this.setState({message: ''});
      DES_ws.send(`GQ#$42,${gr},${name},${str}`);
      DES_ws.send(`CE#$42,${gr},${name},${ar[0]},${ar[1]},,`);
      if ( (result == goal) && test && test2 && !interrupt ) {
          this.setState({DS_T: -1});
          DES_ws.send( `CK#$42,${gr},${name},One point for ${name}` );
          DES_ws.send( `CR#$42,${gr},${name},${name}` );
          DES_ws.send( `CG#$42,${gr},${name},1` );
      }
      else if ( (result == goal) && test && test2 && interrupt ) {
        this.setState({DS_T: -1});
        DES_ws.send( `CK#$42,${gr},${name},One point for ${name}. Two points deducted from ${impossibleClicker}`);
        DES_ws.send( `CR#$42,${gr},${name},${name}` );
        DES_ws.send( `CG#$42,${gr},${name},1` );
        DES_ws.send( `CG#$42,${gr},${impossibleClicker},-2` );
      }
      else if (test2) {
        DES_ws.send( `CK#$42,${gr},${name},10` );
      }
      else {
        DES_ws.send( `CK#$42,${gr},${name},Did not click SCORE!` );
      }
    }
    else if (j === 1) {
      if (result === goal) {
        if (test2) {
          if (interrupt) {
            this.setState({DS_T: -1});
            DES_ws.send( `CK#$42,${gr},${name},One point for ${name}. Two points deducted from ${impossibleClicker}`);
            DES_ws.send( `CR#$42,${gr},${name},${name}` );
            DES_ws.send( `CG#$42,${gr},${name},1` );
            DES_ws.send( `CG#$42,${gr},${impossibleClicker},-2` );
          }
          else if (!interrupt) {
            DES_ws.send( `CK#$42,${gr},${name},One point for ${name}` );
            DES_ws.send( `CR#$42,${gr},${name},${name}` );
            DES_ws.send( `CG#$42,${gr},${name},1` );
          }
        }
      }

      else if ((result !== goal) && test2) {
        if (interrupt && (impossibleClicker !== interruptClicker)) {
            console.log('cow');
            DES_ws.send(`CG#$42,${gr},${impossibleClicker},1`);
            DES_ws.send(`CG#$42,${gr},${interruptClicker},-1`);
            DES_ws.send( `CK#$42,${gr},${name},The result is not 20. ${name} lost one point. One point awarded to ${impossibleClicker}.`);
        }
        else if (interrupt && (impossibleClicker === interruptClicker)) {
              DES_ws.send(`CG#$42,${gr},${impossibleClicker},-1`);
              DES_ws.send(`CH#$42,${gr},${impossibleClicker},${impossibleClicker} forfeits two points for blocking with SCORE!`);
        }
        else if (!interrupt) {
              DES_ws.send(`CG#$42,${gr},${scoreClicker},-1`);
              DES_ws.send(`CH#$42,${gr},${scoreClicker},${scoreClicker} forfeits one point. The result is not ${goal}`);
        }
      }
    }
  }

The for clause toward the top of newNums() does two important things. It configures an array of number for the next round containing the remaining un-used number(s) indexed sequentially from '0', along with the new number; i.e., the result of the prior computation. newNums() also determines the integer 'j', which gets smaller on each succeeding round. 'j' is the number of items in the array. Each computation uses up two numbers and creates one number (the result). If j == 3, it is too soon for a score; if j == 2 a test makes sure a point is awarded only if the computation used the result of the first; if j == 1, the round is over.

I am using js6 function syntax '= () => {' instead of '() {' in order to eliminate the need to explicitely bind functions to B2. Instead of components and HTML elements in B2's render function having the form 'myFunc = {this.myFunc.bind(this)}', with jsx function syntax it is simply 'myFunc = {this.myFunc}'.

Rule Interlude

If a player clicks IMPOSSIBLE instead of SCORE!, a sixty-second coundown begins. If no other player in the group clicks SCORE! before the time runs out, the player who clicked IMPOSSIBLE gets one point. A one-minute 'hour glass' is used in the table-top version. If a player clickes SCORE! before the 60 seconds expires, that player gets one point and the player who clicked IMPOSSIBLE loses two points, but only if the SCORE! clicker succeeds. If the SCORE! clicker fails to compute 20 (or the player-defined goal), that player loses one point and the player who clicked IMPOSSIBLE gains one point because time ran out with no one registering a solution. The SCORE! button is available to the IMPOSSIBLE clicker, so if during the sixty-second coundown that player sees a solution that seems fairly obvious, clicking SCORE! is a way to make sure two points won't be lost due to an opponent's clicking SCORE! and succeeding. If the IMPOSSIBLE clicker clicks SCORE! and succeeds in computing the goal, one point is gained for the success and two points are lost because a solution was found before 60 seconds expired. The net result is a loss of one point. If the IMPOSSIBLE clicker clickes SCORE! and lets the 10 seconds run out, the rules discussed so far would mean the IMPOSSIBLE clicker gains one point because no solution was found and loses one point for letting the ten seconds run out. The net result would be no gain and no loss. It would be as though the player used the IMPOSSIBLE button to take back the rash clicking of IMPOSSIBLE. The ploy won't work because of the 'no blocking' rule. If the impossible clicker clicks score and does not succeed, the impossible clicker loses two points for preventing other players from clicking SCORE! and succeeding.

Back to the code discussion

A player might have clicked 'SCORE!' before any other player clicked anything, or the player might have clicked 'SCORE!' after someone clicked 'IMPOSSIBLE'. The Boolean state variable 'interrupt' changes from 'false' to 'true' whenever someone clicks 'IMPOSSIBLE' and reverts to 'false' during each new roll of the dice. When a player clicks IMPOSSIBLE, the 'impossibleClicker' variable takes the value of that player's name.

I haven't explained all of newNum()' functionality, or what messages going to the server do. Here's what one category of message does: When the server receives a message prefixed by 'XXXXX', it logs the message in 'log.txt'. The version shown above doesn't have any of these, but it did during the first stages of development. The other prefixes correspond to things such as updating state and broadcasting display informaiton to the browsers. Messages prefixed by 'CG#$42' and ending with 1 or -1 cause the server to update scores in the state list of tuples in the server's TMVar.

Here is how this is accomplished. First, the prefix causes the message data to be grabbed:

  else if "CG#$42" `T.isPrefixOf` msg
        then
            mask_ $ do
                old <- atomically $ takeTMVar state
                let new = changeScore sender extraNum old
                atomically $ putTMVar state new
                let subSt = subState sender group new
                broadcast msg subSt
                broadcast ("CB#$42," `mappend` group `mappend` ","
                    `mappend` sender `mappend` "," `mappend` T.concat (intersperse "<br>" (textState subSt))) subSt

'old' is the ServerState list of tuples removed from the TMVar. 'new' mirrors 'old', only with the change caused by 'changeScore'.

changeS :: Text -> Int -> Client -> Client
changeS x y (a, b, c, d) | x == a    = (a, b+y, c, d)
                         | otherwise = (a, b, c, d)

changeScore :: Text -> Int -> ServerState -> ServerState
changeScore name k = map (changeS name k)

The Int argument can be 1 or -1, depending on what was chosen in 'newNums'. As you see, changeS changes the tuple corresponding to the player named 'x' and leaves the rest unchanged. Currently, it is mapped over the entire ServerState list, but it would be easy to map over only the group to which the player belongs. Here is how the sub-list is isolated:

subState :: Text -> Text -> [(Text,Int,Text,WS.Connection)] -> [(Text,Int,Text,WS.Connection)]
subState name gr state  | gr /= solo  = [ (a,b,c,d) | (a,b,c,d) <- state, gr == c ]
                        | gr == solo = [ (a,b,c,d) | (a,b,c,d) <- state, name == a]

'solo' is the group name for players who have not joined a group. solo players don't get information about other solo players, so name is used to narrow down the result to only one item in the ServerState list. Group members who look at computer generated solutions are temporarily assigned to group 'solo'. When they close the solutions interface they rejoin their old group, keeping the score they had when they left to look at solution.

The information arriving from the server is a comma-separated entity treated as a list of Char, a/k/a String. It gets separated at the commas to a list of type [String] and the item corresponding to the user's Group is converted to Text. It never had type Group, although the list comprehension treats it as the Group element in a ServerState tuple. Haskell's type safety gets diluted through its continual exchange of information with browsers.

I'll have a little more to say about isolating groups in ServerState later. There was a time during development when the browsers had to screen messages. When I turned my attention to having the server send no more messages than necessary, it was pleasant to be coding Haskell again where list comprehensions and pattern matching tell the compiler what is wanted in the simplest possible terms, and the compiler complies with exactly what was requested.

The timer

The timer can be started either by clicking SCORE! or by clicking IMPOSSIBLE. SCORE! starts a ten-second coundown during which the first computation must be completed or a point will be forfeited. Completing the first computation before ten seconds have expired starts another ten-second countdown. If the result of the second computation is the number '20', the player is awarded a point; otherwise, another ten-second countdown begins. If the time expires or the computation doen not result in '20', a point is deducted. Otherwise the result is '20' and the player gains a point.

Clicking Score starts a sixty-second countdown. If the time expires, the player gains one point. If, during the countdown, a player clicks SCORE! and computes the number '20', that player gains a point and the player who clicked IMPOSSIBLE loses two points.

The SCORE! button is in B2's render function. it is defined as follows:

          <button onClick={this.handleScore2}
          style={this.style7(cr19,cr190,scoreDisplay2)}
          onMouseEnter={() => {this.mouse[19] = 'blue'; this.mouse[190]  = '#01afaf' }}
          onMouseLeave={() => {this.mouse[19] = '#000'; this.mouse[190]  = 'darkred' }} >
            SCORE!
          </button>

style7() handles style for several buttons. The first two parameters are 'backgroundColor' and 'borderColor'. The third parameter matches 'display' in style7(). It's values are either 'none' or 'inline'. Player actions make it come and go. Clicking IMPOSSIBLE removes it and substiturs a button that looks just like it for use in iterrupting the 60-second countdown. Here is the click handler:

  handleScore () {
    let name = this.state.name;
    let group = this.state.group;
    DES_ws.send( `CY#$42,${group},${name},${name}` );
  }

The message "CY#$42,${group},${name},${name}" arrives at the server and is broadcast to all members of the sender's group. That is all the server does with it. It determines which sockets correspond to the members of the sender's group and sends the message to each of them. Here is what the browsers do with the message:

  case "CY#$42": // Triggered by clicking "SCORE!".
    that.setState( {
      scoreClicker: extra,
      score: true,
      message: '',
      DS_T: 10,
      impossibleDisplay: 'none',
      solutionsDisplay: 'none',
      timerDisplay: 'inline',
      scoreDisplay: 'none',
      rollDisplay: 'none'
    } )
    if (extra !== name) {      
        that.setState({numDisplay: 'none'}) // Players can see calculations after wait.
        setTimeout ( function() {
          that.setState({solutionsDisplay: 'inline'});
        },8000 )
    }
  break;

If the countdown reaches 0, a message is circulated to all members of the group (through the server) setting the value of DS_T in the following manner:

this.setState({DS\_T: `10 seconds expired. Deduct one point from ${scoreClicker}`});
this.setState({DS\_T: `60 seconds expired. One point for ${impossibleClicker}`});
this.setState( {DS_T: `10 seconds expired. One point awarded to ${that.state.impossibleClicker}
    One point deducted from ${this.state.interruptClicker}`} 

This stops the clock by setting DS_T to a string value. What is sent to the server, and the resulting messages broadcast to other group member, depends on whether the browser belongs to a player who clicked SCORE! to begin a round, a player who clicked IMPOSSIBLE, or a player who clicked SCORE! after IMPOSSIBLE was clicked. In any given round there will be only one player who clicked SCORE! since initially clicking SCORE! causes the IMPOSSIBLE button to disappear preventing the second SCORE! button from appearing. Clicking IMPOSSIBLE causes the first SCORE! button to disappear. Every player in the group has a timer, but only the ones with 'name == scoreClicker' or 'name == impossibleClicker' send messages updating the score board. Clicking SCORE! or IMPOSSIBLE sets the scoreClicker and impossibleClicker variables to the clicker's login name.

As you see below, DS_T > 0 causes the countdown to continue while DS_T == 0 causes a message, or messages, to go out to the server.

  setInterval( () => {
    let name = this.state.name;
    let group = this.state.group;
    let scoreClicker = this.state.scoreClicker;
        let impossibleClicker = this.state.impossibleClicker;
        let interruptClicker = this.state.interruptClicker
        let score = this.state.score;
        let impossible = this.state.impossible;
        let interrupt = this.state.interrupt;

    if ( this.state.DS_T > 0 ) {
      this.setState({
        DS_T: this.state.DS_T - 1,
        timeSize: 40
      });
      this.setState({info: this.state.DS_T});

    }

    if ( this.state.DS_T*1 === 0 ) {
      this.setState ({
            message1: 0,  // Wipes the old numbers.
            message2: 0,
            message3: 0,
            message4: 0,
            info: '',
            timeSize: 20, // Returns number display to normal size.
            rollDisplay: 'inline', // Displays the ROLL button.
            solutionsDisplay: 'inline',
            DS_t: -1
        })
      let z = scoreClicker === name;
        let z2 = impossibleClicker === name;
        let z3 = interruptClicker === name;
      let gr = group;
      if (!interrupt) {
                if (z) {
            DES_ws.send(`CG#$42,${gr},${name},-1`);
          DES_ws.send(`CH#$42,${gr},${name},10 seconds expired. Deduct one point from ${scoreClicker}`);

        }
              else if (z2) {
            DES_ws.send(`CG#$42,${gr},${name},1`);
          DES_ws.send(`CH#$42,${gr},${name},60 seconds expired. One point for ${impossibleClicker}`);

                }
            }
      else if (z3) {
        DES_ws.send(`CG#$42,${gr},${interruptClicker},-1`);
                DES_ws.send(`CH#$42,${group},${interruptClicker},10 seconds expired. One point awarded to ${that.state.impossibleClicker}. One point deducted from ${interruptClicker}.`);

                DES_ws.send(`CG#$42,${gr},${impossibleClicker},1`);
          }
        }
  }, 1000 )
}

That is the gist of how the timer works. Because DS_t is a plain Javascript variable, it has no set type. That makes it convenient to stop the integer countdown by assigning a string value to DS_t. The counter can't use a string, but it doesn't complain. It just stops counting.

I won't present any more details here. I think they can be deduced by following the code and besides, most readers are interested in a general overview of how one person (me) used a Haskell Websockets server to create a multiplayer dice game with user-defined competition groups and chat rooms.

More on How the server determines which players are sent broadcast messages.

As previously mentioned, the server's broadcast function doesn't broadcast to every Client in the ServerState list. Instead, it broadcasts to each member of the group to which the sender of a triggering message belongs. So, for example, if the server receives the Message Board message 'CD#$42,GroupA,Fred,Fred: Hello out there.', it parses it just as it parses all incoming messages:

msg <- WS.receiveData conn
let msgArray = splitOn "," (T.unpack msg)
let group = T.pack (msgArray !! 1)
let sender = T.pack (msgArray !! 2)
let extra = T.pack (msgArray !! 3)
let extraNum = read (msgArray !! 3) :: Int
let range = get4 msgArray  -- 7 items in msgArray

It then runs:

do
    st <- atomically $ readTMVar state
    let subSt = subState group st
    broadcast msg subSt

Here is the function 'subState' again:

subState :: Text -> Text -> [(Text,Int,Text,WS.Connection)] -> [(Text,Int,Text,WS.Connection)]
subState name gr state  | gr /= solo  = [ (a,b,c,d) | (a,b,c,d) <- state, gr == c ]
                        | gr == solo = [ (a,b,c,d) | (a,b,c,d) <- state, name == a]

That might not be the most efficient way to get the list of Client tupples belonging to the sender's group, but I think it is wonderfull that, in Haskell, we can simply say what we want and get it without further ado. The function matches every Client in the designated group unless the group is 'solo'. In that case, the unique player with the designated name is the sole member of the substate list.

A player wanting to change groups sends a string prefixed by 'CO#$42', The server deals with it as follows:
else if "CO#$42" `T.isPrefixOf` msg
    then
        mask_ $ do
            old <- atomically $ takeTMVar state
            let new = changeGroup sender extra old
            atomically $ putTMVar state new
            let subState1 = subState sender group new
            let subState2 = subState sender extra new
            let x = "CB#$42," `mappend` group `mappend` "," `mappend` sender `mappend` "," `mappend` T.concat (intersperse "<br>" (textState subState1))
            let y = "CB#$42," `mappend` extra `mappend` "," `mappend` sender `mappend` "," `mappend` T.concat (intersperse "<br>" (textState subState2))
            broadcast y subState2
            if group /= "solo"
               then
               broadcast x subState1
               else
               return ()
'changeGroup()' takes three arguments: 'sender', 'extra', and 'old'. 'extra' is the fourth element of the list produced by parsing the comma-separated string that arrives from the browser. In this case, it is the name of a group. old is the ServerState list before the group membership change. Here is 'changeGroup()':

changeGroup :: Text -> Text -> ServerState -> ServerState changeGroup name group = map (newGroup name group


As you see, it maps 'newGroup' over the ServerState list. Here is newGroup:

newGroup :: Text -> Text -> Client -> Client newGroup name group (a, b, c, d) | name == a = (a, 0, group, d) | otherwise = (a, b, c, d)


Notice that the new group member starts with a score of '0'. The exception to that rule occurs when a player re-joins a group after looking at computer-generated solutions. The code in such cases is:

newGroupKeepScore :: Text -> Text -> Client -> Client newGroupKeepScore name group (a, b, c, d) | name == a = (a, b, group, d) | otherwise = (a, b, c, d)

changeGroupKeepScore :: Text -> Text -> ServerState -> ServerState changeGroupKeepScore name group = map (newGroupKeepScore name group)


The second member of the tupple is 'b', the old score, rather than always being '0'. 'group' in this function is 'solo' when a player displays soloutions and the old group, which is saved in the browser, when the solutions are hidden. After hiding the solutions, a player must wait until the next round to resume competition.

Finally, here is the broadcast function, just as it first appeared in the Haskell Websockets library:

broadcast :: Text -> ServerState -> IO () broadcast message clients = do T.putStrLn message forM clients $ ( , , , conn) -> WS.sendTextData conn message

##The Front End



## APPENDIX
### IMPOSSIBLES
The essence of the Score calculation algorythm in the module Fm is contained in the "impossibles.hs" file. Fm has much formatting code, which is a distraction when evaluating the algorythm.

impossibles.hs computes all dice combinations which cannot be made into the number "20" in two or three stages, as required by the game. In 1.5 seconds, it finds all 104 such combinations using a list comprehension on the seven list comprehensions which cover all possible computations. The five operations are defined as follows:

```haskell
{-# LANGUAGE OverloadedStrings #-}

import Data.List
import System.CPUTime

notWhole :: Double -> Bool
notWhole x = fromIntegral (round x) /= x

cat :: Double -> Double -> Double
cat l m  | (whole l) && (whole m) && m >= 0 && l /= 0  = read ((show $ fRound l) ++ (show $ fRound m))
         | otherwise = 8.888

f :: Double -> String
f x = show (round x)

ops =  [cat, (+), (-), (*), (/)]

The seven algorithms necessary to perform every possible computation are:

calc :: Double -> Double -> Double -> Double -> [(Double, Double, Double, Double)]
calc a b c d = [ (a',b',c',d') |
                        [a',b',c',d'] <- nub(permutations [a,b,c,d]),
                            op1 <- ops,
                            op2 <- ops,
                            op2 (op1 a' b') c' == 20]

calc2 :: Double -> Double -> Double -> Double -> [(Double, Double, Double, Double)]
calc2 a b c d = [ (a',b',c',d') |
                        [a',b',c',d'] <- nub(permutations [a,b,c,d]),
                            op1 <- ops,
                            op2 <- ops,
                            op2 a' (op1 b' c') == 20]

calc3 :: Double -> Double -> Double -> Double -> [(Double, Double, Double, Double)]
calc3 a b c d = [ (a',b',c',d') |
                        [a',b',c',d'] <- nub(permutations [a,b,c,d]),
                            op1 <- ops,
                            op2 <- ops,
                            op3 <- ops,
                            op3 (op1 a' b') (op2 c' d') == 20]

calc4 :: Double -> Double -> Double -> Double -> [(Double, Double, Double, Double)]
calc4 a b c d = [ (a',b',c',d')  |
                        [a',b',c',d'] <- nub(permutations [a,b,c,d]),
                            op1 <- ops,
                            op2 <- ops,
                            op3 <- ops,
                            op3 (op2 (op1 a' b') c') d' == 20]

calc5 a b c d = [ (a',b',c',d') |
                        [a',b',c',d'] <- nub(permutations [a,b,c,d]),
                            op1 <- ops,
                            op2 <- ops,
                            op3 <- ops,
                            op3 (op2 a' (op1 b' c')) d' == 20]

calc6 a b c d = [ (a',b',c',d') |
                        [a',b',c',d'] <- nub(permutations [a,b,c,d]),
                            op1 <- ops,
                            op2 <- ops,
                            op3 <- ops,
                            op3 a' (op2 (op1 b' c') d') == 20]

calc7 a b c d = [ (a',b',c',d') |
                        [a',b',c',d'] <- nub(permutations [a,b,c,d]),
                            op1 <- ops,
                            op2 <- ops,
                            op3 <- ops,
                            op3 a' (op2 b' (op1 c' d')) == 20]

It is easy to see that there are seven ways to order two or three sequential computations on four numbers. They can be represented by

a bc
ab c
ab cd
(a bc)d
(ab c)d
a(b cd)
a(bc d)

Those are the combinations used in the seven calc functions. The list comprehension works on all permutations of the order of the four numbers in receives, so c ba is covered by a bc. Next, I wanted to find out if all seven algorithms are necessary to find at least one solution, so I wrote this:

{-# LANGUAGE OverloadedStrings #-}

import Data.List
import System.CPUTime

notWhole :: Double -> Bool
notWhole x = fromIntegral (round x) /= x

cat :: Double -> Double -> Double
cat l m  | (whole l) && (whole m) && m >= 0 && l /= 0  = read ((show $ fRound l) ++ (show $ fRound m))
         | otherwise = 8.888

f :: Double -> String
f x = show (round x)

ops =  [cat, (+), (-), (*), (/)]

calc :: Double -> Double -> Double -> Double -> [(Double, Double, Double, Double)]
calc a b c d = [ (a',b',c',d') |
                        [a',b',c',d'] <- nub(permutations [a,b,c,d]),
                            op1 <- ops,
                            op2 <- ops,
                            op2 (op1 a' b') c' == 20]

calc2 :: Double -> Double -> Double -> Double -> [(Double, Double, Double, Double)]
calc2 a b c d = [ (a',b',c',d') |
                        [a',b',c',d'] <- nub(permutations [a,b,c,d]),
                            op1 <- ops,
                            op2 <- ops,
                            op2 a' (op1 b' c') == 20]

calc3 :: Double -> Double -> Double -> Double -> [(Double, Double, Double, Double)]
calc3 a b c d = [ (a',b',c',d') |
                        [a',b',c',d'] <- nub(permutations [a,b,c,d]),
                            op1 <- ops,
                            op2 <- ops,
                            op3 <- ops,
                            op3 (op1 a' b') (op2 c' d') == 20]

calc4 :: Double -> Double -> Double -> Double -> [(Double, Double, Double, Double)]
calc4 a b c d = [ (a',b',c',d')  |
                        [a',b',c',d'] <- nub(permutations [a,b,c,d]),
                            op1 <- ops,
                            op2 <- ops,
                            op3 <- ops,
                            op3 (op2 (op1 a' b') c') d' == 20]

calc5 a b c d = [ (a',b',c',d') |
                        [a',b',c',d'] <- nub(permutations [a,b,c,d]),
                            op1 <- ops,
                            op2 <- ops,
                            op3 <- ops,
                            op3 (op2 a' (op1 b' c')) d' == 20]

calc6 a b c d = [ (a',b',c',d') |
                        [a',b',c',d'] <- nub(permutations [a,b,c,d]),
                            op1 <- ops,
                            op2 <- ops,
                            op3 <- ops,
                            op3 a' (op2 (op1 b' c') d') == 20]

calc7 a b c d = [ (a',b',c',d') |
                        [a',b',c',d'] <- nub(permutations [a,b,c,d]),
                            op1 <- ops,
                            op2 <- ops,
                            op3 <- ops,
                            op3 a' (op2 b' (op1 c' d')) == 20]



only_calc = [ [a, b, c, d] | a <- [1..6], b <- [1..6], c <- [1..12], d <- [1..20],
                     a <= b, b <= c, c <= d,
                     not (null $ calc a b c d), null $ calc2 a b c d, null $ calc3 a b c d,
                     null $ calc4 a b c d, null $ calc5 a b c d, null $ calc6 a b c d,
                     null $ calc7 a b c d ]


only_calc2 = [ [a, b, c, d] | a <- [1..6], b <- [1..6], c <- [1..12], d <- [1..20],
                     a <= b, b <= c, c <= d,
                     null $ calc a b c d, not (null $ calc2 a b c d), null $ calc3 a b c d,
                     null $ calc4 a b c d, null $ calc5 a b c d, null $ calc6 a b c d,
                     null $ calc7 a b c d ]

only_calc3 = [ [a, b, c, d] | a <- [1..6], b <- [1..6], c <- [1..12], d <- [1..20],
                     a <= b, b <= c, c <= d,
                     null $ calc a b c d, null $ calc2 a b c d, not (null $ calc3 a b c d),
                     null $ calc4 a b c d, null $ calc5 a b c d, null $ calc6 a b c d,
                     null $ calc7 a b c d ]

only_calc4 = [ [a, b, c, d] | a <- [1..6], b <- [1..6], c <- [1..12], d <- [1..20],
                     a <= b, b <= c, c <= d,
                     null $ calc a b c d, null $ calc2 a b c d, null $ calc3 a b c d,
                     not (null $ calc4 a b c d), null $ calc5 a b c d, null $ calc6 a b c d,
                     null $ calc7 a b c d ]

only_calc5 = [ [a, b, c, d] | a <- [1..6], b <- [1..6], c <- [1..12], d <- [1..20],
                     a <= b, b <= c, c <= d,
                     null $ calc a b c d, null $ calc2 a b c d, null $ calc3 a b c d,
                     null $ calc4 a b c d, not (null $ calc5 a b c d), null $ calc6 a b c d,
                     null $ calc7 a b c d ]

only_calc6 = [ [a, b, c, d] | a <- [1..6], b <- [1..6], c <- [1..12], d <- [1..20],
                     a <= b, b <= c, c <= d,
                     null $ calc a b c d, null $ calc2 a b c d, null $ calc3 a b c d,
                     null $ calc4 a b c d, null $ calc5 a b c d, not (null $ calc6 a b c d),
                     null $ calc7 a b c d ]

only_calc7 = [ [a, b, c, d] | a <- [1..6], b <- [1..6], c <- [1..12], d <- [1..20],
                     a <= b, b <= c, c <= d,
                     null $ calc a b c d, null $ calc2 a b c d, null $ calc3 a b c d,
                     null $ calc4 a b c d, null $ calc5 a b c d, null $ calc6 a b c d,
                     not (null $ calc7 a b c d )]

main = do
    print "*****************************___only_calc"
    t1 <- getCPUTime
    mapM_ print only_calc
    print " "

    print "*****************************___only_calc2"
    mapM_ print only_calc2
    print " "

    print "*****************************___only_calc3"
    mapM_ print only_calc3
    print " "

    print "*****************************___only_calc4"
    mapM_ print only_calc4
    print " "

    print "*****************************___only_calc5"
    mapM_ print only_calc5
    print " "

    print "*****************************___only_calc6"
    mapM_ print only_calc6
    print " "

    print "*****************************___only_calc7"
    mapM_ print only_calc7
    t2 <- getCPUTime
    let t = fromIntegral (t2-t1) * 1e-12
    print t
    print " "

Here is what I got:

e@e:~/b0$ ./analysis_A
"*****************************___only_calc"
[1.0,3.0,11.0,15.0]
[1.0,3.0,11.0,19.0]
[1.0,6.0,9.0,20.0]
[1.0,6.0,10.0,20.0]
[1.0,6.0,11.0,20.0]
[2.0,2.0,11.0,15.0]
[2.0,2.0,11.0,17.0]
[3.0,3.0,3.0,13.0]
[3.0,3.0,7.0,17.0]
[3.0,4.0,9.0,16.0]
[3.0,4.0,11.0,14.0]
[4.0,4.0,6.0,17.0]
[5.0,5.0,5.0,11.0]
[5.0,5.0,5.0,13.0]
[5.0,5.0,5.0,17.0]
" "
"*****************************___only_calc2"
" "
"*****************************___only_calc3"
[1.0,1.0,1.0,11.0]
[1.0,1.0,7.0,17.0]
[1.0,1.0,12.0,12.0]
[1.0,6.0,6.0,6.0]
[1.0,6.0,9.0,9.0]
[3.0,3.0,6.0,6.0]
[3.0,4.0,7.0,18.0]
[3.0,6.0,7.0,14.0]
[5.0,5.0,6.0,17.0]
[5.0,6.0,6.0,6.0]
" "
"*****************************___only_calc4"
[1.0,1.0,4.0,11.0]
[1.0,4.0,9.0,9.0]
[1.0,4.0,9.0,19.0]
[1.0,5.0,11.0,11.0]
[1.0,6.0,6.0,12.0]
[1.0,6.0,11.0,11.0]
[3.0,6.0,9.0,12.0]
[6.0,6.0,7.0,18.0]
[6.0,6.0,9.0,14.0]
" "
"*****************************___only_calc5"
[1.0,3.0,8.0,20.0]
[3.0,3.0,10.0,17.0]
[3.0,4.0,10.0,16.0]
" "
"*****************************___only_calc6"
" "
"*****************************___only_calc7"
8.27113
" "

This shows that there is no solution that only calc2, only calc6, or only calc7 can find. Next, I checked all combinations of these three:

{-# LANGUAGE OverloadedStrings #-}

import Data.List
import System.CPUTime

notWhole :: Double -> Bool
notWhole x = fromIntegral (round x) /= x

cat :: Double -> Double -> Double
cat l m  | (whole l) && (whole m) && m >= 0 && l /= 0  = read ((show $ fRound l) ++ (show $ fRound m))
         | otherwise = 8.888

f :: Double -> String
f x = show (round x)

ops =  [cat, (+), (-), (*), (/)]

calc :: Double -> Double -> Double -> Double -> [(Double, Double, Double, Double)]
calc a b c d = [ (a',b',c',d') |
                        [a',b',c',d'] <- nub(permutations [a,b,c,d]),
                            op1 <- ops,
                            op2 <- ops,
                            op2 (op1 a' b') c' == 20]

calc2 :: Double -> Double -> Double -> Double -> [(Double, Double, Double, Double)]
calc2 a b c d = [ (a',b',c',d') |
                        [a',b',c',d'] <- nub(permutations [a,b,c,d]),
                            op1 <- ops,
                            op2 <- ops,
                            op2 a' (op1 b' c') == 20]

calc3 :: Double -> Double -> Double -> Double -> [(Double, Double, Double, Double)]
calc3 a b c d = [ (a',b',c',d') |
                        [a',b',c',d'] <- nub(permutations [a,b,c,d]),
                            op1 <- ops,
                            op2 <- ops,
                            op3 <- ops,
                            op3 (op1 a' b') (op2 c' d') == 20]

calc4 :: Double -> Double -> Double -> Double -> [(Double, Double, Double, Double)]
calc4 a b c d = [ (a',b',c',d')  |
                        [a',b',c',d'] <- nub(permutations [a,b,c,d]),
                            op1 <- ops,
                            op2 <- ops,
                            op3 <- ops,
                            op3 (op2 (op1 a' b') c') d' == 20]

calc5 a b c d = [ (a',b',c',d') |
                        [a',b',c',d'] <- nub(permutations [a,b,c,d]),
                            op1 <- ops,
                            op2 <- ops,
                            op3 <- ops,
                            op3 (op2 a' (op1 b' c')) d' == 20]

calc6 a b c d = [ (a',b',c',d') |
                        [a',b',c',d'] <- nub(permutations [a,b,c,d]),
                            op1 <- ops,
                            op2 <- ops,
                            op3 <- ops,
                            op3 a' (op2 (op1 b' c') d') == 20]

calc7 a b c d = [ (a',b',c',d') |
                        [a',b',c',d'] <- nub(permutations [a,b,c,d]),
                            op1 <- ops,
                            op2 <- ops,
                            op3 <- ops,
                            op3 a' (op2 b' (op1 c' d')) == 20]


only_calc2_or_6 = [ [a, b, c, d] | a <- [1..6], b <- [1..6], c <- [1..12], d <- [1..20],
                     a <= b, b <= c, c <= d,
                     null $ calc a b c d, not (null $ calc2 a b c d), null $ calc3 a b c d,
                     null $ calc4 a b c d, null $ calc5 a b c d, not (null $ calc6 a b c d),
                     null $ calc7 a b c d ]

only_calc2_or_7 = [ [a, b, c, d] | a <- [1..6], b <- [1..6], c <- [1..12], d <- [1..20],
                     a <= b, b <= c, c <= d,
                     null $ calc a b c d, not (null $ calc2 a b c d), null $ calc3 a b c d,
                     null $ calc4 a b c d, null $ calc5 a b c d, null $ calc6 a b c d,
                     not (null $ calc7 a b c d) ]

only_calc6_or_7 = [ [a, b, c, d] | a <- [1..6], b <- [1..6], c <- [1..12], d <- [1..20],
                     a <= b, b <= c, c <= d,
                     null $ calc a b c d, null $ calc2 a b c d, null $ calc3 a b c d,
                     null $ calc4 a b c d, null $ calc5 a b c d, not (null $ calc6 a b c d),
                     not (null $ calc7 a b c d )]


only_calc2_or_6_or_7 = [ [a, b, c, d] | a <- [1..6], b <- [1..6], c <- [1..12], d <- [1..20],
                     a <= b, b <= c, c <= d,
                     null $ calc a b c d, not (null $ calc2 a b c d), null $ calc3 a b c d,
                     null $ calc4 a b c d, null $ calc5 a b c d, not (null $ calc6 a b c d),
                     not (null $ calc7 a b c d )]

main = do
    print "*****************************___only_calc2_or_6"
    t1 <- getCPUTime
    mapM_ print only_calc2_or_6
    print " "

    print "*****************************___only_calc2_or_7"
    mapM_ print only_calc2_or_7
    print " "

    print "*****************************___only_calc6_or_7"
    mapM_ print only_calc6_or_7
    print " "

    print "*****************************___only_calc2_or_6_or_7"
    mapM_ print only_calc2_or_6_or_7
    t2 <- getCPUTime
    let t = fromIntegral (t2-t1) * 1e-12
    print t

And here is what I got:

    e@e:~/b0$ ./analysis_B
"*****************************___only_calc2_or_6"
" "
"*****************************___only_calc2_or_7"
" "
"*****************************___only_calc6_or_7"
" "
"*****************************___only_calc2_or_6_or_7"
[2.0,5.0,12.0,12.0]
3.385727

There are no rolls of the dice that can be found only by some pair of these functions, and (2,5,12,12) is the only roll that can be found by all three, but none of the other algorithms (calc, calc3, calc4, and calc5). Those four along with any one of calc2, calc6, or calc7, are sufficient to find at least one solution if a roll is solvable. A corollary is that if calc, calc2, calc3, calc4, and calc5 can't find a solution, calc6 and calc7 won't either. I tested this by removing calc6 and calc7 from impossibles.hs and renaming it impossibles2.hs. Like impossibles.hs, it found the 104 impossible rolls, only in 1.33 instead of 1.50 seconds. The module Fm uses the seven algorithms to find solutions to random rolls or numbers entered by Score players. It massages the output into a single line of Text with solutions separated by "br" in <> brackets. The browsers receive the Text as a Javascript string which, when appended to a div, displays the solutions neatly in a column.

All 104 Impossible Rolls

Here is the code for impossibles2.hs:

{-# LANGUAGE OverloadedStrings #-}

import Data.List
import System.CPUTime

notWhole :: Double -> Bool
notWhole x = fromIntegral (round x) /= x

cat :: Double -> Double -> Double
cat l m  | (whole l) && (whole m) && m >= 0 && l /= 0  = read ((show $ fRound l) ++ (show $ fRound m))
         | otherwise = 8.888

f :: Double -> String
f x = show (round x)

ops :: [Double -> Double -> Double]
ops =  [cat, (+), (-), (*), (/)]

calc :: Double -> Double -> Double -> Double -> [(Double, Double, Double, Double)]
calc a b c d = [ (a',b',c',d') |
                        [a',b',c',d'] <- nub(permutations [a,b,c,d]),
                            op1 <- ops,
                            op2 <- ops,
                            op2 (op1 a' b') c' == 20]

calc2 :: Double -> Double -> Double -> Double -> [(Double, Double, Double, Double)]
calc2 a b c d = [ (a',b',c',d') |
                        [a',b',c',d'] <- nub(permutations [a,b,c,d]),
                            op1 <- ops,
                            op2 <- ops,
                            op2 a' (op1 b' c') == 20]

calc3 :: Double -> Double -> Double -> Double -> [(Double, Double, Double, Double)]
calc3 a b c d = [ (a',b',c',d') |
                        [a',b',c',d'] <- nub(permutations [a,b,c,d]),
                            op1 <- ops,
                            op2 <- ops,
                            op3 <- ops,
                            op3 (op1 a' b') (op2 c' d') == 20]

calc4 :: Double -> Double -> Double -> Double -> [(Double, Double, Double, Double)]
calc4 a b c d = [ (a',b',c',d')  |
                        [a',b',c',d'] <- nub(permutations [a,b,c,d]),
                            op1 <- ops,
                            op2 <- ops,
                            op3 <- ops,
                            op3 (op2 (op1 a' b') c') d' == 20]

calc5 a b c d = [ (a',b',c',d') |
                        [a',b',c',d'] <- nub(permutations [a,b,c,d]),
                            op1 <- ops,
                            op2 <- ops,
                            op3 <- ops,
                            op3 (op2 a' (op1 b' c')) d' == 20]

impossibles = [ [a, b, c, d] | a <- [1..6], b <- [1..6], c <- [1..12], d <- [1..20],
                     a <= b, b <= c, c <= d,
                     null $ calc a b c d, null $ calc2 a b c d, null $ calc3 a b c d,
                     null $ calc4 a b c d, null $ calc5 a b c d ]

main = do
    t1 <- getCPUTime
    mapM_ print impossibles
    t2 <- getCPUTime
    let t = fromIntegral (t2-t1) * 1e-12
    print t