revisions by @paf31

revisions by @paf31

module Test.QuickCheck
  ( (<?>)
  , AlphaNumString(..)
  , Arbitrary
  , CoArbitrary
  , Negative(..)
  , NonZero(..)
  , Positive(..)
  , QC(..)
  , arbitrary
  , coarbitrary
  , quickCheck
  , quickCheck'
  , quickCheckPure
  , Result(..)
  , runAlphaNumString
  , runNegative
  , runNonZero
  , runPositive
  , runSignum
  , Signum(..)
  , smallCheck
  , smallCheckPure
  , statCheck
  , statCheckPure
  , test
  , Testable
  ) where

import Debug.Trace
import Control.Monad.Eff
import Control.Monad.Trampoline
import Control.Bind
import Control.Monad.Eff.Random
import Control.Monad.Eff.Exception
import Data.Array
import Data.Tuple
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Monoid
import Data.Either
import Data.Traversable
import Math

import qualified Data.String as S
import Data.Char

import Test.QuickCheck.LCG

class Arbitrary t where
  arbitrary :: Gen t

class CoArbitrary t where
  coarbitrary :: forall r. t -> Gen r -> Gen r

class Testable prop where
  test :: prop -> Gen Result

newtype AlphaNumString = AlphaNumString String

newtype Positive = Positive Number

newtype Negative = Negative Number

newtype NonZero  = NonZero Number

newtype Signum   = Signum Number

type QC a = forall eff. Eff (trace :: Trace, random :: Random, err :: Exception | eff) a

data Result = Success | Failed String

(<?>) :: Boolean -> String -> Result
(<?>) true  = const Success
(<?>) false = Failed

quickCheckPure :: forall prop. (Testable prop) => Number -> Seed -> prop -> [Result]
quickCheckPure n s prop = runTrampoline $ sample' n (defState s) (test prop)

quickCheck' :: forall prop. (Testable prop) => Number -> prop -> QC Unit
quickCheck' n prop = check (quickCheckPure n) prop

quickCheck :: forall prop. (Testable prop) => prop -> QC Unit
quickCheck prop = quickCheck' 100 prop

smallCheckPure :: forall prop. (Testable prop) => Number -> prop -> [Result]
smallCheckPure s prop = runTrampoline $ collectAll (defState s) (test prop)

smallCheck :: forall prop. (Testable prop) => prop -> QC Unit
smallCheck prop = check smallCheckPure prop

statCheckPure :: forall prop. (Testable prop) => Seed -> Number -> prop -> Result
statCheckPure s freq prop = try 100
  where try x = let measure n = let results = quickCheckPure n s prop
                                in  (countSuccesses results) / (length results)

                    measure' 0 = []
                    measure' n = measure' (n - 1) <> [measure (n * x)]

                    freqs = measure' 4

                    dists = (Math.abs <<< (-) freq) <$> freqs

                    dirs  = zipWith (\a b -> a - b) (1 : dists) dists

                    fails = length $ filter ((>) 0) dirs

                    succs = filter ((<=) 0) dirs

                in  if fails > 1 then
                      if x < 1000000 then try (x * 10)
                      else Failed $ "Divergence of statistical test: freqs = " ++ show freqs ++ ", dists = " ++ show dists ++ ", dirs = " ++ show dirs ++ ", fails: " ++ show fails
                    else maybe (Failed "Error!") (\l -> if l > 0.5 then Failed $ "Final convergence distance too low: " ++ show l else Success) (last succs)

statCheck :: forall prop. (Testable prop) => Number -> prop -> QC Unit
statCheck freq prop = do
  seed <- random
  trace <<< show $ statCheckPure seed freq prop

defState :: Number -> GenState
defState s = (GenState {seed: s, size: 10})

check :: forall prop. (Testable prop) => (Seed -> prop -> [Result]) -> prop -> QC Unit
check f prop = do
  seed <- random
  let results   = f seed prop
  let successes = countSuccesses results
  trace $ show successes ++ "/" ++ show (length results) ++ " test(s) passed."
  throwOnFirstFailure 1 results

throwOnFirstFailure :: Number -> [Result] -> QC Unit
throwOnFirstFailure _ []                  = return unit
throwOnFirstFailure n (Failed msg : _)    = throwException $ error $ "Test " ++ show n ++ " failed: \n" ++ msg
throwOnFirstFailure n (_          : rest) = throwOnFirstFailure (n + 1) rest

countSuccesses :: [Result] -> Number
countSuccesses = countSuccesses' 0
  where countSuccesses' acc []               = acc
        countSuccesses' acc (Success : rest) = countSuccesses' (acc + 1) rest
        countSuccesses' acc (_       : rest) = countSuccesses' acc rest

maxNumber :: Number
maxNumber = 9007199254740992

runAlphaNumString (AlphaNumString s) = s

runSignum (Signum n) = n

runPositive (Positive n) = n

runNegative (Negative n) = n

runNonZero (NonZero n) = n

instance showResult :: Show Result where
  show Success      = "Success"
  show (Failed msg) = "Failed: " ++ msg

instance semigroupResult :: Semigroup Result where
  (<>) Success Success          = Success
  (<>) (Failed msg) Success     = Failed msg
  (<>) Success (Failed msg)     = Failed msg
  (<>) (Failed m1) (Failed m2)  = Failed (m1 <> m2)

instance monoidResult :: Monoid Result where
  mempty = Success

instance arbNumber :: Arbitrary Number where
  arbitrary = uniform

instance coarbNumber :: CoArbitrary Number where
  coarbitrary = perturbGen

instance arbPositive :: Arbitrary Positive where
  arbitrary = Positive <$> ((*) maxNumber) <$> uniform

instance coarbPositive :: CoArbitrary Positive where
  coarbitrary (Positive n) = coarbitrary n

instance arbNegative :: Arbitrary Negative where
  arbitrary = Negative <$> ((*) (-maxNumber)) <$> uniform

instance coarbNegative :: CoArbitrary Negative where
  coarbitrary (Negative n) = coarbitrary n

instance arbNonZero :: Arbitrary NonZero where
  arbitrary = do n <- arbitrary
                 b <- arbitrary
                 let sign = if b then 1.0 else -1.0
                 return $ NonZero (n * maxNumber * sign)

instance coarbNonZero :: CoArbitrary NonZero where
  coarbitrary (NonZero n) = coarbitrary n

instance arbSignum :: Arbitrary Signum where
  arbitrary = do b <- arbitrary
                 return $ Signum (if b then 1 else -1)

instance coarbSignum :: CoArbitrary Signum where
  coarbitrary (Signum n) = coarbitrary n

instance arbBoolean :: Arbitrary Boolean where
  arbitrary = do
    n <- uniform
    return $ (n * 2) < 1

instance coarbBoolean :: CoArbitrary Boolean where
  coarbitrary true  = perturbGen 1
  coarbitrary false = perturbGen 2

instance arbChar :: Arbitrary Char where
  arbitrary = fromCharCode <<< ((*) 65535) <$> uniform

instance coarbChar :: CoArbitrary Char where
  coarbitrary c = coarbitrary $ toCharCode c

instance arbString :: Arbitrary String where
  arbitrary = S.fromCharArray <$> arbitrary

instance coarbString :: CoArbitrary String where
  coarbitrary s = coarbitrary $ (S.charCodeAt 0 <$> S.split "" s)

instance arbAlphaNumString :: Arbitrary AlphaNumString where
  arbitrary = do
    arrNum <- arbitrary
    return $ fromJust $ (AlphaNumString <<< S.fromCharArray) <$> sequence (lookup <$> arrNum) where
      chars = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"

      lookup x = S.charAt index chars where
        index = Math.min (S.length chars - 1) $ floor (x * (S.length chars))

instance coarbAlphaNumString :: CoArbitrary AlphaNumString where
  coarbitrary (AlphaNumString s) = coarbitrary s

instance arbTuple :: (Arbitrary a, Arbitrary b) => Arbitrary (Tuple a b) where
  arbitrary = Tuple <$> arbitrary <*> arbitrary

instance coarbTuple :: (CoArbitrary a, CoArbitrary b) => CoArbitrary (Tuple a b) where
  coarbitrary (Tuple a b) = coarbitrary a >>> coarbitrary b

