Just working on dependencies

bower.json

@@ -0,0 +1,40 @@
+{
+  "name": "blog.benpence.com",
+  "description": "",
+  "main": "index.js",
+  "authors": [
+    "Ben Pence <github@benpence.com>"
+  ],
+  "license": "MIT",
+  "homepage": "https://github.com/benpence/blog.benpence.com",
+  "private": true,
+  "ignore": [
+    "**/.*",
+    "node_modules",
+    "bower_components",
+    "test"
+  ],
+  "dependencies": {
+    "purescript-assert": "^3.0.0",
+    "purescript-console": "^3.0.0",
+    "purescript-eff": "^3.1.0",
+    "purescript-lists": "^4.9.0",
+    "purescript-lens": "^3.0.0",
+    "purescript-tuples": "^4.1.0",
+    "purescript-foldable-traversable": "^3.4.0",
+    "purescript-either": "^3.1.0",
+    "purescript-pux": "^10.0.0",
+    "purescript-datetime": "^3.3.0",
+    "purescript-enums": "^3.2.0",
+    "purescript-markdown": "^11.0.0",
+    "purescript-affjax": "^4.0.0",
+    "purescript-uri": "^3.0.1",
+    "purescript-pathy": "^4.0.0",
+    "purescript-argonaut-core": "^3.1.0",
+    "purescript-argonaut-codecs": "^3.2.0"
+  },
+  "devDependencies": {
+    "purescript-psci-support": "^3.0.0",
+    "purescript-test-unit": "^11.0.0"
+  }
+}

connections.cabal

@@ -0,0 +1,47 @@
+name:                connections
+version:             0.1.0.0
+stability:           Experimental
+category:            Web
+author:              Ben Pence
+maintainer:          github@benpence.com
+build-type:          Simple
+cabal-version:       >= 1.10
+
+executable connections-main
+  hs-source-dirs:             src/main/haskell/Main
+  main-is:                    Main.hs
+
+  build-depends:
+      base
+    , connections
+    , random
+    , scotty
+    , text
+
+  default-language:           Haskell2010
+
+library
+  hs-source-dirs:             src/main/haskell
+  exposed-modules:
+    Connections.Game.Create
+    Connections.Game.Play
+    Connections.Web.Controller
+    Connections.Web.Handle
+    Connections.Web.Route
+    Connections.Web.Store
+    Connections.Types
+    Connections.Util
+
+  build-depends:
+      base
+    , aeson
+    , array
+    , containers
+    , random
+    , scotty
+    , transformers
+    , text
+
+  default-language:           Haskell2010
+
+  -- TODO: Include data file

package.json

@@ -0,0 +1,18 @@
+{
+  "name": "blog.benpence.com",
+  "version": "0.0.1-SNAPSHOT",
+  "description": "",
+  "main": "index.js",
+  "scripts": {},
+  "author": "",
+  "license": "",
+  "dependencies": {
+    "purescript": "^0.11.5",
+    "react": "^15.6.1",
+    "react-dom": "^15.6.1",
+    "virtual-dom": "^2.1.1"
+  },
+  "devDependencies": {
+    "bower": "^1.8.0"
+  }
+}

src/main/haskell/Connections/Game/Create.hs

