use derived instances in tests

use derived instances in tests

module Test.Data.Map where

import Prelude
import Data.List.NonEmpty as NEL
import Data.Map as M
import Control.Alt ((<|>))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Random (RANDOM)
import Data.Foldable (foldl, for_, all)
import Data.Function (on)
import Data.List (List(Cons), groupBy, length, nubBy, singleton, sort, sortBy)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Tuple (Tuple(..), fst)
import Partial.Unsafe (unsafePartial)
import Test.QuickCheck ((<?>), (===), quickCheck, quickCheck')
import Test.QuickCheck.Arbitrary (class Arbitrary, arbitrary)

newtype TestMap k v = TestMap (M.Map k v)

instance arbTestMap :: (Eq k, Ord k, Arbitrary k, Arbitrary v) => Arbitrary (TestMap k v) where
  arbitrary = TestMap <<< (M.fromFoldable :: List (Tuple k v) -> M.Map k v) <$> arbitrary

data SmallKey = A | B | C | D | E | F | G | H | I | J
derive instance eqSmallKey :: Eq SmallKey
derive instance ordSmallKey :: Ord SmallKey

instance showSmallKey :: Show SmallKey where
  show A = "A"
  show B = "B"
  show C = "C"
  show D = "D"
  show E = "E"
  show F = "F"
  show G = "G"
  show H = "H"
  show I = "I"
  show J = "J"

instance arbSmallKey :: Arbitrary SmallKey where
  arbitrary = do
    n <- arbitrary
    pure case n of
      _ | n < 0.1 -> A
      _ | n < 0.2 -> B
      _ | n < 0.3 -> C
      _ | n < 0.4 -> D
      _ | n < 0.5 -> E
      _ | n < 0.6 -> F
      _ | n < 0.7 -> G
      _ | n < 0.8 -> H
      _ | n < 0.9 -> I
      _ -> J

data Instruction k v = Insert k v | Delete k

instance showInstruction :: (Show k, Show v) => Show (Instruction k v) where
  show (Insert k v) = "Insert (" <> show k <> ") (" <> show v <> ")"
  show (Delete k) = "Delete (" <> show k <> ")"

instance arbInstruction :: (Arbitrary k, Arbitrary v) => Arbitrary (Instruction k v) where
  arbitrary = do
    b <- arbitrary
    case b of
      true -> do
        k <- arbitrary
        v <- arbitrary
        pure (Insert k v)
      false -> do
        k <- arbitrary
        pure (Delete k)

runInstructions :: forall k v. (Ord k) => List (Instruction k v) -> M.Map k v -> M.Map k v
runInstructions instrs t0 = foldl step t0 instrs
  where
  step tree (Insert k v) = M.insert k v tree
  step tree (Delete k) = M.delete k tree

smallKey :: SmallKey -> SmallKey
smallKey k = k

number :: Int -> Int
number n = n

smallKeyToNumberMap :: M.Map SmallKey Int -> M.Map SmallKey Int
smallKeyToNumberMap m = m

mapTests :: forall eff. Eff (console :: CONSOLE, random :: RANDOM, err :: EXCEPTION | eff) Unit
mapTests = do

  -- Data.Map

  log "Test inserting into empty tree"
  quickCheck $ \k v -> M.lookup (smallKey k) (M.insert k v M.empty) == Just (number v)
    <?> ("k: " <> show k <> ", v: " <> show v)

  log "Test delete after inserting"
  quickCheck $ \k v -> M.isEmpty (M.delete (smallKey k) (M.insert k (number v) M.empty))
    <?> ("k: " <> show k <> ", v: " <> show v)

  log "Test pop after inserting"
  quickCheck $ \k v -> M.pop (smallKey k) (M.insert k (number v) M.empty) == Just (Tuple v M.empty)
    <?> ("k: " <> show k <> ", v: " <> show v)

  log "Pop non-existent key"
  quickCheck $ \k1 k2 v -> k1 == k2 || M.pop (smallKey k2) (M.insert k1 (number v) M.empty) == Nothing
    <?> ("k1: " <> show k1 <> ", k2: " <> show k2 <> ", v: " <> show v)

  log "Insert two, lookup first"
  quickCheck $ \k1 v1 k2 v2 -> k1 == k2 || M.lookup k1 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty)) == Just v1
    <?> ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2)

  log "Insert two, lookup second"
  quickCheck $ \k1 v1 k2 v2 -> M.lookup k2 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty)) == Just v2
    <?> ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2)

  log "Insert two, delete one"
  quickCheck $ \k1 v1 k2 v2 -> k1 == k2 || M.lookup k2 (M.delete k1 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty))) == Just v2
    <?> ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2)

  log "Check balance property"
  quickCheck' 1000 $ \instrs ->
    let
      tree :: M.Map SmallKey Int
      tree = runInstructions instrs M.empty
    in M.checkValid tree <?> ("Map not balanced:\n  " <> show tree <> "\nGenerated by:\n  " <> show instrs)

  log "Lookup from empty"
  quickCheck $ \k -> M.lookup k (M.empty :: M.Map SmallKey Int) == Nothing

  log "Lookup from singleton"
  quickCheck $ \k v -> M.lookup (k :: SmallKey) (M.singleton k (v :: Int)) == Just v

  log "Random lookup"
  quickCheck' 1000 $ \instrs k v ->
    let
      tree :: M.Map SmallKey Int
      tree = M.insert k v (runInstructions instrs M.empty)
    in M.lookup k tree == Just v <?> ("instrs:\n  " <> show instrs <> "\nk:\n  " <> show k <> "\nv:\n  " <> show v)

  log "Singleton to list"
  quickCheck $ \k v -> M.toUnfoldable (M.singleton k v :: M.Map SmallKey Int) == singleton (Tuple k v)

  log "fromFoldable [] = empty"
  quickCheck (M.fromFoldable [] == (M.empty :: M.Map Unit Unit)
    <?> "was not empty")

  log "fromFoldable & key collision"
  do
    let nums = M.fromFoldable [Tuple 0 "zero", Tuple 1 "what", Tuple 1 "one"]
    quickCheck (M.lookup 0 nums == Just "zero" <?> "invalid lookup - 0")
    quickCheck (M.lookup 1 nums == Just "one"  <?> "invalid lookup - 1")
    quickCheck (M.lookup 2 nums == Nothing     <?> "invalid lookup - 2")

  log "fromFoldableWith const [] = empty"
  quickCheck (M.fromFoldableWith const [] == (M.empty :: M.Map Unit Unit)
    <?> "was not empty")

  log "fromFoldableWith (+) & key collision"
  do
    let nums = M.fromFoldableWith (+) [Tuple 0 1, Tuple 1 1, Tuple 1 1]
    quickCheck (M.lookup 0 nums == Just 1  <?> "invalid lookup - 0")
    quickCheck (M.lookup 1 nums == Just 2  <?> "invalid lookup - 1")
    quickCheck (M.lookup 2 nums == Nothing <?> "invalid lookup - 2")

  log "sort . toUnfoldable . fromFoldable = sort (on lists without key-duplicates)"
  quickCheck $ \(list :: List (Tuple SmallKey Int)) ->
    let nubbedList = nubBy ((==) `on` fst) list
        f x = M.toUnfoldable (M.fromFoldable x)
    in sort (f nubbedList) == sort nubbedList <?> show nubbedList

  log "fromFoldable . toUnfoldable = id"
  quickCheck $ \(TestMap (m :: M.Map SmallKey Int)) ->
    let f m' = M.fromFoldable (M.toUnfoldable m' :: List (Tuple SmallKey Int))
    in f m == m <?> show m

  log "fromFoldableWith const = fromFoldable"
  quickCheck $ \arr ->
    M.fromFoldableWith const arr ==
    M.fromFoldable (arr :: List (Tuple SmallKey Int)) <?> show arr

  log "fromFoldableWith (<>) = fromFoldable . collapse with (<>) . group on fst"
  quickCheck $ \arr ->
    let combine (Tuple s a) (Tuple t b) = (Tuple s $ b <> a)
        foldl1 g = unsafePartial \(Cons x xs) -> foldl g x xs
        f = M.fromFoldable <<< map (foldl1 combine <<< NEL.toList) <<<
            groupBy ((==) `on` fst) <<< sortBy (compare `on` fst) in
    M.fromFoldableWith (<>) arr === f (arr :: List (Tuple String String))

  log "toAscUnfoldable is sorted version of toUnfoldable"
  quickCheck $ \(TestMap m) ->
    let list = M.toUnfoldable (m :: M.Map SmallKey Int)
        ascList = M.toAscUnfoldable m
    in ascList === sortBy (compare `on` fst) list

  log "Lookup from union"
  quickCheck $ \(TestMap m1) (TestMap m2) k ->
    M.lookup (smallKey k) (M.union m1 m2) == (case M.lookup k m1 of
      Nothing -> M.lookup k m2
      Just v -> Just (number v)) <?> ("m1: " <> show m1 <> ", m2: " <> show m2 <> ", k: " <> show k <> ", v1: " <> show (M.lookup k m1) <> ", v2: " <> show (M.lookup k m2) <> ", union: " <> show (M.union m1 m2))

  log "Union is idempotent"
  quickCheck $ \(TestMap m1) (TestMap m2) -> (m1 `M.union` m2) == ((m1 `M.union` m2) `M.union` (m2 :: M.Map SmallKey Int))

  log "Union prefers left"
  quickCheck $ \(TestMap m1) (TestMap m2) k -> M.lookup k (M.union m1 (m2 :: M.Map SmallKey Int)) == (M.lookup k m1 <|> M.lookup k m2)

  log "unionWith"
  for_ [Tuple (+) 0, Tuple (*) 1] $ \(Tuple op ident) ->
    quickCheck $ \(TestMap m1) (TestMap m2) k ->
      let u = M.unionWith op m1 m2 :: M.Map SmallKey Int
      in case M.lookup k u of
           Nothing -> not (M.member k m1 || M.member k m2)
           Just v -> v == op (fromMaybe ident (M.lookup k m1)) (fromMaybe ident (M.lookup k m2))

  log "unionWith argument order"
  quickCheck $ \(TestMap m1) (TestMap m2) k ->
    let u   = M.unionWith (-) m1 m2 :: M.Map SmallKey Int
        in1 = M.member k m1
        v1  = M.lookup k m1
        in2 = M.member k m2
        v2  = M.lookup k m2
    in case M.lookup k u of
          Just v | in1 && in2 -> Just v == ((-) <$> v1 <*> v2)
          Just v | in1        -> Just v == v1
          Just v              -> Just v == v2
          Nothing             -> not (in1 || in2)

  log "size"
  quickCheck $ \xs ->
    let xs' = nubBy ((==) `on` fst) xs
    in  M.size (M.fromFoldable xs') == length (xs' :: List (Tuple SmallKey Int))

  log "lookupLE result is correct"
  quickCheck $ \k (TestMap m) -> case M.lookupLE k (smallKeyToNumberMap m) of
    Nothing -> all (_ > k) $ M.keys m
    Just { key: k1, value: v } -> let
      isCloserKey k2 = k1 < k2 && k2 < k
      isLTwhenEQexists = k1 < k && M.member k m
      in   k1 <= k
        && all (not <<< isCloserKey) (M.keys m)
        && not isLTwhenEQexists
        && M.lookup k1 m == Just v

  log "lookupGE result is correct"
  quickCheck $ \k (TestMap m) -> case M.lookupGE k (smallKeyToNumberMap m) of
    Nothing -> all (_ < k) $ M.keys m
    Just { key: k1, value: v } -> let
      isCloserKey k2 = k < k2 && k2 < k1
      isGTwhenEQexists = k < k1 && M.member k m
      in   k1 >= k
        && all (not <<< isCloserKey) (M.keys m)
        && not isGTwhenEQexists
        && M.lookup k1 m == Just v

  log "lookupLT result is correct"
  quickCheck $ \k (TestMap m) -> case M.lookupLT k (smallKeyToNumberMap m) of
    Nothing -> all (_ >= k) $ M.keys m
    Just { key: k1, value: v } -> let
      isCloserKey k2 = k1 < k2 && k2 < k
      in   k1 < k
        && all (not <<< isCloserKey) (M.keys m)
        && M.lookup k1 m == Just v

  log "lookupGT result is correct"
  quickCheck $ \k (TestMap m) -> case M.lookupGT k (smallKeyToNumberMap m) of
    Nothing -> all (_ <= k) $ M.keys m
    Just { key: k1, value: v } -> let
      isCloserKey k2 = k < k2 && k2 < k1
      in   k1 > k
        && all (not <<< isCloserKey) (M.keys m)
        && M.lookup k1 m == Just v

  log "findMin result is correct"
  quickCheck $ \(TestMap m) -> case M.findMin (smallKeyToNumberMap m) of
    Nothing -> M.isEmpty m
    Just { key: k, value: v } -> M.lookup k m == Just v && all (_ >= k) (M.keys m)

  log "findMax result is correct"
  quickCheck $ \(TestMap m) -> case M.findMax (smallKeyToNumberMap m) of
    Nothing -> M.isEmpty m
    Just { key: k, value: v } -> M.lookup k m == Just v && all (_ <= k) (M.keys m)

  log "mapWithKey is correct"
  quickCheck $ \(TestMap m :: TestMap String Int) -> let
    f k v = k <> show v
    resultViaMapWithKey = m # M.mapWithKey f
    toList = M.toUnfoldable :: forall k v. M.Map k v -> List (Tuple k v)
    resultViaLists = m # toList # map (\(Tuple k v) → Tuple k (f k v)) # M.fromFoldable
    in resultViaMapWithKey === resultViaLists