instance arbEither :: (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where
  arbitrary = do
    b <- arbitrary
    if b then Left <$> arbitrary else Right <$> arbitrary

instance coarbEither :: (CoArbitrary a, CoArbitrary b) => CoArbitrary (Either a b) where
  coarbitrary (Left a)  = coarbitrary a
  coarbitrary (Right b) = coarbitrary b

instance arbMaybe :: (Arbitrary a) => Arbitrary (Maybe a) where
  arbitrary = do
    b <- arbitrary
    if b then pure Nothing else Just <$> arbitrary

instance coarbMaybe :: (CoArbitrary a) => CoArbitrary (Maybe a) where
  coarbitrary Nothing = perturbGen 1
  coarbitrary (Just a) = coarbitrary a

instance arbFunction :: (CoArbitrary a, Arbitrary b) => Arbitrary (a -> b) where
  arbitrary = repeatable (\a -> coarbitrary a arbitrary)

instance coarbFunction :: (Arbitrary a, CoArbitrary b) => CoArbitrary (a -> b) where
  coarbitrary f gen = do
    xs <- arbitrary
    coarbitrary (map f xs) gen

instance arbArray :: (Arbitrary a) => Arbitrary [a] where
  arbitrary = do
    b <- arbitrary
    if b then return [] else do
      a <- arbitrary
      as <- arbitrary
      return (a : as)

instance coarbArray :: (CoArbitrary a) => CoArbitrary [a] where
  coarbitrary [] = id
  coarbitrary (x : xs) = coarbitrary xs <<< coarbitrary x

instance testableResult :: Testable Result where
  test = return

instance testableBoolean :: Testable Boolean where
  test true = return Success
  test false = return $ Failed "Test returned false"

instance testableFunction :: (Arbitrary t, Testable prop) => Testable (t -> prop) where
  test f = do
    t <- arbitrary
    test (f t)

module Test.QuickCheck
  ( (<?>)
  , AlphaNumString(..)
  , Arbitrary
  , CoArbitrary
  , Negative(..)
  , NonZero(..)
  , Positive(..)
  , QC(..)
  , arbitrary
  , coarbitrary
  , quickCheck
  , quickCheck'
  , quickCheckPure
  , Result(..)
  , runAlphaNumString
  , runNegative
  , runNonZero
  , runPositive
  , runSignum
  , Signum(..)
  , smallCheck
  , smallCheckPure
  , statCheck
  , statCheckPure
  , test
  , Testable
  ) where

import Debug.Trace
import Control.Monad.Eff
import Control.Monad.Trampoline
import Control.Bind
import Control.Monad.Eff.Random
import Control.Monad.Eff.Exception
import Data.Array
import Data.Tuple
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Monoid
import Data.Either
import Data.Traversable
import Math

import qualified Data.String as S
import Data.Char

import Test.QuickCheck.LCG

class Arbitrary t where
  arbitrary :: Gen t

class CoArbitrary t where
  coarbitrary :: forall r. t -> Gen r -> Gen r

class Testable prop where
  test :: prop -> Gen Result

newtype AlphaNumString = AlphaNumString String

newtype Positive = Positive Number

newtype Negative = Negative Number

newtype NonZero  = NonZero Number

newtype Signum   = Signum Number

type QC a = forall eff. Eff (trace :: Trace, random :: Random, err :: Exception | eff) a

data Result = Success | Failed String

(<?>) :: Boolean -> String -> Result
(<?>) true  = const Success
(<?>) false = Failed

quickCheckPure :: forall prop. (Testable prop) => Number -> Seed -> prop -> [Result]
quickCheckPure n s prop = runTrampoline $ sample' n (defState s) (test prop)

quickCheck' :: forall prop. (Testable prop) => Number -> prop -> QC Unit
quickCheck' n prop = check (quickCheckPure n) prop

quickCheck :: forall prop. (Testable prop) => prop -> QC Unit
quickCheck prop = quickCheck' 100 prop

smallCheckPure :: forall prop. (Testable prop) => Number -> prop -> [Result]
smallCheckPure s prop = runTrampoline $ collectAll (defState s) (test prop)

smallCheck :: forall prop. (Testable prop) => prop -> QC Unit
smallCheck prop = check smallCheckPure prop

statCheckPure :: forall prop. (Testable prop) => Seed -> Number -> prop -> Result
statCheckPure s freq prop = try 100
  where try x = let measure n = let results = quickCheckPure n s prop
                                in  (countSuccesses results) / (length results)

                    measure' 0 = []
                    measure' n = measure' (n - 1) <> [measure (n * x)]

                    freqs = measure' 4

                    dists = (Math.abs <<< (-) freq) <$> freqs

                    dirs  = zipWith (\a b -> a - b) (1 : dists) dists

                    fails = length $ filter ((>) 0) dirs

                    succs = filter ((<=) 0) dirs

                in  if fails > 1 then
                      if x < 1000000 then try (x * 10)
                      else Failed $ "Divergence of statistical test: freqs = " ++ show freqs ++ ", dists = " ++ show dists ++ ", dirs = " ++ show dirs ++ ", fails: " ++ show fails
                    else maybe (Failed "Error!") (\l -> if l > 0.5 then Failed $ "Final convergence distance too low: " ++ show l else Success) (last succs)

statCheck :: forall prop. (Testable prop) => Number -> prop -> QC Unit
statCheck freq prop = do
  seed <- random
  trace <<< show $ statCheckPure seed freq prop

defState :: Number -> GenState
defState s = (GenState {seed: s, size: 10})

check :: forall prop. (Testable prop) => (Seed -> prop -> [Result]) -> prop -> QC Unit
check f prop = do
  seed <- random
  let results   = f seed prop
  let successes = countSuccesses results
  trace $ show successes ++ "/" ++ show (length results) ++ " test(s) passed."
  throwOnFirstFailure 1 results

throwOnFirstFailure :: Number -> [Result] -> QC Unit
throwOnFirstFailure _ []                  = return unit
throwOnFirstFailure n (Failed msg : _)    = throwException $ error $ "Test " ++ show n ++ " failed: \n" ++ msg
throwOnFirstFailure n (_          : rest) = throwOnFirstFailure (n + 1) rest

countSuccesses :: [Result] -> Number
countSuccesses = countSuccesses' 0
  where countSuccesses' acc []               = acc
        countSuccesses' acc (Success : rest) = countSuccesses' (acc + 1) rest
        countSuccesses' acc (_       : rest) = countSuccesses' acc rest

maxNumber :: Number
maxNumber = 9007199254740992

runAlphaNumString (AlphaNumString s) = s

runSignum (Signum n) = n

runPositive (Positive n) = n

runNegative (Negative n) = n

runNonZero (NonZero n) = n

instance showResult :: Show Result where
  show Success      = "Success"
  show (Failed msg) = "Failed: " ++ msg

instance semigroupResult :: Semigroup Result where
  (<>) Success Success          = Success
  (<>) (Failed msg) Success     = Failed msg
  (<>) Success (Failed msg)     = Failed msg
  (<>) (Failed m1) (Failed m2)  = Failed (m1 <> m2)

instance monoidResult :: Monoid Result where
  mempty = Success

instance arbNumber :: Arbitrary Number where
  arbitrary = uniform

instance coarbNumber :: CoArbitrary Number where
  coarbitrary = perturbGen

instance arbPositive :: Arbitrary Positive where
  arbitrary = Positive <$> ((*) maxNumber) <$> uniform

instance coarbPositive :: CoArbitrary Positive where
  coarbitrary (Positive n) = coarbitrary n

instance arbNegative :: Arbitrary Negative where
  arbitrary = Negative <$> ((*) (-maxNumber)) <$> uniform

instance coarbNegative :: CoArbitrary Negative where
  coarbitrary (Negative n) = coarbitrary n

instance arbNonZero :: Arbitrary NonZero where
  arbitrary = do n <- arbitrary
                 b <- arbitrary
                 let sign = if b then 1.0 else -1.0
                 return $ NonZero (n * maxNumber * sign)

instance coarbNonZero :: CoArbitrary NonZero where
  coarbitrary (NonZero n) = coarbitrary n

instance arbSignum :: Arbitrary Signum where
  arbitrary = do b <- arbitrary
                 return $ Signum (if b then 1 else -1)

instance coarbSignum :: CoArbitrary Signum where
  coarbitrary (Signum n) = coarbitrary n

instance arbBoolean :: Arbitrary Boolean where
  arbitrary = do
    n <- uniform
    return $ (n * 2) < 1

instance coarbBoolean :: CoArbitrary Boolean where
  coarbitrary true  = perturbGen 1
  coarbitrary false = perturbGen 2

instance arbChar :: Arbitrary Char where
  arbitrary = fromCharCode <<< ((*) 65535) <$> uniform

instance coarbChar :: CoArbitrary Char where
  coarbitrary c = coarbitrary $ toCharCode c

instance arbString :: Arbitrary String where
  arbitrary = do
    arr <- arbitrary
    return $ S.fromCharArray arr

instance coarbString :: CoArbitrary String where
  coarbitrary s = coarbitrary $ (S.charCodeAt 0 <$> S.split "" s)

instance arbAlphaNumString :: Arbitrary AlphaNumString where
  arbitrary = do
    arrNum <- arbitrary
    return $ fromJust $ (AlphaNumString <<< S.fromCharArray) <$> sequence (lookup <$> arrNum) where
      chars = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"

      lookup x = S.charAt index chars where
        index = Math.min (S.length chars - 1) $ floor (x * (S.length chars))

instance coarbAlphaNumString :: CoArbitrary AlphaNumString where
  coarbitrary (AlphaNumString s) = coarbitrary s

instance arbTuple :: (Arbitrary a, Arbitrary b) => Arbitrary (Tuple a b) where
  arbitrary = Tuple <$> arbitrary <*> arbitrary

instance coarbTuple :: (CoArbitrary a, CoArbitrary b) => CoArbitrary (Tuple a b) where
  coarbitrary (Tuple a b) = coarbitrary a >>> coarbitrary b

instance arbEither :: (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where
  arbitrary = do
    b <- arbitrary
    if b then Left <$> arbitrary else Right <$> arbitrary

instance coarbEither :: (CoArbitrary a, CoArbitrary b) => CoArbitrary (Either a b) where
  coarbitrary (Left a)  = coarbitrary a
  coarbitrary (Right b) = coarbitrary b

instance arbMaybe :: (Arbitrary a) => Arbitrary (Maybe a) where
  arbitrary = do
    b <- arbitrary
    if b then pure Nothing else Just <$> arbitrary

instance coarbMaybe :: (CoArbitrary a) => CoArbitrary (Maybe a) where
  coarbitrary Nothing = perturbGen 1
  coarbitrary (Just a) = coarbitrary a

instance arbFunction :: (CoArbitrary a, Arbitrary b) => Arbitrary (a -> b) where
  arbitrary = repeatable (\a -> coarbitrary a arbitrary)

instance coarbFunction :: (Arbitrary a, CoArbitrary b) => CoArbitrary (a -> b) where
  coarbitrary f gen = do
    xs <- arbitrary
    coarbitrary (map f xs) gen

instance arbArray :: (Arbitrary a) => Arbitrary [a] where
  arbitrary = do
    b <- arbitrary
    if b then return [] else do
      a <- arbitrary
      as <- arbitrary
      return (a : as)

instance coarbArray :: (CoArbitrary a) => CoArbitrary [a] where
  coarbitrary [] = id
  coarbitrary (x : xs) = coarbitrary xs <<< coarbitrary x

instance testableResult :: Testable Result where
  test = return

instance testableBoolean :: Testable Boolean where
  test true = return Success
  test false = return $ Failed "Test returned false"

instance testableFunction :: (Arbitrary t, Testable prop) => Testable (t -> prop) where
  test f = do
    t <- arbitrary
    test (f t)


fixes identifier validation

fixes identifier validation

module Data.Identifier
       ( Identifier
       , identifier
       , identifierParser
       , getIdentifierRepresentation
       ) where

import Prelude
import Control.Alt ((<|>))
import Data.Array (many, singleton)
import Data.Either (Either)
import Data.String (fromCharArray)
import Data.String.Regex (Regex, regex)
import Data.String.Regex.Flags (noFlags)
import Text.Parsing.Parser.String (char)
import Text.Parsing.Parser.Token (digit)

import Parsers (StringParser, englishLetter)
import Validators (Validated, matches', toValidated')

newtype Identifier = Identifier String

instance eqIdentifier :: Eq Identifier where
  eq (Identifier a) (Identifier b) = a == b

instance ordIdentifier :: Ord Identifier where
  compare (Identifier a) (Identifier b) = compare a b

instance showIdentifier :: Show Identifier where
  show (Identifier a) = "Identifier " <> show a

identifier :: String -> Validated Identifier
identifier x =
  Identifier <$>
    matches' (toValidated' identifierRegex) "identifier format is not valid" x

identifierRegex :: Either String Regex
identifierRegex = regex "^[\\_a-z][\\_a-z0-9]*$" noFlags

identifierParser :: StringParser Identifier
identifierParser = do
  c  <- char '_' <|> englishLetter
  cs <- many $ char '_' <|> englishLetter <|> digit
  pure $ Identifier $ fromCharArray (singleton c <> cs)

getIdentifierRepresentation :: Identifier -> String
getIdentifierRepresentation (Identifier s) = s

module Data.Identifier
       ( Identifier
       , identifier
       , identifierParser
       , getIdentifierRepresentation
       ) where

import Prelude
import Control.Alt ((<|>))
import Data.Array (many, singleton)
import Data.Either (Either)
import Data.String (fromCharArray)
import Data.String.Regex (Regex, regex)
import Data.String.Regex.Flags (ignoreCase)
import Text.Parsing.Parser.String (char)
import Text.Parsing.Parser.Token (digit)

import Parsers (StringParser, englishLetter)
import Validators (Validated, matches', toValidated')

newtype Identifier = Identifier String

instance eqIdentifier :: Eq Identifier where
  eq (Identifier a) (Identifier b) = a == b

instance ordIdentifier :: Ord Identifier where
  compare (Identifier a) (Identifier b) = compare a b

instance showIdentifier :: Show Identifier where
  show (Identifier a) = "Identifier " <> show a

identifier :: String -> Validated Identifier
identifier x =
  Identifier <$>
    matches' (toValidated' identifierRegex) "identifier format is not valid" x