@@ -0,0 +1,71 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Connections.Game.Create where
+
+import qualified Connections.Util                as Util
+import qualified Data.Aeson.Types                as Aeson
+import qualified Data.Array                      as Array
+import qualified Data.List                       as List
+import qualified Data.Set                        as Set
+import qualified System.Random                   as Random
+
+import Data.Set (Set)
+import Data.Text (Text)
+
+import Connections.Types
+
+newGame :: Board -> Game
+newGame board = Game RedTurn board
+
+data BoardConfig
+    = BoardConfig
+        { boardHeight :: Int
+        , boardWidth  :: Int
+        , redWords    :: Int
+        , blueWords   :: Int
+        , assassins   :: Int
+        }
+
+defaultBoardConfig :: BoardConfig
+defaultBoardConfig = BoardConfig
+  { boardHeight = 5
+  , boardWidth  = 5
+  , redWords    = 7
+  , blueWords   = 6
+  , assassins   = 1
+  }
+
+type InvalidConfig = Text
+
+randomBoard :: (Random.RandomGen g) => BoardConfig -> [Text] -> g -> Either InvalidConfig (Board, g)
+randomBoard (BoardConfig { .. }) dictionary randomGen
+  | boardHeight < 1 = Left "Board Height < 1"
+  | boardWidth < 1  = Left "Board Width < 1"
+  | redWords < 1    = Left "Red words < 1"
+  | blueWords < 1   = Left "Blue words < 1"
+  | assassins < 1   = Left "Assassins < 1"
+  | length dictionary < boardHeight * boardWidth = Left "Dictionary too small"
+  | boardHeight * boardWidth < redWords + blueWords + assassins = Left "Board not big enough"
+  | otherwise =
+  let
+    squaresCount       = boardHeight * boardWidth
+    markedSquaresCount = redWords + blueWords + assassins
+    (words, gen1)      = Util.chooseN randomGen squaresCount dictionary
+
+    markedSquares = 
+        List.replicate redWords Red ++
+        List.replicate blueWords Blue ++
+        List.replicate assassins Assassin
+    greySquares        = List.replicate (squaresCount - markedSquaresCount) Grey
+    (squares, gen2)    = Util.chooseN gen1 squaresCount (greySquares ++ markedSquares)
+
+    boardArray = Array.listArray ((0, 0), (boardHeight - 1, boardWidth - 1))
+        [ Square { squareGuessed = False
+                 , squareType    = squareType
+                 , squareWord    = word
+                 }
+        | (index, squareType, word) <- zip3 [0..] squares words
+        ]
+  in
+    Right (Board boardArray, gen2)

src/main/haskell/Connections/Game/Play.hs