module Test.Data.Map where

import Prelude
import Data.List.NonEmpty as NEL
import Data.Map as M
import Control.Alt ((<|>))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Random (RANDOM)
import Data.Foldable (foldl, for_, all)
import Data.Function (on)
import Data.List (List(Cons), groupBy, length, nubBy, singleton, sort, sortBy)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Tuple (Tuple(..), fst)
import Partial.Unsafe (unsafePartial)
import Test.QuickCheck ((<?>), (===), quickCheck, quickCheck')
import Test.QuickCheck.Arbitrary (class Arbitrary, arbitrary)

newtype TestMap k v = TestMap (M.Map k v)

instance arbTestMap :: (Eq k, Ord k, Arbitrary k, Arbitrary v) => Arbitrary (TestMap k v) where
  arbitrary = TestMap <<< (M.fromFoldable :: List (Tuple k v) -> M.Map k v) <$> arbitrary

data SmallKey = A | B | C | D | E | F | G | H | I | J

instance showSmallKey :: Show SmallKey where
  show A = "A"
  show B = "B"
  show C = "C"
  show D = "D"
  show E = "E"
  show F = "F"
  show G = "G"
  show H = "H"
  show I = "I"
  show J = "J"

instance eqSmallKey :: Eq SmallKey where
  eq A A = true
  eq B B = true
  eq C C = true
  eq D D = true
  eq E E = true
  eq F F = true
  eq G G = true
  eq H H = true
  eq I I = true
  eq J J = true
  eq _ _ = false

smallKeyToInt :: SmallKey -> Int
smallKeyToInt A = 0
smallKeyToInt B = 1
smallKeyToInt C = 2
smallKeyToInt D = 3
smallKeyToInt E = 4
smallKeyToInt F = 5
smallKeyToInt G = 6
smallKeyToInt H = 7
smallKeyToInt I = 8
smallKeyToInt J = 9

instance ordSmallKey :: Ord SmallKey where
  compare = compare `on` smallKeyToInt

instance arbSmallKey :: Arbitrary SmallKey where
  arbitrary = do
    n <- arbitrary
    pure case n of
      _ | n < 0.1 -> A
      _ | n < 0.2 -> B
      _ | n < 0.3 -> C
      _ | n < 0.4 -> D
      _ | n < 0.5 -> E
      _ | n < 0.6 -> F
      _ | n < 0.7 -> G
      _ | n < 0.8 -> H
      _ | n < 0.9 -> I
      _ -> J

data Instruction k v = Insert k v | Delete k

instance showInstruction :: (Show k, Show v) => Show (Instruction k v) where
  show (Insert k v) = "Insert (" <> show k <> ") (" <> show v <> ")"
  show (Delete k) = "Delete (" <> show k <> ")"

instance arbInstruction :: (Arbitrary k, Arbitrary v) => Arbitrary (Instruction k v) where
  arbitrary = do
    b <- arbitrary
    case b of
      true -> do
        k <- arbitrary
        v <- arbitrary
        pure (Insert k v)
      false -> do
        k <- arbitrary
        pure (Delete k)

runInstructions :: forall k v. (Ord k) => List (Instruction k v) -> M.Map k v -> M.Map k v
runInstructions instrs t0 = foldl step t0 instrs
  where
  step tree (Insert k v) = M.insert k v tree
  step tree (Delete k) = M.delete k tree

smallKey :: SmallKey -> SmallKey
smallKey k = k

number :: Int -> Int
number n = n

smallKeyToNumberMap :: M.Map SmallKey Int -> M.Map SmallKey Int
smallKeyToNumberMap m = m

mapTests :: forall eff. Eff (console :: CONSOLE, random :: RANDOM, err :: EXCEPTION | eff) Unit
mapTests = do

  -- Data.Map

  log "Test inserting into empty tree"
  quickCheck $ \k v -> M.lookup (smallKey k) (M.insert k v M.empty) == Just (number v)
    <?> ("k: " <> show k <> ", v: " <> show v)

  log "Test delete after inserting"
  quickCheck $ \k v -> M.isEmpty (M.delete (smallKey k) (M.insert k (number v) M.empty))
    <?> ("k: " <> show k <> ", v: " <> show v)

  log "Test pop after inserting"
  quickCheck $ \k v -> M.pop (smallKey k) (M.insert k (number v) M.empty) == Just (Tuple v M.empty)
    <?> ("k: " <> show k <> ", v: " <> show v)

  log "Pop non-existent key"
  quickCheck $ \k1 k2 v -> k1 == k2 || M.pop (smallKey k2) (M.insert k1 (number v) M.empty) == Nothing
    <?> ("k1: " <> show k1 <> ", k2: " <> show k2 <> ", v: " <> show v)

  log "Insert two, lookup first"
  quickCheck $ \k1 v1 k2 v2 -> k1 == k2 || M.lookup k1 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty)) == Just v1
    <?> ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2)

  log "Insert two, lookup second"
  quickCheck $ \k1 v1 k2 v2 -> M.lookup k2 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty)) == Just v2
    <?> ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2)

  log "Insert two, delete one"
  quickCheck $ \k1 v1 k2 v2 -> k1 == k2 || M.lookup k2 (M.delete k1 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty))) == Just v2
    <?> ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2)

  log "Check balance property"
  quickCheck' 1000 $ \instrs ->
    let
      tree :: M.Map SmallKey Int
      tree = runInstructions instrs M.empty
    in M.checkValid tree <?> ("Map not balanced:\n  " <> show tree <> "\nGenerated by:\n  " <> show instrs)

  log "Lookup from empty"
  quickCheck $ \k -> M.lookup k (M.empty :: M.Map SmallKey Int) == Nothing

  log "Lookup from singleton"
  quickCheck $ \k v -> M.lookup (k :: SmallKey) (M.singleton k (v :: Int)) == Just v

  log "Random lookup"
  quickCheck' 1000 $ \instrs k v ->
    let
      tree :: M.Map SmallKey Int
      tree = M.insert k v (runInstructions instrs M.empty)
    in M.lookup k tree == Just v <?> ("instrs:\n  " <> show instrs <> "\nk:\n  " <> show k <> "\nv:\n  " <> show v)

  log "Singleton to list"
  quickCheck $ \k v -> M.toUnfoldable (M.singleton k v :: M.Map SmallKey Int) == singleton (Tuple k v)

  log "fromFoldable [] = empty"
  quickCheck (M.fromFoldable [] == (M.empty :: M.Map Unit Unit)
    <?> "was not empty")

  log "fromFoldable & key collision"
  do
    let nums = M.fromFoldable [Tuple 0 "zero", Tuple 1 "what", Tuple 1 "one"]
    quickCheck (M.lookup 0 nums == Just "zero" <?> "invalid lookup - 0")
    quickCheck (M.lookup 1 nums == Just "one"  <?> "invalid lookup - 1")
    quickCheck (M.lookup 2 nums == Nothing     <?> "invalid lookup - 2")

  log "fromFoldableWith const [] = empty"
  quickCheck (M.fromFoldableWith const [] == (M.empty :: M.Map Unit Unit)
    <?> "was not empty")

  log "fromFoldableWith (+) & key collision"
  do
    let nums = M.fromFoldableWith (+) [Tuple 0 1, Tuple 1 1, Tuple 1 1]
    quickCheck (M.lookup 0 nums == Just 1  <?> "invalid lookup - 0")
    quickCheck (M.lookup 1 nums == Just 2  <?> "invalid lookup - 1")
    quickCheck (M.lookup 2 nums == Nothing <?> "invalid lookup - 2")

  log "sort . toUnfoldable . fromFoldable = sort (on lists without key-duplicates)"
  quickCheck $ \(list :: List (Tuple SmallKey Int)) ->
    let nubbedList = nubBy ((==) `on` fst) list
        f x = M.toUnfoldable (M.fromFoldable x)
    in sort (f nubbedList) == sort nubbedList <?> show nubbedList

  log "fromFoldable . toUnfoldable = id"
  quickCheck $ \(TestMap (m :: M.Map SmallKey Int)) ->
    let f m' = M.fromFoldable (M.toUnfoldable m' :: List (Tuple SmallKey Int))
    in f m == m <?> show m

  log "fromFoldableWith const = fromFoldable"
  quickCheck $ \arr ->
    M.fromFoldableWith const arr ==
    M.fromFoldable (arr :: List (Tuple SmallKey Int)) <?> show arr

  log "fromFoldableWith (<>) = fromFoldable . collapse with (<>) . group on fst"
  quickCheck $ \arr ->
    let combine (Tuple s a) (Tuple t b) = (Tuple s $ b <> a)
        foldl1 g = unsafePartial \(Cons x xs) -> foldl g x xs
        f = M.fromFoldable <<< map (foldl1 combine <<< NEL.toList) <<<
            groupBy ((==) `on` fst) <<< sortBy (compare `on` fst) in
    M.fromFoldableWith (<>) arr === f (arr :: List (Tuple String String))

  log "toAscUnfoldable is sorted version of toUnfoldable"
  quickCheck $ \(TestMap m) ->
    let list = M.toUnfoldable (m :: M.Map SmallKey Int)
        ascList = M.toAscUnfoldable m
    in ascList === sortBy (compare `on` fst) list

  log "Lookup from union"
  quickCheck $ \(TestMap m1) (TestMap m2) k ->
    M.lookup (smallKey k) (M.union m1 m2) == (case M.lookup k m1 of
      Nothing -> M.lookup k m2
      Just v -> Just (number v)) <?> ("m1: " <> show m1 <> ", m2: " <> show m2 <> ", k: " <> show k <> ", v1: " <> show (M.lookup k m1) <> ", v2: " <> show (M.lookup k m2) <> ", union: " <> show (M.union m1 m2))

  log "Union is idempotent"
  quickCheck $ \(TestMap m1) (TestMap m2) -> (m1 `M.union` m2) == ((m1 `M.union` m2) `M.union` (m2 :: M.Map SmallKey Int))

  log "Union prefers left"
  quickCheck $ \(TestMap m1) (TestMap m2) k -> M.lookup k (M.union m1 (m2 :: M.Map SmallKey Int)) == (M.lookup k m1 <|> M.lookup k m2)

  log "unionWith"
  for_ [Tuple (+) 0, Tuple (*) 1] $ \(Tuple op ident) ->
    quickCheck $ \(TestMap m1) (TestMap m2) k ->
      let u = M.unionWith op m1 m2 :: M.Map SmallKey Int
      in case M.lookup k u of
           Nothing -> not (M.member k m1 || M.member k m2)
           Just v -> v == op (fromMaybe ident (M.lookup k m1)) (fromMaybe ident (M.lookup k m2))

  log "unionWith argument order"
  quickCheck $ \(TestMap m1) (TestMap m2) k ->
    let u   = M.unionWith (-) m1 m2 :: M.Map SmallKey Int
        in1 = M.member k m1
        v1  = M.lookup k m1
        in2 = M.member k m2
        v2  = M.lookup k m2
    in case M.lookup k u of
          Just v | in1 && in2 -> Just v == ((-) <$> v1 <*> v2)
          Just v | in1        -> Just v == v1
          Just v              -> Just v == v2
          Nothing             -> not (in1 || in2)

  log "size"
  quickCheck $ \xs ->
    let xs' = nubBy ((==) `on` fst) xs
    in  M.size (M.fromFoldable xs') == length (xs' :: List (Tuple SmallKey Int))

  log "lookupLE result is correct"
  quickCheck $ \k (TestMap m) -> case M.lookupLE k (smallKeyToNumberMap m) of
    Nothing -> all (_ > k) $ M.keys m
    Just { key: k1, value: v } -> let
      isCloserKey k2 = k1 < k2 && k2 < k
      isLTwhenEQexists = k1 < k && M.member k m
      in   k1 <= k
        && all (not <<< isCloserKey) (M.keys m)
        && not isLTwhenEQexists
        && M.lookup k1 m == Just v

  log "lookupGE result is correct"
  quickCheck $ \k (TestMap m) -> case M.lookupGE k (smallKeyToNumberMap m) of
    Nothing -> all (_ < k) $ M.keys m
    Just { key: k1, value: v } -> let
      isCloserKey k2 = k < k2 && k2 < k1
      isGTwhenEQexists = k < k1 && M.member k m
      in   k1 >= k
        && all (not <<< isCloserKey) (M.keys m)
        && not isGTwhenEQexists
        && M.lookup k1 m == Just v

  log "lookupLT result is correct"
  quickCheck $ \k (TestMap m) -> case M.lookupLT k (smallKeyToNumberMap m) of
    Nothing -> all (_ >= k) $ M.keys m
    Just { key: k1, value: v } -> let
      isCloserKey k2 = k1 < k2 && k2 < k
      in   k1 < k
        && all (not <<< isCloserKey) (M.keys m)
        && M.lookup k1 m == Just v

  log "lookupGT result is correct"
  quickCheck $ \k (TestMap m) -> case M.lookupGT k (smallKeyToNumberMap m) of
    Nothing -> all (_ <= k) $ M.keys m
    Just { key: k1, value: v } -> let
      isCloserKey k2 = k < k2 && k2 < k1
      in   k1 > k
        && all (not <<< isCloserKey) (M.keys m)
        && M.lookup k1 m == Just v

  log "findMin result is correct"
  quickCheck $ \(TestMap m) -> case M.findMin (smallKeyToNumberMap m) of
    Nothing -> M.isEmpty m
    Just { key: k, value: v } -> M.lookup k m == Just v && all (_ >= k) (M.keys m)

  log "findMax result is correct"
  quickCheck $ \(TestMap m) -> case M.findMax (smallKeyToNumberMap m) of
    Nothing -> M.isEmpty m
    Just { key: k, value: v } -> M.lookup k m == Just v && all (_ <= k) (M.keys m)

  log "mapWithKey is correct"
  quickCheck $ \(TestMap m :: TestMap String Int) -> let
    f k v = k <> show v
    resultViaMapWithKey = m # M.mapWithKey f
    toList = M.toUnfoldable :: forall k v. M.Map k v -> List (Tuple k v)
    resultViaLists = m # toList # map (\(Tuple k v) → Tuple k (f k v)) # M.fromFoldable
    in resultViaMapWithKey === resultViaLists


