Henry Laxen April 24, 2013
Updated November 15, 2013

Background

First I would like to thank Chris Done and Adam Bergmark for their superb job in creating Fay, a way to write Javascript without writing Javascript. I've always disliked Javascript. I'm not sure why, but it is probably because of my Forth heritage. I remember a saying, I think by Bill Ragsdale: "Inside every big program is a small program trying to get out." That, for me, summarizes how I feel about Javascript. But now, thanks to Chris and Adam, I get to program in the best of all possible programming languages, Haskell. (My apologies to Voltaire.)

A couple of years ago, my friend Bonnie asked me to help her solve a Calcudoku puzzle. Rather than sit down and try to figure it out, I decided that since I was a powerful, master of the universe, Haskell programmer, I would just write a solver and short circuit all future questions. So I fired up emacs and went to the Calcudoku/ site, imported TagSoup, and started parsing. Next I wrote a solver, using Control.Monad.Logic, and voila, problem solved. However I didn't like that my solver was intimately tied to one website. I wanted a way to conveniently input a Calcudoku puzzle and get back a result. This meant I would have to write Javascript, and a lot of it. Sorry, no can do. Well, once Fay came along, I thought, why not finally write my inputter. While I was at it, I might as well document it so that it might still mean something to me in a couple of months, and perhaps help you, gentle reader, if you struggle with some the same issues I did.

Design

At this point you may want to take a peek at http://www.nadineloveshenry.com/calcudoku/index and scroll down to where you see the heading Enter the data yourself. There you will see a lonely select list, asking for the Puzzle Size. Once you select a puzzle size, a bunch of other widgets appear, waiting for your input. Obviously there is a lot of ajax going on behind the scenes.

In order to solve a Calcudoku puzzle, we need to know a few things. First the puzzle size. Next the range of values to be used for the puzzle data. Next the type of puzzle, there are three defined at the Calcudoku site, namely single puzzles, double puzzles, and so called killer puzzles. These are global pieces of data that describe the puzzle in general. Next each puzzle consists of regions, and each region has associated with it a value, an operator, and a set of cells. This code is supposed to make the input of this data the least tedious it can be. Once you enter the operator (from a select list) and a value in the text box, you should proceed to click on the cells that comprise the region. While entering the region, you can change the value and the operator, but once the region is finished, these cannot be changed. You can press [Enter] to complete the region, or click on the finish region button. Clicking on a cell while defining a region toggles its membership in the region, so if you accidently added a cell you didn't mean to add, just click on it again and you'll remove it from the region. Once you've finished a region, if you discover an error you can always remove regions in the reverse order in which they were defined by clicking on the discard last region button. Once the last region is finished, the data is sent to the server and the response is received and displayed. That's all there is to it!

Now that we know what we want to do, let's do it. As usual, I'll start at the bottom by first describing the types that we will use.

Shared Types

First a few words about why Fay is really amazing. It's all in the types, dude. The beauty of using Fay is that you can define your Types, use them in your Fay/Javascript client code, and then turn right around and use them in your Snap/Haskell server code. No converting to/from json or sql or strings or whatever. It is all done for you and you don't really have to care. This means you get that angel on your shoulder, the Haskell typechecker, for free. This alone is reason enough to use Fay, but for me the most compelling reason was still, it isn't javascript.

For starters, lets get the declarations and imports out of the way.