@@ -0,0 +1,51 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Connections.Game.Play where
+
+import qualified Data.Array                      as Array
+
+import Data.Text (Text)
+import GHC.Generics (Generic)
+
+import Data.Array ((//))
+import Data.Monoid ((<>))
+import Connections.Util (showT)
+
+import Connections.Types
+
+data Move
+    = Guess (Int, Int)
+    | EndTurn
+    deriving (Eq, Show, Ord, Generic)
+
+type InvalidMove = Text
+
+makeMove :: Game -> Move -> Either InvalidMove Game
+makeMove game@(Game {..}) guess@(Guess (i, j))
+  | i < minI || maxI < i || j < minJ || maxJ < j =
+      Left ("Guess (" <> showT i <> ", " <> showT j <> ") is out of bounds.")
+  | squareGuessed =
+      Left ("Square (" <> showT i <> ", " <> showT j <> ") already guessed.")
+  | otherwise =
+      Right (game
+        { gameTurn = updatedTurn
+        , gameBoard = Board updatedBoard
+        }
+      )
+  where 
+    -- Examine game
+    (Board boardMatrix)          = gameBoard
+    ((minI, minJ), (maxI, maxJ)) = Array.bounds boardMatrix
+
+    square@(Square {..})         = boardMatrix Array.! (i, j)
+
+    -- Transform game
+    correctGuess                 = ((squareType == Red)  && (gameTurn == RedTurn)) ||
+                                   ((squareType == Blue) && (gameTurn == BlueTurn))
+    updatedTurn                  = if correctGuess then gameTurn else succ gameTurn
+
+    updatedSquare                = square { squareGuessed = True }
+    updatedBoard                 = boardMatrix // [((i, j), updatedSquare)]
+makeMove game EndTurn = Right (game { gameTurn = succ (gameTurn game) })

src/main/haskell/Connections/Types.hs

@@ -0,0 +1,53 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Connections.Types where
+
+import qualified Data.Aeson.Types                as Aeson
+import qualified Data.Array                      as Array
+
+import Data.Array (Array)
+import Data.Text (Text)
+import GHC.Generics (Generic)
+
+data Game
+    = Game
+        { gameTurn      :: Turn
+        , gameBoard     :: Board
+        }
+    deriving (Eq, Show, Ord, Generic)
+
+instance Aeson.ToJSON Game
+
+data Turn
+    = RedTurn
+    | BlueTurn
+    deriving (Eq, Enum, Show, Ord, Generic)
+
+instance Aeson.ToJSON Turn
+
+newtype Board
+    = Board (Array (Int, Int) Square)
+    deriving (Eq, Show, Ord, Generic)
+
+instance Aeson.ToJSON Board where
+    toJSON (Board array) = Aeson.toJSON (Array.assocs array)
+
+data Square
+    = Square
+        { squareGuessed :: Bool
+        , squareType    :: SquareType
+        , squareWord    :: Text
+        }
+    deriving (Eq, Show, Ord, Generic)
+
+instance Aeson.ToJSON Square
+
+data SquareType
+    = Red
+    | Blue
+    | Grey
+    | Assassin
+    deriving (Eq, Show, Ord, Generic)
+
+instance Aeson.ToJSON SquareType

src/main/haskell/Connections/Util.hs

@@ -0,0 +1,24 @@
+module Connections.Util where
+
+import qualified Data.Text                       as Text
+import qualified System.Random                   as Random
+
+import Data.Text (Text)
+
+showT :: (Show a) => a -> Text
+showT = Text.pack . show
+
+-- TODO: Rewrite this. Currently O(n^2) and not tail recursive
+chooseN :: (Random.RandomGen g) => g -> Int -> [a] -> ([a], g)
+chooseN randomGen 0 _     = ([], randomGen)
+chooseN randomGen _ []    = ([], randomGen)
+chooseN randomGen n items =
+  let
+    (chosenIndex, newGen) = Random.randomR (0, ((length items) - 1)) randomGen
+
+    newItems              = (take chosenIndex items) ++ (drop (chosenIndex + 1) items)
+    (chosenList, lastGen) = chooseN newGen (n - 1) newItems
+
+    chosenItem            = items !! chosenIndex
+  in
+    (chosenItem : chosenList, lastGen)

src/main/haskell/Connections/Web/Controller.hs

@@ -0,0 +1,69 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Connections.Web.Controller where
+
+import qualified Connections.Game.Create         as Create
+import qualified Connections.Game.Play           as Play
+import qualified Connections.Web.Handle          as Handle
+import qualified Connections.Web.Store           as Store
+import qualified Data.Aeson.Types                as Aeson
+
+import Connections.Web.Store (Store)
+import Connections.Util (showT)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Data.Aeson ((.=))
+import Data.Monoid ((<>))
+import Data.Text (Text)
+import GHC.Generics (Generic)
+
+data Action
+    = NewGame
+    | Status
+    | Move Play.Move
+
+data AppConfig
+    = AppConfig
+        { boardConfig :: Create.BoardConfig
+        , dictionary  :: [Text]
+        }
+
+data ApiResponse
+    = Results
+        { results :: Aeson.Value
+        }
+    | Errors
+        { errors :: [Text]
+        }
+    deriving (Eq, Show, Generic)
+
+instance Aeson.ToJSON ApiResponse where
+    toJSON (Results result) = Aeson.object ["results" .= result]
+    toJSON (Errors errors)  = Aeson.object ["errors"  .= errors]
+
+onAction :: (MonadIO io) => AppConfig -> Store io -> Store.Key -> Action -> io ApiResponse
+onAction (AppConfig {..}) store key NewGame = do
+    result <- Handle.newGame store key boardConfig dictionary
+
+    let apiResponse = case result of
+            Right ()          -> Results Aeson.Null
+            Left errorMessage -> Errors [errorMessage]
+
+    pure apiResponse
+
+onAction _ store key Status = do
+    maybeGame <- Handle.status store key
+
+    let apiResponse = Results (Aeson.toJSON maybeGame)
+
+    pure apiResponse
+
+onAction (AppConfig {..}) store key (Move move) = do
+    result <- Handle.move store key move
+
+    let apiResponse = case result of
+            Right ()          -> Results Aeson.Null
+            Left errorMessage -> Errors [errorMessage]
+
+    pure apiResponse