better dying animation

better dying animation

module Rendering where

import Debug.Trace
import Data.Array hiding (map, (..))
import Data.Function
import qualified Data.Map as M
import Data.Tuple
import Data.Maybe
import Data.Foldable
import Graphics.Canvas
  (getContext2D, setCanvasHeight, setCanvasWidth, Rectangle(), Arc(),
  Context2D(), Canvas(), getCanvasElementById, TextAlign(..), LineCap(..))
import Control.Monad.Eff
import Control.Monad (when)
import Control.Monad.Reader.Class (reader)
import Control.Lens ((^.), (..), (~), (^?))
import Math (pi, floor, ceil)

import LevelMap
import Types
import CanvasM
import Utils
import Game
import Style

halfBlock     = floor (pxPerBlock / 2)
halfPxPerTile = floor (pxPerTile / 2)
halfCanvas    = floor (canvasSize / 2)

scaleRect :: Number -> Position -> Rectangle
scaleRect scale (Position p) =
  {x: p.x * scale, y: p.y * scale, h: scale, w: scale}

toPosition :: Rectangle -> Position
toPosition r = Position {x:r.x, y:r.y}

getRectAt :: Position -> Rectangle
getRectAt = scaleRect pxPerBlock

getCentredRectAt :: Position -> Rectangle
getCentredRectAt p =
  let r = getRectAt p
  in  r {x = r.x + halfBlock, y = r.y + halfBlock}

getRectAt' :: Number -> Number -> Rectangle
getRectAt' x y = getRectAt (Position {x: x, y: y})

getTileRectAt :: Position -> Rectangle
getTileRectAt = scaleRect pxPerTile

getTileRectAt' :: Number -> Number -> Rectangle
getTileRectAt' x y = getTileRectAt (Position {x: x, y: y})

setupRendering :: forall e. Eff (canvas :: Canvas | e) RenderingContext
setupRendering = do
  fg <- setupRenderingById "foreground"
  bg <- setupRenderingById "background"
  return { foreground: fg, background: bg }

-- set up a canvas with the correct dimensions and return its context
setupRenderingById :: forall e.
  String -> Eff (canvas :: Canvas | e) Context2D
setupRenderingById elId =
  getCanvasElementById elId
    >>= justOrError
    >>= setCanvasHeight canvasSize
    >>= setCanvasWidth canvasSize
    >>= getContext2D

  where
  justOrError (Just x) = return x
  justOrError Nothing = error $ "no canvas element found with id = " <> elId

clearBackground :: forall e. CanvasM e Unit
clearBackground = do
  setFillStyle backgroundColor
  fillRect {x: 0, y: 0, h: canvasSize, w: canvasSize}

data CornerType
  = CRO -- rounded outer
  | CRI -- rounded inner
  | CSH -- straight horizontal
  | CSV -- straight vertical
  | NON -- nothing (inside a block)

instance showCornerType :: Show CornerType where
  show CRO = "CRO"
  show CRI = "CRI"
  show CSH = "CSH"
  show CSV = "CSV"

type Corners =
  { tl :: CornerType, tr :: CornerType, bl :: CornerType, br :: CornerType }

toBasic :: Tile -> BasicTile
toBasic Inaccessible = W
toBasic _ = E

renderMap :: forall e. LevelMap -> CanvasM e Unit
renderMap map = do
  setStrokeStyle tileColor

  let tileIndices = range 0 (tilesAlongSide - 1)
  let getTile i j = map.tiles !! i >>= (\r -> r !! j)
  let t i j = toBasic <$> getTile i j

  for_ tileIndices $ \i ->
    for_ tileIndices $ \j -> do
      let above      = fromMaybe W $ t i (j-1)
      let aboveRight = fromMaybe W $ t (i+1) (j-1)
      let right      = fromMaybe W $ t (i+1) j
      let belowRight = fromMaybe W $ t (i+1) (j+1)
      let below      = fromMaybe W $ t i (j+1)
      let belowLeft  = fromMaybe W $ t (i-1) (j+1)
      let left       = fromMaybe W $ t (i-1) j
      let aboveLeft  = fromMaybe W $ t (i-1) (j-1)

      case t i j of
        Just W -> do
          let cs = getCorners above aboveRight right belowRight
                              below belowLeft left aboveLeft
          let es = getEdges above right below left
          withContext $ do
            translate { translateX: (i + 0.5) * pxPerTile
                      , translateY: (j + 0.5) * pxPerTile
                      }
            renderCorners cs
            renderEdges es
        _ ->
          return unit

showCorners :: Corners -> String
showCorners cs =
  showRecord "Corners"
    ["tl" .:: cs.tl, "tr" .:: cs.tr, "br" .:: cs.br, "bl" .:: cs.bl]

getCorners above aboveRight right belowRight below belowLeft left aboveLeft =
  { tl: getCorner left above aboveLeft
  , tr: getCorner right above aboveRight
  , br: getCorner right below belowRight
  , bl: getCorner left below belowLeft
  }

-- order is: horizontal vertical corner
getCorner W W E = CRI
getCorner W W W = NON
getCorner W E _ = CSH
getCorner E W _ = CSV
getCorner E E _ = CRO

renderCorners :: forall e.  Corners -> CanvasM e Unit
renderCorners cs = do
  let renderCorner c a t =
    case c of
        CRO ->
          { prep: do
              translate t
              rotate a
          , go:
              arc { start: pi
                  , end:   3*pi/2
                  , x:     cornerMid
                  , y:     cornerMid
                  , r:     cornerRadius
                  }
          }
        CRI ->
          { prep: do
              translate t
              rotate a
          , go:
              arc { start: 0
                  , end:   pi/2
                  , x:     -cornerMid
                  , y:     -cornerMid
                  , r:     cornerRadius
                  }
          }
        CSH ->
          { prep: translate t
          , go: do
              moveTo (-cornerMid -1) 0
              lineTo (cornerMid + 1)  0
          }
        CSV ->
          { prep: translate t
          , go: do
              moveTo 0 (-cornerMid - 1)
              lineTo 0 (cornerMid + 1)
          }
        NON ->
          { prep: return unit
          , go: return unit
          }

  let s = (pxPerTile - cornerSize) / 2
  let cs' =
      [ { c: cs.tl
        , a: 0
        , t: {translateX: -s, translateY: -s}
        },

        { c: cs.tr
        , a: pi/2
        , t: {translateX: s, translateY: -s}
        },

        { c: cs.br
        , a: pi
        , t: {translateX: s, translateY: s}
        },

        { c: cs.bl
        , a: 3*pi/2
        , t: {translateX: -s, translateY: s}
        }
        ]

  for_ cs' $ \c -> do
    withContext $ do
      setLineCap Square
      let r = renderCorner c.c c.a c.t
      r.prep
      beginPath
      r.go
      stroke

getEdges above right below left =
  { t: above, r: right, b: below, l: left }

renderEdges es =
  let s = (pxPerTile / 2) - cornerSize
      x1 = -s - 1
      y1 = -s - (cornerSize / 2)
      x2 = s
      y2 = y1

      renderEdge e =
        when (e == E) $ do
          moveTo x1 y1
          lineTo x2 y2

      es' =
        [ { e: es.t, a: 0 }
        , { e: es.r, a: pi/2 }
        , { e: es.b, a: pi }
        , { e: es.l, a: 3*pi/2 }
        ]

  in
  for_ es' $ \e ->
    withContext $ do
      rotate e.a
      beginPath
      renderEdge e.e
      stroke

renderPlayer :: forall e.
  PlayerId
  -> Player
  -> CanvasM e Unit
renderPlayer pId player = do
  setFillStyle $ playerColor pId
  let r = playerRenderParameters player
  let centre = getCentredRectAt (player ^. pPosition)
  beginPath
  moveTo r.start.x r.start.y
  arc r.arc
  lineTo r.start.x r.start.y
  fill

playerRenderParameters player =
  let centre = getCentredRectAt (player ^. pPosition)
      direction = fromMaybe Left (player ^. pDirection)

      baseAngle = directionToRadians direction
      index = player ^. pNomIndex
      half = floor (nomIndexMax / 2)
      maxAngle = pi / 2
      halfAngle = maxAngle / 2
      multiplier = nomIndexMax / maxAngle
      delta =
        case player ^. pRespawnCounter of
          Just ctr ->
            halfAngle + ((1 - (ctr / respawnLength)) * (pi - halfAngle))
          Nothing ->
            multiplier * (if index <= half
                            then index
                            else (nomIndexMax - index)) + 0.001

      op = dirToPos $ opposite direction
      start = add (scalePos (playerRadius / 2) op) (toPosition centre)
  in
    { arc: { x: centre.x
           , y: centre.y
           , start: (baseAngle + delta)
           , end: (baseAngle - delta)
           , r: playerRadius
           }
    , start: { x: start ^. pX
             , y: start ^. pY
             }
    }

enlargeRect :: Number -> Rectangle -> Rectangle
enlargeRect delta r =
  { x: r.x - delta
  , y: r.y - delta
  , w: r.w + (2 * delta)
  , h: r.h + (2 * delta)
  }

renderItems :: forall e. Game -> CanvasM e Unit
renderItems game =
  eachItem' game renderItem

renderItem :: forall e. Item -> CanvasM e Unit
renderItem item = do
  let centre = getCentredRectAt (item ^. iPosition)
  setFillStyle dotColor
  beginPath
  arc { x: centre.x
      , y: centre.y
      , start: 0
      , end: 2 * pi
      , r: dotRadiusFor (item ^. iType)
      }
  fill

renderPlayers :: forall e. Game -> CanvasM e Unit
renderPlayers game =
  eachPlayer' game renderPlayer

clearCanvas :: forall e. CanvasM e Unit
clearCanvas =
  clearRect {x: 0, y: 0, h: canvasSize, w: canvasSize}

renderCountdown :: forall e. Game -> PlayerId -> CanvasM e Unit
renderCountdown game pId = do
  whenJust game.countdown $ \cd -> do
    renderCounter cd
    renderReminderArrow game pId

setFontSize :: forall e. Number -> CanvasM e Unit
setFontSize x =
  setFont $ show x <> "pt " <> fontName

renderCounter cd = do
  setFontSize $ pxPerTile * 3
  setTextAlign AlignCenter
  setLineWidth 3
  setFillStyle fontColor
  setStrokeStyle "black"
  let text = show (ceil (cd / 30))
  let x = halfCanvas
  let y = floor (halfCanvas / 2)
  fillText   text x y
  strokeText text x y

renderReminderArrow game pId = do
  whenJust (game ^? player pId) $ \pl ->
    withContext $ do
      let pos = pl ^. pPosition
      let playerX = pos ^. pX
      let y = pos ^. pY

      let greater = playerX > mapSize / 2
      let d = 1.5 * tileSize
      let x = playerX + (if greater then d else -d)

      let centre = getCentredRectAt (Position {x:x, y:y})

      setLineWidth 1
      beginPath
      arrowPath greater centre.x centre.y 30 10
      fill
      stroke

arrowPath toRight x y length width = do
  let halfLen = floor (length / 2)
  let halfWid = floor (width / 2)
  let f z = if toRight then x + z else x - z

  moveTo (f halfLen)           (y - halfWid)
  lineTo (f (- halfLen))       (y - halfWid)
  lineTo (f (- halfLen))       (y - (2 * halfWid))
  lineTo (f (- (2 * halfLen))) (y)
  lineTo (f (- halfLen))       (y + (2 * halfWid))
  lineTo (f (- halfLen))       (y + halfWid)
  lineTo (f halfLen)           (y + halfWid)
  lineTo (f halfLen)           (y - halfWid)

render :: forall e.
  RenderingContext
  -> Game
  -> PlayerId
  -> Boolean
  -> Eff (canvas :: Canvas | e) Unit