identifierRegex :: Either String Regex
identifierRegex = regex "^[\\_a-z][\\_a-z0-9]*$" ignoreCase

identifierParser :: StringParser Identifier
identifierParser = do
  c  <- char '_' <|> englishLetter
  cs <- many $ char '_' <|> englishLetter <|> digit
  pure $ Identifier $ fromCharArray (singleton c <> cs)

getIdentifierRepresentation :: Identifier -> String
getIdentifierRepresentation (Identifier s) = s


Use "location.assign" instead of "location ="

As it currently stands, the stable release of closure-compiler errors
out due to the use of "location = value;".

See:
https://groups.google.com/forum/#!topic/closure-compiler-discuss/sbAQr18Xe9g

According to
https://developer.mozilla.org/en-US/docs/Web/API/window.location,
`window.location` is technically read-only but lets you assign to it
using `=` anyway, to change the URL.

Because of that, this is definitely a closure-compiler issue (and was
fixed in git), but it seems like a simple enough change that can be
made in purescript-simple-dom so that the stable closure-compiler can
work with it too.

There is no functionality change at all, this simply uses `.assign()`
instead of `=` and according to the specification, they do the same thing.

Signed-off-by: Ricky Elrod <3de8762d49a778edd8b1aa9f381ea5a9ccb62944@elrod.me>

module Data.DOM.Simple.Unsafe.Window where

import Control.Monad.Eff

import Data.DOM.Simple.Types

foreign import unsafeDocument
  "function unsafeDocument(win) {    \
  \  return function () {            \
  \    return win.document;          \
  \  };                              \
  \}" :: forall eff a. a -> (Eff (dom :: DOM | eff) HTMLDocument)

foreign import unsafeLocation
  "function unsafeLocation(win) {   \
  \  return function () {           \
  \    return win.location;         \
  \  };                             \
  \}" :: forall eff a. a -> (Eff (dom :: DOM | eff) DOMLocation)

-- hmmm. useless re-cast?
foreign import unsafeGetLocation
  "function unsafeGetLocation(loc) {\
  \  return function () {           \
  \    return loc;                  \
  \  };                             \
  \}" :: forall eff a. a -> (Eff (dom :: DOM | eff) String)

foreign import unsafeSetLocation
  "function unsafeSetLocation(value) {  \
  \  return function (loc) {            \
  \    return function () {             \
  \      location.assign(value);        \
  \    };                               \
  \  };                                 \
  \}" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeGetSearchLocation
  "function unsafeGetSearchLocation(loc) { \
  \  return function () {                  \
  \    return loc.search;                  \
  \  };                                    \
  \}" :: forall eff a. a -> (Eff (dom :: DOM | eff) String)

foreign import unsafeSetTimeout
  "function unsafeSetTimeout(win) { \
  \  return function(delay) { \
  \    return function(func) { \
  \      return function() { \
  \        return win.setTimeout(func, delay); \
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall eff b. b -> Number -> Eff eff Unit -> (Eff (dom :: DOM | eff) Timeout)

foreign import unsafeSetInterval
  "function unsafeSetInterval(win) { \
  \  return function(delay) { \
  \    return function(func) { \
  \      return function() { \
  \        return win.setInterval(func, delay); \
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall eff b. b -> Number -> Eff eff Unit -> (Eff (dom :: DOM | eff) Timeout)

