Change generate size to 10

Change generate size to 10

-- | This module defines the random generator monad used by the `Test.QuickCheck`
-- | module, as well as helper functions for constructing random generators.
module Test.QuickCheck.Gen
  ( Gen
  , unGen
  , GenState
  , Size
  , repeatable
  , stateful
  , variant
  , suchThat
  , sized
  , resize
  , choose
  , chooseInt
  , oneOf
  , frequency
  , arrayOf
  , arrayOf1
  , listOf
  , vectorOf
  , elements
  , shuffle
  , runGen
  , evalGen
  , perturbGen
  , uniform
  , sample
  , randomSample
  , randomSample'
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Lazy (class Lazy)
import Control.Monad.Gen.Class (class MonadGen)
import Control.Monad.Rec.Class (class MonadRec, Step(..), tailRecM)
import Control.Monad.State (State, runState, evalState)
import Control.Monad.State.Class (modify, state)
import Data.Array ((!!), length, zip, sortBy)
import Data.Enum (class BoundedEnum, fromEnum, toEnum)
import Data.Foldable (fold)
import Data.Int (toNumber, floor)
import Data.List (List(..), toUnfoldable)
import Data.Maybe (fromMaybe, fromJust)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (unwrap)
import Data.NonEmpty (NonEmpty, (:|))
import Data.Tuple (Tuple(..), fst, snd)
import Effect (Effect)
import Math ((%))
import Partial.Unsafe (unsafePartial)
import Random.LCG (Seed, lcgPerturb, lcgM, lcgNext, unSeed, randomSeed)

-- | Tests are parameterized by the `Size` of the randomly-generated data,
-- | the meaning of which depends on the particular generator used.
type Size = Int

-- | The state of the random generator monad
type GenState = { newSeed :: Seed, size :: Size }

-- | The random generator monad
-- |
-- | `Gen` is a state monad which encodes a linear congruential generator.
newtype Gen a = Gen (State GenState a)

derive newtype instance functorGen :: Functor Gen
derive newtype instance applyGen :: Apply Gen
derive newtype instance applicativeGen :: Applicative Gen
derive newtype instance bindGen :: Bind Gen
derive newtype instance monadGen :: Monad Gen
derive newtype instance altGen :: Alt Gen
derive newtype instance monadRecGen :: MonadRec Gen
derive newtype instance lazyGen :: Lazy (Gen a)

instance monadGenGen :: MonadGen Gen where
  chooseInt = chooseInt
  chooseFloat = choose
  chooseBool = (_ < 0.5) <$> uniform
  resize f g = sized \s -> resize (f s) g
  sized = sized

-- | Exposes the underlying State implementation.
unGen :: forall a. Gen a -> State GenState a
unGen (Gen st) = st

-- | Create a random generator for a function type.
repeatable :: forall a b. (a -> Gen b) -> Gen (a -> b)
repeatable f = Gen $ state \s -> Tuple (\a -> fst (runGen (f a) s)) (s { newSeed = lcgNext s.newSeed })

-- | Create a random generator which uses the generator state explicitly.
stateful :: forall a. (GenState -> Gen a) -> Gen a
stateful f = Gen $ state \s -> runGen (f s) s

-- | Modify a random generator by setting a new random seed.
variant :: forall a. Seed -> Gen a -> Gen a
variant n g = Gen $ state \s -> runGen g s { newSeed = n }

-- | Ensure that a generator only produces values that match a predicate. If
-- | the predicate always returns false the generator will loop forever.
suchThat :: forall a. Gen a -> (a -> Boolean) -> Gen a
suchThat gen pred = tailRecM go unit
  where
  go :: Unit -> Gen (Step Unit a)
  go _ = do
    a <- gen
    pure if pred a then Done a else Loop unit

-- | Create a random generator which depends on the size parameter.
sized :: forall a. (Size -> Gen a) -> Gen a
sized f = stateful (\s -> f s.size)

-- | Modify a random generator by setting a new size parameter.
resize :: forall a. Size -> Gen a -> Gen a
resize sz g = Gen $ state \{ newSeed, size } ->
  (_ {size = size} ) <$> runGen g { newSeed, size: sz}

-- | Create a random generator which samples a range of `Number`s i
-- | with uniform probability.
choose :: Number -> Number -> Gen Number
choose a b = (*) (max' - min') >>> (+) min' <$> uniform where
  min' = min a b
  max' = max a b

-- | Create a random generator which chooses uniformly distributed
-- | integers from the closed interval `[a, b]`.
-- | Note that very large intervals will cause a loss of uniformity.
chooseInt :: Int -> Int -> Gen Int
chooseInt a b = if a <= b then chooseInt' a b else chooseInt' b a

-- guaranteed a <= b
chooseInt' :: Int -> Int -> Gen Int
chooseInt' a b = floor <<< clamp <$> choose32BitPosNumber
  where
    choose32BitPosNumber :: Gen Number
    choose32BitPosNumber =
      (+) <$> choose31BitPosNumber <*> (((*) 2.0) <$> choose31BitPosNumber)

    choose31BitPosNumber :: Gen Number
    choose31BitPosNumber = toNumber <$> lcgStep

    clamp :: Number -> Number
    clamp x = numA + (x % (numB - numA + one))

    numA = toNumber a
    numB = toNumber b

-- | Create a random generator which selects and executes a random generator from
-- | a non-empty array of random generators with uniform probability.
oneOf :: forall a. NonEmpty Array (Gen a) -> Gen a
oneOf (x :| xs) = do
  n <- chooseInt zero (length xs)
  if n < one then x else fromMaybe x (xs !! (n - one))

-- | Create a random generator which selects and executes a random generator from
-- | a non-empty, weighted list of random generators.
frequency :: forall a. NonEmpty List (Tuple Number (Gen a)) -> Gen a
frequency (x :| xs) = let
    xxs   = Cons x xs
    total = unwrap $ fold (map (Additive <<< fst) xxs :: List (Additive Number))
    pick n d Nil = d
    pick n d (Cons (Tuple k x') xs') = if n <= k then x' else pick (n - k) d xs'
  in do
    n <- choose zero total
    pick n (snd x) xxs

-- | Create a random generator which generates an array of random values.
arrayOf :: forall a. Gen a -> Gen (Array a)
arrayOf g = sized $ \n ->
  do k <- chooseInt zero n
     vectorOf k g

-- | Create a random generator which generates a non-empty array of random values.
arrayOf1 :: forall a. Gen a -> Gen (NonEmpty Array a)
arrayOf1 g = sized $ \n ->
  do k <- chooseInt zero n
     x <- g
     xs <- vectorOf (k - one) g
     pure $ x :| xs

-- | Create a random generator for a finite enumeration.
-- | `toEnum i` must be well-behaved:
-- | It must return a value wrapped in Just for all Ints between
-- | `fromEnum bottom` and `fromEnum top`.
enum :: forall a. BoundedEnum a => Gen a
enum = do
  i <- chooseInt (fromEnum (bottom :: a)) (fromEnum (top :: a))
  pure (unsafePartial $ fromJust $ toEnum i)

replicateMRec :: forall m a. MonadRec m => Int -> m a -> m (List a)
replicateMRec k _ | k <= 0 = pure Nil
replicateMRec k gen = tailRecM go (Tuple Nil k)
  where
  go :: (Tuple (List a) Int) -> m (Step (Tuple (List a) Int) (List a))
  go (Tuple acc 0) = pure $ Done acc
  go (Tuple acc n) = gen <#> \x -> Loop (Tuple (Cons x acc) (n - 1))

-- | Create a random generator which generates a list of random values of the specified size.
listOf :: forall a. Int -> Gen a -> Gen (List a)
listOf = replicateMRec

-- | Create a random generator which generates a vector of random values of a specified size.
vectorOf :: forall a. Int -> Gen a -> Gen (Array a)
vectorOf k g = toUnfoldable <$> listOf k g

-- | Create a random generator which selects a value from a non-empty array with
-- | uniform probability.
elements :: forall a. NonEmpty Array a -> Gen a
elements (x :| xs) = do
  n <- chooseInt zero (length xs)
  pure if n == zero then x else fromMaybe x (xs !! (n - one))

-- | Generate a random permutation of the given array
shuffle :: forall a. Array a -> Gen (Array a)
shuffle xs = do
  ns <- vectorOf (length xs) (chooseInt 0 top)
  pure (map snd (sortBy (comparing fst) (zip ns xs)))

-- | Run a random generator
runGen :: forall a. Gen a -> GenState -> Tuple a GenState
runGen = runState <<< unGen

-- | Run a random generator, keeping only the randomly-generated result
evalGen :: forall a. Gen a -> GenState -> a
evalGen = evalState <<< unGen

-- | Sample a random generator
sample :: forall a. Seed -> Size -> Gen a -> Array a
sample seed sz g = evalGen (vectorOf sz g) { newSeed: seed, size: sz }

-- | Generate a single value using a randomly generated seed.
generate :: forall a. Gen a -> Effect a
generate gen = do
  seed <- randomSeed
  pure $ evalGen gen { newSeed: seed, size: 10 }

-- | Sample a random generator, using a randomly generated seed
randomSample' :: forall a. Size -> Gen a -> Effect (Array a)
randomSample' n g = do
  seed <- randomSeed
  pure $ sample seed n g

-- | Get a random sample of 10 values
randomSample :: forall a. Gen a -> Effect (Array a)
randomSample = randomSample' 10

-- | A random generator which simply outputs the current seed
lcgStep :: Gen Int
lcgStep = Gen $ state f where
  f s = Tuple (unSeed s.newSeed) (s { newSeed = lcgNext s.newSeed })

-- | A random generator which approximates a uniform random variable on `[0, 1]`
uniform :: Gen Number
uniform = (\n -> toNumber n / toNumber lcgM) <$> lcgStep

foreign import float32ToInt32 :: Number -> Int

-- | Perturb a random generator by modifying the current seed
perturbGen :: forall a. Number -> Gen a -> Gen a
perturbGen n gen = Gen do
  void $ modify \s -> s { newSeed = lcgPerturb (toNumber (float32ToInt32 n)) s.newSeed }
  unGen gen

-- | This module defines the random generator monad used by the `Test.QuickCheck`
-- | module, as well as helper functions for constructing random generators.
module Test.QuickCheck.Gen
  ( Gen
  , unGen
  , GenState
  , Size
  , repeatable
  , stateful
  , variant
  , suchThat
  , sized
  , resize
  , choose
  , chooseInt
  , oneOf
  , frequency
  , arrayOf
  , arrayOf1
  , listOf
  , vectorOf
  , elements
  , shuffle
  , runGen
  , evalGen
  , perturbGen
  , uniform
  , sample
  , randomSample
  , randomSample'
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Lazy (class Lazy)
import Control.Monad.Gen.Class (class MonadGen)
import Control.Monad.Rec.Class (class MonadRec, Step(..), tailRecM)
import Control.Monad.State (State, runState, evalState)
import Control.Monad.State.Class (modify, state)
import Data.Array ((!!), length, zip, sortBy)
import Data.Enum (class BoundedEnum, fromEnum, toEnum)
import Data.Foldable (fold)
import Data.Int (toNumber, floor)
import Data.List (List(..), toUnfoldable)
import Data.Maybe (fromMaybe, fromJust)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (unwrap)
import Data.NonEmpty (NonEmpty, (:|))
import Data.Tuple (Tuple(..), fst, snd)
import Effect (Effect)
import Math ((%))
import Partial.Unsafe (unsafePartial)
import Random.LCG (Seed, lcgPerturb, lcgM, lcgNext, unSeed, randomSeed)

-- | Tests are parameterized by the `Size` of the randomly-generated data,
-- | the meaning of which depends on the particular generator used.
type Size = Int

-- | The state of the random generator monad
type GenState = { newSeed :: Seed, size :: Size }

-- | The random generator monad
-- |
-- | `Gen` is a state monad which encodes a linear congruential generator.
newtype Gen a = Gen (State GenState a)

derive newtype instance functorGen :: Functor Gen
derive newtype instance applyGen :: Apply Gen
derive newtype instance applicativeGen :: Applicative Gen
derive newtype instance bindGen :: Bind Gen
derive newtype instance monadGen :: Monad Gen
derive newtype instance altGen :: Alt Gen
derive newtype instance monadRecGen :: MonadRec Gen
derive newtype instance lazyGen :: Lazy (Gen a)

instance monadGenGen :: MonadGen Gen where
  chooseInt = chooseInt
  chooseFloat = choose
  chooseBool = (_ < 0.5) <$> uniform
  resize f g = sized \s -> resize (f s) g
  sized = sized

-- | Exposes the underlying State implementation.
unGen :: forall a. Gen a -> State GenState a
unGen (Gen st) = st

-- | Create a random generator for a function type.
repeatable :: forall a b. (a -> Gen b) -> Gen (a -> b)
repeatable f = Gen $ state \s -> Tuple (\a -> fst (runGen (f a) s)) (s { newSeed = lcgNext s.newSeed })

-- | Create a random generator which uses the generator state explicitly.
stateful :: forall a. (GenState -> Gen a) -> Gen a
stateful f = Gen $ state \s -> runGen (f s) s

-- | Modify a random generator by setting a new random seed.
variant :: forall a. Seed -> Gen a -> Gen a
variant n g = Gen $ state \s -> runGen g s { newSeed = n }

-- | Ensure that a generator only produces values that match a predicate. If
-- | the predicate always returns false the generator will loop forever.
suchThat :: forall a. Gen a -> (a -> Boolean) -> Gen a
suchThat gen pred = tailRecM go unit
  where
  go :: Unit -> Gen (Step Unit a)
  go _ = do
    a <- gen
    pure if pred a then Done a else Loop unit

-- | Create a random generator which depends on the size parameter.
sized :: forall a. (Size -> Gen a) -> Gen a
sized f = stateful (\s -> f s.size)

-- | Modify a random generator by setting a new size parameter.
resize :: forall a. Size -> Gen a -> Gen a
resize sz g = Gen $ state \{ newSeed, size } ->
  (_ {size = size} ) <$> runGen g { newSeed, size: sz}

-- | Create a random generator which samples a range of `Number`s i
-- | with uniform probability.
choose :: Number -> Number -> Gen Number
choose a b = (*) (max' - min') >>> (+) min' <$> uniform where
  min' = min a b
  max' = max a b

-- | Create a random generator which chooses uniformly distributed
-- | integers from the closed interval `[a, b]`.
-- | Note that very large intervals will cause a loss of uniformity.
chooseInt :: Int -> Int -> Gen Int
chooseInt a b = if a <= b then chooseInt' a b else chooseInt' b a

-- guaranteed a <= b
chooseInt' :: Int -> Int -> Gen Int
chooseInt' a b = floor <<< clamp <$> choose32BitPosNumber
  where
    choose32BitPosNumber :: Gen Number
    choose32BitPosNumber =
      (+) <$> choose31BitPosNumber <*> (((*) 2.0) <$> choose31BitPosNumber)

    choose31BitPosNumber :: Gen Number
    choose31BitPosNumber = toNumber <$> lcgStep

    clamp :: Number -> Number
    clamp x = numA + (x % (numB - numA + one))

    numA = toNumber a
    numB = toNumber b

-- | Create a random generator which selects and executes a random generator from
-- | a non-empty array of random generators with uniform probability.
oneOf :: forall a. NonEmpty Array (Gen a) -> Gen a
oneOf (x :| xs) = do
  n <- chooseInt zero (length xs)
  if n < one then x else fromMaybe x (xs !! (n - one))

-- | Create a random generator which selects and executes a random generator from
-- | a non-empty, weighted list of random generators.
frequency :: forall a. NonEmpty List (Tuple Number (Gen a)) -> Gen a
frequency (x :| xs) = let
    xxs   = Cons x xs
    total = unwrap $ fold (map (Additive <<< fst) xxs :: List (Additive Number))
    pick n d Nil = d
    pick n d (Cons (Tuple k x') xs') = if n <= k then x' else pick (n - k) d xs'
  in do
    n <- choose zero total
    pick n (snd x) xxs

-- | Create a random generator which generates an array of random values.
arrayOf :: forall a. Gen a -> Gen (Array a)
arrayOf g = sized $ \n ->
  do k <- chooseInt zero n
     vectorOf k g

-- | Create a random generator which generates a non-empty array of random values.
arrayOf1 :: forall a. Gen a -> Gen (NonEmpty Array a)
arrayOf1 g = sized $ \n ->
  do k <- chooseInt zero n
     x <- g
     xs <- vectorOf (k - one) g
     pure $ x :| xs

-- | Create a random generator for a finite enumeration.
-- | `toEnum i` must be well-behaved:
-- | It must return a value wrapped in Just for all Ints between
-- | `fromEnum bottom` and `fromEnum top`.
enum :: forall a. BoundedEnum a => Gen a
enum = do
  i <- chooseInt (fromEnum (bottom :: a)) (fromEnum (top :: a))
  pure (unsafePartial $ fromJust $ toEnum i)

replicateMRec :: forall m a. MonadRec m => Int -> m a -> m (List a)
replicateMRec k _ | k <= 0 = pure Nil
replicateMRec k gen = tailRecM go (Tuple Nil k)
  where
  go :: (Tuple (List a) Int) -> m (Step (Tuple (List a) Int) (List a))
  go (Tuple acc 0) = pure $ Done acc
  go (Tuple acc n) = gen <#> \x -> Loop (Tuple (Cons x acc) (n - 1))

-- | Create a random generator which generates a list of random values of the specified size.
listOf :: forall a. Int -> Gen a -> Gen (List a)
listOf = replicateMRec

-- | Create a random generator which generates a vector of random values of a specified size.
vectorOf :: forall a. Int -> Gen a -> Gen (Array a)
vectorOf k g = toUnfoldable <$> listOf k g

-- | Create a random generator which selects a value from a non-empty array with
-- | uniform probability.
elements :: forall a. NonEmpty Array a -> Gen a
elements (x :| xs) = do
  n <- chooseInt zero (length xs)
  pure if n == zero then x else fromMaybe x (xs !! (n - one))

-- | Generate a random permutation of the given array
shuffle :: forall a. Array a -> Gen (Array a)
shuffle xs = do
  ns <- vectorOf (length xs) (chooseInt 0 top)
  pure (map snd (sortBy (comparing fst) (zip ns xs)))

-- | Run a random generator
runGen :: forall a. Gen a -> GenState -> Tuple a GenState
runGen = runState <<< unGen

-- | Run a random generator, keeping only the randomly-generated result
evalGen :: forall a. Gen a -> GenState -> a
evalGen = evalState <<< unGen

-- | Sample a random generator
sample :: forall a. Seed -> Size -> Gen a -> Array a
sample seed sz g = evalGen (vectorOf sz g) { newSeed: seed, size: sz }

-- | Generate a single value using a randomly generated seed.
generate :: forall a. Gen a -> Effect a
generate gen = do
  seed <- randomSeed
  pure $ evalGen gen { newSeed: seed, size: 1 }

-- | Sample a random generator, using a randomly generated seed
randomSample' :: forall a. Size -> Gen a -> Effect (Array a)
randomSample' n g = do
  seed <- randomSeed
  pure $ sample seed n g

-- | Get a random sample of 10 values
randomSample :: forall a. Gen a -> Effect (Array a)
randomSample = randomSample' 10

-- | A random generator which simply outputs the current seed
lcgStep :: Gen Int
lcgStep = Gen $ state f where
  f s = Tuple (unSeed s.newSeed) (s { newSeed = lcgNext s.newSeed })

-- | A random generator which approximates a uniform random variable on `[0, 1]`
uniform :: Gen Number
uniform = (\n -> toNumber n / toNumber lcgM) <$> lcgStep

foreign import float32ToInt32 :: Number -> Int

-- | Perturb a random generator by modifying the current seed
perturbGen :: forall a. Number -> Gen a -> Gen a
perturbGen n gen = Gen do
  void $ modify \s -> s { newSeed = lcgPerturb (toNumber (float32ToInt32 n)) s.newSeed }
  unGen gen


Simpler way of expressing 2^31 - 1

Simpler way of expressing 2^31 - 1

module Test.QuickCheck.LCG
  ( Seed()
  , lcgM
  , lcgC
  , lcgN
  , lcgNext
  , randomSeed
  ) where

import Prelude

import Math ((%))
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Random (RANDOM(), randomInt)
import Data.Int (fromNumber, toNumber)
import Data.Int.Bits (shl)
import qualified Data.Maybe.Unsafe as U

type Seed = Int

-- | The *multiplier*: a magic constant for the linear congruential generator
lcgM :: Int
lcgM = 48271

-- | The *increment*: a magic constant for the linear congruential generator
lcgC :: Int
lcgC = 0

-- | The *modulus*: a magic constant for the linear congruential generator
lcgN :: Int
lcgN = 1 `shl` 31 - 1

-- | Step the linear congruential generator
lcgNext :: Int -> Int
lcgNext n = U.fromJust $ fromNumber $ (toNumber lcgM * toNumber n + toNumber lcgC) % toNumber lcgN

-- | Create a random seed
randomSeed :: forall e. Eff (random :: RANDOM | e) Seed
randomSeed = randomInt 1 lcgM

module Test.QuickCheck.LCG
  ( Seed()
  , lcgM
  , lcgC
  , lcgN
  , lcgNext
  , randomSeed
  ) where

import Prelude

import Math ((%))
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Random (RANDOM(), randomInt)
import Data.Int (fromNumber, toNumber)
import Data.Int.Bits (shl, (.|.))
import Data.Array (replicate)
import Data.Foldable (product)
import qualified Data.Maybe.Unsafe as U

type Seed = Int

-- | The *multiplier*: a magic constant for the linear congruential generator
lcgM :: Int
lcgM = 48271

-- | The *increment*: a magic constant for the linear congruential generator
lcgC :: Int
lcgC = 0

-- | The *modulus*: a magic constant for the linear congruential generator
lcgN :: Int
lcgN = product (replicate 31 2) - 1

-- | Step the linear congruential generator
lcgNext :: Int -> Int
lcgNext n = U.fromJust $ fromNumber $ (toNumber lcgM * toNumber n + toNumber lcgC) % toNumber lcgN

-- | Create a random seed
randomSeed :: forall e. Eff (random :: RANDOM | e) Seed
randomSeed = randomInt 1 lcgM


Added mine level information

Added mine level information

module Level where

import Data.Char
import Data.String (String)
import qualified Data.String as S
import Data.Array ((..), (!!), updateAt, map, length)
import qualified Data.Array.Unsafe as U
import Data.Maybe
import GameData
import Utils
import Astar

data Tile = Air        | Water      | BrickWall
          | Ground     | Grass      | Wall      | SWall
          | DoorLocked | DoorClosed | DoorOpen
          | BgCave     | BgHouse
          | Bush       | Stairs
          | Trunk      | Leaves

data Level = Level
    { width  :: Number
    , height :: Number
    , tiles  :: [Tile]
    }

isTileSolid :: Tile -> Boolean
isTileSolid Ground     = true
isTileSolid Grass      = true
isTileSolid Wall       = true
isTileSolid BrickWall  = true
isTileSolid SWall      = true
isTileSolid DoorLocked = true
isTileSolid DoorClosed = true
isTileSolid _          = false

isTileTransparent :: Tile -> Boolean
isTileTransparent Ground     = false
isTileTransparent Grass      = false
isTileTransparent Wall       = false
isTileTransparent BrickWall  = false
isTileTransparent SWall      = false
isTileTransparent DoorLocked = false
isTileTransparent DoorClosed = false
isTileTransparent Bush       = false
isTileTransparent Water      = false
isTileTransparent Leaves     = false
isTileTransparent _          = true

isTileClimbable :: Tile -> Boolean
isTileClimbable Stairs     = true
isTileClimbable Water      = true
isTileClimbable DoorOpen   = true
isTileClimbable DoorClosed = true
isTileClimbable DoorLocked = true
isTileClimbable Leaves     = true
isTileClimbable _          = false

-- Calculates tile weights for pathfinding.
levelWeights :: Level -> [[Number]]
levelWeights l@(Level level) = do
    y <- 0 .. (level.height - 1)
    [makeRow y 0]
    where
        makeRow :: Number -> Number -> [Number]
        makeRow i x | x < level.width = tileWeight {x: x, y: i} : makeRow i (x + 1)
        makeRow i x | otherwise       = []

        tileWeight :: Point -> Number
        tileWeight p | canWalkOn p || canClimbOn p = 1
        tileWeight p | otherwise                   = 0

        getTile' :: Point -> Tile
        getTile' = fromMaybe Ground <<< getTile l

        canWalkOn :: Point -> Boolean
        canWalkOn p = blocked (p .+. {x:0, y:1}) && not (blocked p)

        canClimbOn :: Point -> Boolean
        canClimbOn = isTileClimbable <<< getTile'

        blocked :: Point -> Boolean
        blocked = blocksNpc <<< getTile'

        blocksNpc :: Tile -> Boolean
        blocksNpc DoorOpen   = false
        blocksNpc DoorClosed = false
        blocksNpc DoorLocked = false
        blocksNpc t = isTileSolid t

newLevel :: Number -> Number -> Level
newLevel w h = Level { width: w, height: h, tiles: replicate (w * h) Air }

emptyLevel :: Level
emptyLevel = Level { width: 0, height: 0, tiles: [] }

index :: Level -> Number -> Number -> Number
index (Level level) x y = x + y * level.width

getTile :: Level -> Point -> Maybe Tile
getTile l@(Level level) p | p.x >= 0 && p.y > 0 && p.x < level.width && p.y < level.height =
    level.tiles !! index l p.x p.y
getTile l@(Level level) p | p.y >= level.height = Just Ground
getTile l@(Level level) p | otherwise = Just Air

setTile :: Level -> Point -> Tile -> Level
setTile l@(Level level) p newTile =
    Level $ level { tiles = updateAt (index l p.x p.y) newTile level.tiles }

isValidMove :: Level -> Point -> Boolean
isValidMove level = not <<< isTileSolid <<< fromMaybe Air <<< getTile level

isTransparent :: Level -> Point -> Boolean
isTransparent level = isTileTransparent <<< fromMaybe Air <<< getTile level

isClimbable :: Level -> Point -> Boolean
isClimbable level = isTileClimbable <<< fromMaybe Air <<< getTile level

inFreeFall :: forall r. Level -> { pos :: Point, vel :: Point | r } -> Boolean
inFreeFall level c = isValidMove level (c.pos .+. {x:0, y: 1}) || c.vel.y < 0

-- Returns all points inside level.
levelPoints :: Level -> [Point]
levelPoints (Level level) = do
    x' <- 0 .. (level.width - 1)
    y' <- 0 .. (level.height - 1)
    return {x: x', y: y'}

stringToLevel :: [String] -> Level
stringToLevel strs = Level $ { width: S.length (U.head strs), height: length strs, tiles: makeTiles strs }
    where
        makeTiles :: [String] -> [Tile]
        makeTiles (x:xs) = map charToTile (S.toCharArray x) ++ makeTiles xs
        makeTiles _      = []

        charToTile :: Char -> Tile
        charToTile c | c == makeChar "." = Air
        charToTile c | c == makeChar "#" = Ground
        charToTile c | c == makeChar "G" = Grass
        charToTile c | c == makeChar "S" = Wall
        charToTile c | c == makeChar "W" = SWall
        charToTile c | c == makeChar "$" = BrickWall
        charToTile c | c == makeChar "*" = DoorLocked
        charToTile c | c == makeChar "+" = DoorClosed
        charToTile c | c == makeChar "|" = DoorOpen
        charToTile c | c == makeChar "c" = BgCave
        charToTile c | c == makeChar "C" = BgHouse
        charToTile c | c == makeChar "B" = Bush
        charToTile c | c == makeChar "=" = Water
        charToTile c | c == makeChar "<" = Stairs
        charToTile c | c == makeChar "I" = Trunk
        charToTile c | c == makeChar "%" = Leaves
        charToTile _ = Air

type LevelDefinition =
    { name      :: String
    , plan      :: [String]
    , itemPos   :: [Point]
    , lootPos   :: [Point]
    , npcPos    :: [{ p :: Point, ctype :: CreatureType, ai :: AIState }]
    , startPos  :: Point
    }

allLevels :: [LevelDefinition]
allLevels = [{ name: "a small village"
             , plan: tutorialLevel
             , itemPos: [p 55 6, p 62 5, p 23 9]
             , lootPos: [p 40 9, p 48 9, p 64 9, p 66 9, p 21 9, p 22 9]
             , npcPos: [patrol (p 59 9)]
             , startPos: {x: 2, y: 7}}

            ,{ name: "a small castle"
             , plan: castleLevel
             , itemPos: [p 30 13, p 45 13, p 72 13, p 76 6, p 27 6]
             , lootPos: [p 24 10, p 24 13, p 39 16, p 69 13, p 70 13, p 71 13]
             , npcPos: [patrol (p 37 10), patrol (p 72 10), aIdle (p 76 3), aIdle (p 24 6)]
             , startPos: {x: 2, y: 15}}

            ,{ name: "a small town with clock tower"
             , plan: clockTower
             , itemPos: [p 31 14, p 24 9, p 29 2, p 43 14, p 56 17]
             , lootPos: [p 19 17, p 10 16, p 11 16, p 40 11, p 40 14, p 42 14, p 44 17]
             , npcPos: [aIdle (p 24 6), patrol (p 60 17), patrol (p 33 6)]
             , startPos: {x: 2, y: 15}}

            ,{ name: "a hidden pirate cove"
             , plan: pirateCove
             , itemPos: [p 34 14, p 25 14, p 30 11, p 35 11, p 78 13]
             , lootPos: [p 54 13, p 23 14, p 24 14, p 28 11, p 76 13, p 74 13]
             , npcPos: [patrol (p 77 13), patrol (p 46 13)]
             , startPos: {x: 3, y: 13}}

            ,{ name: "an old mine"
             , plan: mine
             , itemPos: [p 73 5, p 7 10, p 29 10, p 17 22, p 2 24, p 1 24]
             , lootPos: [p 6 24, p 7 24, p 50 24, p 35 17, p 3 12, p 70 13, p 69 13, p 40 8, p 18 17]
             , npcPos: [patrol (p 19 15), aIdle (p 74 5), aIdle (p 42 17), aIdle (p 1 24)]
             , startPos: {x: 1, y: 5}}]
    where
        p x y = {x: x, y: y}

        idler p' = { p: p', ctype: Guard, ai: Idle p' }
        patrol p' = { p: p', ctype: Guard, ai: Patrol p' }

        aIdle p' = { p: p', ctype: Archer, ai: Idle p' }

emptyLevel' :: [String]
emptyLevel' =
    ["................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"]

tutorialLevel :: [String]
tutorialLevel =
    ["................................................................................"
    ,"................................................................................"
    ,"...............................................................................S"
    ,"...............................................................................S"
    ,"..................................................SSSSSSS.................%%.. S"
    ,"...............................%................SSSCCCCCS................%%%%..S"
    ,"......................####....%%%...............I.+CCCCCS.....SSSSSSS...%%I%...S"
    ,"................B..GG#####....%I%%....SSSS*S..SSSSSSS<SSS.....SCCCCCS.....I....S"
    ,"#####GG..B......GGG##ccc###....I......SCCC<S..SCCCSCC<CCS.....SCCCCCS.....I....S"
    ,"#######GGGG===GG#####ccccccB.B.I..GG..*CCC<*..*CCC+CC<CC*.....*CCCCC*...B.IB...S"
    ,"###########===#############GGGGGGG##GGSSSSSSGGSSSSSSSSSSSGGGGGGGGGGGGGGGGGGGGGGG"
    ,"###########==###################################################################"
    ,"################################################################################"]

castleLevel :: [String]
castleLevel =
    ["...............................................................................$"
    ,"...............................................................................$"
    ,"...............................................................................$"
    ,"..........................................................................$....$"
    ,"..........................................................................$$$$*$"
    ,"...........................................................................$CC<$"
    ,"......................$.....$..............................................$CC<$"
    ,"......................$$$$+$$..............................................$$$+$"
    ,".......................$CC<$.....................$$$$$$$$$$$$$$$...........$CC<$"
    ,".......................$CC<$.....................$CCCCCCC$CCCCC$...........$CC<$"
    ,".......................$CC<*.....................*CCCCCCC+CCCCC*...........*CC<$"
    ,".......................$$$+$$$$$$*$$$$$$$$$$$$$$$$$$+$$$$$$$$$$$$$$$$$$$$$$$$$$$"
    ,"...................%...$CC<$CCCCC<CCCC$CCCCCCCCCC$CC<CCCC$CCCCCCCCCC$CCCCCC$CCC$"
    ,"..................%%%%.$CC<$CCCCC<CCCC+CCCCCCCCCC+CC<CCCC$CCCCCCCCCC$CCCCCC*CCC$"
    ,"..................%I%..$$$+$$$$$$$$$$$$$$$$$$$$$$$$$+$$$$$CCCCCCCCCC$$$$$$$$$$C$"
    ,"#..................I...$CC<$CCCCCCC$CCCCCC$CCCCCCCCC<CCCC$CCCCICICCC$CCCCCCCCC$$"
    ,"##G.B.......B......I...*CC<+CCCCCCC+CCCCCC*CCCCCCCCC<CCCC*CCCC$=$CCC*CCCCCCCC$$$"
    ,"###GG====GGGGGGGGGGGGGG$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$=$$$$$$$$$$$$$$$$"
    ,"######=======##################=======############ccccccc######=################"
    ,"#######================########=#####=#####=========#c#cc######=################"
    ,"#########====#########==========#####=======#########c##========################"
    ,"################################################################################"]

clockTower :: [String]
clockTower =
    ["......................................................................."
    ,"......................................................................."
    ,"......................................................................."
    ,"............................SSS........................................"
    ,"...........................SSSSS......................................."
    ,"..........................SSSSSSS......................................"
    ,"..........................I.....I......................................"
    ,".........................SSSS*SSSS....................................."
    ,"..........................ICC<CCI.....................................S"
    ,"..........................SCC<CCS.....................................S"
    ,"..........................SSS+SSS.....................................S"
    ,"..........................SCC<CCS.....................................S"
    ,"..........................SCC<CCS......SSSSSSS........................S"
    ,"............%.............ICC<CCI......SCCCCCS........................S"
    ,"...........%%%............SCC<CCS......SCCCCC*..S.....................S"
    ,"...........%I%...SSSS+SS..SSS+SSS......SSSSSSSSSSSS..SSSSSSSSSS.......S"
    ,"####........I....SCCC<CS..SCC<CCS......SCCCCCCCCCCS..SCCCCCCCCS.......S"
    ,"####......B.I....*CCC<C*..*CC<CC*......*CCCCCCCCCC*..*CCCCCCCC*....B..S"
    ,"########GGGGGG###################################################GGGGG#"
    ,"#######################################################################"]

pirateCove :: [String]
pirateCove =
    ["................................................................................"
    ,"................................................................................"
    ,".................................%.............................................."
    ,"................................%%%............................................I"
    ,"................................%I%............................................S"
    ,".................................I.....B......................................SS"
    ,".................................I.B..GGGG.....................................S"
    ,"............................B.GGGGGGGG#########.............................I..S"
    ,"............................GG#####################........................SSSSS"
    ,".........................###############################....................I..S"
    ,".......................####ccccc#cccc#ccc################......................S"
    ,"......................#####ccccc*cccc*ccccc##########ccc.......................S"
    ,"......................#####c#############ccccccc####cccc........I....I.........S"
    ,".....................##ccc##c##############ccccccc+cccccc.......SSSSSSCCCCCCCCCS"
    ,"####................###ccc+ccccccccccccc+cc#########SSSSSS==========SSSSSSSSSSSS"
    ,"#######...........################################========================SSSSSS"
    ,"###########======#################=============================================S"
    ,"#############======================#############################################"
    ,"################################################################################"]

mines :: [String]
mines =
    ["...................................#############################################"
    ,"........................%........%%#############################################"
    ,"...........%%..........%%%......%%%*cccccccccccccccccccccccccccccccccccccccccc##"
    ,"...........%%%........%%I%.....%%%%##########################################<##"
    ,"...........%I%..........I%......%I%##############cccc#################CCCCC##<##"
    ,"....B.......I.......B..BI........I.+ccccccccccccIccccIccccccccccccccc*CCCCC##<##"
    ,"GGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGG#################cc#######c#################<##"
    ,"#################################################cc########c#################<##"
    ,"########################################cccccccccc#########c#################<##"
    ,"####CCCC##################CCCC#################c<##########c####cc###########<##"
    ,"####CCCC*cccccccccccccccc*CCCC+ccccccccccccccccc<ccccccccccccccccccccccc#####<##"
    ,"###########<###################################c<##############ccc###########<##"
    ,"###cccccccc<##################ccccc#############cc##############c###cc#######<##"
    ,"####cc#####<######################cc#############ccccccccc########ccccc######<##"
    ,"###cc######<#####CCCC############cc###############cc########c######c#########<##"
    ,"###ccccccccccccc*CCCC+cccccccccccccccccccccccccccccccccccccccccccccc#########<##"
    ,"######################################c######c#############cc################c##"
    ,"#######ccccccccccccccccccccccccc#####cc###cccccc#############################c##"
    ,"###############################c#############################################c##"
    ,"######c############cccccccccccccccc<<<<<cccccccccccccccccc*cccccccc*cccccccc*cc#"
    ,"#####ccc#########ccc################ccc#######################################<#"
    ,"####ccccc##########c################ccc#################ccccccc###############<#"
    ,"###IccCCcI#######cccccccccccc#######cccc###############cc#####cc##############<#"
    ,"##cIcCCcCIc########################cc#c###############cc#######cc#############<#"
    ,"#CCIccCCcIcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc<#"
    ,"################################################################################"]

module Level where

import Data.Char
import Data.String (String)
import qualified Data.String as S
import Data.Array ((..), (!!), updateAt, map, length)
import qualified Data.Array.Unsafe as U
import Data.Maybe
import GameData
import Utils
import Astar

data Tile = Air        | Water      | BrickWall
          | Ground     | Grass      | Wall      | SWall
          | DoorLocked | DoorClosed | DoorOpen
          | BgCave     | BgHouse
          | Bush       | Stairs
          | Trunk      | Leaves

data Level = Level
    { width  :: Number
    , height :: Number
    , tiles  :: [Tile]
    }

isTileSolid :: Tile -> Boolean
isTileSolid Ground     = true
isTileSolid Grass      = true
isTileSolid Wall       = true
isTileSolid BrickWall  = true
isTileSolid SWall      = true
isTileSolid DoorLocked = true
isTileSolid DoorClosed = true
isTileSolid _          = false

isTileTransparent :: Tile -> Boolean
isTileTransparent Ground     = false
isTileTransparent Grass      = false
isTileTransparent Wall       = false
isTileTransparent BrickWall  = false
isTileTransparent SWall      = false
isTileTransparent DoorLocked = false
isTileTransparent DoorClosed = false
isTileTransparent Bush       = false
isTileTransparent Water      = false
isTileTransparent Leaves     = false
isTileTransparent _          = true

isTileClimbable :: Tile -> Boolean
isTileClimbable Stairs     = true
isTileClimbable Water      = true
isTileClimbable DoorOpen   = true
isTileClimbable DoorClosed = true
isTileClimbable DoorLocked = true
isTileClimbable Leaves     = true
isTileClimbable _          = false

-- Calculates tile weights for pathfinding.
levelWeights :: Level -> [[Number]]
levelWeights l@(Level level) = do
    y <- 0 .. (level.height - 1)
    [makeRow y 0]
    where
        makeRow :: Number -> Number -> [Number]
        makeRow i x | x < level.width = tileWeight {x: x, y: i} : makeRow i (x + 1)
        makeRow i x | otherwise       = []

        tileWeight :: Point -> Number
        tileWeight p | canWalkOn p || canClimbOn p = 1
        tileWeight p | otherwise                   = 0

        getTile' :: Point -> Tile
        getTile' = fromMaybe Ground <<< getTile l

        canWalkOn :: Point -> Boolean
        canWalkOn p = blocked (p .+. {x:0, y:1}) && not (blocked p)

        canClimbOn :: Point -> Boolean
        canClimbOn = isTileClimbable <<< getTile'

        blocked :: Point -> Boolean
        blocked = blocksNpc <<< getTile'

        blocksNpc :: Tile -> Boolean
        blocksNpc DoorOpen   = false
        blocksNpc DoorClosed = false
        blocksNpc DoorLocked = false
        blocksNpc t = isTileSolid t

newLevel :: Number -> Number -> Level
newLevel w h = Level { width: w, height: h, tiles: replicate (w * h) Air }

emptyLevel :: Level
emptyLevel = Level { width: 0, height: 0, tiles: [] }

index :: Level -> Number -> Number -> Number
index (Level level) x y = x + y * level.width

getTile :: Level -> Point -> Maybe Tile
getTile l@(Level level) p | p.x >= 0 && p.y > 0 && p.x < level.width && p.y < level.height =
    level.tiles !! index l p.x p.y
getTile l@(Level level) p | p.y >= level.height = Just Ground
getTile l@(Level level) p | otherwise = Just Air

setTile :: Level -> Point -> Tile -> Level
setTile l@(Level level) p newTile =
    Level $ level { tiles = updateAt (index l p.x p.y) newTile level.tiles }

isValidMove :: Level -> Point -> Boolean
isValidMove level = not <<< isTileSolid <<< fromMaybe Air <<< getTile level

isTransparent :: Level -> Point -> Boolean
isTransparent level = isTileTransparent <<< fromMaybe Air <<< getTile level

isClimbable :: Level -> Point -> Boolean
isClimbable level = isTileClimbable <<< fromMaybe Air <<< getTile level

inFreeFall :: forall r. Level -> { pos :: Point, vel :: Point | r } -> Boolean
inFreeFall level c = isValidMove level (c.pos .+. {x:0, y: 1}) || c.vel.y < 0

-- Returns all points inside level.
levelPoints :: Level -> [Point]
levelPoints (Level level) = do
    x' <- 0 .. (level.width - 1)
    y' <- 0 .. (level.height - 1)
    return {x: x', y: y'}

stringToLevel :: [String] -> Level
stringToLevel strs = Level $ { width: S.length (U.head strs), height: length strs, tiles: makeTiles strs }
    where
        makeTiles :: [String] -> [Tile]
        makeTiles (x:xs) = map charToTile (S.toCharArray x) ++ makeTiles xs
        makeTiles _      = []

        charToTile :: Char -> Tile
        charToTile c | c == makeChar "." = Air
        charToTile c | c == makeChar "#" = Ground
        charToTile c | c == makeChar "G" = Grass
        charToTile c | c == makeChar "S" = Wall
        charToTile c | c == makeChar "W" = SWall
        charToTile c | c == makeChar "$" = BrickWall
        charToTile c | c == makeChar "*" = DoorLocked
        charToTile c | c == makeChar "+" = DoorClosed
        charToTile c | c == makeChar "|" = DoorOpen
        charToTile c | c == makeChar "c" = BgCave
        charToTile c | c == makeChar "C" = BgHouse
        charToTile c | c == makeChar "B" = Bush
        charToTile c | c == makeChar "=" = Water
        charToTile c | c == makeChar "<" = Stairs
        charToTile c | c == makeChar "I" = Trunk
        charToTile c | c == makeChar "%" = Leaves
        charToTile _ = Air

type LevelDefinition =
    { name      :: String
    , plan      :: [String]
    , itemPos   :: [Point]
    , lootPos   :: [Point]
    , npcPos    :: [{ p :: Point, ctype :: CreatureType, ai :: AIState }]
    , startPos  :: Point
    }

allLevels :: [LevelDefinition]
allLevels = [{ name: "a small village"
             , plan: tutorialLevel
             , itemPos: [p 55 6, p 62 5, p 23 9]
             , lootPos: [p 40 9, p 48 9, p 64 9, p 66 9, p 21 9, p 22 9]
             , npcPos: [patrol (p 59 9)]
             , startPos: {x: 2, y: 7}}

            ,{ name: "a small castle"
             , plan: castleLevel
             , itemPos: [p 30 13, p 45 13, p 72 13, p 76 6, p 27 6]
             , lootPos: [p 24 10, p 24 13, p 39 16, p 69 13, p 70 13, p 71 13]
             , npcPos: [patrol (p 37 10), patrol (p 72 10), aIdle (p 76 3), aIdle (p 24 6)]
             , startPos: {x: 2, y: 15}}

            ,{ name: "a small town with clock tower"
             , plan: clockTower
             , itemPos: [p 31 14, p 24 9, p 29 2, p 43 14, p 56 17]
             , lootPos: [p 19 17, p 10 16, p 11 16, p 40 11, p 40 14, p 42 14, p 44 17]
             , npcPos: [aIdle (p 24 6), patrol (p 60 17), patrol (p 33 6)]
             , startPos: {x: 2, y: 15}}

            ,{ name: "a hidden pirate cove"
             , plan: pirateCove
             , itemPos: [p 34 14, p 25 14, p 30 11, p 35 11, p 78 13]
             , lootPos: [p 54 13, p 23 14, p 24 14, p 28 11, p 76 13, p 74 13]
             , npcPos: [patrol (p 77 13), patrol (p 46 13)]
             , startPos: {x: 3, y: 13}}]
    where
        p x y = {x: x, y: y}

        idler p' = { p: p', ctype: Guard, ai: Idle p' }
        patrol p' = { p: p', ctype: Guard, ai: Patrol p' }

        aIdle p' = { p: p', ctype: Archer, ai: Idle p' }

emptyLevel' :: [String]
emptyLevel' =
    ["................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"]

tutorialLevel :: [String]
tutorialLevel =
    ["................................................................................"
    ,"................................................................................"
    ,"...............................................................................S"
    ,"...............................................................................S"
    ,"..................................................SSSSSSS.................%%.. S"
    ,"...............................%................SSSCCCCCS................%%%%..S"
    ,"......................####....%%%...............I.+CCCCCS.....SSSSSSS...%%I%...S"
    ,"................B..GG#####....%I%%....SSSS*S..SSSSSSS<SSS.....SCCCCCS.....I....S"
    ,"#####GG..B......GGG##ccc###....I......SCCC<S..SCCCSCC<CCS.....SCCCCCS.....I....S"
    ,"#######GGGG===GG#####ccccccB.B.I..GG..*CCC<*..*CCC+CC<CC*.....*CCCCC*...B.IB...S"
    ,"###########===#############GGGGGGG##GGSSSSSSGGSSSSSSSSSSSGGGGGGGGGGGGGGGGGGGGGGG"
    ,"###########==###################################################################"
    ,"################################################################################"]

castleLevel :: [String]
castleLevel =
    ["...............................................................................$"
    ,"...............................................................................$"
    ,"...............................................................................$"
    ,"..........................................................................$....$"
    ,"..........................................................................$$$$*$"
    ,"...........................................................................$CC<$"
    ,"......................$.....$..............................................$CC<$"
    ,"......................$$$$+$$..............................................$$$+$"
    ,".......................$CC<$.....................$$$$$$$$$$$$$$$...........$CC<$"
    ,".......................$CC<$.....................$CCCCCCC$CCCCC$...........$CC<$"
    ,".......................$CC<*.....................*CCCCCCC+CCCCC*...........*CC<$"
    ,".......................$$$+$$$$$$*$$$$$$$$$$$$$$$$$$+$$$$$$$$$$$$$$$$$$$$$$$$$$$"
    ,"...................%...$CC<$CCCCC<CCCC$CCCCCCCCCC$CC<CCCC$CCCCCCCCCC$CCCCCC$CCC$"
    ,"..................%%%%.$CC<$CCCCC<CCCC+CCCCCCCCCC+CC<CCCC$CCCCCCCCCC$CCCCCC*CCC$"
    ,"..................%I%..$$$+$$$$$$$$$$$$$$$$$$$$$$$$$+$$$$$CCCCCCCCCC$$$$$$$$$$C$"
    ,"#..................I...$CC<$CCCCCCC$CCCCCC$CCCCCCCCC<CCCC$CCCCICICCC$CCCCCCCCC$$"
    ,"##G.B.......B......I...*CC<+CCCCCCC+CCCCCC*CCCCCCCCC<CCCC*CCCC$=$CCC*CCCCCCCC$$$"
    ,"###GG====GGGGGGGGGGGGGG$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$=$$$$$$$$$$$$$$$$"
    ,"######=======##################=======############ccccccc######=################"
    ,"#######================########=#####=#####=========#c#cc######=################"
    ,"#########====#########==========#####=======#########c##========################"
    ,"################################################################################"]

clockTower :: [String]
clockTower =
    ["......................................................................."
    ,"......................................................................."
    ,"......................................................................."
    ,"............................SSS........................................"
    ,"...........................SSSSS......................................."
    ,"..........................SSSSSSS......................................"
    ,"..........................I.....I......................................"
    ,".........................SSSS*SSSS....................................."
    ,"..........................ICC<CCI.....................................S"
    ,"..........................SCC<CCS.....................................S"
    ,"..........................SSS+SSS.....................................S"
    ,"..........................SCC<CCS.....................................S"
    ,"..........................SCC<CCS......SSSSSSS........................S"
    ,"............%.............ICC<CCI......SCCCCCS........................S"
    ,"...........%%%............SCC<CCS......SCCCCC*..S.....................S"
    ,"...........%I%...SSSS+SS..SSS+SSS......SSSSSSSSSSSS..SSSSSSSSSS.......S"
    ,"####........I....SCCC<CS..SCC<CCS......SCCCCCCCCCCS..SCCCCCCCCS.......S"
    ,"####......B.I....*CCC<C*..*CC<CC*......*CCCCCCCCCC*..*CCCCCCCC*....B..S"
    ,"########GGGGGG###################################################GGGGG#"
    ,"#######################################################################"]

pirateCove :: [String]
pirateCove =
    ["................................................................................"
    ,"................................................................................"
    ,".................................%.............................................."
    ,"................................%%%............................................I"
    ,"................................%I%............................................S"
    ,".................................I.....B......................................SS"
    ,".................................I.B..GGGG.....................................S"
    ,"............................B.GGGGGGGG#########.............................I..S"
    ,"............................GG#####################........................SSSSS"
    ,".........................###############################....................I..S"
    ,".......................####ccccc#cccc#ccc################......................S"
    ,"......................#####ccccc*cccc*ccccc##########ccc.......................S"
    ,"......................#####c#############ccccccc####cccc........I....I.........S"
    ,".....................##ccc##c##############ccccccc+cccccc.......SSSSSSCCCCCCCCCS"
    ,"####................###ccc+ccccccccccccc+cc#########SSSSSS==========SSSSSSSSSSSS"
    ,"#######...........################################========================SSSSSS"
    ,"###########======#################=============================================S"
    ,"#############======================#############################################"
    ,"################################################################################"]

mines :: [String]
mines =
    ["...................................#############################################"
    ,"........................%........%%#############################################"
    ,"...........%%..........%%%......%%%*cccccccccccccccccccccccccccccccccccccccccc##"
    ,"...........%%%........%%I%.....%%%%##########################################<##"
    ,"...........%I%..........I%......%I%##############cccc#################CCCCC##<##"
    ,"....B.......I.......B..BI........I.+ccccccccccccIccccIccccccccccccccc*CCCCC##<##"
    ,"GGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGG#################cc#######c#################<##"
    ,"#################################################cc########c#################<##"
    ,"########################################cccccccccc#########c#################<##"
    ,"####CCCC##################CCCC#################c<##########c####cc###########<##"
    ,"####CCCC*cccccccccccccccc*CCCC+ccccccccccccccccc<ccccccccccccccccccccccc#####<##"
    ,"###########<###################################c<##############ccc###########<##"
    ,"###cccccccc<##################ccccc#############cc##############c###cc#######<##"
    ,"####cc#####<######################cc#############ccccccccc########ccccc######<##"
    ,"###cc######<#####CCCC############cc###############cc########c######c#########<##"
    ,"###ccccccccccccc*CCCC+cccccccccccccccccccccccccccccccccccccccccccccc#########<##"
    ,"######################################c######c#############cc################c##"
    ,"#######ccccccccccccccccccccccccc#####cc###cccccc#############################c##"
    ,"###############################c#############################################c##"
    ,"######c############cccccccccccccccc<<<<<cccccccccccccccccc*cccccccc*cccccccc*cc#"
    ,"#####ccc#########ccc################ccc#######################################<#"
    ,"####ccccc##########c################ccc#################ccccccc###############<#"
    ,"###IccCCcI#######cccccccccccc#######cccc###############cc#####cc##############<#"
    ,"##cIcCCcCIc########################cc#c###############cc#######cc#############<#"
    ,"#CCIccCCcIcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc<#"
    ,"################################################################################"]


Name IRUnions within IRUnion cases

Name IRUnions within IRUnion cases

Original commit 52c8575eb96f4adf6e026e3696a6f8f83bcff0f4

module Swift
    ( renderSwiftClass
    ) where

import Prelude

import Doc
import IR

import Data.Foldable (for_, intercalate)
import Data.Function (on)

import Data.List as L
import Data.List.NonEmpty as NE

import Data.Map as M

import Data.Set as S
import Data.Tuple (Tuple(..))

renderSwiftClass :: IRClassData -> Doc Unit
renderSwiftClass { name, properties } = do
    line $ words ["struct", name]
    line "{"
    indent do
        let props = properties # M.toUnfoldable <#> \(Tuple name typ) -> { name, typ }
        let propGroups = L.groupBy (eq `on` _.typ) props
        for_ propGroups renderPropGroup
    line "}"

    blank

    for_ (M.values properties) renderUnions

renderPropGroup :: NE.NonEmptyList { name :: String, typ :: IRType} -> Doc Unit
renderPropGroup props = line do
    let names = intercalate ", " (_.name <$> props)
    words ["let", names <> ":"]
    string " "

    let { typ } = NE.head props
    string $ renderType typ

renderType :: IRType -> String
renderType = case _ of
    IRNothing -> "Any"
    IRNull -> "Any"
    IRInteger -> "Int"
    IRDouble -> "Double"
    IRBool -> "Bool"
    IRString -> "String"
    IRArray a -> "[" <> renderType a <> "]"
    IRClass { name } -> name
    IRUnion s ->  unionName s

renderUnions :: IRType -> Doc Unit
renderUnions = case _ of
    IRUnion s -> do
        renderUnion s
        for_ (S.toUnfoldable s :: Array _) renderUnions
    IRArray (IRUnion s) -> renderUnion s
    _ -> pure unit

unionName :: S.Set IRType -> String
unionName s = intercalate "Or" $ (caseName <$> S.toUnfoldable s :: Array _)

caseName :: IRType -> String
caseName = case _ of
    IRArray a -> renderType a <> "s"
    IRUnion s ->  unionName s
    t -> renderType t

renderUnion :: S.Set IRType -> Doc Unit
renderUnion types = do
    line $ words ["enum", unionName types, "{"]
    indent do
        for_ types \typ -> line do
            string "case ."
            string $ "some" <> caseName typ
            string "("
            string $ renderType typ
            string ")"
    line "}"
    blank

module Swift
    ( renderSwiftClass
    ) where

import Prelude

import Doc
import IR

import Data.Foldable (for_, intercalate)
import Data.Function (on)

import Data.List as L
import Data.List.NonEmpty as NE

import Data.Map as M

import Data.Set as S
import Data.Tuple (Tuple(..))

renderSwiftClass :: IRClassData -> Doc Unit
renderSwiftClass { name, properties } = do
    line $ words ["struct", name]
    line "{"
    indent do
        let props = properties # M.toUnfoldable <#> \(Tuple name typ) -> { name, typ }
        let propGroups = L.groupBy (eq `on` _.typ) props
        for_ propGroups renderPropGroup
    line "}"

    blank

    for_ (M.values properties) renderUnions

renderPropGroup :: NE.NonEmptyList { name :: String, typ :: IRType} -> Doc Unit
renderPropGroup props = line do
    let names = intercalate ", " (_.name <$> props)
    words ["let", names <> ":"]
    string " "

    let { typ } = NE.head props
    string $ renderType typ

renderType :: IRType -> String
renderType = case _ of
    IRNothing -> "Any"
    IRNull -> "Any"
    IRInteger -> "Int"
    IRDouble -> "Double"
    IRBool -> "Bool"
    IRString -> "String"
    IRArray a -> "[" <> renderType a <> "]"
    IRClass { name } -> name
    IRUnion s ->  unionName s

renderUnions :: IRType -> Doc Unit
renderUnions = case _ of
    IRUnion s -> do
        renderUnion s
        for_ (S.toUnfoldable s :: Array _) renderUnions
    IRArray (IRUnion s) -> renderUnion s
    _ -> pure unit

unionName :: S.Set IRType -> String
unionName s = intercalate "Or" $ (caseName <$> S.toUnfoldable s :: Array _)

caseName :: IRType -> String
caseName = case _ of
    IRArray a -> renderType a <> "s"
    IRUnion _ ->  "Union"
    t -> renderType t

renderUnion :: S.Set IRType -> Doc Unit
renderUnion types = do
    line $ words ["enum", unionName types, "{"]
    indent do
        for_ types \typ -> line do
            string "case ."
            string $ "some" <> caseName typ
            string "("
            string $ renderType typ
            string ")"
    line "}"
    blank


Add `profileParser`

Add `profileParser`

This ensures the profiler prints both on success and failure

module Debug.Profile where

import Prelude
import Debug.Trace
import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.Eff.Unsafe
import Text.Parsing.Parser (PState(..), ParserT(..), unParserT) as P

profileA :: forall m a. (Monad m) => String -> (Unit -> m a) -> m a
profileA msg f = do
  let t  = unsafePerformEff sampleTime
  a <- f unit
  let t' = unsafePerformEff sampleTime
  traceA $ msg <> " (" <> (show $ t' - t) <> " ms)"
  pure a

profileParser :: forall s m a. (Monad m) => String -> P.ParserT s m a -> P.ParserT s m a
profileParser msg p = P.ParserT $ \s -> profileA msg \_ -> P.unParserT p s

foreign import sampleTime :: forall eff. Eff eff Int

module Debug.Profile where

import Prelude
import Debug.Trace
import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.Eff.Unsafe

profileA :: forall m a. (Monad m) => String -> (Unit -> m a) -> m a
profileA msg f = do
  let t  = unsafePerformEff sampleTime
  a <- f unit
  let t' = unsafePerformEff sampleTime
  traceA $ msg <> " (" <> (show $ t' - t) <> "ms)"
  pure a

foreign import sampleTime :: forall eff. Eff eff Int


Added ability to obtain "clientX" and "clientY" from mouse events

module Data.DOM.Simple.Events where

import Prelude

import Control.Monad.Eff
import Control.Monad

import Data.DOM.Simple.Types
import Data.DOM.Simple.Window(document, globalWindow)
import Data.DOM.Simple.Ajax
import Data.DOM.Simple.Unsafe.Events
import DOM

-- XXX Should this be in the Prelude?
class Read s where
  read :: String -> s

{- Generic properties and methods available on all events. -}

class Event e where
  eventTarget     :: forall eff a. e -> (Eff (dom :: DOM | eff) a)
  stopPropagation :: forall eff. e -> (Eff (dom :: DOM | eff) Unit)
  preventDefault  :: forall eff. e -> (Eff (dom :: DOM | eff) Unit)

instance eventDOMEvent :: Event DOMEvent where
  eventTarget     = unsafeEventTarget
  stopPropagation = unsafeStopPropagation
  preventDefault  = unsafePreventDefault

{- Mouse Events -}

data MouseEventType = MouseMoveEvent | MouseOverEvent | MouseEnterEvent
                    | MouseOutEvent | MouseLeaveEvent | MouseClickEvent
                    | MouseDblClickEvent | MouseUpEvent | MouseDownEvent

instance mouseEventTypeShow :: Show MouseEventType where
  show MouseMoveEvent     = "mousemove"
  show MouseOverEvent     = "mouseover"
  show MouseEnterEvent    = "mouseenter"
  show MouseOutEvent      = "mouseout"
  show MouseLeaveEvent    = "mouseleave"
  show MouseClickEvent    = "click"
  show MouseDblClickEvent = "dblclick"
  show MouseUpEvent       = "mouseup"
  show MouseDownEvent     = "mousedown"

instance mouseEventTypeRead :: Read MouseEventType where
  read "mousemove"  = MouseMoveEvent
  read "mouseover"  = MouseOverEvent
  read "mouseenter" = MouseEnterEvent
  read "mouseout"   = MouseOutEvent
  read "mouseleave" = MouseLeaveEvent
  read "click"      = MouseClickEvent
  read "dblclick"   = MouseDblClickEvent
  read "mouseup"    = MouseUpEvent
  read "mousedown"  = MouseDownEvent

class (Event e) <= MouseEvent e where
  mouseEventType :: forall eff. e -> (Eff (dom :: DOM | eff) MouseEventType)
  screenX :: forall eff. e -> (Eff (dom :: DOM | eff) Int)
  screenY :: forall eff. e -> (Eff (dom :: DOM | eff) Int)
  clientX :: forall eff. e -> (Eff (dom :: DOM | eff) Int)
  clientY :: forall eff. e -> (Eff (dom :: DOM | eff) Int)

instance mouseEventDOMEvent :: MouseEvent DOMEvent where
  mouseEventType ev = read <$> unsafeEventStringProp "type" ev
  screenX = unsafeEventNumberProp "screenX"
  screenY = unsafeEventNumberProp "screenY"
  clientX = unsafeEventNumberProp "clientX"
  clientY = unsafeEventNumberProp "clientY"

class MouseEventTarget b where
  addMouseEventListener :: forall e t ta. (MouseEvent e) =>
                           MouseEventType
                               -> (e -> Eff (dom :: DOM | t) Unit)
                               -> b
                               -> (Eff (dom :: DOM | ta) Unit)

  removeMouseEventListener :: forall e t ta. (MouseEvent e) =>
                              MouseEventType
                                  -> (e -> Eff (dom :: DOM | t) Unit)
                                  -> b
                                  -> (Eff (dom :: DOM | ta) Unit)

instance mouseEventTargetHTMLWindow :: MouseEventTarget HTMLWindow where
  addMouseEventListener typ    = unsafeAddEventListener (show typ)
  removeMouseEventListener typ = unsafeRemoveEventListener (show typ)

instance mouseEventTargetHTMLDocument :: MouseEventTarget HTMLDocument where
  addMouseEventListener typ    = unsafeAddEventListener (show typ)
  removeMouseEventListener typ = unsafeRemoveEventListener (show typ)

instance mouseEventTargetHTMLElement :: MouseEventTarget HTMLElement where
  addMouseEventListener typ    = unsafeAddEventListener (show typ)
  removeMouseEventListener typ = unsafeRemoveEventListener (show typ)

{- Keyboard Events -}

data KeyboardEventType = KeydownEvent | KeypressEvent | KeyupEvent

instance keyboardEventTypeShow :: Show KeyboardEventType where
  show KeydownEvent     = "keydown"
  show KeypressEvent       = "keypress"
  show KeyupEvent       = "keyup"

instance keyboardEventTypeRead :: Read KeyboardEventType where
  read "keydown"  = KeydownEvent
  read "keypress" = KeypressEvent
  read "keyup"    = KeyupEvent

data KeyLocation = KeyLocationStandard | KeyLocationLeft | KeyLocationRight | KeyLocationNumpad

toKeyLocation :: Int -> KeyLocation
toKeyLocation 0 = KeyLocationStandard
toKeyLocation 1 = KeyLocationLeft
toKeyLocation 2 = KeyLocationRight
toKeyLocation 3 = KeyLocationNumpad

class (Event e) <= KeyboardEvent e where
  keyboardEventType :: forall eff. e -> (Eff (dom :: DOM | eff) KeyboardEventType)
  key         :: forall eff. e -> (Eff (dom :: DOM | eff) String)
  keyCode     :: forall eff. e -> (Eff (dom :: DOM | eff) Int)
  keyLocation :: forall eff. e -> (Eff (dom :: DOM | eff) KeyLocation)
  altKey      :: forall eff. e -> (Eff (dom :: DOM | eff) Boolean)
  ctrlKey     :: forall eff. e -> (Eff (dom :: DOM | eff) Boolean)
  metaKey     :: forall eff. e -> (Eff (dom :: DOM | eff) Boolean)
  shiftKey    :: forall eff. e -> (Eff (dom :: DOM | eff) Boolean)

instance keyboardEventDOMEvent :: KeyboardEvent DOMEvent where
  keyboardEventType ev = read <$> unsafeEventStringProp "type" ev

  key = unsafeEventKey
  keyCode = unsafeEventKeyCode

  keyLocation ev = toKeyLocation <$> unsafeEventNumberProp "keyLocation" ev

  altKey   = unsafeEventBooleanProp "altKey"
  ctrlKey  = unsafeEventBooleanProp "ctrlKey"
  metaKey  = unsafeEventBooleanProp "metaKey"
  shiftKey = unsafeEventBooleanProp "shiftKey"

class KeyboardEventTarget b where
  addKeyboardEventListener :: forall e t ta. (KeyboardEvent e) =>
                              KeyboardEventType
                                  -> (e -> Eff (dom :: DOM | t) Unit)
                                  -> b
                                  -> (Eff (dom :: DOM | ta) Unit)

  removeKeyboardEventListener :: forall e t ta. (KeyboardEvent e) =>
                                 KeyboardEventType
                                     -> (e -> Eff (dom :: DOM | t) Unit)
                                     -> b
                                     -> (Eff (dom :: DOM | ta) Unit)

instance keyboardEventTargetHTMLWindow :: KeyboardEventTarget HTMLWindow where
  addKeyboardEventListener typ    = unsafeAddEventListener (show typ)
  removeKeyboardEventListener typ = unsafeRemoveEventListener (show typ)

instance keyboardEventTargetHTMLDocument :: KeyboardEventTarget HTMLDocument where
  addKeyboardEventListener typ    = unsafeAddEventListener (show typ)
  removeKeyboardEventListener typ = unsafeRemoveEventListener (show typ)

instance keyboardEventTargetHTMLElement :: KeyboardEventTarget HTMLElement where
  addKeyboardEventListener typ    = unsafeAddEventListener (show typ)
  removeKeyboardEventListener typ = unsafeRemoveEventListener (show typ)

{- UI Events -}

-- XXX this is slightly ham-handed, since
-- <http://www.w3.org/TR/DOM-Level-3-Events/#interface-UIEvent>
-- specifies that only some kinds of elements are valid targets for
-- each of these events.  Might make to refactor more carefully based
-- on what targets can accept what handlers.

data UIEventType = LoadEvent | UnloadEvent | AbortEvent
                 | ErrorEvent | SelectEvent | ResizeEvent
                 | ScrollEvent

instance uiEventTypeShow :: Show UIEventType where
  show LoadEvent    = "load"
  show UnloadEvent  = "unload"
  show AbortEvent   = "abort"
  show ErrorEvent   = "error"
  show SelectEvent  = "select"
  show ResizeEvent  = "resize"
  show ScrollEvent  = "scroll"

instance uiEventTypeRead :: Read UIEventType where
  read "load"     = LoadEvent
  read "unload"   = UnloadEvent
  read "abort"    = AbortEvent
  read "error"    = ErrorEvent
  read "select"   = SelectEvent
  read "resize"   = ResizeEvent
  read "scroll"   = ScrollEvent

class (Event e) <= UIEvent e where
  -- XXX this should really be returning an HTMLAbstractView...
  view   :: forall eff. e -> (Eff (dom :: DOM | eff) HTMLWindow)
  detail :: forall eff. e -> (Eff (dom :: DOM | eff) Int)

instance uiEventDOMEvent :: UIEvent DOMEvent where
  view   = unsafeEventView
  detail = unsafeEventNumberProp "detail"

class UIEventTarget b where
  addUIEventListener :: forall e t ta. (UIEvent e) =>
                        UIEventType
                            -> (e -> Eff (dom :: DOM | t) Unit)
                            -> b
                            -> (Eff (dom :: DOM | ta) Unit)

  removeUIEventListener :: forall e t ta. (UIEvent e) =>
                           UIEventType
                               -> (e -> Eff (dom :: DOM | t) Unit)
                               -> b
                               -> (Eff (dom :: DOM | ta) Unit)

instance uiEventTargetHTMLWindow :: UIEventTarget HTMLWindow where
  addUIEventListener typ    = unsafeAddEventListener (show typ)
  removeUIEventListener typ = unsafeRemoveEventListener (show typ)

{-
instance eventTargetXMLHttpRequest :: EventTarget XMLHttpRequest where
  addEventListener = unsafeAddEventListener
  removeEventListener = unsafeRemoveEventListener
-}

{-
ready :: forall t ta. (Eff (dom :: DOM | t) Unit) -> (Eff (dom :: DOM | ta) Unit)
ready cb = document globalWindow >>= (addEventListener "DOMContentLoaded" $ \_ -> cb)
-}

module Data.DOM.Simple.Events where

import Prelude

import Control.Monad.Eff
import Control.Monad

import Data.DOM.Simple.Types
import Data.DOM.Simple.Window(document, globalWindow)
import Data.DOM.Simple.Ajax
import Data.DOM.Simple.Unsafe.Events
import DOM

-- XXX Should this be in the Prelude?
class Read s where
  read :: String -> s

{- Generic properties and methods available on all events. -}

class Event e where
  eventTarget     :: forall eff a. e -> (Eff (dom :: DOM | eff) a)
  stopPropagation :: forall eff. e -> (Eff (dom :: DOM | eff) Unit)
  preventDefault  :: forall eff. e -> (Eff (dom :: DOM | eff) Unit)

instance eventDOMEvent :: Event DOMEvent where
  eventTarget     = unsafeEventTarget
  stopPropagation = unsafeStopPropagation
  preventDefault  = unsafePreventDefault

{- Mouse Events -}

data MouseEventType = MouseMoveEvent | MouseOverEvent | MouseEnterEvent
                    | MouseOutEvent | MouseLeaveEvent | MouseClickEvent
                    | MouseDblClickEvent | MouseUpEvent | MouseDownEvent

instance mouseEventTypeShow :: Show MouseEventType where
  show MouseMoveEvent     = "mousemove"
  show MouseOverEvent     = "mouseover"
  show MouseEnterEvent    = "mouseenter"
  show MouseOutEvent      = "mouseout"
  show MouseLeaveEvent    = "mouseleave"
  show MouseClickEvent    = "click"
  show MouseDblClickEvent = "dblclick"
  show MouseUpEvent       = "mouseup"
  show MouseDownEvent     = "mousedown"

instance mouseEventTypeRead :: Read MouseEventType where
  read "mousemove"  = MouseMoveEvent
  read "mouseover"  = MouseOverEvent
  read "mouseenter" = MouseEnterEvent
  read "mouseout"   = MouseOutEvent
  read "mouseleave" = MouseLeaveEvent
  read "click"      = MouseClickEvent
  read "dblclick"   = MouseDblClickEvent
  read "mouseup"    = MouseUpEvent
  read "mousedown"  = MouseDownEvent

class (Event e) <= MouseEvent e where
  mouseEventType :: forall eff. e -> (Eff (dom :: DOM | eff) MouseEventType)
  screenX :: forall eff. e -> (Eff (dom :: DOM | eff) Int)
  screenY :: forall eff. e -> (Eff (dom :: DOM | eff) Int)

instance mouseEventDOMEvent :: MouseEvent DOMEvent where
  mouseEventType ev = read <$> unsafeEventStringProp "type" ev
  screenX = unsafeEventNumberProp "screenX"
  screenY = unsafeEventNumberProp "screenY"

class MouseEventTarget b where
  addMouseEventListener :: forall e t ta. (MouseEvent e) =>
                           MouseEventType
                               -> (e -> Eff (dom :: DOM | t) Unit)
                               -> b
                               -> (Eff (dom :: DOM | ta) Unit)

  removeMouseEventListener :: forall e t ta. (MouseEvent e) =>
                              MouseEventType
                                  -> (e -> Eff (dom :: DOM | t) Unit)
                                  -> b
                                  -> (Eff (dom :: DOM | ta) Unit)

instance mouseEventTargetHTMLWindow :: MouseEventTarget HTMLWindow where
  addMouseEventListener typ    = unsafeAddEventListener (show typ)
  removeMouseEventListener typ = unsafeRemoveEventListener (show typ)

instance mouseEventTargetHTMLDocument :: MouseEventTarget HTMLDocument where
  addMouseEventListener typ    = unsafeAddEventListener (show typ)
  removeMouseEventListener typ = unsafeRemoveEventListener (show typ)

instance mouseEventTargetHTMLElement :: MouseEventTarget HTMLElement where
  addMouseEventListener typ    = unsafeAddEventListener (show typ)
  removeMouseEventListener typ = unsafeRemoveEventListener (show typ)

{- Keyboard Events -}

data KeyboardEventType = KeydownEvent | KeypressEvent | KeyupEvent

instance keyboardEventTypeShow :: Show KeyboardEventType where
  show KeydownEvent     = "keydown"
  show KeypressEvent       = "keypress"
  show KeyupEvent       = "keyup"

instance keyboardEventTypeRead :: Read KeyboardEventType where
  read "keydown"  = KeydownEvent
  read "keypress" = KeypressEvent
  read "keyup"    = KeyupEvent

data KeyLocation = KeyLocationStandard | KeyLocationLeft | KeyLocationRight | KeyLocationNumpad

toKeyLocation :: Int -> KeyLocation
toKeyLocation 0 = KeyLocationStandard
toKeyLocation 1 = KeyLocationLeft
toKeyLocation 2 = KeyLocationRight
toKeyLocation 3 = KeyLocationNumpad

class (Event e) <= KeyboardEvent e where
  keyboardEventType :: forall eff. e -> (Eff (dom :: DOM | eff) KeyboardEventType)
  key         :: forall eff. e -> (Eff (dom :: DOM | eff) String)
  keyCode     :: forall eff. e -> (Eff (dom :: DOM | eff) Int)
  keyLocation :: forall eff. e -> (Eff (dom :: DOM | eff) KeyLocation)
  altKey      :: forall eff. e -> (Eff (dom :: DOM | eff) Boolean)
  ctrlKey     :: forall eff. e -> (Eff (dom :: DOM | eff) Boolean)
  metaKey     :: forall eff. e -> (Eff (dom :: DOM | eff) Boolean)
  shiftKey    :: forall eff. e -> (Eff (dom :: DOM | eff) Boolean)

instance keyboardEventDOMEvent :: KeyboardEvent DOMEvent where
  keyboardEventType ev = read <$> unsafeEventStringProp "type" ev

  key = unsafeEventKey
  keyCode = unsafeEventKeyCode

  keyLocation ev = toKeyLocation <$> unsafeEventNumberProp "keyLocation" ev

  altKey   = unsafeEventBooleanProp "altKey"
  ctrlKey  = unsafeEventBooleanProp "ctrlKey"
  metaKey  = unsafeEventBooleanProp "metaKey"
  shiftKey = unsafeEventBooleanProp "shiftKey"

class KeyboardEventTarget b where
  addKeyboardEventListener :: forall e t ta. (KeyboardEvent e) =>
                              KeyboardEventType
                                  -> (e -> Eff (dom :: DOM | t) Unit)
                                  -> b
                                  -> (Eff (dom :: DOM | ta) Unit)

  removeKeyboardEventListener :: forall e t ta. (KeyboardEvent e) =>
                                 KeyboardEventType
                                     -> (e -> Eff (dom :: DOM | t) Unit)
                                     -> b
                                     -> (Eff (dom :: DOM | ta) Unit)

instance keyboardEventTargetHTMLWindow :: KeyboardEventTarget HTMLWindow where
  addKeyboardEventListener typ    = unsafeAddEventListener (show typ)
  removeKeyboardEventListener typ = unsafeRemoveEventListener (show typ)

instance keyboardEventTargetHTMLDocument :: KeyboardEventTarget HTMLDocument where
  addKeyboardEventListener typ    = unsafeAddEventListener (show typ)
  removeKeyboardEventListener typ = unsafeRemoveEventListener (show typ)

instance keyboardEventTargetHTMLElement :: KeyboardEventTarget HTMLElement where
  addKeyboardEventListener typ    = unsafeAddEventListener (show typ)
  removeKeyboardEventListener typ = unsafeRemoveEventListener (show typ)

{- UI Events -}

-- XXX this is slightly ham-handed, since
-- <http://www.w3.org/TR/DOM-Level-3-Events/#interface-UIEvent>
-- specifies that only some kinds of elements are valid targets for
-- each of these events.  Might make to refactor more carefully based
-- on what targets can accept what handlers.

data UIEventType = LoadEvent | UnloadEvent | AbortEvent
                 | ErrorEvent | SelectEvent | ResizeEvent
                 | ScrollEvent

instance uiEventTypeShow :: Show UIEventType where
  show LoadEvent    = "load"
  show UnloadEvent  = "unload"
  show AbortEvent   = "abort"
  show ErrorEvent   = "error"
  show SelectEvent  = "select"
  show ResizeEvent  = "resize"
  show ScrollEvent  = "scroll"

instance uiEventTypeRead :: Read UIEventType where
  read "load"     = LoadEvent
  read "unload"   = UnloadEvent
  read "abort"    = AbortEvent
  read "error"    = ErrorEvent
  read "select"   = SelectEvent
  read "resize"   = ResizeEvent
  read "scroll"   = ScrollEvent

class (Event e) <= UIEvent e where
  -- XXX this should really be returning an HTMLAbstractView...
  view   :: forall eff. e -> (Eff (dom :: DOM | eff) HTMLWindow)
  detail :: forall eff. e -> (Eff (dom :: DOM | eff) Int)

instance uiEventDOMEvent :: UIEvent DOMEvent where
  view   = unsafeEventView
  detail = unsafeEventNumberProp "detail"

class UIEventTarget b where
  addUIEventListener :: forall e t ta. (UIEvent e) =>
                        UIEventType
                            -> (e -> Eff (dom :: DOM | t) Unit)
                            -> b
                            -> (Eff (dom :: DOM | ta) Unit)

  removeUIEventListener :: forall e t ta. (UIEvent e) =>
                           UIEventType
                               -> (e -> Eff (dom :: DOM | t) Unit)
                               -> b
                               -> (Eff (dom :: DOM | ta) Unit)

instance uiEventTargetHTMLWindow :: UIEventTarget HTMLWindow where
  addUIEventListener typ    = unsafeAddEventListener (show typ)
  removeUIEventListener typ = unsafeRemoveEventListener (show typ)

{-
instance eventTargetXMLHttpRequest :: EventTarget XMLHttpRequest where
  addEventListener = unsafeAddEventListener
  removeEventListener = unsafeRemoveEventListener
-}

{-
ready :: forall t ta. (Eff (dom :: DOM | t) Unit) -> (Eff (dom :: DOM | ta) Unit)
ready cb = document globalWindow >>= (addEventListener "DOMContentLoaded" $ \_ -> cb)
-}


Fix indentation, remove import

Fix indentation, remove import

module Test.RefSpec (refSpec) where

import Control.Monad.Eff.Class (liftEff)
import Data.Maybe (Maybe(Just, Nothing))
import Prelude (Unit, bind, discard, ($), (>>=), (<>))
import Test.Spec (describe, it, Spec)
import Test.Spec.Assertions (shouldEqual)
import Test.Spec.Assertions.Aff (expectError)
import Web.Firebase (child, key, toString)
import Web.Firebase.Aff as FAff
import Web.Firebase.Types as FBT

refSpec :: forall eff. FBT.Firebase -> Spec (firebase :: FBT.FirebaseEff | eff) Unit
refSpec ref = do
 describe "A reference in" do
   describe "Eff" do
     it "root reference is Nothing" do
       let rootKey = key ref
       rootKey `shouldEqual` Nothing
     it "key of root refences' child is child" do
       actual <- liftEff $ (child "achild" ref)
       (key actual) `shouldEqual` (Just "achild")
     describe "toString" do
       it "on root represents full database URl" do
         actual <- liftEff $ toString ref
         actual `shouldEqual` "https://purescript-spike.firebaseio.com/"
       it "on child represents full database URl plus child" do
         actual <- liftEff $ (child "achild" ref) >>= toString
         actual `shouldEqual` "https://purescript-spike.firebaseio.com/achild"
   describe "Aff" do
     describe "Getting a key" do
       it "on root throws an error" do
         expectError $ FAff.key ref
       it "on child of root returns child" do
         actual <- (FAff.child "affchild" ref) >>= FAff.key
         actual `shouldEqual` "affchild"
     describe "toString" do
       it "on root returns url" do
         actual <- FAff.toString ref
         actual `shouldEqual` "https://purescript-spike.firebaseio.com/"
       it "on child of root returns root url + child" do
         let child = "achild"
         actual <- (FAff.child child ref) >>= FAff.toString
         actual `shouldEqual` ("https://purescript-spike.firebaseio.com/" <> child)

module Test.RefSpec (refSpec) where

import Control.Monad.Eff.Class (liftEff)
import Data.Maybe (Maybe(Just, Nothing))
import Prelude (Unit, bind, discard, ($), (>>=), (<>))
import Test.Spec (describe, it, Spec)
import Test.Spec.Assertions (shouldEqual)
import Test.Spec.Assertions.Aff (expectError)
import Web.Firebase (child, key, toString)
import Web.Firebase.Aff as FAff
import Web.Firebase.Types as FBT
import Web.Firebase.UnsafeRef (refFor)

refSpec :: forall eff. FBT.Firebase -> Spec (firebase :: FBT.FirebaseEff | eff) Unit
refSpec ref = do
 describe "A reference in" do
   describe "Eff" do
     it "root reference is Nothing" do
       let rootKey = key ref
       rootKey `shouldEqual` Nothing
     it "key of root refences' child is child" do
       actual <- liftEff $ (child "achild" ref)
       (key actual) `shouldEqual` (Just "achild")
     describe "toString" do
       it "on root represents full database URl" do
         actual <- liftEff $ toString ref
         actual `shouldEqual` "https://purescript-spike.firebaseio.com/"
       it "on child represents full database URl plus child" do
         actual <- liftEff $ (child "achild" ref) >>= toString
         actual `shouldEqual` "https://purescript-spike.firebaseio.com/achild"
     describe "Aff" do
       describe "Getting a key" do
        it "on root throws an error" do
          expectError $ FAff.key ref
        it "on child of root returns child" do
          actual <- (FAff.child "affchild" ref) >>= FAff.key
          actual `shouldEqual` "affchild"
       describe "toString" do
         it "on root returns url" do
           actual <- FAff.toString ref
           actual `shouldEqual` "https://purescript-spike.firebaseio.com/"
         it "on child of root returns root url + child" do
           let child = "achild"
           actual <- (FAff.child child ref) >>= FAff.toString
           actual `shouldEqual` ("https://purescript-spike.firebaseio.com/" <> child)