render ctx game pId redrawMap = do
  when redrawMap $ do
    runCanvasM ctx.background $
      renderMap game.map

  runCanvasM ctx.foreground $ do
    clearCanvas
    renderItems game
    renderPlayers game
    renderCountdown game pId

clearBoth :: forall e.
  RenderingContext
  -> Eff (canvas :: Canvas | e) Unit
clearBoth ctx = do
  runCanvasM ctx.background clearCanvas
  runCanvasM ctx.foreground clearCanvas

setTextStyle = do
  setFontSize $ floor (0.6 * pxPerTile)
  setFillStyle fontColor

module Rendering where

import Debug.Trace
import Data.Array hiding (map, (..))
import Data.Function
import qualified Data.Map as M
import Data.Tuple
import Data.Maybe
import Data.Foldable
import Graphics.Canvas
  (getContext2D, setCanvasHeight, setCanvasWidth, Rectangle(), Arc(),
  Context2D(), Canvas(), getCanvasElementById, TextAlign(..), LineCap(..))
import Control.Monad.Eff
import Control.Monad (when)
import Control.Monad.Reader.Class (reader)
import Control.Lens ((^.), (..), (~), (^?))
import Math (pi, floor, ceil)

import LevelMap
import Types
import CanvasM
import Utils
import Game
import Style

halfBlock     = floor (pxPerBlock / 2)
halfPxPerTile = floor (pxPerTile / 2)
halfCanvas    = floor (canvasSize / 2)

scaleRect :: Number -> Position -> Rectangle
scaleRect scale (Position p) =
  {x: p.x * scale, y: p.y * scale, h: scale, w: scale}

toPosition :: Rectangle -> Position
toPosition r = Position {x:r.x, y:r.y}

getRectAt :: Position -> Rectangle
getRectAt = scaleRect pxPerBlock

getCentredRectAt :: Position -> Rectangle
getCentredRectAt p =
  let r = getRectAt p
  in  r {x = r.x + halfBlock, y = r.y + halfBlock}

getRectAt' :: Number -> Number -> Rectangle
getRectAt' x y = getRectAt (Position {x: x, y: y})

getTileRectAt :: Position -> Rectangle
getTileRectAt = scaleRect pxPerTile

getTileRectAt' :: Number -> Number -> Rectangle
getTileRectAt' x y = getTileRectAt (Position {x: x, y: y})

setupRendering :: forall e. Eff (canvas :: Canvas | e) RenderingContext
setupRendering = do
  fg <- setupRenderingById "foreground"
  bg <- setupRenderingById "background"
  return { foreground: fg, background: bg }

-- set up a canvas with the correct dimensions and return its context
setupRenderingById :: forall e.
  String -> Eff (canvas :: Canvas | e) Context2D
setupRenderingById elId =
  getCanvasElementById elId
    >>= justOrError
    >>= setCanvasHeight canvasSize
    >>= setCanvasWidth canvasSize
    >>= getContext2D

  where
  justOrError (Just x) = return x
  justOrError Nothing = error $ "no canvas element found with id = " <> elId

clearBackground :: forall e. CanvasM e Unit
clearBackground = do
  setFillStyle backgroundColor
  fillRect {x: 0, y: 0, h: canvasSize, w: canvasSize}

data CornerType
  = CRO -- rounded outer
  | CRI -- rounded inner
  | CSH -- straight horizontal
  | CSV -- straight vertical
  | NON -- nothing (inside a block)

instance showCornerType :: Show CornerType where
  show CRO = "CRO"
  show CRI = "CRI"
  show CSH = "CSH"
  show CSV = "CSV"

type Corners =
  { tl :: CornerType, tr :: CornerType, bl :: CornerType, br :: CornerType }

toBasic :: Tile -> BasicTile
toBasic Inaccessible = W
toBasic _ = E

renderMap :: forall e. LevelMap -> CanvasM e Unit
renderMap map = do
  setStrokeStyle tileColor

  let tileIndices = range 0 (tilesAlongSide - 1)
  let getTile i j = map.tiles !! i >>= (\r -> r !! j)
  let t i j = toBasic <$> getTile i j

  for_ tileIndices $ \i ->
    for_ tileIndices $ \j -> do
      let above      = fromMaybe W $ t i (j-1)
      let aboveRight = fromMaybe W $ t (i+1) (j-1)
      let right      = fromMaybe W $ t (i+1) j
      let belowRight = fromMaybe W $ t (i+1) (j+1)
      let below      = fromMaybe W $ t i (j+1)
      let belowLeft  = fromMaybe W $ t (i-1) (j+1)
      let left       = fromMaybe W $ t (i-1) j
      let aboveLeft  = fromMaybe W $ t (i-1) (j-1)

      case t i j of
        Just W -> do
          let cs = getCorners above aboveRight right belowRight
                              below belowLeft left aboveLeft
          let es = getEdges above right below left
          withContext $ do
            translate { translateX: (i + 0.5) * pxPerTile
                      , translateY: (j + 0.5) * pxPerTile
                      }
            renderCorners cs
            renderEdges es
        _ ->
          return unit

showCorners :: Corners -> String
showCorners cs =
  showRecord "Corners"
    ["tl" .:: cs.tl, "tr" .:: cs.tr, "br" .:: cs.br, "bl" .:: cs.bl]

getCorners above aboveRight right belowRight below belowLeft left aboveLeft =
  { tl: getCorner left above aboveLeft
  , tr: getCorner right above aboveRight
  , br: getCorner right below belowRight
  , bl: getCorner left below belowLeft
  }

-- order is: horizontal vertical corner
getCorner W W E = CRI
getCorner W W W = NON
getCorner W E _ = CSH
getCorner E W _ = CSV
getCorner E E _ = CRO

renderCorners :: forall e.  Corners -> CanvasM e Unit
renderCorners cs = do
  let renderCorner c a t =
    case c of
        CRO ->
          { prep: do
              translate t
              rotate a
          , go:
              arc { start: pi
                  , end:   3*pi/2
                  , x:     cornerMid
                  , y:     cornerMid
                  , r:     cornerRadius
                  }
          }
        CRI ->
          { prep: do
              translate t
              rotate a
          , go:
              arc { start: 0
                  , end:   pi/2
                  , x:     -cornerMid
                  , y:     -cornerMid
                  , r:     cornerRadius
                  }
          }
        CSH ->
          { prep: translate t
          , go: do
              moveTo (-cornerMid -1) 0
              lineTo (cornerMid + 1)  0
          }
        CSV ->
          { prep: translate t
          , go: do
              moveTo 0 (-cornerMid - 1)
              lineTo 0 (cornerMid + 1)
          }
        NON ->
          { prep: return unit
          , go: return unit
          }

  let s = (pxPerTile - cornerSize) / 2
  let cs' =
      [ { c: cs.tl
        , a: 0
        , t: {translateX: -s, translateY: -s}
        },

        { c: cs.tr
        , a: pi/2
        , t: {translateX: s, translateY: -s}
        },

        { c: cs.br
        , a: pi
        , t: {translateX: s, translateY: s}
        },

        { c: cs.bl
        , a: 3*pi/2
        , t: {translateX: -s, translateY: s}
        }
        ]

  for_ cs' $ \c -> do
    withContext $ do
      setLineCap Square
      let r = renderCorner c.c c.a c.t
      r.prep
      beginPath
      r.go
      stroke

getEdges above right below left =
  { t: above, r: right, b: below, l: left }

renderEdges es =
  let s = (pxPerTile / 2) - cornerSize
      x1 = -s - 1
      y1 = -s - (cornerSize / 2)
      x2 = s
      y2 = y1

      renderEdge e =
        when (e == E) $ do
          moveTo x1 y1
          lineTo x2 y2

      es' =
        [ { e: es.t, a: 0 }
        , { e: es.r, a: pi/2 }
        , { e: es.b, a: pi }
        , { e: es.l, a: 3*pi/2 }
        ]

  in
  for_ es' $ \e ->
    withContext $ do
      rotate e.a
      beginPath
      renderEdge e.e
      stroke

renderPlayer :: forall e.
  PlayerId
  -> Player
  -> CanvasM e Unit
renderPlayer pId player = do
  setFillStyle $ if isRespawning player then "grey" else playerColor pId
  let r = playerRenderParameters player
  let centre = getCentredRectAt (player ^. pPosition)
  beginPath
  moveTo r.start.x r.start.y
  arc r.arc
  lineTo r.start.x r.start.y
  fill

playerRenderParameters player =
  let centre = getCentredRectAt (player ^. pPosition)
      direction = fromMaybe Left (player ^. pDirection)

      baseAngle = directionToRadians direction
      index = player ^. pNomIndex
      half = floor (nomIndexMax / 2)
      maxAngle = pi / 2
      multiplier = nomIndexMax / maxAngle
      delta = multiplier * (if index <= half
                                then index
                                else (nomIndexMax - index)) + 0.001

      op = dirToPos $ opposite direction
      start = add (scalePos (playerRadius / 2) op) (toPosition centre)
  in
    { arc: { x: centre.x
           , y: centre.y
           , start: (baseAngle + delta)
           , end: (baseAngle - delta)
           , r: playerRadius
           }
    , start: { x: start ^. pX
             , y: start ^. pY
             }
    }

enlargeRect :: Number -> Rectangle -> Rectangle
enlargeRect delta r =
  { x: r.x - delta
  , y: r.y - delta
  , w: r.w + (2 * delta)
  , h: r.h + (2 * delta)
  }

renderItems :: forall e. Game -> CanvasM e Unit
renderItems game =
  eachItem' game renderItem

renderItem :: forall e. Item -> CanvasM e Unit
renderItem item = do
  let centre = getCentredRectAt (item ^. iPosition)
  setFillStyle dotColor
  beginPath
  arc { x: centre.x
      , y: centre.y
      , start: 0
      , end: 2 * pi
      , r: dotRadiusFor (item ^. iType)
      }
  fill

renderPlayers :: forall e. Game -> CanvasM e Unit
renderPlayers game =
  eachPlayer' game renderPlayer

clearCanvas :: forall e. CanvasM e Unit
clearCanvas =
  clearRect {x: 0, y: 0, h: canvasSize, w: canvasSize}

renderCountdown :: forall e. Game -> PlayerId -> CanvasM e Unit
renderCountdown game pId = do
  whenJust game.countdown $ \cd -> do
    renderCounter cd
    renderReminderArrow game pId

setFontSize :: forall e. Number -> CanvasM e Unit
setFontSize x =
  setFont $ show x <> "pt " <> fontName

renderCounter cd = do
  setFontSize $ pxPerTile * 3
  setTextAlign AlignCenter
  setLineWidth 3
  setFillStyle fontColor
  setStrokeStyle "black"
  let text = show (ceil (cd / 30))
  let x = halfCanvas
  let y = floor (halfCanvas / 2)
  fillText   text x y
  strokeText text x y

renderReminderArrow game pId = do
  whenJust (game ^? player pId) $ \pl ->
    withContext $ do
      let pos = pl ^. pPosition
      let playerX = pos ^. pX
      let y = pos ^. pY

      let greater = playerX > mapSize / 2
      let d = 1.5 * tileSize
      let x = playerX + (if greater then d else -d)

      let centre = getCentredRectAt (Position {x:x, y:y})

      setLineWidth 1
      beginPath
      arrowPath greater centre.x centre.y 30 10
      fill
      stroke

arrowPath toRight x y length width = do
  let halfLen = floor (length / 2)
  let halfWid = floor (width / 2)
  let f z = if toRight then x + z else x - z

  moveTo (f halfLen)           (y - halfWid)
  lineTo (f (- halfLen))       (y - halfWid)
  lineTo (f (- halfLen))       (y - (2 * halfWid))
  lineTo (f (- (2 * halfLen))) (y)
  lineTo (f (- halfLen))       (y + (2 * halfWid))
  lineTo (f (- halfLen))       (y + halfWid)
  lineTo (f halfLen)           (y + halfWid)
  lineTo (f halfLen)           (y - halfWid)

render :: forall e.
  RenderingContext
  -> Game
  -> PlayerId
  -> Boolean
  -> Eff (canvas :: Canvas | e) Unit
render ctx game pId redrawMap = do
  when redrawMap $ do
    runCanvasM ctx.background $
      renderMap game.map

  runCanvasM ctx.foreground $ do
    clearCanvas
    renderItems game
    renderPlayers game
    renderCountdown game pId

clearBoth :: forall e.
  RenderingContext
  -> Eff (canvas :: Canvas | e) Unit
clearBoth ctx = do
  runCanvasM ctx.background clearCanvas
  runCanvasM ctx.foreground clearCanvas

setTextStyle = do
  setFontSize $ floor (0.6 * pxPerTile)
  setFillStyle fontColor


Revise AJAX example

Revise AJAX example

module Main where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)

import Data.Maybe (Maybe(..))

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.Util (runHalogenAff, awaitBody)
import Halogen.VirtualDOM.Driver (runUI)

import Network.HTTP.Affjax as AX

-- | The component state record.
type State =
  { busy :: Boolean
  , username :: String
  , result :: Maybe String
  }