foreign import unsafeClearTimeout
  "function unsafeClearTimeout(win) { \
  \  return function(timeout) { \
  \    return function() { \
  \      win.clearTimeout(timeout); \
  \    }; \
  \  }; \
  \}" :: forall eff b. b -> Timeout -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeInnerWidth
  "function unsafeInnerWidth(win) { \
  \  return function() { \
  \    return win.innerWidth; \
  \  }; \
  \}" :: forall eff b. b -> (Eff (dom :: DOM | eff) Number)

foreign import unsafeInnerHeight
  "function unsafeInnerHeight(win) { \
  \  return function() { \
  \    return win.innerHeight; \
  \  }; \
  \}" :: forall eff b. b -> (Eff (dom :: DOM | eff) Number)

module Data.DOM.Simple.Unsafe.Window where

import Control.Monad.Eff

import Data.DOM.Simple.Types

foreign import unsafeDocument
  "function unsafeDocument(win) {    \
  \  return function () {            \
  \    return win.document;          \
  \  };                              \
  \}" :: forall eff a. a -> (Eff (dom :: DOM | eff) HTMLDocument)

foreign import unsafeLocation
  "function unsafeLocation(win) {   \
  \  return function () {           \
  \    return win.location;         \
  \  };                             \
  \}" :: forall eff a. a -> (Eff (dom :: DOM | eff) DOMLocation)

-- hmmm. useless re-cast?
foreign import unsafeGetLocation
  "function unsafeGetLocation(loc) {\
  \  return function () {           \
  \    return loc;                  \
  \  };                             \
  \}" :: forall eff a. a -> (Eff (dom :: DOM | eff) String)

foreign import unsafeSetLocation
  "function unsafeSetLocation(value) {  \
  \  return function (loc) {            \
  \    return function () {             \
  \      location = value;              \
  \    };                               \
  \  };                                 \
  \}" :: forall eff a. String -> a -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeGetSearchLocation
  "function unsafeGetSearchLocation(loc) { \
  \  return function () {                  \
  \    return loc.search;                  \
  \  };                                    \
  \}" :: forall eff a. a -> (Eff (dom :: DOM | eff) String)

foreign import unsafeSetTimeout
  "function unsafeSetTimeout(win) { \
  \  return function(delay) { \
  \    return function(func) { \
  \      return function() { \
  \        return win.setTimeout(func, delay); \
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall eff b. b -> Number -> Eff eff Unit -> (Eff (dom :: DOM | eff) Timeout)

foreign import unsafeSetInterval
  "function unsafeSetInterval(win) { \
  \  return function(delay) { \
  \    return function(func) { \
  \      return function() { \
  \        return win.setInterval(func, delay); \
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall eff b. b -> Number -> Eff eff Unit -> (Eff (dom :: DOM | eff) Timeout)

foreign import unsafeClearTimeout
  "function unsafeClearTimeout(win) { \
  \  return function(timeout) { \
  \    return function() { \
  \      win.clearTimeout(timeout); \
  \    }; \
  \  }; \
  \}" :: forall eff b. b -> Timeout -> (Eff (dom :: DOM | eff) Unit)

foreign import unsafeInnerWidth
  "function unsafeInnerWidth(win) { \
  \  return function() { \
  \    return win.innerWidth; \
  \  }; \
  \}" :: forall eff b. b -> (Eff (dom :: DOM | eff) Number)

foreign import unsafeInnerHeight
  "function unsafeInnerHeight(win) { \
  \  return function() { \
  \    return win.innerHeight; \
  \  }; \
  \}" :: forall eff b. b -> (Eff (dom :: DOM | eff) Number)


Add addRow method to Tab

Add addRow method to Tab

Signed-off-by: Joern Bernhardt <7b85a41a628204b76aba4326273a3ccc74bd009a@campudus.com>

module Tab
  ( Cell
  , Col
  , class ColType
  , kind
  , Tab
  ) where

import Prelude
import Data.Maybe (Maybe(..))
import Data.Vec
import Data.Vec (empty, snoc) as Vec
import Data.List
import Data.Typelevel.Num (class Nat, class Succ, D0)

type Col x = ColType x =>
  { id :: Int
  , name :: String
  , kind :: x
  }

class ColType a where
  kind :: a

instance stringCol :: ColType String where
  kind = ""

type Cell a = Maybe a

class Conv a where
  conv :: ColType a => a -> Cell a

instance convAny :: Conv a where
  conv x = Just x

newtype Tab size cols cells = Tab
  { columns :: Vec size cols
  , rows :: List (Vec size cells)
  }

empty :: forall cols rows. Tab D0 cols rows
empty = Tab
  { columns : Vec.empty
  , rows : Nil
  }

-- addColumn :: forall s0 c0 r0 s1 c1 r1 ck. Tab s0 c0 r0 => Tab s1 c1 r1 => ColType ck => Tab s0 c0 r0 -> Col ck -> Tab s1 c1 r1
addColumn (Tab table) column = Tab
  { columns : Vec.snoc column table.columns
  , rows : map (\row -> Vec.snoc Nothing row) table.rows
  }

addRow (Tab table) row = Tab
  { columns : table.columns
  , rows : (Cons row table.rows)
  }

module Tab
  ( Cell
  , Col
  , class ColType
  , kind
  , Tab
  ) where

import Prelude
import Data.Maybe (Maybe(..))
import Data.Vec
import Data.Vec (empty, snoc) as Vec
import Data.List
import Data.Typelevel.Num (class Nat, class Succ, D0)

type Col x = ColType x =>
  { id :: Int
  , name :: String
  , kind :: x
  }

class ColType a where
  kind :: a

instance stringCol :: ColType String where
  kind = ""

type Cell a = Maybe a

class Conv a where
  conv :: ColType a => a -> Cell a

instance convAny :: Conv a where
  conv x = Just x

newtype Tab size cols cells = Tab
  { columns :: Vec size cols
  , rows :: List (Vec size cells)
  }

empty :: forall cols rows. Tab D0 cols rows
empty = Tab
  { columns : Vec.empty
  , rows : Nil
  }

-- addColumn :: forall s0 s1 c0 c1 ck r0 r1. Succ s0 s1 => ColType ck => Tab s0 c0 r0 -> Col ck -> Tab s1 c1 r1
addColumn (Tab table) column = Tab
  { columns : Vec.snoc column table.columns
  , rows : map (\row -> Vec.snoc Nothing row) table.rows
  }


Types compiles!

Types compiles!

module Types where

import Prelude
import Data.Maybe
import Data.Traversable
import Data.Foldable
import Data.Function
import Data.Map (Map())
import Data.Map as Map
import Data.Either (Either())
import Data.Either as E
import Data.Argonaut.Core
import Data.Argonaut.Encode
import Data.Argonaut.Decode
import Data.Argonaut.Combinators ((:=), (.?))
import Data.Tuple
import Data.String hiding (singleton, uncons)
import Data.Array (singleton)
import Data.Sequence as S
import Data.Generic
import Graphics.Canvas
import Control.Monad.Writer.Trans
import Control.Monad.Writer.Class
import Control.Monad.State
import Control.Monad.State.Class
import Control.Monad.Eff
import Control.Monad.Eff.Ref
import DOM.Timer
import Data.Lens
import Data.Lens.Getter ((^.))
import Data.Lens.Setter (over)
import Data.Lens.Types (LensP())
import DOM (DOM())
import Math (floor, pi, pow)

import GenericMap
import Utils
import NodeWebSocket as WS
import WebSocket as BWS

-- newtype wrapper is just for instances. We have to duplicate the type synonym
-- because of psc bug #1443
type Game =
  { map :: WrappedLevelMap
  , players :: GenericMap PlayerId Player
  , items   :: GenericMap ItemId Item
  , countdown :: Maybe Number
  , rampage :: Maybe Rampage
  , safeZone :: Array Position
  }

newtype WrappedGame = WrappedGame
  { map :: WrappedLevelMap
  , players :: GenericMap PlayerId Player
  , items   :: GenericMap ItemId Item
  , countdown :: Maybe Number
  , rampage :: Maybe Rampage
  , safeZone :: Array Position
  }

derive instance genericWrappedGame :: Generic WrappedGame

unwrapGame :: WrappedGame -> Game
unwrapGame (WrappedGame g) = g

instance encodeJsonWrappedGame :: EncodeJson WrappedGame where
  encodeJson = gEncodeJson

instance decodeJsonWrappedGame :: DecodeJson WrappedGame where
  decodeJson = gDecodeJson

data PlayerId = P1 | P2 | P3 | P4

derive instance genericPlayerId :: Generic PlayerId

allPlayerIds :: Array PlayerId
allPlayerIds = [P1, P2, P3, P4]

playerIdToInt :: PlayerId -> Int
playerIdToInt p =
  case p of
    P1 -> 1
    P2 -> 2
    P3 -> 3
    P4 -> 4