«sharedTypes imports»
{-# LANGUAGE CPP                      #-}
{-# LANGUAGE DeriveDataTypeable       #-}
{-# LANGUAGE OverloadedStrings        #-}


module Calcudoku.SharedTypes where

import Data.Text
import Data.Data
#ifdef FAY
instance Read Text
#else
#endif
I define a couple of type synonyms to make things clearer, and then define the Coord type, which is just the row and column of a cell in the puzzle. The first time I wrote this, I just used a tuple for this, but Fay gave me a lot of trouble with that, (when I tried to encode and decode the data, and also with pattern matching) so I decided it was easier to just define a new data type and let emacs query-replace go to work for me.
«sharedTypes Coord»
type Row = Int
type Column = Int
type Value = Int
type Coord = (Row, Column)

cRow :: Coord -> Row
cRow (row,_) = row

cColumn :: Coord -> Column
cColumn (_,col) = col

mkC :: Row -> Column -> Coord
mkC x1 x2 = (x1,x2)
Next are the data types for the operations and the puzzle type. The non commutative operations work as follows. For Minus one of the cells holds the first value and the rest are subtracted from it. Similar for Divide, one if the cells in the Divide region is the dividend, and the rest are the divisors. A Mod region can have two cells, and Id can only be a one cell region. I use Empty internally for a basically non-existant region.

The Subscriber PuzzleType constructor was an afterthought, and is not used in the Fay Client portion of the code. It us used in case the user tries to parse a puzzle from the calcudoku.org website that is for subscibers only.

«sharedTypes Region»
data Operation          = Plus   | Minus  | Times  | Divide | Power
                        | Or     | And    |  Mod   | Id     | Empty
  deriving (Data, Eq, Read, Show, Typeable)

defaultPuzzleType :: PuzzleType
defaultPuzzleType = NullP

data PuzzleType         = Single | Double | Killer | Subscriber | NullP
  deriving (Data, Eq, Read, Show, Typeable)

data Region             = Region {
  regionResult           :: Value,
  regionOperation        :: Operation,
  regionCoords           :: [Coord] }
  deriving (Data, Eq, Read, Show, Typeable)

emptyRegion :: Region
emptyRegion = Region 0 Empty []

Constraints are just lists of Regions, and a Board is a collection of data that totally defines the puzzle. Board is the important Data type that is shared between the client and the server.

«sharedTypes Board»
data Constraints        = Constraints
  { regions             :: [Region] }
  deriving (Data, Eq, Read, Show, Typeable)

data Board              = Board {
  puzzleType            :: PuzzleType,
  puzzleSide            :: Int,
  puzzleElementRange    :: [Int],
  puzzleConstraints     :: [Constraints] }
  -- puzzleConstraints is a list because when we solve a Double PuzzleType
  -- we use flipConstraints to switch the constraints from one board
  -- to another.  Thus head puzzleConstraints is the current list of Regions
  deriving (Data, Eq, Read, Show, Typeable)

defaultBoard :: Board
defaultBoard = Board NullP 0 [] []
After running this for a few months, I realized that editing existing puzzle boards was really a pain in the ..., so I impletment different modes to make editing easier. The original (and only mode) became ModeToggleCell. The ModeRemoveCell allows users to remove cells from any region. The ModeSelectRegion allows users to change regions, and finally ModeChangeValue lets users change the operator and/or value associated with a region.
«sharedTypes PuzzleMode»
data PuzzleMode =
  ModeToggleCell | ModeRemoveCell | ModeSelectRegion |  ModeChangeValue
  deriving (Data, Eq, Read, Show, Typeable)

Another feature I added is to run the solver in a seperate process from the web server. This allows the solver to run longer and not hang up the user. I need to send the data in the Shared data type to the solver process.
«sharedTypes Shared»
data Shared = Shared {
    sharedBoard     :: Board
  , sharedEvents    :: [CEvent]
  , sharedIPAddress :: Text
  , sharedURL       :: Text
  } deriving (Data, Eq, Read, Show, Typeable)

Client Types

There is one more type I need for the client, but I don't need it for the server. One of the nice things anansi does for me is it allows me to define things in a logical order and place, and then move them around into seperate files like Haskell likes. So the following data type actually appears in a file called ClientTypes.hs, even though I define it here along with all of the shared types. Because the Fay client code needs a notion of the current region, I added a simple data type, used throughout the client, that includes a Board and the current region.

After running this for a few days, I started getting emails that the puzzle didn't have a solution. I needed a way for the user to be able to send me the data that he input, so I could take a look at it. That required a new datatype, the CEvent. Each CEvent corresponds to a user's action. By replaying the user input, I can debug anything that goes wrong in the Fay code, as well as make sure the solver is running correctly. So far, all of the errors have been mistakes on the data entry part. This means I need to rethink how to make the data entry simpler and need to figure out a convenient way to edit already entered data.

«clientTypes World»
data W = W {
    board                 :: Board      -- The puzzle board
  , currentRegionIndex    :: Maybe Int  -- If we have a current region
                                        -- this is the index into the
                                        -- puzzleConstraints list
  , editing               :: PuzzleMode -- the current editing mode
  , cevents               :: [CEvent]   -- a list of user generated
                                        -- browser events
    } deriving (Data, Eq, Read, Show, Typeable)

defaultW :: W
defaultW = W (Board NullP 0 [] [Constraints []]) Nothing ModeToggleCell []

type World = Ref W
type UpdateW a = W -> a -> W
«sharedTypes CEvent»
data CEvent =
               P PuzzleType Int [Int]   -- Type Size Range
             | D Int Int                -- Discard region containing x,y
             | L Int Int                -- l on cell x y
             | M PuzzleMode             -- change editing mode
             | R (Maybe Int)            -- change current region
             | V Operation Int          -- change op and value of region
             | N Int Int Operation Int  -- add a new region

  deriving (Data, Eq, Read, Show, Typeable)

Updaters

Well, there aren't instances in Fay, and there aren't even maps, but as every good lisp programmer knows, you don't really need all that fluff as long as you have lists. Another thing lacking from Fay is the State Monad, so one workaround is to pass the state into every function that needs it. That's where the World comes in. The World type is a reference to the W type defined above. References are defined in the JQBindings code above, and allow you to have mutable variables in the Fay monad. All we need now is a COMMON block and it's just like programming in Fortran all over again. ;-)

So a World is a reference to a W, and and UpdateW is a function that updates a subfield of a W.

«updaters typeSynonyms»
type World = Ref W
type UpdateW a = W -> a -> W
I need to represent operations three different ways. One as a haskell data type, two as a string that gets put in the value field of an option html element, and three as the text associated with that value that is displayed to the user. These maps allow me to translate from any one of these representations to another. Painful but necessary.
«updaters operatorMaps»
valueToOperationMap :: [(Text, Operation)]
valueToOperationMap = [
      ("Id" , Id)
    , ("Plus" , Plus)
    , ("Minus" , Minus)
    , ("Times" , Times)
    , ("Divide", Divide)
    , ("Power" , Power)
    , ("Mod" , Mod)
    , ("And" , And)
    , ("Or" , Or)
  ]

showOperationForUser :: Operation -> Text
showOperationForUser = showLookup "No such operation for show"  valueToOperationMap

readOperationForUser :: Text -> Operation
readOperationForUser x = readLookup ("No such operation for read " <> x) valueToOperationMap x


valueToOperationTextMap :: [(Text, Text)]
valueToOperationTextMap = [
      ("", "Select operator for region")
    , ("Id" , "=")
    , ("Plus" , "+")
    , ("Minus" , "-")
    , ("Times" , "×")
    , ("Divide", "÷")
    , ("Power" , "^")
    , ("Mod" , "mod")
    , ("And" , "∧")
    , ("Or" , "∨")
  ]
operationToTextMap :: [(Operation,Text)]
operationToTextMap =
  let
    textOps = 
      Prelude.map (\x -> maybe (tError "Missing op") id
        (lookup x valueToOperationTextMap)) (Prelude.map fst valueToOperationMap)
    opNames = Prelude.map snd valueToOperationMap
    in zip opNames textOps
You'ld think I'ld need the same three representations for the PuzzleType data type, but I thought I'ld implement it differently by having the option elements already populate the html file. Just like Perl, tmtowtdi. I also have explanations associated with each PuzzleType that are displayed to the user and stored as hidden elements in the html page.
«updaters puzzles»
puzzleTypeMap :: [(Text, PuzzleType)]
puzzleTypeMap = [
    ("Single" , Single)
  , ("Double", Double)
  , ("Killer", Killer) ]

reversePuzzleTypeMap :: [(PuzzleType,Text)]
reversePuzzleTypeMap = reverseMap puzzleTypeMap

showPuzzleType :: PuzzleType -> Text
showPuzzleType = showLookup "No such puzzle type for show" puzzleTypeMap

readPuzzleType :: Text -> PuzzleType
readPuzzleType x = readLookup ("No such puzzle type for read " <> x ) puzzleTypeMap x

puzzleModeMap :: [(Text, PuzzleMode)]
puzzleModeMap = [
     ( "ModeToggleCell"   ,  ModeToggleCell )
  ,  ( "ModeRemoveCell"   ,  ModeRemoveCell )
  ,  ( "ModeSelectRegion" ,  ModeSelectRegion )
  ,  ( "ModeChangeValue"  ,  ModeChangeValue) ]


reversePuzzleModeMap ::[(PuzzleMode,Text)]
reversePuzzleModeMap = reverseMap puzzleModeMap

showPuzzleMode :: PuzzleMode -> Text
showPuzzleMode = showLookup "No such puzzle type for show" puzzleModeMap

readPuzzleMode :: Text -> PuzzleMode
readPuzzleMode x = readLookup ("No such puzzle type for read " <> x ) puzzleModeMap x

showCEvent :: CEvent -> Text
showCEvent cev = case cev of
  P x1 x2 x3  -> Data.Text.intercalate underscore
    [ "P" , showPuzzleType x1, showInt x2, showList x3 ]
  L x1 x2     -> showWith2Ints "L" x1 x2
  D x1 x2     -> showWith2Ints "D" x1 x2
  M x1        -> "M_" <> showPuzzleMode x1
  R Nothing   -> "R_Nothing"
  R (Just x1) -> "R_Just_" <> showInt x1
  V x1 x2     -> Data.Text.intercalate underscore
    [ "V" , showOperationForUser x1, showInt x2]
  N x1 x2 x3 x4 -> Data.Text.intercalate underscore
    [ "N", showInt x1, showInt x2, showOperationForUser x3, showInt x4 ]
  where
    showWith2Ints str i1 i2 = Data.Text.intercalate underscore
      [ str , showInt i1, showInt i2]

readCEvent :: Text -> CEvent
readCEvent str =
  let a = split underscore str
  in case Prelude.head a of
      "P" -> P (readPuzzleType (a!!1)) (readInt (a!!2)) (readIntList (a!!3))
      "L" -> L (readInt (a!!1)) (readInt (a!!2))
      "D" -> D (readInt (a!!1)) (readInt (a!!2))
      "M" -> M (readPuzzleMode (a!!1))
      "R" -> R (if (a!!1) == "Nothing" then Nothing else Just (readInt (a!!2)))
      "V" -> V (readOperationForUser (a!!1)) (readInt (a!!2))
      "N" -> N (readInt (a!!1)) (readInt (a!!2)) (readOperationForUser (a!!3)) (readInt (a!!4))
      otherwise -> tError $ "CEvent not recognized in read "  <> otherwise
                                      
explainMap :: [(PuzzleType, Text)]
explainMap = [
      (Single , "#explainCreateRegion")
    , (Double , "#explainCreateRegion")
    , (Killer , "#explainKillerCreateRegion") ]
Here are all the various updaters we need. Makes you appreciate Lenses, which aren't available in Fay.
«updaters code»
updateSide :: UpdateW Int
updateSide w v = w { board = (board w) { puzzleSide = v}}
updatePuzzleType :: UpdateW PuzzleType 
updatePuzzleType w v = w { board = (board w) { puzzleType = v}}
updateElementRange :: UpdateW [Int]
updateElementRange w v = w { board = (board w) { puzzleElementRange = v}}

updateLow :: UpdateW Int
updateLow w v = w { board = (board w)
 { puzzleElementRange = [v .. (Prelude.last . puzzleElementRange . board $ w)]}}
updateHigh :: UpdateW Int
updateHigh w v = w { board = (board w)
 { puzzleElementRange = [(Prelude.head . puzzleElementRange . board $ w) .. v]}}
updateAll w v = w { board = (board w) { puzzleSide = v, puzzleElementRange = [1..v] }}


currentRegion :: W -> Region
currentRegion w =
  maybe (tError "currentRegion is Nothing") thisRegion (currentRegionIndex w)
  where
    thisRegion i = (regions $ currentConstraints w) !! i

currentConstraints :: W -> Constraints
currentConstraints w = if Prelude.null p then tError "currentConstraints is null" else Prelude.head p
  where p = puzzleConstraints . board $ w

currentRegionCoords :: W -> [Coord]
currentRegionCoords w = maybe [] theseCoords (currentRegionIndex w)
  where
    theseCoords _ = regionCoords . currentRegion $ w

updateCurrentRegion :: UpdateW Region
updateCurrentRegion w r =
  let
    b = board w
    allRegions = regions . currentConstraints $ w
    newW = case (currentRegionIndex w) of
      Nothing -> 
        let
          newRegions = r : allRegions
          newC = Constraints newRegions : Prelude.tail (puzzleConstraints b)
          newB = b { puzzleConstraints = newC }
        in w { board = newB, currentRegionIndex = Just 0 }
      Just i ->
        let
          regionIsEmpty = Prelude.null . regionCoords
          (before,after) = splitAt i allRegions
          newRegions = if regionIsEmpty r then before ++ (Prelude.tail after)
                         else before ++ [r] ++ (Prelude.tail after)
          newC = Constraints newRegions : Prelude.tail (puzzleConstraints b)
          newB = b { puzzleConstraints = newC }
          w1 = if regionIsEmpty r then w { currentRegionIndex = Nothing } else w
          w2 = w1 { board = newB }
        in w2
    in newW

isNewRegion :: W -> Bool
isNewRegion w = maybe True (const False) (currentRegionIndex w)

removeEmptyRegions :: W -> W
removeEmptyRegions w =
  let
    b = board w
    allRegions :: W -> [Region]
    allRegions = regions . currentConstraints
    nonEmptyRegions :: W -> [Region]
    nonEmptyRegions = filter hasCells . allRegions
    hasCells :: Region -> Bool
    hasCells  = not . Prelude.null . regionCoords
    newB = b { puzzleConstraints = Constraints (nonEmptyRegions w)
                                   : Prelude.tail (puzzleConstraints b) }
    newW = w { board = newB }
  in newW

Color List

I need to display the different regions in different background colors, so here are the ones that I chose. If we have more regions than that, we wrap around
«shared colorList»
backgroundColorList :: [Text]
backgroundColorList = map pack [
    "DarkCyan"
  , "DarkGoldenRod"
  , "DarkGreen"
  , "DarkKhaki"
  , "DarkMagenta"
  , "DarkOliveGreen"
  , "Darkorange"
  , "DarkOrchid"
  , "DarkRed"
  , "DarkSalmon"
  , "DarkSeaGreen"
  , "DarkSlateBlue"
  , "DarkSlateGray"
  , "DarkTurquoise"
  , "DarkViolet"
  , "DeepPink"
  , "DeepSkyBlue"
  , "FireBrick"
  , "ForestGreen"
  , "HotPink"
  , "IndianRed"
  , "Indigo"
  , "Maroon"
  , "MidnightBlue"
  , "OrangeRed"
  , "Peru"
  , "RoyalBlue"
  , "SlateGray"
  ]

jQuery Bindings

Even though Fay is Haskell, it is not all of Haskell. In particular, I've found that a lot of read and show instances you take for granted in regular Haskell don't work in Fay. The way around it is to write a bunch of functions with specific types so that the underlying JSON.stringify function does the right thing. Most of this code was ripped from the examples that came with Fay, so I won't go into details here. Also the fay-jquery module continues to change, so please look there to see what is going on. I'll just include a few examples of the functions I defined here, and hide the rest from your gaze.
«jqbindings exposed»

showOperation :: Operation -> Text
showOperation = ffi "JSON.stringify(%1)"

readOperation :: Text -> Operation
readOperation = ffi "JSON.parse(%1)"

showCoords :: [Coord] -> Text
showCoords = ffi "JSON.stringify(%1)"

showRegion :: Region -> Text
showRegion = ffi "JSON.stringify(%1)"

showWorld :: W -> Text
showWorld = ffi "JSON.stringify(%1)"

readWorld :: Text -> W
readWorld = ffi "JSON.parse(%1)"

readBoard :: Text -> Board
readBoard = ffi "JSON.parse(%1)"

showEvent :: CEvent -> Text
showEvent = ffi "JSON.stringify(%1)"

readEvent :: Text -> CEvent
readEvent = ffi "JSON.parse(%1)"

showBoard :: Board -> Text
showBoard = ffi "JSON.stringify(%1)"

showShared :: Shared -> Text
showShared = ffi "JSON.stringify(%1)"

windowConfirm :: Text -> Fay Bool
windowConfirm = ffi "window.confirm(%1)"

simpleClone :: JQuery -> Fay JQuery
simpleClone = ffi "%1['clone']()"

jPostBoard :: Text -> Text -> (Text -> Fay ()) -> Fay ()
jPostBoard = ffi "jQuery.ajax(%1, { data: %2, type: 'POST', processData: false, contentType: 'text/json', success: %3 })"

Shared Utils

These are shamelessly copied from Data.List. Since I need them for my Fay code, it thought they might come in hander in the server code too, and there is no reason to not share them.
«shared utils 1»
split :: Char -> String -> [String]
split c str = words' (dropWhile isC str)
  where words' []  = []
        words' s = case break isC s of (a,b) -> a : (split c) b
        isC = (==c)

isPrefixOf              :: (Eq a) => [a] -> [a] -> Bool
isPrefixOf [] _         =  True
isPrefixOf _  []        =  False
isPrefixOf (x:xs) (y:ys)=  x == y && isPrefixOf xs ys

isSuffixOf              :: (Eq a) => [a] -> [a] -> Bool
isSuffixOf x y          =  reverse x `isPrefixOf` reverse y

isInfixOf               :: (Eq a) => [a] -> [a] -> Bool
isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)

tails                   :: [a] -> [[a]]
tails xs                =  xs : case xs of
                                  []      -> []
                                  _ : xs' -> tails xs'

Miscellaneous Utilities

Everybody needs a module where you stick things that don't really belong anywhere else. Welcome to the Utils module. With Fay you often find yourself stringing together a bunch of jquery calls. The & function is just a rebinding of >>= which is more convenient to use.
debug appends a jquery element to my span identified the the #debug id. It makes it easier to dump stuff to chome when I'm not sure what is being passed back and forth.
selectId just selects the DOM element with the specified id. I got tired of always typeing "#".
«utils 1»
debug :: JQuery -> Fay ()
debug x = do
  d <- selectId "debug"
  appendTo d x & hvoid

hvoid :: a -> Fay ()
hvoid _ = return ()
englishInt does very simple grammatical correctness for nouns whose plural end with s.
splitWith takes a Char and a String and splits the string into a list of strings, removing the Char from the list. Just like Perl's split function.
idFromCoord and coordFromId are inverses. They transforms a Coord type into a string suitable for insertion into the DOM as an id.
hvoid is used often to make the types come out right. Generally in Fay you are returning a Fay (), but sometimes your last statement returns a Fay Notvoid, so just append a & hvoid to the function and you're golden.
Void used to exist in the Prelude defined by Fay, but the definition changed and it was easier to do a global replace of void with hvoid instead of rewrite everything.
«utils 2»
idFromCoord :: Coord -> Text
idFromCoord (r,c)  = "T" <> Data.Text.intercalate "_" [showInt r, showInt c]

coordFromId :: Text -> Coord
coordFromId str =
  let
    digitTexts = split "_" (Data.Text.tail str)
    ints = Prelude.map readInt digitTexts
  in ((ints!!0) , (ints!!1))
doubleQuote - I got tired of escaping everything, and solved it with this simple function.
For some reason mapM isn't included (yet) in Fay's Prelude, so here it is.
exposeIds and hideIds are inverses, and just remove or add the hidden class to a list of elements with the given ids.
The three set functions just set the contents of various spans and divs I've defined. Nothing profound.
I tried this out on an ipad, and the keyboard kept popping up, so I need to see if I'm running on a tablet and disable the checkForEnter feature when inputting the squares.
«utils 3»
setError :: Text -> Fay ()
setError msg = do
  statusError <- selectId "statusError"
  case msg of
    "" -> Fay.JQuery.empty statusError & removeClass "error"
    _  -> appendText msg statusError & addClass "error"
  return ()

setExplain :: Text -> Fay ()
setExplain explainId = do
  explain <- selectId explainId & contents & simpleClone
  selectId "instructions" & Fay.JQuery.empty & appendJQuery explain & hvoid

setStatus :: Text -> Text -> Fay ()
setStatus statusId msg = do
  status <- selectId statusId
  setHtml msg status & hvoid

whenTablet :: a -> (a -> Fay ()) -> (a -> Fay ()) -> Fay ()
whenTablet arg trueFun falseFun = do
  agent <- windowUserAgent
  let
    isTablet = "iPhone" `isInfixOf` agent || "iPad" `isInfixOf` agent
  if isTablet then trueFun arg else falseFun arg

-- Monadic fold over the elements of a structure,
-- associating to the left, i.e. from left to right.
foldM :: (a -> b -> Fay a) -> a -> [b] -> Fay a
foldM f z0 xs = foldr f' return xs z0
  where f' x k z = f z x >>= k

The Calcudoku Client

So here is the meat and potatoes of the App. The general idea for a Handler is to update the state of the World based on the Event received, and do whatever Fay actions are necessary. main just waits for the document to be ready, creates a new reference to W, and starts by setting up the size selection widget.

Also I check to see if the query parameter is debug, and if so a couple of addtional text inputs show up on the page at the top. These allow me to input the parsed board or the input log into the textbox and let the server crunch.

«client initialize»
type Handler a = World -> a -> Fay ()
type EventHandler = Handler Event
type CellHandler  = Handler Coord

main :: Fay ()
main =  ready $ newRef defaultW & initialize

initialize :: World -> Fay ()
initialize world =  do
  d <- Calcudoku.CalcudokuClient.isDebug
  let
    sizeRange = if d then [2..15] else [4..15]
  setupSize world sizeRange
  when d $ do
    (exposeIds ["debug"])
    -- set world debugDefaultW
    -- setupPuzzleMode world
    -- setupSize world [1..2]
    -- setupRange world 2
    -- setupPuzzleTable world
    -- exposeIds ["range", "operator", "resultSpan" , "finish", "editingSpan"]

isDebug :: Fay Bool
isDebug = do
  url <- windowUrl
  let
    debug = T.unpack "debug" 
    queryParms = dropWhile (/= '?') (T.unpack url)
    isDebug = not (null queryParms) && debug == (take (length debug) . tail $ queryParms)
  return isDebug
As the COBOL people like to say, numberOfRegionsDefined and numberOfSquaresToGo are self documenting, so I'll just explain what is going on in updateBoard. I wanted to have all singleton entries, ie cells whose operation is id, be the color white, all cells that aren't part of a region, either existing or being formed, be AliceBlue, cells that are part of the region being created be DeepSkyBlue, and the rest, the already existing regions be various different colors as defined by the backgroundColorList. Additionally, the first cell in every region should contain the operation and value for that region.
«client regions»
------------------------------ Regions ------------------------------

numberOfRegionsDefined :: W -> Int
numberOfRegionsDefined = length . regions . currentConstraints

numberOfSquaresToGo :: W -> Int
numberOfSquaresToGo w =
  let
    total = (puzzleSide . board $ w)^2
    alreadyDefined = 
      case  map (length . regionCoords) . regions . currentConstraints $ w of
        [] -> 0
        x -> sum x
  in total - alreadyDefined
This code divides the regions into the different classes I want to represent with a distinct background colors. rs is a list of all the exsiting regions. c is a list of lists of the co-ordinates of these regions. singletons filters c and keeps just the co-ordinates that have only length 1 regions. These correspond to regions that are associated to the = (id) operation. multiples are the list of co-ordinates with more than 1 cell in their regions. unmarked are cells that are not part of an existing finished region. Finally, beingDefined are the co-ordinates of the region currently being defined. Each of these types of cells are zipped together with their background color as described above. Finally allRegions is a list of all non-empty regions, even the one that is currently being defined and hasn't yet been completed.
«client regions 1»
updateBoard :: W -> Fay ()
updateBoard w = do
  let
    rs :: [Region]
    rs = reverse . regions . currentConstraints $ w
    c :: [[Coord]]
    c = map regionCoords rs
    n =  puzzleSide . board $ w
    allCoords = [ (i, j) | i <- [ 1 .. n] , j <- [1 .. n] ]
    singleTons :: [[Coord]]
    singleTons = filter ((== 1) . length) c
    multiples :: [[Coord]]
    multiples  = filter ((/= 1) . length) c
    unmarked :: [[Coord]]
    unmarked = [filter (\x -> x `notElem` (concat c)) allCoords]
    beingDefined :: [[Coord]]
    beingDefined = [currentRegionCoords w]
    white :: [ ([Coord],Text) ]
    white = zip singleTons (repeat "White")
    colored :: [ ([Coord],Text) ]
    colored = zip multiples (concat . repeat $ backgroundColorList)
    yellow = zip unmarked (repeat "Yellow")
    red = zip beingDefined (repeat "Red")
    allRegions :: [Region]
    allRegions = regions . currentConstraints $ w
This double loop sets the background color of all the regions. It also resets the attributes and the values of each cell. They will be filled back in later, depending on their type.
«client regions 2»
  forM_ (white ++ colored ++ yellow ++ red) $ \i -> do
    let
      cells = fst i
      color = snd i
    forM_ cells $ \j -> do
      cell <- selectCell j
      let v = T.intercalate "" ["background-color:", color, ";"]
      setAttr "style" v cell &
        removeClass "cellConstrained"
      setVal "" cell
This double loop adds back the cellConstrained class to each region that is already defined and completed.
«client regions 3»
  forM_ (white ++ colored) $ \i -> do
    let
      cells = fst i
      color = snd i
    forM_ cells $ \j -> do
      cell <- selectCell j
      addClass "cellConstrained" cell
This loop restores the operation and the value for the first cell in every region.
«client regions 4»
  forM_ allRegions $ \g ->
    when (not (null (regionCoords g))) $ do
      firstCell <- selectCell . head . regionCoords $ g
      let
        operator = regionOperation g
        opText = maybe "" id $ lookup operator operationToTextMap
        value = showInt . regionResult $ g
      setVal (value <> opText) firstCell & hvoid

  selectId (showPuzzleMode (editing w) <> "id") & checked & hvoid
  return ()

selectCell :: Coord -> Fay JQuery
selectCell c = do
  let cellId = idFromCoord c
  selectId cellId 
doRegionsExist simple checks whether any regions have been defined or are being defined. resetRegions resets the state of the World back to when no regions are yet defined. This is called if the user changes the size or type of the puzzle.
«client regions 5»
doRegionsExist :: World -> Fay Bool
doRegionsExist world = do
  w <- get world
  return $ numberOfRegionsDefined w > 0

resetRegions :: World -> Fay ()
resetRegions world = do
  w <- get world
  let
    newW = w { currentRegionIndex = Nothing }
  set world newW
  selectId  "statusRegion" & empty
  setupPuzzleTable world
There is a div in the html file for the current status. This is handy for the user so he can see what is going on, and handy for me to make sure I haven't gone off the rails. rangeStatus display the range of numbers that make up the puzzle, usually from 1 to n. regionStatus displays how many regions have been defined, and how many squares are left to be added to the regions.
«client status»
------------------------------ Status ------------------------------

rangeStatus :: W -> Fay ()
rangeStatus w = do
  let
    msg = Fay.Utils.unwords
      [ "The range runs from" 
       , showInt (head . puzzleElementRange . board $ w)
       , "to"
       ,  showInt (last . puzzleElementRange . board $ w) ]
  setStatus "statusRange" msg

regionStatus :: W -> Fay ()
regionStatus w = do
  let
    d = numberOfRegionsDefined w
    g = numberOfSquaresToGo w
    dText = englishInt d "region"
    gText = englishInt g "square"
    allText = dText <> " defined, " <> gText <> " remaining."
  setStatus "statusRegion" allText
These functions setup the various widgets displayed on the page, and associate them with their handlers. change is a jQuery onchange callback, which is called whenever the status of the widget is changed. There are two little gotchas that are not obvious in this code. One was that to make an option be selected you have to set the selected atrribute to the value "selected." The other is that in the html file, the span associated with the puzzle table must have the attribute contenteditable set to "true."
«client setup»
------------------------------ Setup ------------------------------

setupPuzzleMode :: World -> Fay ()
setupPuzzleMode world = do
  editing <- select "[name=editing]"
  change (handlePuzzleMode world) editing

setupSize :: World -> [Int] -> Fay ()
setupSize world l = do
  selectId "inputWorld"  & click (handleInputWorld world)
  selectId "inputEvents" & click (handleInputEvents world)
  selectId "inputShared" & click (handleInputShared world)
  size <- selectId "size"
  change (handleSize world) size
  forM_ l $ \i -> do
    option <- select "<option value=''></option>" & setVal (showInt i)
    appendTo size option
    setText (showInt i) option

ints :: [Int]
ints = [0..]

setupRange :: World -> Int -> Fay ()
setupRange world n = do
  fromSelect <- selectId "from"
  change (handleFrom world) fromSelect
  toSelect <- selectId "to"
  change (handleTo world) toSelect
  add fromSelect toSelect & empty
    -- Note: JQuery is not an instance of Eq
    -- thus the need for the zip junk and the wierd case statement
  forM_ (zip ints [fromSelect, toSelect]) $ \(j,div) ->
    forM_ [-n .. n] $ \i -> do
       option <- select "<option value=''></option>" 
       setVal (showInt i) option
       let
         selected :: JQuery -> Fay JQuery
         selected = case j of
           0 -> if i == 1 then setAttr "selected" "selected" else return
           1 -> if i == n then setAttr "selected" "selected" else return
       s <- selected option
       appendTo div s
       setText (showInt i) s

setupPuzzleTable :: World -> Fay ()
setupPuzzleTable world = do
  w <- get world
  let n =  puzzleSide . board $ w
  table <- select "<table border='1' style='float:left'></table>"
  p <- selectId "puzzleTable" 
  empty p & appendJQuery table 
  whenTablet p hvoid (keyup (checkForEnter world))
  let
    rowColumn :: [[[Int]]]
    rowColumn = [ [ [i,j] | j<-[1..n] ] | i<-[1..n] ]
  forM_ rowColumn $ \row -> do
    tr <- select "<tr></tr>" & appendTo table
    forM_ row $ \ij -> do
      let c = ((ij!!0) , (ij!!1))
      td <- select "<td></td>" & appendTo tr
      let button = Fay.Utils.unwords [
                  "<input type='button'"
                , "id='" <> idFromCoord c <> "'"
                , "class='tableCell'>" ]
      selectText button & appendTo td
                    & click (handleSquareEvent world)
  setupPuzzleMode world
  updateBoard w
Here all the various callback handlers are defined. worldChangeHandler takes one of two actions, depending upon whether regions exist or not. This is used when the user decides to change a parameter of the puzzle that would affect the currently existing regions. An alert window is presented to give the user a chance to change his mind. If he goes ahead, all existing regions are reset. backoutWithWorld resets the value of the widget associated with an event to a string that is computed based on the current state of the world.
«client handlers 1»
------------------------------ Handlers ------------------------------

worldChangeHandler :: World -> Event -> EventHandler -> EventHandler -> Fay ()
worldChangeHandler world e h1 h2 = do
  ok <- doRegionsExist world
  handler <- if ok then do
    msg <- selectId "worldChange" & getHtml
    ok <- windowConfirm msg
    return $ if ok then h1 else h2
    else return h1
  handler world e

backoutWithWorld :: (W -> Text) -> EventHandler  
backoutWithWorld f world e = do
  w <- get world
  let v = f w
  t <- target e
  select t & setVal v
  return ()
handleSize takes care of two cases. changeSize is called the first time the size is defined and resetSize is called when the size is changed after some regions have already been defined. Once the size is specified, we are ready to let the user define the range of values to be allowed in the puzzle, so we populate and display the "from" and "to" range select widgets based on the size. At this point we can expose the range widget, the puzzleType widget, and the puzzleTable table. The operation and value remain hidden until the puzzleType is known, since if the puzzleType is Killer thexn there is no need for the operation select widget, as it is always Plus. Also the instructions div set to explain to the user what to do next. The way this works is to copy the contents of a hidden div in the html file to the instructions div. The
doParm function handles updating the state of world based on a parser, an updater, and an event.
«client handlers 2»
handleSize :: EventHandler
handleSize world e = worldChangeHandler world e changeSize resetSize 
  where
    changeSize world e = do
      reinitialize <- doRegionsExist world
      when reinitialize  (resetRegions world >> initialize world)
      w <- doParam world readInt updateAll e
      let
        pSize = puzzleSide . board $ w
        n = showInt pSize
        msg = "The size of the puzzle is " <> n <> " by " <>  n
      setStatus "statusSize" msg
      setupRange world pSize
      puzzleType <- selectId "puzzleType"
      change (handlePuzzleType world) puzzleType
      setExplain "explainRange"
      rangeStatus w
      exposeIds ["range"]
      setupPuzzleTable world
      selectId "size" & setProp "disabled" "disabled" & hvoid
    resetSize = backoutWithWorld (showInt . puzzleSide . board)
handleFrom and handleTo are pretty straightforward. handlePuzzleType is again more complicated because if it is called after regions have been defined, we must warn the user of the consequences of changing the type, namely that his regions will be lost. At this point we set up the Operation widget and if the puzzleType is Killer, we hide it, otherwise we expose it. We also set up the instructions div to tell the user what to do next.
«client handlers 3»
handleFrom :: EventHandler
handleFrom world e = do
  doParam world readInt updateLow e
  get world >>= rangeStatus

handleTo :: EventHandler
handleTo world e = do
  doParam world readInt updateHigh e
  get world >>= rangeStatus

handlePuzzleType :: EventHandler
handlePuzzleType world e =
  worldChangeHandler world e changePuzzleType resetPuzzleType 
  where
    changePuzzleType world e = do
      reinitialize <- doRegionsExist world
      when reinitialize (resetRegions world)
      let parsePuzzle x = maybe (tError "No such puzzle type") id (lookup x puzzleTypeMap)
      w <- doParam world parsePuzzle updatePuzzleType e
      let bd = board w
      logEvent world (P (puzzleType bd) (puzzleSide bd)(puzzleElementRange bd) )
      operator <- selectId "operator" & empty
      forM_ valueToOperationTextMap $ \vt -> do
        option <- select "<option></option>" & appendTo operator
        setVal (fst vt) option
        setHtml (snd vt) option
      if (puzzleType . board $ w) == Killer then do
        hideIds ["operator"]
        setExplain "explainKillerCreateRegion"
        else do
          exposeIds ["operator"]
          setExplain "explainCreateRegion"
      selectId "finishRegion"  & click (handleFinishRegion world)
      exposeIds ["resultSpan" , "finish", "editingSpan" ]
      rangeStatus w
    toPuzzleText x = maybe "single" id (lookup x reversePuzzleTypeMap)
    resetPuzzleType = backoutWithWorld (toPuzzleText . puzzleType . board)
To make recovering from mistakes easier, I've added the some editing modes. The default mode is to toggle a square's membership in the current region, adding it if it is not a member, and removing it if it is a member. Another mode is delete mode, which simply removes cells from their region. Another mode is to create a new region or make an existing region the current region when you click on a square. Finally in case you discover that you put the wrong operator or value on a region, there is a mode that allows you to change that too. That pretty much covers all the ways you can enter a puzzle and then discover that you made a mistake, and fix it easily.

The modes I define are:

handlePuzzleMode is the registered event hander when the user clicks on one of the radio buttons to change the current mode. It grabs the new mode and stores it in the world global. If the new mode is ModeSelectRegion we finish the current region.

«client handlers 4»
handlePuzzleMode :: EventHandler
handlePuzzleMode world e = do
  w <- get world
  modeName <- target e & select & getVal
  let 
    newEditState = readPuzzleMode modeName
    newW = w { editing = newEditState }
  set world newW
  logEvent world $ M newEditState
  case newEditState of
    ModeSelectRegion -> handleFinishRegion world undefined
    otherwise -> return ()
handleSquareEvent is called whenever a square is clicked. It just get the co-ordinates of the square and calls handleCell to dispatch on the current mode
«client handlers 5»
handleSquareEvent :: EventHandler
handleSquareEvent world e = do
  tableCell <- target e & select
  Defined coordId <- getAttr "id" tableCell
  let
    thisCoord = coordFromId coordId
  handleCell world thisCoord 

handleCell :: CellHandler
handleCell world thisCoord = do
  w <- get world
  case editing w of
    ModeToggleCell   -> handleModeToggleCell world thisCoord
    ModeRemoveCell   -> handleModeRemoveCell world thisCoord
    ModeSelectRegion -> handleModeSelectRegion world thisCoord
    ModeChangeValue  -> handleModeChangeValue world thisCoord
  w <- get world
  updateBoard w
handleModeChangeValue is called when you want to change the operator and/or the value for a particular region. I try to cause the least surprise, so if the user is in this mode and clicks on a cell that is not in an existing region, we just toggle it into the current region. If the cell is in an existing region, we make sure the operator is valid and if it is, update the world global with changeValueEffect to reflect the change.

This might be a good time to mention logging. Every event the user generates is logged and displayed to the right of the board. When problems occur, they can copy and past the event log and send it to me via email. I can then replay the events on my machine and where something when wrong.

«client handlers 6»
handleModeChangeValue :: CellHandler
handleModeChangeValue world thisCoord = do
  w <- get world
  let
    maybeExistingRegion = lookupCellInRegions w thisCoord 
    w1 = w {   currentRegionIndex = maybeExistingRegion
               , editing = ModeToggleCell }
  case maybeExistingRegion of
    Nothing -> do                   -- This cell was not in a region,
                                    -- so just proceed to toggle it into
                                    -- a new region
      set world w1
      logEvent world $ R maybeExistingRegion
      logEvent world $ M ModeToggleCell
      handleCell world thisCoord
    Just existingRegionIndex ->  do -- This cell is in an existing region
                                    -- and we want to change its operator
                                    -- and value, so make sure a valid
                                    -- (not null) operator and value are
                                    -- entered
      valid <- setupNewRegion w
      case valid of
        Nothing -> do               -- The operator or value wasn't valid
                                    -- so change nothing and keep the world
                                    -- as it was
          return ()
        Just r -> do                -- The operator and value were valid,
                                    -- and there exists a region that contains
                                    -- this coord, so change this regions
                                    -- operator and value to the new ones
          let
            newW = changeValueEffect w1 (regionOperation r) (regionResult r)
          set world newW
          logEvent world $ M ModeToggleCell
          logEvent world $ R maybeExistingRegion
          logEvent world $ V (regionOperation r) (regionResult r)
          setError ""

changeValueEffect :: W -> Operation -> Value -> W
changeValueEffect w o v =
  let
    rExisting = currentRegion w
    newR = rExisting {   regionResult = v
                       , regionOperation = o }
    newW = updateCurrentRegion w newR
  in newW  
handleModeSelectRegion is the handler called when a cell is clicked in the ModeSelectRegion mode. If the cell is in an existing region, it is made current and blinked. If the cell isn't in an existing region, we try to create a new region, which will probably fail unless the user was prescient enough to have selected a new operator and value. This mode is only enabled for one click, after which the mode returns to ModeToggleCell.
«client handlers 7»
handleModeSelectRegion :: CellHandler
handleModeSelectRegion world thisCoord = do
  w <- get world
  -- tPutStrLn $ "In handleModeSelectRegion with " <> (tShow thisCoord)
  let newW = selectRegionEffect w thisCoord
  set world newW
  logCoordEvent world thisCoord
  -- tPutStrLn $ "maybeExistingRegion is " <> (tShow maybeExistingRegion)
  case currentRegionIndex newW of
    Nothing -> handleCell world thisCoord
    Just _ ->  do
      selectCell thisCoord & blink "redBackground"
  -- w1 <- get world
  -- tPutStrLn $ "world is " <> (tShow w1) <> " on exit"

blink :: Text -> JQuery -> Fay ()
blink = ffi "%2['blink'](%1)"

selectRegionEffect w c =
  w {   currentRegionIndex = maybeExistingRegion
      , editing = ModeToggleCell }
  where
    maybeExistingRegion = lookupCellInRegions w c 
handleModeRemoveCell is the handler called when a cell is clicked in the ModeRemoveCell mode. If no regions exist, the user gets an error message, otherwise the cell is removed from its region. You will notice a worrying head . puzzleConstraints in the definition of removeFromBoard. Recall that puzzleConstraints is never empty. It has one element is the PuzzleType is Single or Killer, and two elements if the PuzzleType is Double. Removing a cell always makes no region current.
«client handlers 8»
handleModeRemoveCell :: CellHandler
handleModeRemoveCell world thisCoord = do
  thereAreRegions <- doRegionsExist world
  if thereAreRegions then do
    w <- get world
    let newW = removeCellEffect w thisCoord
    set world newW
    logCoordEvent world thisCoord
    regionStatus newW
    else do
      setError "There are no more regions to remove squares from"

removeCellEffect :: W -> Coord -> W
removeCellEffect w c = removeEmptyRegions $ 
  w {  board = newBoard
     , currentRegionIndex = Nothing}
  where  newBoard = removeFromBoard c (board w)

removeFromBoard :: Coord -> Board -> Board
removeFromBoard c bd = bd { puzzleConstraints = newConstraints bd : tail (puzzleConstraints bd) }
  where
    newConstraints :: Board -> Constraints
    newConstraints = removeFromConstraint c . head . puzzleConstraints 
    removeFromConstraint :: Coord -> Constraints -> Constraints
    removeFromConstraint c1 = Constraints . map (removeFromRegion c1) . regions

removeFromRegion :: Coord -> Region -> Region
removeFromRegion c g = g { regionCoords = filter (/= c) (regionCoords g) }
setupNewRegion is called whenever we want to create a new region. It checks that the prerequisites already exist, namely that the puzzle type, region operator, and region value are defined. And error message is displayed if any of these are missing. If all is well, a new Region is returned.
«client handlers 9»
setupNewRegion :: W -> Fay (Maybe Region)
setupNewRegion w = do
  let pType = puzzleType . board $ w
  if pType == NullP then setError "You must select a puzzle type!" >> return Nothing
    else do
      operator <- case puzzleType . board $ w of
        Killer -> return "Plus"
        otherwise -> selectId "operator" & getVal
      let
        op = lookup operator valueToOperationMap
      result <- selectId "result" & getVal
      setError ""
      case op of
        Nothing -> setError "You must select an operator!" >> return Nothing
        Just theOperator -> do
          setError ""
          case result of
            "" -> setError "You must select a value!" >> return Nothing
            r -> do
              setError ""
              return $ Just (Region (readInt r) theOperator [])
handleModeToggleCell is called when a square is clicked and we are in ModeToggleCell mode. If we are in a new region, we make sure its prerequisites are valid, and then toggle this cell into or out of the current region. We are slightly smart about the operator, namely if we know in advance how many cells are needed by a specific operator, we immediately finish that region. For example, if the operator is Id, which means that the specified cell must have this value, then we know the region can only be one cell large. This logic is handled in the runToggle function below. We also check to see of all of the cells have been used, and if so finish the current region.
«client handlers 10»
handleModeToggleCell :: CellHandler
handleModeToggleCell world thisCoord = do
  {- When I finally tried this on my ipad, I discovered that every time
     I touched a square in the puzzle, the keyboard would pop up.  I 
     tried not attaching the keyup handler to the table, but that had 
     no effect, so after searching around discovered I could blur the
     active element and that would push the keyboard back down into
     its place. 
  -}
  w <- get world
  whenTablet () (const hideIpadKeyboard) hvoid
  if isNewRegion w then do
    valid <- setupNewRegion w
    case valid of
      Nothing -> updateBoard w
      Just r -> do
        logEvent world $ N (cRow thisCoord) (cColumn thisCoord) (regionOperation r) (regionResult r)
        runToggle world thisCoord r
        setError ""
    else do
      logCoordEvent world thisCoord
      runToggle world thisCoord (currentRegion w)

runToggle :: World -> Coord -> Region -> Fay ()
runToggle world thisCoord r = do
  w <- get world
  let
    w1 = toggleCellEffect w thisCoord r
    theOperator = regionOperation r
  set world w1
  case length (regionCoords (currentRegion w1)) of
    1 -> when (theOperator ==  Id) $ handleFinishRegion world undefined
    2 -> when (theOperator == Mod) $ handleFinishRegion world undefined
    otherwise -> return ()
  w3 <- get world  
  regionStatus w3
  updateBoard w3
  let squaresLeft = numberOfSquaresToGo w3
  when (squaresLeft == 0) $ handleFinishRegion world undefined
  return ()

toggleCellEffect :: W -> Coord -> Region -> W
toggleCellEffect w c r = updateCurrentRegion w (toggleMembership c r)

toggleMembership :: Coord -> Region -> Region
toggleMembership c g =
  if c `elem` regionCoords g then removeFromRegion c g
    else g { regionCoords = regionCoords g ++ [c]}
handleFinishRegion as you might guess, we get here when a region has been finished. We do nothing if there is no current region, otherwise we reset the operator and result fields of the form, set the current region to Nothing, redisplay the board and check if all of the squares have been used. If so we call handleAllCellsDefined which will might send the board to server. handleAllCellsDefined is called whenever there are no more squares left to define. That does not necessarily mean we are completely finished with the puzzle. Some calcudoku puzzles are Doubles, meaning that the same solution must exist for two different puzzles. If the puzzle type is Double and we have only defined one board, we need to go and define the other board. This involves creating a new board with the head of puzzleConstraints null, and the tail (second element) of puzzleConstraints equal to the just defined set of constraints for the first half of the double puzzle. If the puzzle type isn't Double, or we have finished defining the second half of a Double puzzle, we call postToSnap to send the world to the server. Once the puzzle is defined completely, we set the answer region to a message that the answer should appear here shortly. This is in case the puzzle takes too long to solve. We then run an ajax call to the server with the Board as the posted data. If all goes well, the server responds with a solution which is put into the answer div. The answer returned should be plain text that is stuffed into an pre element. Just for fun, we also display the data sent to the server in the post request in the puzzleData div. I found this useful for debugging, and perhaps if the user is a programmer it will help them understand what is going on.
«client finishRegion»
handleFinishRegion :: EventHandler
handleFinishRegion world _ = do
  w1 <- get world
  when (not $ isNewRegion w1) $ do
    let g = currentRegion w1
    logEvent world (V (regionOperation g) (regionResult g) )
    logEvent world (R Nothing)
    selectId "operator" & setVal ""
    selectId "result" & setVal ""
    w2 <- get world
    let newW = w2 { currentRegionIndex = Nothing }
    set world newW
    updateBoard newW
    let squaresLeft = numberOfSquaresToGo newW
    regionStatus newW
    if squaresLeft /= 0 then return () else handleAllCellsDefined world
    -- tPutStrln $ "In handleFinishRegion2 with " <> (tShow newW)

handleAllCellsDefined :: World -> Fay ()
handleAllCellsDefined world = do
  w <- get world
  if (puzzleType . board $ w) == Double then
     case length . puzzleConstraints . board $ w of
       1 -> do
         let
           b = board w
           newB = b { puzzleConstraints = Constraints [] : puzzleConstraints b}
           newW = w { board = newB }
         setExplain "secondPartOfDouble"
         hideIds ["size", "puzzleType", "range" ]
         set world newW
         setupPuzzleTable world
       2 ->  setExplain "doubleFinished" >> postToSnap w
       _ -> tError "there should only be 1 or 2 puzzle constraints"
     else postToSnap w
postToSnap is called when we have finished defining the puzzle. It tells the user to be patient, and cleans up any empty regions that may have been created. It sets the puzzleData region on the web page to the data that is about to be sent to the server, creates a new Shared data type, and packs it all of to send to the server. The server should reply with a simple text message, which will be displayed in the answer div once it is received.
«client postToSnap»
postToSnap :: W -> Fay ()
postToSnap w = do
  let bd = board w
  setExplain "puzzleFinished"
  -- tPutStrLn $ "Board: is done" <> showWorld w
  selectId "answer" & empty & setHtml "The answer should appear here shortly"
  let
    cleanConstraints = map removeEmptyRegions (puzzleConstraints bd)
    removeEmptyRegions c = Constraints $
                          filter (\g -> regionOperation g /= Empty) (regions c)
    newB = bd { puzzleConstraints = cleanConstraints }
  puzzleData <- selectId "puzzleData" & empty
  let
    sb = showBoard newB
    lsb = T.length sb
    t1 = "<hr/><br/>This is the data that is being sent to the server,\
         \if you have problems, please copy and paste it in a message to Henry.<br/>"
    t2 = "<br/>Post length is: " <> showInt lsb <> " bytes</p>"
    shared = Shared newB (reverse $ cevents w) "" ""
  jPost "fayParse" shared setAnswer
  
setAnswer :: Text -> Fay ()
setAnswer s = do
  answer <- selectId "answer" & empty
  Fay.JQuery.append s answer & hvoid
logEvent and logCoordEvent are called throughout to log the event so that it can be replayed.
«client logging»
logCoordEvent :: World -> Coord -> Fay ()
logCoordEvent world thisCoord =  logEvent world (L (cRow thisCoord) (cColumn thisCoord) )

logEvent :: World -> CEvent -> Fay ()
logEvent world e = do
  puzzleEvents <- selectId "puzzleEvents"
  appendText (" " <> showCEvent e ) puzzleEvents & hvoid
  w <- get world
  let newW = w {cevents = e : cevents w}
  set world newW
  -- tPutStrLn $ "logEvent Event" <> showCEvent e 
  -- tPutStrLn $ "logEvent World" <> showWorld newW
checkForEnter is an event handler that checks to see if the enter key has been pressed. Pressing the enter key means that the current region being defined is finished. It is easier to do this rather than clicking on the "finish region" button.
«client checkForEnter»
checkForEnter :: EventHandler
checkForEnter world e = do
  code <- which e
  -- tPutStrLn $ "checkForEnter: " <> (showInt code)
  when (code == 13) $ handleFinishRegion world e
simulateEvents unravels a bunch of space delimited events that were recorded while the user was doing his input. These events are displayed as the user enters them to the right of the puzzle board. If something goes wrong, the user can easily copy and paste these events and send them to me. I can run them through this function and recreate the board. It has come in handy several times now.

runEvents calls simulateEvents to create a new world global that gets posted to the server.

handleInputEvents is only available in debug mode. It reads worldEvents textbox and runs the events

«client events»
simulateEvent :: CEvent -> W -> W
simulateEvent cev w = 
  let
    bd = board w
    result = case cev of
      P x1 x2 x3 -> w { board =
                          bd {puzzleType = x1,
                              puzzleSide = x2,
                              puzzleElementRange = x3}}
      L x1 x2 ->
        let
          r = currentRegion w
          c = mkC x1 x2
          mode = editing w
          newW = case mode of
            ModeToggleCell   -> toggleCellEffect w c r
            ModeRemoveCell   -> removeCellEffect w c
            ModeSelectRegion -> selectRegionEffect w c
            ModeChangeValue  -> w
        in newW
      M x1 -> w { editing = x1 }
      R x1 -> w {currentRegionIndex = x1 }
      V x1 x2 -> changeValueEffect w x1 x2
      N x1 x2 x3 x4 -> toggleCellEffect w (mkC x1 x2) (Region x4 x3 [])
      otherwise -> tError $ "simulate events error " <> tShow otherwise
  in result

readEvents :: Text -> Fay [CEvent]
readEvents events = do
  mapM readEventWithIO (Fay.Utils.words events)
  where
    readEventWithIO txt = do
      -- tPutStrLn txt
      return (readCEvent txt)

runEvents :: Text -> Fay ()
runEvents theEvents = do
  events <- readEvents theEvents
  finalW <- foldM simulate1 defaultW events
  newWorld <- newRef finalW 
  setupPuzzleTable  newWorld
  -- tPutStrLn $ showBoard (board finalW)
  postToSnap finalW
  where
    simulate1 a b = do
      -- tPutStrLn (showCEvent b)
      return $ simulateEvent b a

handleInputEvents :: EventHandler
handleInputEvents _ _ = do
  worldEvents <- selectId "worldEvents" & getVal
  runEvents worldEvents
Similar to handleInputEvents, handleInputWorld runs the board defined by the global World. Why do I need two different ways to run the solver? Well, if instead of entering the puzzle via fay, the user uses this solver to grab and parse a calcudoku puzzle from calcudoku.org, then there won't be any events defined. The server will parse the puzzle it finds at the specified url, create a World, and send it off to the solver. I get a copy of the World data if something goes wrong via email.
«client handleInputWorld»
handleInputWorld :: EventHandler
handleInputWorld _ _ = do
  worldText <- selectId "worldText" & getVal
  let newB = readBoard worldText
      newW = W newB Nothing ModeToggleCell []
  newWorld <- newRef newW
  setupPuzzleTable  newWorld
  postToSnap newW

handleInputShared :: EventHandler
handleInputShared _ _ = do
  sharedText <- selectId "sharedText" & getVal
  jPost "sharedParse" sharedText setAnswer
lookupCellInRegions looks to see if the cell is in an existing region. If so, it returns Just the index of the region in the list of current constraints. If not, it returns Nothing.
«client lookupCellInRegions»
lookupCellInRegions :: W -> Coord -> Maybe Int
lookupCellInRegions w c =
  let
    justRegions = regions . currentConstraints $ w
    indexedRegions = zip justRegions [0..]
    go [] = Nothing
    go (r1:rs) = if c `elem` (regionCoords . fst $ r1) 
                   then Just (snd r1) else go rs
  in go indexedRegions
As you might guess, we get here when a region has been finished. At this point we have to add the current region to the list of Constraints, and reset the current region to null. We also check to see if there are any more squares left to be defined. If not we need to do more finishing.

Fay version 18 and beyond

When Fay version 18 came out, all strings disappeared and were changed to Text. At this point I decided to move the pieces of Fay that I use often into their own module, which I import into different projects. The result is the code below, some of it shamelessly stolen from others. Since the JQuery interface always uses the matched set as the last arguement, and usually returns the matched set, the use of the infix & make writing some of the functions shorter and more expressive.
«fayUtils bind»
(&) :: Fay a -> (a -> Fay b) -> Fay b
x & y = x >>= y
infixl 1 &
Next we include some DOM manipulations that we have to do frequently. selectId happens so often, that I got tired of typing the "#" sign. Hopefully they are pretty much self explanatory.
«fayUtils dom»
selectId :: Text -> Fay JQuery
selectId = ffi "jQuery('#'+%1)"

selectText :: Text -> Fay JQuery
selectText = ffi "window['jQuery'](%1)"

appendText :: Text -> JQuery -> Fay JQuery
appendText = ffi "%2['append'](%1)"

prependText :: Text -> JQuery -> Fay JQuery
prependText = ffi "%2['prepend'](%1)"

exposeIds :: [Text] -> Fay ()
exposeIds l =  forM_ l $ \i -> selectId i & removeClass "hidden"

hideIds :: [Text] -> Fay ()
hideIds l =  forM_ l $ \i -> selectId i & addClass "hidden"

enable ::  JQuery -> Fay ()
enable = ffi "%1['prop'](\"disabled\",false)"

disable ::  JQuery -> Fay ()
disable = ffi "%1['prop'](\"disabled\",true)"

checked :: JQuery -> Fay ()
checked  = ffi "%1['prop'](\"checked\",true)"

unchecked :: JQuery -> Fay ()
unchecked  = ffi "%1['prop'](\"checked\",false)"

scrollOneLine :: JQuery -> Fay ()
scrollOneLine = ffi "%1['scroll']()"

jsBlur :: JQuery -> Fay ()
jsBlur = ffi "%1['blur']()"
Here are some text and show functions that I need all the time, and for some reason didn't work for me with pack . show when I tried them. Again, hopefully they are pretty much self explanatory.
«fayUtils show and text»
trim :: Text -> Text
trim = ffi "jQuery['trim'](%1)"

englishInt :: Int -> Text -> Text
englishInt n t = 
  case n of
      0 -> "No " <> t <> "s"
      1 -> "1 " <> t
      x -> showInt x <> " " <> t <> "s"

showJQuery :: JQuery -> Text
showJQuery = ffi "JSON.stringify(%1)"

showElement :: Element -> Text
showElement = ffi "JSON.stringify(%1)"

showEvent :: Event -> Text
showEvent = ffi "JSON.stringify(%1)"

showList :: [Int] -> Text
showList = ffi "JSON.stringify(%1)"

doubleQuote :: Text -> Text
doubleQuote s = "\"" <> s <> "\""

deblank :: Text -> Text
deblank = ffi "%1.replace(/\\s+/g,'')"
I wish these had been included in the Prelude defined by fay-base.
«fayUtils missing from the prelude»
split :: Text -> Text -> [Text]
split = ffi "%2.split(%1)"

words :: Text -> [Text]
words = ffi "%1.split(\" \")"

unwords :: [Text] -> Text
unwords = ffi "%1.join(\" \")"

readBool :: Text -> Bool
readBool x = if x == "True" then True else False
Here are some parsers that didn't work as read . unpack, so I added them here.
«fayUtils parsers»
readInt :: Text -> Int
readInt = ffi "parseInt(%1)"

readIntList :: Text -> [Int]
readIntList = ffi "JSON.parse(%1)"

readDouble :: Int -> Text -> Double
readDouble = ffi "parseFloat(%2,%1) || 0"
Some miscellaneous functions that come in handy.
«fayUtils other»

exists :: JQuery -> Bool
exists = ffi "%1.length > 0"

alert :: Text -> Fay ()
alert = ffi "alert(%1)"

jPost :: Text -> Automatic f -> (Automatic g -> Fay ()) -> Fay ()
jPost = ffi "jQuery.ajax(%1, { data: JSON.stringify(%2), type: 'POST', processData: false, contentType: 'text/json', success: %3 })"

windowUrl :: Fay Text
windowUrl = ffi "window.location.href"

windowUserAgent :: Fay Text
windowUserAgent = ffi "navigator.userAgent"

hideIpadKeyboard :: Fay ()
hideIpadKeyboard = ffi "document.activeElement.blur()"

isPrefixOf :: Text -> Text -> Bool
isPrefixOf  = ffi "%2.indexOf(%1) == 0"

isInfixOf :: Text -> Text -> Bool
isInfixOf = ffi "%2.indexOf(%1) >= 0"
These guys want a string in Haskell, but Fay wants Text.
«fayUtils text versions»
tError :: Text -> a
tError = error . unpack

tPutStrLn :: Text -> Fay ()
tPutStrLn = Data.Text.putStrLn

tShow :: Show a => a -> Text
tShow = pack . show

tPrint :: Show a => a -> Fay ()
tPrint = tPutStrLn . tShow

serialize :: JQuery -> Fay Text
serialize = ffi "%1['serialize']()"

consoleLog :: JQuery -> Fay ()
consoleLog = ffi "console['log'](%1)"

safeTail :: [a] -> [a]
safeTail l = if Prelude.null l then l else Prelude.tail l
I implement some Read/Show instances with lookup from the Prelude. Also doParam is a helper that is a little complicated. It take a reference to a variable, usually the global state world, a parser function that converts Text to an internal type, and updating function that modifies the internal structure of the world, and a Javascript event. It decodes the event, and updates the world to the new value. It returns the new world, wrapped in the Fay monad.
«fayUtils read show with maps»
doParam :: Ref b -> (Text -> a) -> (b -> a -> b) -> Event -> Fay b
doParam world parser updateF e = do
  t <- target e
  sval <- select t & getVal 
  w <- get world
  let newW = updateF w (parser sval)
  set world newW
  return newW

reverseMap :: [(a,b)] -> [(b,a)]
reverseMap = Prelude.map (\x -> (snd x, fst x))
                     
readLookup :: Eq a => Text -> [(a,b)] -> a -> b
readLookup msg l x = fromMaybe (tError msg) $ lookup x l

showLookup :: Eq b => Text -> [(a,b)] -> b -> a
showLookup msg l x = fromMaybe (tError msg) $ lookup x (reverseMap l)

underscore :: Text
underscore = "_"

redirect :: Text -> Fay ()
redirect = ffi "window.location.href = %1"

debug :: Text -> Fay ()
-- debug _ = return ()
debug = Data.Text.putStrLn

onEvent :: EventType -> (Event -> Fay ()) -> Fay ()
onEvent = ffi "jQuery(document).bind(%1,%2)"

isDebug :: Fay Bool
isDebug = do
  url <- windowUrl
  let
    debug = unpack "debug"
    queryParms = dropWhile (/= '?') (unpack url)
    debugging = Prelude.not (Prelude.null queryParms) && debug == (Prelude.take (Prelude.length debug) . Prelude.tail $ queryParms)
  return debugging

cloneId :: Text -> Fay JQuery
cloneId idText = do
  selectId idText & clone WithoutDataAndEvents
    & removeAttr "id"
    & removeClass "hidden"

fmap :: (a -> b) -> Fay a -> Fay b
fmap f a = do
  a1 <- a
  return (f a1)

Conclusion

Well, that is all for now. Next I'll try to document the Solver, for your amusement and edification. I hope you've enjoyed this tour through a sample Fay application. Thank you again, Chris and Adam for allowing me to escape the Javascript jail and enter the Haskell heaven.

You can download this code from here.

Quote of the day:
You should never say anything to a woman that even remotely suggests that you think she's pregnant unless you can see an actual baby emerging from her at that moment.
Dave Barry

Sitemap
Go up to Haskell Go up to Home Page of Nadine Loves Henry
Go back to How to use Data.Lens Continue with A Medium Sized Snaplet Example