-- | The component query algebra.
data Query a
  = SetUsername String a
  | MakeRequest a

-- | The effects used within the component.
type Effects eff = (ajax :: AX.AJAX | eff)

-- | The state value to use when the component is initialized.
initialState :: State
initialState = { busy: false, username: "", result: Nothing }

-- | The component renderer.
render :: State -> H.ComponentHTML Query
render st =
  HH.div_ $
    [ HH.h1_ [ HH.text "Lookup GitHub user" ]
    , HH.label_
        [ HH.div_ [ HH.text "Enter username:" ]
        , HH.input
            [ HP.value st.username
            , HE.onValueInput (HE.input SetUsername)
            ]
        ]
    , HH.button
        [ HP.disabled st.busy
        , HE.onClick (HE.input_ MakeRequest)
        ]
        [ HH.text "Fetch info" ]
    , HH.p_
        [ HH.text (if st.busy then "Working..." else "") ]
    , HH.div_
        case st.result of
          Nothing -> []
          Just res ->
            [ HH.h2_
                [ HH.text "Response:" ]
            , HH.pre_
                [ HH.code_ [ HH.text res ] ]
            ]
    ]

-- | The component query evaluator.
eval :: forall eff. Query ~> H.ComponentDSL State Query Void (Aff (Effects eff))
eval = case _ of
  SetUsername username next -> do
    H.modify (_ { username = username, result = Nothing :: Maybe String })
    pure next
  MakeRequest next -> do
    username <- H.gets _.username
    H.modify (_ { busy = true })
    response <- H.liftAff $ AX.get ("https://api.github.com/users/" <> username)
    H.modify (_ { busy = false, result = Just response.response })
    pure next

-- | The main UI component.
ui :: forall eff. H.Component HH.HTML Query Void (Aff (Effects eff))
ui = H.component { render, eval, initialState }

-- | Run the app.
main :: Eff (H.HalogenEffects (Effects ())) Unit
main = runHalogenAff do
  body <- awaitBody
  runUI ui body

module Main where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Except (runExcept)

import Data.Either (Either(..))
import Data.Foldable (foldMap)
import Data.Foreign.Class (readProp)
import Data.Maybe (Maybe(..))

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.Util (runHalogenAff, awaitBody)
import Halogen.VirtualDOM.Driver (runUI)

import Network.HTTP.Affjax (AJAX, post)

-- | The state of the component.
type State = { busy :: Boolean, code :: String, result :: Maybe String }

initialState :: State
initialState = { busy: false, code: exampleCode, result: Nothing }

exampleCode :: String
exampleCode = """module Main where

import Prelude
import Control.Monad.Eff.Console (print)

fact :: Int -> Int
fact 0 = 1
fact n = n * fact (n - 1)

main = print (fact 20)
"""

-- | The component query algebra.
data Query a
  = SetCode String a
  | MakeRequest String a

-- | The effects used in the app.
type AppEffects eff = H.HalogenEffects (ajax :: AJAX | eff)

-- | The definition for the app's main UI component.
ui :: forall eff. H.Component HH.HTML Query Void (Aff (AppEffects eff))
ui = H.component { render, eval, initialState }
  where

  render :: State -> H.ComponentHTML Query
  render st =
    HH.div_ $
      [ HH.h1_
          [ HH.text "ajax example / trypurescript" ]
      , HH.h2_
          [ HH.text "purescript input:" ]
      , HH.p_
          [ HH.textarea
              [ HP.value st.code
              , HE.onValueInput (HE.input SetCode)
              ]
          ]
      , HH.p_
          [ HH.button
              [ HP.disabled st.busy
              , HE.onClick (HE.input_ (MakeRequest st.code))
              ]
              [ HH.text "Compile" ]
          ]
      , HH.p_
          [ HH.text (if st.busy then "Working..." else "") ]
      ]
      <> flip foldMap st.result \js ->
          [ HH.div_
              [ HH.h2_
                  [ HH.text "javascript output:" ]
              , HH.pre_
                  [ HH.code_ [ HH.text js ] ]
              ]
          ]

  eval :: Query ~> H.ComponentDSL State Query Void (Aff (AppEffects eff))
  eval (SetCode code next) = H.modify (_ { code = code, result = Nothing :: Maybe String }) $> next
  eval (MakeRequest code next) = do
    H.modify (_ { busy = true })
    result <- H.liftAff (fetchJS code)
    H.modify (_ { busy = false, result = Just result })
    pure next

-- | Post some PureScript code to the trypurescript API and fetch the JS result.
fetchJS :: forall eff. String -> Aff (ajax :: AJAX | eff) String
fetchJS code = do
  result <- post "http://try.purescript.org/compile/text" code
  let response = result.response
  pure case runExcept $ readProp "js" response <|> readProp "error" response of
    Right js -> js
    Left _ -> "Invalid response"

-- | Run the app.
main :: Eff (AppEffects ()) Unit
main = runHalogenAff do
  body <- awaitBody
  runUI ui body


Use System.Collections.Generic

Use System.Collections.Generic

Original commit 18a146f89573203ae1c0a2e13cfabfeaa4cfb1a8

module CSharp
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude
import Types

import Data.Foldable (for_, intercalate)
import Data.List (List, fromFoldable, (:))
import Data.List as L
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set as Set
import Data.String.Util (capitalize, camelCase)
import Data.Tuple as Tuple

renderer :: Renderer
renderer =
    { name: "C#"
    , aceMode: "csharp"
    , doc: csharpDoc
    }

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

nullableFromSet :: Set.Set IRType -> Maybe IRType
nullableFromSet s =
    case L.fromFoldable s of
    IRNull : x : L.Nil -> Just x
    x : IRNull : L.Nil -> Just x
    _ -> Nothing

renderUnionToCSharp :: IRGraph -> Set.Set IRType -> String
renderUnionToCSharp graph s =
    case nullableFromSet s of
    Just x -> if isValueType x then renderTypeToCSharp graph x <> "?" else renderTypeToCSharp graph x
    Nothing -> "Either<" <> intercalate ", " (map (renderTypeToCSharp graph) (L.fromFoldable s)) <> ">"

renderTypeToCSharp :: IRGraph -> IRType -> String
renderTypeToCSharp graph = case _ of
    IRNothing -> "object"
    IRNull -> "object"
    IRInteger -> "int"
    IRDouble -> "double"
    IRBool -> "bool"
    IRString -> "string"
    IRArray a -> renderTypeToCSharp graph a <> "[]"
    IRClass i ->
        let IRClassData { names: names, properties } = getClassFromGraph graph i
        in
            csNameStyle $ combineNames names
    IRMap t -> "Dictionary<string, " <> renderTypeToCSharp graph t <> ">"
    IRUnion types -> renderUnionToCSharp graph types

csNameStyle :: String -> String
csNameStyle = camelCase >>> capitalize

csharpDoc :: Doc Unit
csharpDoc = do
    lines """namespace QuickType
             {"""
    blank
    indent do
        lines """using System.Net;
                 using System.Collections.Generic;
                 using Newtonsoft.Json;"""
        blank
        classes <- getClasses
        for_ classes \cls -> do
            renderCSharpClass cls
            blank
    lines "}"

renderCSharpClass :: IRClassData -> Doc Unit
renderCSharpClass (IRClassData { names, properties }) = do
    line $ words ["class", csNameStyle $ combineNames names]

    lines "{"
    indent do
        for_ (Map.toUnfoldable properties :: Array _) \(Tuple.Tuple pname ptype) -> do
            line do
                string "[JsonProperty(\""
                string pname
                string "\")]"
            line do
                string "public "
                graph <- getGraph
                string $ renderTypeToCSharp graph ptype
                words ["", csNameStyle pname, "{ get; set; }"]
            blank

        -- TODO don't rely on 'TopLevel'
        when (names == Set.singleton "TopLevel") do
            lines """// Loading helpers
                     public static TopLevel FromJson(string json) => JsonConvert.DeserializeObject<TopLevel>(json);"""
    lines "}"

module CSharp
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude
import Types

import Data.Foldable (for_, intercalate)
import Data.List (List, fromFoldable, (:))
import Data.List as L
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set as Set
import Data.String.Util (capitalize, camelCase)
import Data.Tuple as Tuple

renderer :: Renderer
renderer =
    { name: "C#"
    , aceMode: "csharp"
    , doc: csharpDoc
    }

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

nullableFromSet :: Set.Set IRType -> Maybe IRType
nullableFromSet s =
    case L.fromFoldable s of
    IRNull : x : L.Nil -> Just x
    x : IRNull : L.Nil -> Just x
    _ -> Nothing

renderUnionToCSharp :: IRGraph -> Set.Set IRType -> String
renderUnionToCSharp graph s =
    case nullableFromSet s of
    Just x -> if isValueType x then renderTypeToCSharp graph x <> "?" else renderTypeToCSharp graph x
    Nothing -> "Either<" <> intercalate ", " (map (renderTypeToCSharp graph) (L.fromFoldable s)) <> ">"

renderTypeToCSharp :: IRGraph -> IRType -> String
renderTypeToCSharp graph = case _ of
    IRNothing -> "object"
    IRNull -> "object"
    IRInteger -> "int"
    IRDouble -> "double"
    IRBool -> "bool"
    IRString -> "string"
    IRArray a -> renderTypeToCSharp graph a <> "[]"
    IRClass i ->
        let IRClassData { names: names, properties } = getClassFromGraph graph i
        in
            csNameStyle $ combineNames names
    IRMap t -> "Dictionary<string, " <> renderTypeToCSharp graph t <> ">"
    IRUnion types -> renderUnionToCSharp graph types

csNameStyle :: String -> String
csNameStyle = camelCase >>> capitalize

csharpDoc :: Doc Unit
csharpDoc = do
    lines """namespace QuickType
             {"""
    blank
    indent do
        lines """using System.Net;
                 using Newtonsoft.Json;"""
        blank
        classes <- getClasses
        for_ classes \cls -> do
            renderCSharpClass cls
            blank
    lines "}"

renderCSharpClass :: IRClassData -> Doc Unit
renderCSharpClass (IRClassData { names, properties }) = do
    line $ words ["class", csNameStyle $ combineNames names]

    lines "{"
    indent do
        for_ (Map.toUnfoldable properties :: Array _) \(Tuple.Tuple pname ptype) -> do
            line do
                string "[JsonProperty(\""
                string pname
                string "\")]"
            line do
                string "public "
                graph <- getGraph
                string $ renderTypeToCSharp graph ptype
                words ["", csNameStyle pname, "{ get; set; }"]
            blank

        -- TODO don't rely on 'TopLevel'
        when (names == Set.singleton "TopLevel") do
            lines """// Loading helpers
                     public static TopLevel FromJson(string json) => JsonConvert.DeserializeObject<TopLevel>(json);"""
    lines "}"


Call the function passed to Signal.foldp curried

module Signal where

import Control.Monad.Eff

foreign import data Signal :: * -> *

foreign import constant
  "function constant(initial) {\
  \    var subs = [];\
  \    var val = initial;\
  \    var sig = {\
  \      subscribe: function(sub) {\
  \        subs.push(sub);\
  \      },\
  \      get: function() { return val; },\
  \      set: function(newval) {\
  \        val = newval;\
  \        subs.forEach(function(sub) { sub(newval); });\
  \      }\
  \    };\
  \    return sig;\
  \}" :: forall a. a -> Signal a

foreign import lift
  "function lift(fun) {\
  \  return function(sig) {\
  \    var out = constant(fun(sig.get()));\
  \    sig.subscribe(function(val) { out.set(fun(val)); });\
  \    return out;\
  \  };\
  \}" :: forall a b. (a -> b) -> Signal a -> Signal b

foreign import applySig
  "function applySig(fun) {\
  \  return function(sig) {\
  \    var out = constant(fun.get()(sig.get()));\
  \    var produce = function() { out.set(fun.get()(sig.get())); };\
  \    fun.subscribe(produce);\
  \    sig.subscribe(produce);\
  \    return out;\
  \  };\
  \}" :: forall a b. Signal (a -> b) -> Signal a -> Signal b

foreign import merge
  "function merge(sig1) {\
  \  return function(sig2) {\
  \    var out = constant(sig1.get());\
  \    sig1.subscribe(out.set);\
  \    sig2.subscribe(out.set);\
  \    return out;\
  \  };\
  \}" :: forall a. Signal a -> Signal a -> Signal a

foreign import foldp
  "function foldp(fun) {\
  \  return function(seed) {\
  \    return function(sig) {\
  \      var acc = fun(sig.get())(seed);\
  \      var out = constant(acc);\
  \      sig.subscribe(function(val) {\
  \        acc = fun(val)(acc);\
  \        out.set(acc);\
  \      });\
  \      return out;\
  \    };\
  \  };\
  \}" :: forall a b. (a -> b -> b) -> b -> Signal a -> Signal b

foreign import sampleOn
  "function sampleOn(sig1) {\
  \  return function(sig2) {\
  \    var out = constant(sig2.get());\
  \    sig1.subscribe(function() {\
  \      out.set(sig2.get());\
  \    });\
  \    return out;\
  \  };\
  \}" :: forall a b. Signal a -> Signal b -> Signal b