intToPlayerId :: Int -> Maybe PlayerId
intToPlayerId x =
  case x of
    1 -> Just P1
    2 -> Just P2
    3 -> Just P3
    4 -> Just P4
    _ -> Nothing

instance showPlayerId :: Show PlayerId where
  show = gShow

instance eqPlayerId :: Eq PlayerId where
  eq = gEq

instance ordPlayerId :: Ord PlayerId where
  compare = gCompare

instance decodeJsonPlayerId :: DecodeJson PlayerId where
  decodeJson = gDecodeJson

instance encodeJsonPlayerId :: EncodeJson PlayerId where
  encodeJson = gEncodeJson

type ItemId = Number

-- psc bug #1443
type LevelMap =
  { blocks   :: Array (Array Block)
  , tiles    :: Array (Array Tile)
  }

newtype WrappedLevelMap = WrappedLevelMap
  { blocks   :: Array (Array Block)
  , tiles    :: Array (Array Tile)
  }

derive instance genericLevelMap :: Generic WrappedLevelMap

instance encodeJsonLevelMap :: EncodeJson WrappedLevelMap where
  encodeJson = gEncodeJson

instance decodeJsonLevelMap :: DecodeJson WrappedLevelMap where
  decodeJson = gDecodeJson

data Block = Wall | Empty

derive instance genericBlock :: Generic Block

instance showBlock :: Show Block where
  show = gShow

instance encodeJsonBlock :: EncodeJson Block where
  encodeJson = gEncodeJson

instance decodeJSONBlock :: DecodeJson Block where
  decodeJson = gDecodeJson

-- A fixed size two-dimensional array of blocks.
type BlockTile = Array (Array Block)

data Tile
  = Intersection
  | TeeJunctionUp
  | TeeJunctionRight
  | TeeJunctionDown
  | TeeJunctionLeft
  | CornerUpRight
  | CornerRightDown
  | CornerDownLeft
  | CornerLeftUp
  | StraightHorizontal
  | StraightVertical
  | Inaccessible

derive instance genericTile :: Generic Tile

instance showTile :: Show Tile where
  show = gShow

instance encodeJsonTile :: EncodeJson Tile where
  encodeJson = gEncodeJson

instance decodeJsonTile :: DecodeJson Tile where
  decodeJson = gDecodeJson

isWall :: Block -> Boolean
isWall Wall = true
isWall _ = false

showRecord :: String -> Array String -> String
showRecord name props =
    "(" <> name <> " {" <> joinWith ", " props <> "})"

(.::) :: forall a. (Show a) => String -> a -> String
(.::) name value = name <> ": " <> show value

failJsonParse :: forall a b. (Show a) => a -> String -> Either String b
failJsonParse value typ =
  E.Left $ "failed to parse " <> show value <> " as " <> typ <> "."

newtype Position = Position {x :: Number, y :: Number}

derive instance genericPosition :: Generic Position

instance showPosition :: Show Position where
  show = gShow

instance eqPosition :: Eq Position where
  eq = gEq

instance decodeJsonPosition :: DecodeJson Position where
  decodeJson = gDecodeJson

instance encodeJsonPosition :: EncodeJson Position where
  encodeJson = gEncodeJson

addPos :: Position -> Position -> Position
addPos (Position p) (Position q) = Position {x: p.x + q.x, y: p.y + q.y}

scalePos :: Number -> Position -> Position
scalePos s (Position p) = Position {x: s * p.x, y: s * p.y}

quadrance :: Position -> Position -> Number
quadrance (Position p) (Position q) =
  ((p.x - q.x) `pow` 2.0) + ((p.y - q.y) `pow` 2.0)

data GameObject = GOPlayer Player | GOItem Item

derive instance genericGameObject :: Generic GameObject

newtype Player
  = Player
      { position :: Position
      , direction :: Maybe Direction
      , intendedDirection :: Maybe Direction
      , score :: Int
      , nomIndex :: Int
      , respawnCounter :: Maybe Int
      }

derive instance genericPlayer :: Generic Player

instance encodeJsonPlayer :: EncodeJson Player where
  encodeJson = gEncodeJson

instance decodeJsonPlayer :: DecodeJson Player where
  decodeJson = gDecodeJson

nomIndexMax = 10

mkPlayer :: Position -> Player
mkPlayer pos =
  Player { position: pos
         , direction: Nothing
         , intendedDirection: Nothing
         , score: 0
         , nomIndex: nomIndexMax / 2
         , respawnCounter: Nothing
         }

players :: LensP Game (Map PlayerId Player)
players = lens (\o -> runGenericMap o.players) (\o x -> o { players = GenericMap x })

items :: LensP Game (Map ItemId Item)
items = lens (\o -> runGenericMap o.items) (\o x -> o { items = GenericMap x })

pPosition :: LensP Player Position
pPosition = lens
  (\(Player p) -> p.position)
  (\(Player p) pos -> Player $ p { position = pos })

pDirection :: LensP Player (Maybe Direction)
pDirection = lens
  (\(Player p) -> p.direction)
  (\(Player p) dir -> Player $ p { direction = dir })

pIntendedDirection :: LensP Player (Maybe Direction)
pIntendedDirection = lens
  (\(Player p) -> p.intendedDirection)
  (\(Player p) dir -> Player $ p { intendedDirection = dir })

pScore :: LensP Player Int
pScore = lens
  (\(Player p) -> p.score)
  (\(Player p) s -> Player $ p { score = s })

pNomIndex :: LensP Player Int
pNomIndex = lens
  (\(Player p) -> p.nomIndex)
  (\(Player p) s -> Player $ p { nomIndex = s })

pRespawnCounter :: LensP Player (Maybe Int)
pRespawnCounter = lens
  (\(Player p) -> p.respawnCounter)
  (\(Player p) s -> Player $ p { respawnCounter = s })

eachPlayer' :: forall f. (Applicative f) =>
  Game -> (PlayerId -> Player -> f Unit) -> f Unit
eachPlayer' game action =
  for_ (Map.toList $ game ^. players) $ uncurry action

eachPlayer :: (PlayerId -> Player -> GameUpdateM Unit) -> GameUpdateM Unit
eachPlayer action = do
  game <- getGame
  eachPlayer' game action

newtype Item
  = Item
     { position :: Position
     , itemType :: ItemType
     }

derive instance genericItem :: Generic Item

instance showItem :: Show Item where
  show = gShow

instance decodeJsonItem :: DecodeJson Item where
  decodeJson = gDecodeJson

instance encodeJsonItem :: EncodeJson Item where
  encodeJson = gEncodeJson

iType :: LensP Item ItemType
iType = lens
  (\(Item x) -> x.itemType)
  (\(Item x) typ -> Item $ x { itemType = typ })

iPosition :: LensP Item Position
iPosition = lens
  (\(Item x) -> x.position)
  (\(Item x) pos -> Item $ x { position = pos })

pX :: LensP Position Number
pX = lens
  (\(Position p) -> p.x)
  (\(Position p) x -> Position $ p { x = x })

pY :: LensP Position Number
pY = lens
  (\(Position p) -> p.y)
  (\(Position p) y -> Position $ p { y = y })

eachItem' :: forall f. (Applicative f) =>
  Game -> (Item -> f Unit) -> f Unit
eachItem' game action =
  for_ (game ^. items) action

data Direction = Up | Down | Left | Right

derive instance genericDirection :: Generic Direction

instance showDirection :: Show Direction where
  show = gShow

instance decodeJsonDirection :: DecodeJson Direction where
  decodeJson = gDecodeJson

instance encodeJsonDirection :: EncodeJson Direction where
  encodeJson = gEncodeJson

data ItemType = LittleDot | BigDot | Cherry

derive instance genericItemType :: Generic ItemType

instance showItemType :: Show ItemType where
  show = gShow

instance eqItemType :: Eq ItemType where
  eq = gEq

instance encodeJsonItemType :: EncodeJson ItemType where
  encodeJson = gEncodeJson

instance decodeJsonItemType :: DecodeJson ItemType where
  decodeJson = gDecodeJson

dirToPos :: Direction -> Position
dirToPos Up    = Position {x:  0.0, y: -1.0}
dirToPos Left  = Position {x: -1.0, y:  0.0}
dirToPos Right = Position {x:  1.0, y:  0.0}
dirToPos Down  = Position {x:  0.0, y:  1.0}

directionToRadians :: Direction -> Number
directionToRadians d =
  case d of
    Right -> 0.0
    Down -> pi / 2.0
    Left -> pi
    Up -> 3.0 * pi / 2.0

opposite d =
  case d of
    Up -> Down
    Down -> Up
    Right -> Left
    Left -> Right

type Input = Map PlayerId (Maybe Direction)