foreign import distinct
  "function distinct(eq) {\
  \  return function(sig) {\
  \    var val = sig.get();\
  \    var out = constant(val);\
  \    sig.subscribe(function(newval) {\
  \      if (eq['/='](val, newval)) {\
  \        val = newval;\
  \        out.set(val);\
  \      }\
  \    });\
  \    return out;\
  \  };\
  \}" :: forall a. (Eq a) => Signal a -> Signal a

foreign import runSignal
  "function runSignal(sig) {\
  \  return function() {\
  \    sig.subscribe(function(val) {\
  \      val();\
  \    });\
  \    return {};\
  \  };\
  \}" :: forall e. Signal (Eff e Unit) -> Eff e Unit

foreign import unwrap
  "function unwrap(sig) {\
  \  return function() {\
  \    var out = constant(sig.get()());\
  \    sig.subscribe(function(val) { out.set(val()); });\
  \    return out;\
  \  };\
  \}" :: forall e a. Signal (Eff e a) -> Eff e (Signal a)

instance functorSignal :: Functor Signal where
  (<$>) = lift

instance applySignal :: Apply Signal where
  (<*>) = applySig

instance applicativeSignal :: Applicative Signal where
  pure = constant

instance semigroupSignal :: Semigroup (Signal a) where
  (<>) = merge

infixl 4 <~
(<~) :: forall f a b. (Functor f) => (a -> b) -> f a -> f b
(<~) = (<$>)

infixl 4 ~>
(~>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b
(~>) = flip (<$>)

infixl 4 ~
(~) :: forall f a b. (Apply f) => f (a -> b) -> f a -> f b
(~) = (<*>)

module Signal where

import Control.Monad.Eff

foreign import data Signal :: * -> *

foreign import constant
  "function constant(initial) {\
  \    var subs = [];\
  \    var val = initial;\
  \    var sig = {\
  \      subscribe: function(sub) {\
  \        subs.push(sub);\
  \      },\
  \      get: function() { return val; },\
  \      set: function(newval) {\
  \        val = newval;\
  \        subs.forEach(function(sub) { sub(newval); });\
  \      }\
  \    };\
  \    return sig;\
  \}" :: forall a. a -> Signal a

foreign import lift
  "function lift(fun) {\
  \  return function(sig) {\
  \    var out = constant(fun(sig.get()));\
  \    sig.subscribe(function(val) { out.set(fun(val)); });\
  \    return out;\
  \  };\
  \}" :: forall a b. (a -> b) -> Signal a -> Signal b

foreign import applySig
  "function applySig(fun) {\
  \  return function(sig) {\
  \    var out = constant(fun.get()(sig.get()));\
  \    var produce = function() { out.set(fun.get()(sig.get())); };\
  \    fun.subscribe(produce);\
  \    sig.subscribe(produce);\
  \    return out;\
  \  };\
  \}" :: forall a b. Signal (a -> b) -> Signal a -> Signal b

foreign import merge
  "function merge(sig1) {\
  \  return function(sig2) {\
  \    var out = constant(sig1.get());\
  \    sig1.subscribe(out.set);\
  \    sig2.subscribe(out.set);\
  \    return out;\
  \  };\
  \}" :: forall a. Signal a -> Signal a -> Signal a

foreign import foldp
  "function foldp(fun) {\
  \  return function(seed) {\
  \    return function(sig) {\
  \      var acc = fun(sig.get(), seed);\
  \      var out = constant(acc);\
  \      sig.subscribe(function(val) {\
  \        acc = fun(val, acc);\
  \        out.set(acc);\
  \      });\
  \      return out;\
  \    };\
  \  };\
  \}" :: forall a b. (a -> b -> b) -> b -> Signal a -> Signal b

foreign import sampleOn
  "function sampleOn(sig1) {\
  \  return function(sig2) {\
  \    var out = constant(sig2.get());\
  \    sig1.subscribe(function() {\
  \      out.set(sig2.get());\
  \    });\
  \    return out;\
  \  };\
  \}" :: forall a b. Signal a -> Signal b -> Signal b

foreign import distinct
  "function distinct(eq) {\
  \  return function(sig) {\
  \    var val = sig.get();\
  \    var out = constant(val);\
  \    sig.subscribe(function(newval) {\
  \      if (eq['/='](val, newval)) {\
  \        val = newval;\
  \        out.set(val);\
  \      }\
  \    });\
  \    return out;\
  \  };\
  \}" :: forall a. (Eq a) => Signal a -> Signal a

foreign import runSignal
  "function runSignal(sig) {\
  \  return function() {\
  \    sig.subscribe(function(val) {\
  \      val();\
  \    });\
  \    return {};\
  \  };\
  \}" :: forall e. Signal (Eff e Unit) -> Eff e Unit

foreign import unwrap
  "function unwrap(sig) {\
  \  return function() {\
  \    var out = constant(sig.get()());\
  \    sig.subscribe(function(val) { out.set(val()); });\
  \    return out;\
  \  };\
  \}" :: forall e a. Signal (Eff e a) -> Eff e (Signal a)

instance functorSignal :: Functor Signal where
  (<$>) = lift

instance applySignal :: Apply Signal where
  (<*>) = applySig

instance applicativeSignal :: Applicative Signal where
  pure = constant

instance semigroupSignal :: Semigroup (Signal a) where
  (<>) = merge

infixl 4 <~
(<~) :: forall f a b. (Functor f) => (a -> b) -> f a -> f b
(<~) = (<$>)

infixl 4 ~>
(~>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b
(~>) = flip (<$>)

infixl 4 ~
(~) :: forall f a b. (Apply f) => f (a -> b) -> f a -> f b
(~) = (<*>)


refine the code

refine the code

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Chart.BuildOptions.Radar where

import SlamData.Prelude

import Data.Argonaut (JCursor)
import Data.Foldable (minimum, maximum)
import Data.Array ((!!))
import Data.Array as A
import Data.Function (on)
import Data.List (List(..))
import Data.List as L
import Data.Map (Map)
import Data.Int (toNumber)
import Math ((%))

import ECharts.Monad (DSL)
import ECharts.Commands as E
import ECharts.Types as ET
import ECharts.Types.Phantom (OptionI)
import ECharts.Types.Phantom as ETP

import SlamData.Workspace.Card.Chart.Aggregation (Aggregation(..), runAggregation)
import SlamData.Workspace.Card.Chart.Axis as Ax
import SlamData.Workspace.Card.Chart.ChartConfiguration (ChartConfiguration)
import SlamData.Workspace.Card.Chart.BuildOptions.Common (SeriesKey, ChartAxes, colors, buildChartAxes, keyName)

--sample data:
-- Tuple ['dimA', 'dimB']
--       [ (Tuple '' [(Tuple 'series1' [1, 5]), (Tuple 'series2' [1, 5])]) ]
type RadarData = Tuple (Array String) (Array (Tuple String (Array (Tuple String (Array Number)))))

buildRadarData ∷ ChartAxes → RadarData
buildRadarData axes = Tuple (A.fromFoldable distinctDims) $
  A.fromFoldable
    $ map (map (A.fromFoldable
      <<< L.catMaybes
      <<< map checkDimAndTransform
      -- output sample:
      -- ( Tuple ''
      --         ( (Tuple 'series1' (Tuple 'dimA' 1 : Tuple 'dimB' 5))
      --         : (Tuple 'series2' (Tuple 'dimA' 1 : Tuple 'dimB' 5)) )
      -- )
      <<< map combineDim
      -- output sample:
      -- ( Tuple ''
      --         ( (Tuple 'series1' (Tuple 'dimA' 1 : Tuple 'dimB' 2 : Tuple 'dimB' 3))
      --         : (Tuple 'series2' (Tuple 'dimA' 1 : Tuple 'dimB' 2 : Tuple 'dimB' 3)) )
      -- )
      <<< L.catMaybes
      <<< map combineSerie
      -- output sample:
      -- ( Tuple ''
      --         ( (Tuple 'series1' (Tuple 'dimA' 1) : Tuple 'series1' (Tuple 'dimB' 2) : Tuple 'series1' (Tuple 'dimB' 3))
      --         : (Tuple 'series2' (Tuple 'dimA' 1) : Tuple 'series2' (Tuple 'dimB' 2) : Tuple 'series2' (Tuple 'dimB' 3)) )
      -- )
      <<< L.groupBy ((==) `on` fst)
      <<< L.sortBy (compare `on` fst)
    ))
    -- output sample:
    -- ( Tuple ''
    --         ( Tuple 'series1' (Tuple 'dimA' 1) : Tuple 'series1' (Tuple 'dimB' 2)
    --         : Tuple 'series1' (Tuple 'dimB' 3) : Tuple 'series2' (Tuple 'dimA' 1)
    --         : Tuple 'series2' (Tuple 'dimB' 2) : Tuple 'series2' (Tuple 'dimB' 3) )
    -- )
    $ L.catMaybes
    $ map combineDup
    -- output sample:
    -- (( Tuple '' (Tuple 'series1' (Tuple 'dimA' 1)) : Tuple '' (Tuple 'series1' (Tuple 'dimB' 2))
    --  : Tuple '' (Tuple 'series1' (Tuple 'dimB' 3)) : Tuple '' (Tuple 'series2' (Tuple 'dimA' 1))
    --  : Tuple '' (Tuple 'series2' (Tuple 'dimB' 2)) : Tuple '' (Tuple 'series2' (Tuple 'dimB' 3)) ))
    $ L.groupBy ((==) `on` fst)
    $ L.sortBy (compare `on` fst)
    -- output sample:
    -- ( Tuple '' (Tuple 'series1' (Tuple 'dimA' 1)) : Tuple '' (Tuple 'series1' (Tuple 'dimB' 2))
    -- : Tuple '' (Tuple 'series1' (Tuple 'dimB' 3)) : Tuple '' (Tuple 'series2' (Tuple 'dimA' 1))
    -- : Tuple '' (Tuple 'series2' (Tuple 'dimB' 2)) : Tuple '' (Tuple 'series2' (Tuple 'dimB' 3)) )
    $ L.catMaybes
    $ map filterInvalid
    $ tagDuplications duplications
    $ tagSeriesKey seriesKeys
    $ L.zip dimensions values

  where
  dimensions ∷ List (Maybe String)
  dimensions = fromMaybe Nil $ axes.dimensions !! 0

  values ∷ List (Maybe Number)
  values = fromMaybe Nil $ axes.measures !! 0

  series ∷ List (Maybe String)
  series = fromMaybe Nil $ axes.series !! 0

  duplications ∷ List (Maybe String)
  duplications = fromMaybe Nil $ axes.series !! 1

  agg ∷ Maybe Aggregation
  agg = fromMaybe (Just Sum) $ join (axes.aggregations !! 0)

  distinctDims ∷ List String
  distinctDims = L.sort $ L.catMaybes $ L.nub dimensions

  tagDuplications
    ∷ List (Maybe String)
    → List (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number)))
    → List (Tuple (Maybe String) (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number))))
  tagDuplications d v = case L.null d of
    true → map (Tuple Nothing) v
    false → L.zip d v

  tagSeriesKey
    ∷ List SeriesKey
    → List (Tuple (Maybe String) (Maybe Number))
    → List (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number)))
  tagSeriesKey k v = case L.null k of
    true → map (Tuple Nothing) v
    false → L.zip k v

  seriesKeys ∷ List SeriesKey
  seriesKeys = map (\x → mkSeriesKey x Nothing) series

  mkSeriesKey ∷ Maybe String → Maybe String → SeriesKey
  mkSeriesKey f s =
    f >>= \f → pure $ Tuple f s

  filterInvalid
    ∷ Tuple (Maybe String) (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number)))
    → Maybe (Tuple String (Tuple String (Tuple String Number)))
  filterInvalid (a × b × c × d) =
    case c, d of
      Just c', Just d' →
        Just $ Tuple
                (fromMaybe "" a)
                (Tuple (keyName (Tuple "" b)) (Tuple c' d'))
      _, _ → Nothing

  combineDup
    ∷ List (Tuple String (Tuple String (Tuple String Number)))
    → Maybe (Tuple String (List (Tuple String (Tuple String Number))))
  combineDup x = do
    d ← fst <$> L.head x
    pure $ Tuple d $ map snd x

  combineSerie
    ∷ List (Tuple String (Tuple String Number))
    → Maybe (Tuple String (List (Tuple String Number)))
  combineSerie x = do
    k ← fst <$> L.head x
    pure $ Tuple k $ map snd x

  combineDim
    ∷ Tuple String (List (Tuple String Number))
    → Tuple String (List (Tuple String Number))
  combineDim x =
    map (L.catMaybes <<< map combine <<< L.groupBy ((==) `on` fst) <<< L.sortBy (compare `on` fst)) x
    where
    combine ∷ List (Tuple String Number) → Maybe (Tuple String Number)
    combine x = do
      d ← fst <$> L.head x
      pure $ Tuple d (applyAggregation $ map snd x)

  applyAggregation ∷ List Number → Number
  applyAggregation = runAggregation (fromMaybe Sum agg)

  checkDimAndTransform
    ∷ Tuple String (List (Tuple String Number))
    → Maybe (Tuple String (Array Number))
  checkDimAndTransform a =
    if (L.length $ snd a) == L.length distinctDims
      then Just $ Tuple
        (fst a)
        (A.fromFoldable $ map snd $ snd a)
      else Nothing

buildRadar
  ∷ Map JCursor Ax.Axis
  → ChartConfiguration
  → DSL OptionI
buildRadar axes conf = do
  E.tooltip do
    E.triggerItem
    E.textStyle do
      E.fontFamily "Ubuntu sans"
      E.fontSize 12

  E.legend do
    E.items $ map ET.strItem serieNames
    E.orient ET.Vertical
    E.leftPosition $ ET.LeftHP
    E.topTop
    E.textStyle do
      E.fontFamily "Ubuntu sans"

  E.colors colors

  E.radars
    $ traverse_ E.radar radars

  E.titles
    $ traverse_ E.title titles

  E.series
    $ traverse_ (E.radarSeries ∘ serie)
    $ A.zip (A.range 0 (A.length $ snd radarData)) (snd radarData)

  where
  serieNames ∷ Array String
  serieNames =
    A.nub
      $ A.filter (\e → e /= "")
      $ A.concat
      $ map (map fst)
      $ map snd
      $ snd radarData

  dupNames ∷ Array String
  dupNames = map fst $ snd radarData

  numDup ∷ Int
  numDup = A.length dupNames

  titles ∷ Array (DSL ETP.TitleI)
  titles =
    map (mkTitle numDup) (A.range 0 $ numDup - 1)
    where
    mkTitle ∷ Int → Int → DSL ETP.TitleI
    mkTitle n i = do
      let
        -- max number of plot in one row: 4
        maxCol = 4
        nRow = (n / maxCol + 1)
        nCol = if n <= maxCol then n else maxCol
        row = toNumber (i / nCol)
        col = (toNumber i) % (toNumber nCol)
      E.text $ fromMaybe "" $ dupNames !! i
      E.textStyle do
        E.fontFamily "Ubuntu sans"
        E.fontSize 12
      E.left
        $ ET.Percent
        $ 100.0 * (2.0 * col + 1.0) / (toNumber (nCol * 2))
          -- adjust the position to the center
          - 0.3
      E.top
        $ ET.Percent
        $ 100.0 * (2.0 * row + 1.0) / (toNumber (nRow * 2))
          - (75.0 / (if nRow > nCol then toNumber nRow else toNumber nCol))
      E.textCenter
      E.textBottom

  radars ∷ Array (DSL ETP.RadarI)
  radars =
    map (mkPolar numDup) (A.range 0 $ numDup - 1)
    where
    mkPolar ∷ Int → Int → DSL ETP.RadarI
    mkPolar n i = do
      let
        -- max number of plot in one row: 4
        maxCol = 4
        nRow = (n / maxCol + 1)
        nCol = if n <= maxCol then n else maxCol
        row = toNumber (i / nCol)
        col = (toNumber i) % (toNumber nCol)
      E.indicators
        $ traverse_ E.indicator $ mkIndicatorSet i
      E.nameGap 10.0
      E.center $ ET.Point
        { x: ET.Percent $ 100.0 * (2.0 * col + 1.0) / (toNumber (nCol * 2))
        , y: ET.Percent $ 100.0 * (2.0 * row + 1.0) / (toNumber (nRow * 2))
        }
      E.singleValueRadius
        $ ET.SingleValueRadius
        $ ET.Percent
        $ 75.0 / (if nRow > nCol then toNumber nRow else toNumber nCol)

  mkIndicatorSet ∷ Int → Array (DSL ETP.IndicatorI)
  mkIndicatorSet i =
    let
      dupName = fromMaybe "" $ (map fst $ snd radarData) !! i
    in
      map mkIndicator (fst radarData)

  mkIndicator ∷ String → DSL ETP.IndicatorI
  mkIndicator dim = do
    E.name $ dim
    when (isJust minVal) $ E.min $ fromMaybe zero minVal
    when (isJust maxVal) $ E.max $ fromMaybe zero maxVal

  allValues ∷ Array Number
  allValues = A.concat
    $ map snd
    $ A.concat
    $ map snd
    $ snd radarData

  minVal ∷ Maybe Number
  minVal = minimum allValues

  maxVal ∷ Maybe Number
  maxVal = maximum allValues

  radarData ∷ RadarData
  radarData = buildRadarData $ buildChartAxes axes conf

serie
  ∷ Tuple Int (Tuple String (Array (Tuple String (Array Number))))
  → DSL ETP.RadarSeriesI
serie (ind × (dup × a)) = do
  when (dup ≠ "") $ E.name dup
  E.radarIndex $ toNumber ind
  E.symbol ET.Circle
  if A.null a
    then E.buildItems $ E.addItem blankData
    else E.buildItems $ for_ a \x →
      E.addItem $ makeData x

makeData
  ∷ Tuple String (Array Number)
  → DSL ETP.ItemI
makeData (name × values) = do
    E.name name
    E.values values

blankData ∷ DSL ETP.ItemI
blankData = do
  -- set a value to avoid display issue
  E.values [0.0]
  E.symbol ET.None

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Chart.BuildOptions.Radar where

import SlamData.Prelude

import Data.Argonaut (JCursor)
import Data.Foldable (minimum, maximum)
import Data.Array ((!!))
import Data.Array as A
import Data.Function (on)
import Data.List (List(..))
import Data.List as L
import Data.Map (Map)
import Data.Int (toNumber)
import Math ((%))

import ECharts.Monad (DSL)
import ECharts.Commands as E
import ECharts.Types as ET
import ECharts.Types.Phantom (OptionI)
import ECharts.Types.Phantom as ETP

import SlamData.Workspace.Card.Chart.Aggregation (Aggregation(..), runAggregation)
import SlamData.Workspace.Card.Chart.Axis as Ax
import SlamData.Workspace.Card.Chart.ChartConfiguration (ChartConfiguration)
import SlamData.Workspace.Card.Chart.BuildOptions.Common (SeriesKey, ChartAxes, colors, buildChartAxes, keyName)

--sample data:
-- Tuple ['dimA', 'dimB']
--       [ (Tuple '' [(Tuple 'series1' [1, 5]), (Tuple 'series2' [1, 5])]) ]
type RadarData = Tuple (Array String) (Array (Tuple String (Array (Tuple String (Array Number)))))

buildRadarData ∷ ChartAxes → RadarData
buildRadarData axes = Tuple (A.fromFoldable distinctDims) $
  A.fromFoldable
    $ map (map (A.fromFoldable
      <<< L.catMaybes
      <<< map checkDimAndTransform
      -- output sample:
      -- ( Tuple ''
      --         ( (Tuple 'series1' (Tuple 'dimA' 1 : Tuple 'dimB' 5))
      --         : (Tuple 'series2' (Tuple 'dimA' 1 : Tuple 'dimB' 5)) )
      -- )
      <<< map combineDim
      -- output sample:
      -- ( Tuple ''
      --         ( (Tuple 'series1' (Tuple 'dimA' 1 : Tuple 'dimB' 2 : Tuple 'dimB' 3))
      --         : (Tuple 'series2' (Tuple 'dimA' 1 : Tuple 'dimB' 2 : Tuple 'dimB' 3)) )
      -- )
      <<< L.catMaybes
      <<< map combineSerie
      -- output sample:
      -- ( Tuple ''
      --         ( (Tuple 'series1' (Tuple 'dimA' 1) : Tuple 'series1' (Tuple 'dimB' 2) : Tuple 'series1' (Tuple 'dimB' 3))
      --         : (Tuple 'series2' (Tuple 'dimA' 1) : Tuple 'series2' (Tuple 'dimB' 2) : Tuple 'series2' (Tuple 'dimB' 3)) )
      -- )
      <<< L.groupBy ((==) `on` fst)
      <<< L.sortBy (compare `on` fst)
    ))
    -- output sample:
    -- ( Tuple ''
    --         ( Tuple 'series1' (Tuple 'dimA' 1) : Tuple 'series1' (Tuple 'dimB' 2)
    --         : Tuple 'series1' (Tuple 'dimB' 3) : Tuple 'series2' (Tuple 'dimA' 1)
    --         : Tuple 'series2' (Tuple 'dimB' 2) : Tuple 'series2' (Tuple 'dimB' 3) )
    -- )
    $ L.catMaybes
    $ map combineDup
    -- output sample:
    -- (( Tuple '' (Tuple 'series1' (Tuple 'dimA' 1)) : Tuple '' (Tuple 'series1' (Tuple 'dimB' 2))
    --  : Tuple '' (Tuple 'series1' (Tuple 'dimB' 3)) : Tuple '' (Tuple 'series2' (Tuple 'dimA' 1))
    --  : Tuple '' (Tuple 'series2' (Tuple 'dimB' 2)) : Tuple '' (Tuple 'series2' (Tuple 'dimB' 3)) ))
    $ L.groupBy ((==) `on` fst)
    $ L.sortBy (compare `on` fst)
    -- output sample:
    -- ( Tuple '' (Tuple 'series1' (Tuple 'dimA' 1)) : Tuple '' (Tuple 'series1' (Tuple 'dimB' 2))
    -- : Tuple '' (Tuple 'series1' (Tuple 'dimB' 3)) : Tuple '' (Tuple 'series2' (Tuple 'dimA' 1))
    -- : Tuple '' (Tuple 'series2' (Tuple 'dimB' 2)) : Tuple '' (Tuple 'series2' (Tuple 'dimB' 3)) )
    $ L.catMaybes
    $ map filterInvalid
    $ tagDuplications duplications
    $ tagSeriesKey seriesKeys
    $ L.zip dimensions values

  where
  dimensions ∷ List (Maybe String)
  dimensions = fromMaybe Nil $ axes.dimensions !! 0

  values ∷ List (Maybe Number)
  values = fromMaybe Nil $ axes.measures !! 0

  series ∷ List (Maybe String)
  series = fromMaybe Nil $ axes.series !! 0

  duplications ∷ List (Maybe String)
  duplications = fromMaybe Nil $ axes.series !! 1

  agg ∷ Maybe Aggregation
  agg = fromMaybe (Just Sum) $ join (axes.aggregations !! 0)

  distinctDims ∷ List String
  distinctDims = L.sort $ L.catMaybes $ L.nub dimensions

  tagDuplications
    ∷ List (Maybe String)
    → List (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number)))
    → List (Tuple (Maybe String) (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number))))
  tagDuplications d v = case L.null d of
    true → map (Tuple Nothing) v
    false → L.zip d v

  tagSeriesKey
    ∷ List SeriesKey
    → List (Tuple (Maybe String) (Maybe Number))
    → List (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number)))
  tagSeriesKey k v = case L.null k of
    true → map (Tuple Nothing) v
    false → L.zip k v

  seriesKeys ∷ List SeriesKey
  seriesKeys = map (\x → mkSeriesKey x Nothing) series

  mkSeriesKey ∷ Maybe String → Maybe String → SeriesKey
  mkSeriesKey f s =
    f >>= \f → pure $ Tuple f s

  filterInvalid
    ∷ Tuple (Maybe String) (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number)))
    → Maybe (Tuple String (Tuple String (Tuple String Number)))
  filterInvalid (a × b × c × d) =
    case c, d of
      Just c', Just d' →
        Just $ Tuple
                (fromMaybe "" a)
                (Tuple (keyName (Tuple "" b)) (Tuple c' d'))
      _, _ → Nothing

  combineDup
    ∷ List (Tuple String (Tuple String (Tuple String Number)))
    → Maybe (Tuple String (List (Tuple String (Tuple String Number))))
  combineDup x = do
    d ← L.head $ map fst x
    pure $ Tuple d $ map snd x

  combineSerie
    ∷ List (Tuple String (Tuple String Number))
    → Maybe (Tuple String (List (Tuple String Number)))
  combineSerie x = do
    k ← L.head $ map fst x
    pure $ Tuple k $ map snd x

  combineDim
    ∷ Tuple String (List (Tuple String Number))
    → Tuple String (List (Tuple String Number))
  combineDim x =
    map (L.catMaybes <<< map combine <<< L.groupBy ((==) `on` fst) <<< L.sortBy (compare `on` fst)) x
    where
    combine ∷ List (Tuple String Number) → Maybe (Tuple String Number)
    combine x = do
      d ← L.head $ map fst x
      pure $ Tuple d (applyAggregation $ map snd x)

  applyAggregation ∷ List Number → Number
  applyAggregation a = case agg of
    Just agg' → runAggregation agg' a
    _ → runAggregation Sum a

  checkDimAndTransform
    ∷ Tuple String (List (Tuple String Number))
    → Maybe (Tuple String (Array Number))
  checkDimAndTransform a =
    if (L.length $ snd a) == L.length distinctDims
      then Just $ Tuple
        (fst a)
        (A.fromFoldable $ map snd $ snd a)
      else Nothing

buildRadar
  ∷ Map JCursor Ax.Axis
  → ChartConfiguration
  → DSL OptionI