data PlayerUpdate
  = ChangedDirection (Maybe Direction)
  | ChangedIntendedDirection (Maybe Direction)
  | ChangedPosition Position
  | ChangedScore Number
  | ChangedNomIndex Number
  | ChangedRespawnCounter (Maybe Number)
  | PlayerLeft

derive instance genericPlayerUpdate :: Generic PlayerUpdate

instance showPlayerUpdate :: Show PlayerUpdate where
  show = gShow

instance decodeJsonPlayerUpdate :: DecodeJson PlayerUpdate where
  decodeJson = gDecodeJson

instance encodeJsonPlayerUpdate :: EncodeJson PlayerUpdate where
  encodeJson = gEncodeJson

data ItemUpdate
  = Eaten

derive instance genericItemUpdate :: Generic ItemUpdate

instance showItemUpdate :: Show ItemUpdate where
  show = gShow

instance decodeJsonItemUpdate :: DecodeJson ItemUpdate where
  decodeJson = gDecodeJson

instance encodeJsonItemUpdate :: EncodeJson ItemUpdate where
  encodeJson = gEncodeJson

data GameEndReason
  = Completed
  | TooManyPlayersDisconnected

derive instance genericGameEndReason :: Generic GameEndReason

instance showGameEndReason :: Show GameEndReason where
  show = gShow

instance encodeJsonGameEndReason :: EncodeJson GameEndReason where
  encodeJson = gEncodeJson

instance decodeJsonGameEndReason :: DecodeJson GameEndReason where
  decodeJson = gDecodeJson

data Rampage
  = Rampaging PlayerId Number
  | Cooldown Number

derive instance genericRampage :: Generic Rampage

instance encodeJsonRampage :: EncodeJson Rampage where
  encodeJson = gEncodeJson

instance decodeJsonRampage :: DecodeJson Rampage where
  decodeJson = gDecodeJson

data GameUpdate
  = GUPU PlayerId PlayerUpdate
  | GUIU ItemId ItemUpdate
  | ChangedCountdown (Maybe Number)
  | GameEnded GameEndReason
  | ChangedRampage (Maybe Rampage)

derive instance genericGameUpdate :: Generic GameUpdate

instance decodeJsonGameUpdate :: DecodeJson GameUpdate where
  decodeJson = gDecodeJson

instance encodeJsonGameUpdate :: EncodeJson GameUpdate where
  encodeJson = gEncodeJson

-- Sent by the server during the waiting stage, ie, after initial connection
-- but before the game starts
data WaitingUpdate
  = GameStarting WrappedGame
  | NewReadyStates (GenericMap PlayerId Boolean)

derive instance genericWaitingUpdate :: Generic WaitingUpdate

instance encodeJsonWaitingUpdate :: EncodeJson WaitingUpdate where
  encodeJson = gEncodeJson

instance decodeJsonWaitingUpdate :: DecodeJson WaitingUpdate where
  decodeJson = gDecodeJson

type GameUpdateM a = WriterT (S.Seq GameUpdate) (State WrappedGame) a

-- these are just here to shorten declarations that are required because of
-- types that psc is not able to infer
type GameUpdateState = WrappedGame
type GameUpdateModifier = GameUpdateState -> GameUpdateState

innerGame :: LensP WrappedGame Game
innerGame = lens (\(WrappedGame g) -> g) (const WrappedGame)

tellGameUpdate :: GameUpdate -> GameUpdateM Unit
tellGameUpdate = tell <<< S.singleton

modifyGame :: (Game -> Game) -> GameUpdateM Unit
modifyGame = modify <<< f
  where
  f :: (Game -> Game) -> GameUpdateModifier
  f = over innerGame

getGame :: GameUpdateM Game
getGame = gets f
  where
  f :: GameUpdateState -> Game
  f x = x ^. innerGame

runGameUpdateM :: forall a.
  Game -> GameUpdateM a -> Tuple a (Tuple Game (S.Seq GameUpdate))
runGameUpdateM game action =
  let a0 = runWriterT action
      a1 = runState a0 (WrappedGame game)
      rearrange (Tuple (Tuple x gus) (WrappedGame g))
        = Tuple x (Tuple g gus)

  in  rearrange a1

execGameUpdateM :: forall a.
  Game -> GameUpdateM a -> Tuple Game (S.Seq GameUpdate)
execGameUpdateM game action = snd $ runGameUpdateM game action

input_ = lens (\s -> s.input) (\s x -> s { input = x })
game_ = lens (\s -> s.game) (\s x -> s { game = x })

data GameState
  = WaitingForPlayers GameStateWaitingForPlayers
  | InProgress        GameStateInProgress

type GameStateWaitingForPlayers = Map PlayerId Boolean
type GameStateInProgress = { game :: Game, input :: Input }

type ReadyState = Boolean

data ServerOutgoingMessage
  = SOWaiting WaitingUpdate
  | SOInProgress (Array GameUpdate)

derive instance genericServerOutgoingMessage :: Generic ServerOutgoingMessage

instance encodeJsonServerOutgoingMessage :: EncodeJson ServerOutgoingMessage where
  encodeJson = gEncodeJson

instance decodeJsonServerOutgoingMessage :: DecodeJson ServerOutgoingMessage where
  decodeJson = gDecodeJson

asWaitingMessageO :: ServerOutgoingMessage -> Maybe WaitingUpdate
asWaitingMessageO (SOWaiting x) = Just x
asWaitingMessageO _ = Nothing

asInProgressMessageO :: ServerOutgoingMessage -> Maybe (Array GameUpdate)
asInProgressMessageO (SOInProgress x) = Just x
asInProgressMessageO _ = Nothing

data ServerIncomingMessage
  = SIToggleReadyState
  | SIInProgress Direction

derive instance genericServerIncomingMessage :: Generic ServerIncomingMessage

instance encodeJsonServerIncomingMessage :: EncodeJson ServerIncomingMessage where
  encodeJson = gEncodeJson

instance decodeJsonServerIncomingMessage :: DecodeJson ServerIncomingMessage where
  decodeJson = gDecodeJson

asWaitingMessage :: ServerIncomingMessage -> Maybe Unit
asWaitingMessage (SIToggleReadyState) = Just unit
asWaitingMessage _ = Nothing

asInProgressMessage :: ServerIncomingMessage -> Maybe Direction
asInProgressMessage (SIInProgress d) = Just d
asInProgressMessage _ = Nothing

matchMessage :: forall m a b. (Monad m, EncodeJson a) =>
  (a -> Maybe b) -> a -> (b -> m Unit) -> m Unit
matchMessage f msg action =
  maybe (return unit) action (f msg)

data ClientState
  = CWaitingForPlayers ClientStateWaiting
  | CInProgress        ClientStateInProgress

type ClientStateWaiting
  = { prevGame          :: Maybe Game
    , backgroundCleared :: Boolean
    , cachedHtml        :: String
    , readyStates       :: Map PlayerId Boolean
    }

type ClientStateInProgress
  = { game :: Game
    , prevGame :: Game
    , redrawMap :: Boolean
    , cachedHtml :: String
    }

type RenderingContext =
  { foreground :: Context2D
  , background :: Context2D
  }

redrawMap = lens
  (\s -> s.redrawMap)
  (\s x -> s { redrawMap = x })

backgroundCleared = lens
  (\s -> s.backgroundCleared)
  (\s x -> s { backgroundCleared = x })

readyStates = lens
  (\s -> s.readyStates)
  (\s x -> s { readyStates = x })

cachedHtml = lens
  (\s -> s.cachedHtml)
  (\s x -> s { cachedHtml = x })

module Types where

import Prelude
import Data.Maybe
import Data.Traversable
import Data.Foldable
import Data.Function
import Data.Map (Map())
import Data.Map as Map
import Data.Either (Either())
import Data.Either as E
import Data.Argonaut.Core
import Data.Argonaut.Encode
import Data.Argonaut.Decode
import Data.Argonaut.Combinators ((:=), (.?))
import Data.Tuple
import Data.String hiding (singleton, uncons)
import Data.Array (singleton)
import Data.Sequence as S
import Data.Generic
import Graphics.Canvas
import Control.Monad.Writer.Trans
import Control.Monad.Writer.Class
import Control.Monad.State
import Control.Monad.State.Class
import Control.Monad.Eff
import Control.Monad.Eff.Ref
import DOM.Timer
import Data.Lens
import Data.Lens.Getter ((^.))
import Data.Lens.Setter (over)
import Data.Lens.Types (LensP())
import DOM (DOM())
import Math (floor, pi, pow)

import GenericMap
import Utils
import NodeWebSocket as WS
import WebSocket as BWS