buildRadar axes conf = do
  E.tooltip do
    E.triggerItem
    E.textStyle do
      E.fontFamily "Ubuntu sans"
      E.fontSize 12

  E.legend do
    E.items $ map ET.strItem serieNames
    E.orient ET.Vertical
    E.leftPosition $ ET.LeftHP
    E.topTop
    E.textStyle do
      E.fontFamily "Ubuntu sans"

  E.colors colors

  E.radars
    $ traverse_ E.radar radars

  E.titles
    $ traverse_ E.title titles

  E.series
    $ traverse_ (E.radarSeries ∘ serie)
    $ A.zip (A.range 0 (A.length $ snd radarData)) (snd radarData)

  where
  serieNames ∷ Array String
  serieNames =
    A.nub
      $ A.filter (\e → e /= "")
      $ A.concat
      $ map (map fst)
      $ map snd
      $ snd radarData

  dupNames ∷ Array String
  dupNames = map fst $ snd radarData

  numDup ∷ Int
  numDup = A.length dupNames

  titles ∷ Array (DSL ETP.TitleI)
  titles =
    map (mkTitle numDup) (A.range 0 $ numDup - 1)
    where
    mkTitle ∷ Int → Int → DSL ETP.TitleI
    mkTitle n i = do
      let
        -- max number of plot in one row: 4
        maxCol = 4
        nRow = (n / maxCol + 1)
        nCol = if n <= maxCol then n else maxCol
        row = toNumber (i / nCol)
        col = (toNumber i) % (toNumber nCol)
      E.text $ fromMaybe "" $ dupNames !! i
      E.textStyle do
        E.fontFamily "Ubuntu sans"
        E.fontSize 12
      E.left
        $ ET.Percent
        $ 100.0 * (2.0 * col + 1.0) / (toNumber (nCol * 2))
          -- adjust the position to the center
          - 0.3
      E.top
        $ ET.Percent
        $ 100.0 * (2.0 * row + 1.0) / (toNumber (nRow * 2))
          - (75.0 / (if nRow > nCol then toNumber nRow else toNumber nCol))
      E.textCenter
      E.textBottom

  radars ∷ Array (DSL ETP.RadarI)
  radars =
    map (mkPolar numDup) (A.range 0 $ numDup - 1)
    where
    mkPolar ∷ Int → Int → DSL ETP.RadarI
    mkPolar n i = do
      let
        -- max number of plot in one row: 4
        maxCol = 4
        nRow = (n / maxCol + 1)
        nCol = if n <= maxCol then n else maxCol
        row = toNumber (i / nCol)
        col = (toNumber i) % (toNumber nCol)
      E.indicators
        $ traverse_ E.indicator $ mkIndicatorSet i
      E.nameGap 10.0
      E.center $ ET.Point
        { x: ET.Percent $ 100.0 * (2.0 * col + 1.0) / (toNumber (nCol * 2))
        , y: ET.Percent $ 100.0 * (2.0 * row + 1.0) / (toNumber (nRow * 2))
        }
      E.singleValueRadius
        $ ET.SingleValueRadius
        $ ET.Percent
        $ 75.0 / (if nRow > nCol then toNumber nRow else toNumber nCol)

  mkIndicatorSet ∷ Int → Array (DSL ETP.IndicatorI)
  mkIndicatorSet i =
    let
      dupName = fromMaybe "" $ (map fst $ snd radarData) !! i
    in
      map mkIndicator (fst radarData)

  mkIndicator ∷ String → DSL ETP.IndicatorI
  mkIndicator dim = do
    E.name $ dim
    when (isJust minVal) $ E.min $ fromMaybe zero minVal
    when (isJust maxVal) $ E.max $ fromMaybe zero maxVal

  allValues ∷ Array Number
  allValues = A.concat
    $ map snd
    $ A.concat
    $ map snd
    $ snd radarData

  minVal ∷ Maybe Number
  minVal = minimum allValues

  maxVal ∷ Maybe Number
  maxVal = maximum allValues

  radarData ∷ RadarData
  radarData = buildRadarData $ buildChartAxes axes conf

serie
  ∷ Tuple Int (Tuple String (Array (Tuple String (Array Number))))
  → DSL ETP.RadarSeriesI
serie (ind × (dup × a)) = do
  when (dup ≠ "") $ E.name dup
  E.radarIndex $ toNumber ind
  E.symbol ET.Circle
  if A.null a
    then E.buildItems $ E.addItem blankData
    else E.buildItems $ for_ a \x →
      E.addItem $ makeData x

makeData
  ∷ Tuple String (Array Number)
  → DSL ETP.ItemI
makeData (name × values) = do
    E.name name
    E.values values

blankData ∷ DSL ETP.ItemI
blankData = do
  -- set a value to avoid display issue
  E.values [0.0]
  E.symbol ET.None


Fix appendAtIndex

Fix appendAtIndex

module JQuery where

  import Data.JSON
  import Control.Monad.Eff

  -- An effect type which indicates DOM manipulation
  foreign import data DOM :: !

  -- The jQuery wrapper type
  foreign import data JQuery :: *

  -- Wrapper function for jQuery selection $('..')
  foreign import select
    "function select(selector) { \
    \  return function () { \
    \    return jQuery(selector); \
    \  }; \
    \}" :: forall eff. String -> Eff (dom :: DOM | eff) JQuery

  -- Wrapper function for jQuery creation e.g. $('<div>')
  foreign import create
    "function create(html) { \
    \  return function () { \
    \    return jQuery(html); \
    \  }; \
    \}" :: forall eff. String -> Eff (dom :: DOM | eff) JQuery

  -- .attr({ ... })
  foreign import setAttr
    "function setAttr(attr) { \
    \  return function(val) { \
    \    return function(ob) { \
    \      return function () { \
    \        return ob.attr(attr, val);\
    \      }; \
    \    }; \
    \  }; \
    \}" :: forall eff a. String -> a -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .attr({ ... })
  foreign import attr
    "function attr(attrs) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.attr(attrs);\
    \    }; \
    \  }; \
    \}" :: forall eff attr. { | attr } -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .css({ ... })
  foreign import css
    "function css(props) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.css(props); \
    \    }; \
    \  }; \
    \}" :: forall eff css. { | css } -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .prop({ ... })
  foreign import setProp
    "function setProp(p) { \
    \  return function(val) { \
    \    return function(ob) { \
    \      return function () { \
    \        return ob.prop(p, val);\
    \      }; \
    \    }; \
    \  }; \
    \}" :: forall a eff. String -> a -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .prop({ ... })
  foreign import getProp
    "function getProp(p) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.prop(p);\
    \    }; \
    \  }; \
    \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JSON

  -- .append(...)
  foreign import append
    "function append(ob1) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.append(ob1); \
    \    }; \
    \  }; \
    \}" :: forall eff. JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

  foreign import appendAtIndex
    "function appendAtIndex(i) { \
    \  return function(ob1) { \
    \    return function(ob) { \
    \      return function () { \
    \        var children = ob.children();\
    \        if (children.length > 0) {\
    \          if (i <= 0) {\
    \             ob.prepend(ob1);\
    \          } else if (i >= children.length) {\
    \             ob.append(ob1);\
    \          } else {\
    \             ob1.insertBefore(jQuery(children[i]));\
    \          }\
    \          return ob;\
    \        } else {\
    \          return ob.append(ob1); \
    \        }\
    \      }; \
    \    }; \
    \  }; \
    \}" :: forall eff. Number -> JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .remove()
  foreign import remove
    "function remove(ob) { \
    \  return function () { \
    \    return ob.remove(); \
    \  }; \
    \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .before(...)
  foreign import before
    "function before(ob) { \
    \  return function(ob1) { \
    \    return function () { \
    \      return ob1.before(ob); \
    \    }; \
    \  }; \
    \}" :: forall eff. JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .append(...)
  foreign import appendText
    "function appendText(s) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.append(s); \
    \    }; \
    \  }; \
    \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- Get the document body
  foreign import body
    "function body() { \
    \  return jQuery(document.body); \
    \}" :: forall eff. Eff (dom :: DOM | eff) JQuery

  -- Get the text content of an element
  foreign import getText
    "function getText(ob) { \
    \  return function() { \
    \    return ob.text(); \
    \  }; \
    \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) String

  -- Set the text content of an element
  foreign import setText
    "function setText(text) { \
    \  return function(ob) { \
    \    return function() { \
    \      ob.text(text); \
    \    };\
    \  };\
    \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- Get the value of a text field
  foreign import getValue
    "function getValue(ob) { \
    \  return function() { \
    \    return ob.val(); \
    \  }; \
    \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) JSON

  -- Set the value of a text field
  foreign import setValue
    "function setValue(val) { \
    \  return function(ob) { \
    \    return function() { \
    \      return ob.val(val); \
    \    }; \
    \  }; \
    \}" :: forall eff a. a -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- Register an event handler
  foreign import on
    "function on(evt) { \
    \  return function(act) { \
    \    return function(ob) { \
    \      return function() { \
    \        return ob.on(evt, function() { \
    \          act(); \
    \        }); \
    \      }; \
    \    }; \
    \  }; \
    \}" :: forall eff a. String -> Eff eff a -> JQuery -> Eff (dom :: DOM | eff) JQuery

module JQuery where

  import Data.JSON
  import Control.Monad.Eff

  -- An effect type which indicates DOM manipulation
  foreign import data DOM :: !

  -- The jQuery wrapper type
  foreign import data JQuery :: *

  -- Wrapper function for jQuery selection $('..')
  foreign import select
    "function select(selector) { \
    \  return function () { \
    \    return jQuery(selector); \
    \  }; \
    \}" :: forall eff. String -> Eff (dom :: DOM | eff) JQuery

  -- Wrapper function for jQuery creation e.g. $('<div>')
  foreign import create
    "function create(html) { \
    \  return function () { \
    \    return jQuery(html); \
    \  }; \
    \}" :: forall eff. String -> Eff (dom :: DOM | eff) JQuery

  -- .attr({ ... })
  foreign import setAttr
    "function setAttr(attr) { \
    \  return function(val) { \
    \    return function(ob) { \
    \      return function () { \
    \        return ob.attr(attr, val);\
    \      }; \
    \    }; \
    \  }; \
    \}" :: forall eff a. String -> a -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .attr({ ... })
  foreign import attr
    "function attr(attrs) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.attr(attrs);\
    \    }; \
    \  }; \
    \}" :: forall eff attr. { | attr } -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .css({ ... })
  foreign import css
    "function css(props) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.css(props); \
    \    }; \
    \  }; \
    \}" :: forall eff css. { | css } -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .prop({ ... })
  foreign import setProp
    "function setProp(p) { \
    \  return function(val) { \
    \    return function(ob) { \
    \      return function () { \
    \        return ob.prop(p, val);\
    \      }; \
    \    }; \
    \  }; \
    \}" :: forall a eff. String -> a -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .prop({ ... })
  foreign import getProp
    "function getProp(p) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.prop(p);\
    \    }; \
    \  }; \
    \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JSON

  -- .append(...)
  foreign import append
    "function append(ob1) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.append(ob1); \
    \    }; \
    \  }; \
    \}" :: forall eff. JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

  foreign import appendAtIndex
    "function appendAtIndex(i) { \
    \  return function(ob1) { \
    \    return function(ob) { \
    \      return function () { \
    \        return ob1.before(ob.children()[i]); \
    \      }; \
    \    }; \
    \  }; \
    \}" :: forall eff. Number -> JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .remove()
  foreign import remove
    "function remove(ob) { \
    \  return function () { \
    \    return ob.remove(); \
    \  }; \
    \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .before(...)
  foreign import before
    "function before(ob) { \
    \  return function(ob1) { \
    \    return function () { \
    \      return ob1.before(ob); \
    \    }; \
    \  }; \
    \}" :: forall eff. JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- .append(...)
  foreign import appendText
    "function appendText(s) { \
    \  return function(ob) { \
    \    return function () { \
    \      return ob.append(s); \
    \    }; \
    \  }; \
    \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- Get the document body
  foreign import body
    "function body() { \
    \  return jQuery(document.body); \
    \}" :: forall eff. Eff (dom :: DOM | eff) JQuery

  -- Get the text content of an element
  foreign import getText
    "function getText(ob) { \
    \  return function() { \
    \    return ob.text(); \
    \  }; \
    \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) String

  -- Set the text content of an element
  foreign import setText
    "function setText(text) { \
    \  return function(ob) { \
    \    return function() { \
    \      ob.text(text); \
    \    };\
    \  };\
    \}" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- Get the value of a text field
  foreign import getValue
    "function getValue(ob) { \
    \  return function() { \
    \    return ob.val(); \
    \  }; \
    \}" :: forall eff. JQuery -> Eff (dom :: DOM | eff) JSON

  -- Set the value of a text field
  foreign import setValue
    "function setValue(val) { \
    \  return function(ob) { \
    \    return function() { \
    \      return ob.val(val); \
    \    }; \
    \  }; \
    \}" :: forall eff a. a -> JQuery -> Eff (dom :: DOM | eff) JQuery

  -- Register an event handler
  foreign import on
    "function on(evt) { \
    \  return function(act) { \
    \    return function(ob) { \
    \      return function() { \
    \        return ob.on(evt, function() { \
    \          act(); \
    \        }); \
    \      }; \
    \    }; \
    \  }; \
    \}" :: forall eff a. String -> Eff eff a -> JQuery -> Eff (dom :: DOM | eff) JQuery