-- newtype wrapper is just for instances. We have to duplicate the type synonym
-- because of psc bug #1443
type Game =
  { map :: WrappedLevelMap
  , players :: GenericMap PlayerId Player
  , items   :: GenericMap ItemId Item
  , countdown :: Maybe Number
  , rampage :: Maybe Rampage
  , safeZone :: Array Position
  }

newtype WrappedGame = WrappedGame
  { map :: WrappedLevelMap
  , players :: GenericMap PlayerId Player
  , items   :: GenericMap ItemId Item
  , countdown :: Maybe Number
  , rampage :: Maybe Rampage
  , safeZone :: Array Position
  }

derive instance genericWrappedGame :: Generic WrappedGame

unwrapGame :: WrappedGame -> Game
unwrapGame (WrappedGame g) = g

instance encodeJsonWrappedGame :: EncodeJson WrappedGame where
  encodeJson = gEncodeJson

instance decodeJsonWrappedGame :: DecodeJson WrappedGame where
  decodeJson = gDecodeJson

data PlayerId = P1 | P2 | P3 | P4

derive instance genericPlayerId :: Generic PlayerId

allPlayerIds :: Array PlayerId
allPlayerIds = [P1, P2, P3, P4]

playerIdToInt :: PlayerId -> Int
playerIdToInt p =
  case p of
    P1 -> 1
    P2 -> 2
    P3 -> 3
    P4 -> 4

intToPlayerId :: Int -> Maybe PlayerId
intToPlayerId x =
  case x of
    1 -> Just P1
    2 -> Just P2
    3 -> Just P3
    4 -> Just P4
    _ -> Nothing

instance showPlayerId :: Show PlayerId where
  show = gShow

instance eqPlayerId :: Eq PlayerId where
  eq = gEq

instance ordPlayerId :: Ord PlayerId where
  compare = gCompare

instance decodeJsonPlayerId :: DecodeJson PlayerId where
  decodeJson = gDecodeJson

instance encodeJsonPlayerId :: EncodeJson PlayerId where
  encodeJson = gEncodeJson

type ItemId = Number

type LevelMap =
  { blocks   :: Array (Array Block)
  , tiles    :: Array (Array Tile)
  }

newtype WrappedLevelMap = WrappedLevelMap
  { blocks   :: Array (Array Block)
  , tiles    :: Array (Array Tile)
  }

derive instance genericLevelMap :: Generic WrappedLevelMap

instance encodeJsonLevelMap :: EncodeJson WrappedLevelMap where
  encodeJson = gEncodeJson

instance decodeJsonLevelMap :: DecodeJson WrappedLevelMap where
  decodeJson = gDecodeJson

data Block = Wall | Empty

derive instance genericBlock :: Generic Block

instance showBlock :: Show Block where
  show = gShow

instance encodeJsonBlock :: EncodeJson Block where
  encodeJson = gEncodeJson

instance decodeJSONBlock :: DecodeJson Block where
  decodeJson = gDecodeJson

-- A fixed size two-dimensional array of blocks.
type BlockTile = Array (Array Block)

data Tile
  = Intersection
  | TeeJunctionUp
  | TeeJunctionRight
  | TeeJunctionDown
  | TeeJunctionLeft
  | CornerUpRight
  | CornerRightDown
  | CornerDownLeft
  | CornerLeftUp
  | StraightHorizontal
  | StraightVertical
  | Inaccessible

derive instance genericTile :: Generic Tile

instance showTile :: Show Tile where
  show = gShow

instance encodeJsonTile :: EncodeJson Tile where
  encodeJson = gEncodeJson

instance decodeJsonTile :: DecodeJson Tile where
  decodeJson = gDecodeJson

isWall :: Block -> Boolean
isWall Wall = true
isWall _ = false

showRecord :: String -> Array String -> String
showRecord name props =
    "(" <> name <> " {" <> joinWith ", " props <> "})"

(.::) :: forall a. (Show a) => String -> a -> String
(.::) name value = name <> ": " <> show value

failJsonParse :: forall a b. (Show a) => a -> String -> Either String b
failJsonParse value typ =
  Left $ "failed to parse " <> show value <> " as " <> typ <> "."

newtype Position = Position {x :: Number, y :: Number}

derive instance genericPosition :: Generic Position

instance showPosition :: Show Position where
  show = gShow

instance eqPosition :: Eq Position where
  eq = gEq

instance decodeJsonPosition :: DecodeJson Position where
  decodeJson = gDecodeJson

instance encodeJsonPosition :: EncodeJson Position where
  encodeJson = gEncodeJson

addPos :: Position -> Position -> Position
addPos (Position p) (Position q) = Position {x: p.x + q.x, y: p.y + q.y}

scalePos :: Number -> Position -> Position
scalePos s (Position p) = Position {x: s * p.x, y: s * p.y}

quadrance :: Position -> Position -> Number
quadrance (Position p) (Position q) =
  ((p.x - q.x) `pow` 2.0) + ((p.y - q.y) `pow` 2.0)

data GameObject = GOPlayer Player | GOItem Item

derive instance genericGameObject :: Generic GameObject

newtype Player
  = Player
      { position :: Position
      , direction :: Maybe Direction
      , intendedDirection :: Maybe Direction
      , score :: Int
      , nomIndex :: Int
      , respawnCounter :: Maybe Int
      }

derive instance genericPlayer :: Generic Player

instance encodeJsonPlayer :: EncodeJson Player where
  encodeJson = gEncodeJson

instance decodeJsonPlayer :: DecodeJson Player where
  decodeJson = gDecodeJson

nomIndexMax = 10

mkPlayer :: Position -> Player
mkPlayer pos =
  Player { position: pos
         , direction: Nothing
         , intendedDirection: Nothing
         , score: 0
         , nomIndex: nomIndexMax / 2
         , respawnCounter: Nothing
         }

players :: forall r a. LensP { players :: a | r } a
players = lens (\o -> o.players) (\o x -> o { players = x })

items :: forall r a. LensP { items :: a | r } a
items = lens (\o -> o.items) (\o x -> o { items = x })

pPosition :: LensP Player Position
pPosition = lens
  (\(Player p) -> p.position)
  (\(Player p) pos -> Player $ p { position = pos })

pDirection :: LensP Player (Maybe Direction)
pDirection = lens
  (\(Player p) -> p.direction)
  (\(Player p) dir -> Player $ p { direction = dir })

pIntendedDirection :: LensP Player (Maybe Direction)
pIntendedDirection = lens
  (\(Player p) -> p.intendedDirection)
  (\(Player p) dir -> Player $ p { intendedDirection = dir })

pScore :: LensP Player Int
pScore = lens
  (\(Player p) -> p.score)
  (\(Player p) s -> Player $ p { score = s })

pNomIndex :: LensP Player Int
pNomIndex = lens
  (\(Player p) -> p.nomIndex)
  (\(Player p) s -> Player $ p { nomIndex = s })

pRespawnCounter :: LensP Player (Maybe Int)
pRespawnCounter = lens
  (\(Player p) -> p.respawnCounter)
  (\(Player p) s -> Player $ p { respawnCounter = s })

eachPlayer' :: forall f. (Applicative f) =>
  Game -> (PlayerId -> Player -> f Unit) -> f Unit
eachPlayer' game action =
  for_ (Map.toList $ game ^. players) $ uncurry action

eachPlayer :: (PlayerId -> Player -> GameUpdateM Unit) -> GameUpdateM Unit
eachPlayer action = do
  game <- getGame
  eachPlayer' game action

newtype Item
  = Item
     { position :: Position
     , itemType :: ItemType
     }

derive instance genericItem :: Generic Item

instance showItem :: Show Item where
  show = gShow

instance decodeJsonItem :: DecodeJson Item where
  decodeJson = gDecodeJson

instance encodeJsonItem :: EncodeJson Item where
  encodeJson = gEncodeJson

iType :: LensP Item ItemType
iType = lens
  (\(Item x) -> x.itemType)
  (\(Item x) typ -> Item $ x { itemType = typ })

iPosition :: LensP Item Position
iPosition = lens
  (\(Item x) -> x.position)
  (\(Item x) pos -> Item $ x { position = pos })

pX :: LensP Position Number
pX = lens
  (\(Position p) -> p.x)
  (\(Position p) x -> Position $ p { x = x })

pY :: LensP Position Number
pY = lens
  (\(Position p) -> p.y)
  (\(Position p) y -> Position $ p { y = y })

eachItem' :: forall f. (Applicative f) =>
  Game -> (Item -> f Unit) -> f Unit
eachItem' game action =
  for_ (game ^. items) action

data Direction = Up | Down | Left | Right

derive instance genericDirection :: Generic Direction

instance showDirection :: Show Direction where
  show = gShow

instance decodeJsonDirection :: DecodeJson Direction where
  decodeJson = gDecodeJson

instance encodeJsonDirection :: EncodeJson Direction where
  encodeJson = gEncodeJson

data ItemType = LittleDot | BigDot | Cherry

derive instance genericItemType :: Generic ItemType

instance showItemType :: Show ItemType where
  show = gShow

instance eqItemType :: Eq ItemType where
  eq = gEq

instance encodeJsonItemType :: EncodeJson ItemType where
  encodeJson = gEncodeJson

instance decodeJsonItemType :: DecodeJson ItemType where
  decodeJson = gDecodeJson

dirToPos :: Direction -> Position
dirToPos Up    = Position {x:  0, y: -1}
dirToPos Left  = Position {x: -1, y:  0}
dirToPos Right = Position {x:  1, y:  0}
dirToPos Down  = Position {x:  0, y:  1}

directionToRadians :: Direction -> Number
directionToRadians d =
  case d of
    Right -> 0
    Down -> pi / 2
    Left -> pi
    Up -> 3 * pi / 2

opposite d =
  case d of
    Up -> Down
    Down -> Up
    Right -> Left
    Left -> Right

type Input = Map PlayerId (Maybe Direction)

data PlayerUpdate
  = ChangedDirection (Maybe Direction)
  | ChangedIntendedDirection (Maybe Direction)
  | ChangedPosition Position
  | ChangedScore Number
  | ChangedNomIndex Number
  | ChangedRespawnCounter (Maybe Number)
  | PlayerLeft

derive instance genericPlayerUpdate :: Generic PlayerUpdate

instance showPlayerUpdate :: Show PlayerUpdate where
  show = gShow

instance decodeJsonPlayerUpdate :: DecodeJson PlayerUpdate where
  decodeJson = gDecodeJson

instance encodeJsonPlayerUpdate :: EncodeJson PlayerUpdate where
  encodeJson = gEncodeJson

data ItemUpdate
  = Eaten

derive instance genericItemUpdate :: Generic ItemUpdate

instance showItemUpdate :: Show ItemUpdate where
  show = gShow

instance decodeJsonItemUpdate :: DecodeJson ItemUpdate where
  decodeJson = gDecodeJson

instance encodeJsonItemUpdate :: EncodeJson ItemUpdate where
  encodeJson = gEncodeJson

data GameEndReason
  = Completed
  | TooManyPlayersDisconnected

derive instance genericGameEndReason :: Generic GameEndReason

instance showGameEndReason :: Show GameEndReason where
  show = gShow

instance encodeJsonGameEndReason :: EncodeJson GameEndReason where
  encodeJson = gEncodeJson

instance decodeJsonGameEndReason :: DecodeJson GameEndReason where
  decodeJson = gDecodeJson

data Rampage
  = Rampaging PlayerId Number
  | Cooldown Number

derive instance genericRampage :: Generic Rampage

instance encodeJsonRampage :: EncodeJson Rampage where
  encodeJson = gEncodeJson

instance decodeJsonRampage :: DecodeJson Rampage where
  decodeJson = gDecodeJson

data GameUpdate
  = GUPU PlayerId PlayerUpdate
  | GUIU ItemId ItemUpdate
  | ChangedCountdown (Maybe Number)
  | GameEnded GameEndReason
  | ChangedRampage (Maybe Rampage)

derive instance genericGameUpdate :: Generic GameUpdate

instance decodeJsonGameUpdate :: DecodeJson GameUpdate where
  decodeJson = gDecodeJson

instance encodeJsonGameUpdate :: EncodeJson GameUpdate where
  encodeJson = gEncodeJson

-- Sent by the server during the waiting stage, ie, after initial connection
-- but before the game starts
data WaitingUpdate
  = GameStarting Game
  | NewReadyStates (GenericMap PlayerId Boolean)

derive instance genericWaitingUpdate :: Generic WaitingUpdate

instance encodeJsonWaitingUpdate :: EncodeJson WaitingUpdate where
  encodeJson = gEncodeJson

instance decodeJsonWaitingUpdate :: DecodeJson WaitingUpdate where
  decodeJson = gDecodeJson

type GameUpdateM a = WriterT (S.Seq GameUpdate) (State WrappedGame) a

-- these are just here to shorten declarations that are required because of
-- types that psc is not able to infer
type GameUpdateState = WrappedGame
type GameUpdateModifier = GameUpdateState -> GameUpdateState

innerGame :: LensP WrappedGame Game
innerGame = lens (\(WrappedGame g) -> g) (const WrappedGame)

tellGameUpdate :: GameUpdate -> GameUpdateM Unit
tellGameUpdate = tell <<< S.singleton

modifyGame :: (Game -> Game) -> GameUpdateM Unit
modifyGame = modify <<< f
  where
  f :: (Game -> Game) -> GameUpdateModifier
  f = over innerGame

getGame :: GameUpdateM Game
getGame = gets f
  where
  f :: GameUpdateState -> Game
  f x = x ^. innerGame

runGameUpdateM :: forall a.
  Game -> GameUpdateM a -> Tuple a (Tuple Game (S.Seq GameUpdate))
runGameUpdateM game action =
  let a0 = runWriterT action
      a1 = runState a0 (WrappedGame game)
      rearrange (Tuple (Tuple x gus) (WrappedGame g))
        = Tuple x (Tuple g gus)

  in  rearrange a1

execGameUpdateM :: forall a.
  Game -> GameUpdateM a -> Tuple Game (S.Seq GameUpdate)
execGameUpdateM game action = snd $ runGameUpdateM game action

input_ = lens (\s -> s.input) (\s x -> s { input = x })
game_ = lens (\s -> s.game) (\s x -> s { game = x })

data GameState
  = WaitingForPlayers GameStateWaitingForPlayers
  | InProgress        GameStateInProgress

type GameStateWaitingForPlayers = Map PlayerId Boolean
type GameStateInProgress = { game :: Game, input :: Input }

type ReadyState = Boolean

data ServerOutgoingMessage
  = SOWaiting WaitingUpdate
  | SOInProgress (Array GameUpdate)

derive instance genericServerOutgoingMessage :: Generic ServerOutgoingMessage

instance encodeJsonServerOutgoingMessage :: EncodeJson ServerOutgoingMessage where
  encodeJson = gEncodeJson

instance decodeJsonServerOutgoingMessage :: DecodeJson ServerOutgoingMessage where
  decodeJson = gDecodeJson

asWaitingMessageO :: ServerOutgoingMessage -> Maybe WaitingUpdate
asWaitingMessageO (SOWaiting x) = Just x
asWaitingMessageO _ = Nothing

asInProgressMessageO :: ServerOutgoingMessage -> Maybe (Array GameUpdate)
asInProgressMessageO (SOInProgress x) = Just x
asInProgressMessageO _ = Nothing

data ServerIncomingMessage
  = SIToggleReadyState
  | SIInProgress Direction

derive instance genericServerIncomingMessage :: Generic ServerIncomingMessage

instance encodeJsonServerIncomingMessage :: EncodeJson ServerIncomingMessage where
  encodeJson = gEncodeJson

instance decodeJsonServerIncomingMessage :: DecodeJson ServerIncomingMessage where
  decodeJson = gDecodeJson

asWaitingMessage :: ServerIncomingMessage -> Maybe Unit
asWaitingMessage (SIToggleReadyState) = Just unit
asWaitingMessage _ = Nothing

asInProgressMessage :: ServerIncomingMessage -> Maybe Direction
asInProgressMessage (SIInProgress d) = Just d
asInProgressMessage _ = Nothing

matchMessage :: forall m a b. (Monad m, EncodeJson a) =>
  (a -> Maybe b) -> a -> (b -> m Unit) -> m Unit
matchMessage f msg action =
  maybe (return unit) action (f msg)

data ClientState
  = CWaitingForPlayers ClientStateWaiting
  | CInProgress        ClientStateInProgress

type ClientStateWaiting
  = { prevGame          :: Maybe Game
    , backgroundCleared :: Boolean
    , cachedHtml        :: String
    , readyStates       :: Map PlayerId Boolean
    }

type ClientStateInProgress
  = { game :: Game
    , prevGame :: Game
    , redrawMap :: Boolean
    , cachedHtml :: String
    }

type RenderingContext =
  { foreground :: Context2D
  , background :: Context2D
  }

redrawMap = lens
  (\s -> s.redrawMap)
  (\s x -> s { redrawMap = x })

backgroundCleared = lens
  (\s -> s.backgroundCleared)
  (\s x -> s { backgroundCleared = x })

readyStates = lens
  (\s -> s.readyStates)
  (\s x -> s { readyStates = x })

cachedHtml = lens
  (\s -> s.cachedHtml)
  (\s x -> s { cachedHtml = x })