Fix parsing of sections

Fix parsing of sections

There were some errors where basic expressions like '(1 + 2)'
could not be parsed.

module Parser where

import Global              (readInt)
import Data.String         (joinWith, split)
import Data.Identity       (Identity())
import Data.Maybe
import Control.Alt         ((<|>))
import Control.Apply       ((*>))
import Control.Alternative (some, many)
import Control.Lazy        (fix1)

import Text.Parsing.Parser
import Text.Parsing.Parser.Combinators
import Text.Parsing.Parser.String

import AST

eatSpaces :: Parser String Unit
eatSpaces = void $ many $ string " " <|> string "\t"

---------------------------------------
-- Parsers for the 'Atom' type
---------------------------------------

num :: Parser String Atom
num = do
  sign <- option "" (string "-")
  eatSpaces
  str <- string "0" <|> nat
  return $ Num $ readInt 10 $ sign ++ str
  where
  nat = do
    d <- oneOf $ split "" "123456789"
    ds <- many $ oneOf $ split "" "0123456789"
    return $ joinWith "" $ d:ds

bool :: Parser String Atom
bool = do
  f <|> t
  where
  f = string "false" *> return (Bool false)
  t = string "true" *> return (Bool true)

name :: Parser String String
name = do
  str <- some $ oneOf $ split "" "_abcdefghijklmnopqrstuvwxyz'"
  return $ joinWith "" str

atom :: Parser String Atom
atom = do
  num <|> try bool <|> (Name <$> name) <?> "Atom (Number, Boolean, Name)"

---------------------------------------
-- Parsers for the 'Expr' type
---------------------------------------

list :: forall a. Parser String a -> Parser String [a]
list p = do
  string "["
  eatSpaces
  ls <- p `sepBy` (try (eatSpaces *> string ","))
  eatSpaces
  string "]"
  return ls

app :: Parser String Expr -> Parser String Expr
app expr = do
  str <- name
  exprs <- some (try $ eatSpaces *> expr)
  return $ App str exprs

bracket :: forall a. Parser String a -> Parser String a
bracket p = do
  string "("
  eatSpaces
  e <- p
  eatSpaces
  string ")"
  return e

section :: Parser String Expr -> Parser String Expr
section expr = bracket (try sectR <|> sectL)
  where
  sectR = do
    op <- choice opList
    eatSpaces
    e <- expr
    return $ SectR op e
  sectL = do
    e <- expr
    eatSpaces
    op <- choice opList
    return $ SectL e op

opList :: [Parser String Op]
opList =
  [ opP (string "+" *> notFollowedBy (string "+")) Add
  , opP (string "-" *> notFollowedBy (eatSpaces *> num)) Sub
  , opP (string "*")     Mul
  , opP (string "`div`") Div
  , opP (string ":")     Cons
  , opP (string "++")    Append
  , opP (string "&&")    And
  , opP (string "||")    Or
  ]

base :: Parser String Expr -> Parser String Expr
base expr =  (List <$> list expr)
         <|> bracket expr
         <|> (Atom <$> atom)

termSect :: Parser String Expr -> Parser String Expr
termSect expr = try (section (base expr)) <|> base expr

termApp :: Parser String Expr -> Parser String Expr
termApp expr = try (app (termSect expr)) <|> termSect expr

opP :: forall a. Parser String a -> Op -> Parser String Op
opP strP opConstructor = try $
  (eatSpaces *> strP *> eatSpaces *> return opConstructor)

term7l :: Parser String Expr -> Parser String Expr
term7l expr = chainl1 (termApp expr) (mulP <|> divP)
  where
  mulP = Binary <$> opP (string "*") Mul
  divP = Binary <$> opP (string "`div`") Div

term6l :: Parser String Expr -> Parser String Expr
term6l expr = chainl1 (term7l expr) (addP <|> subP)
  where
  addP = Binary <$> opP (string "+" *> notFollowedBy (string "+")) Add
  subP = Binary <$> opP (string "-") Sub

term5r :: Parser String Expr -> Parser String Expr
term5r expr = chainr1 (term6l expr) (consP <|> appendP)
  where
  consP = Binary <$> opP (string ":") Cons
  appendP = Binary <$> opP (string "++") Append

term3r :: Parser String Expr -> Parser String Expr
term3r expr = chainr1 (term5r expr) (Binary <$> opP (string "&&") And)

term2r :: Parser String Expr -> Parser String Expr
term2r expr = chainr1 (term3r expr) (Binary <$> opP (string "||") Or)

expr :: Parser String Expr
expr = fix1 $ \expr -> term2r expr

---------------------------------------
-- Parsers for the 'Binding' type
---------------------------------------

lit :: Parser String Binding
lit = Lit <$> atom

listLit :: Parser String Binding -> Parser String Binding
listLit binding = ListLit <$> list binding

consLit :: Parser String Binding -> Parser String Binding
consLit binding = bracket recurse
  where
  recurse = fix1 $ \recurse -> try (cons recurse) <|> binding
  cons recurse = do
    b <- binding
    eatSpaces
    string ":"
    eatSpaces
    bs <- recurse
    return $ ConsLit b bs

binding :: Parser String Binding
binding = fix1 $ \binding -> lit <|> consLit binding <|> listLit binding

module Parser where

import Global              (readInt)
import Data.String         (joinWith, split)
import Data.Identity       (Identity())
import Data.Maybe
import Control.Alt         ((<|>))
import Control.Apply       ((*>))
import Control.Alternative (some, many)
import Control.Lazy        (fix1)

import Text.Parsing.Parser
import Text.Parsing.Parser.Combinators
import Text.Parsing.Parser.String

import AST

eatSpaces :: Parser String Unit
eatSpaces = void $ many $ string " " <|> string "\t"

---------------------------------------
-- Parsers for the 'Atom' type
---------------------------------------

num :: Parser String Atom
num = do
  sign <- option "" (string "-")
  eatSpaces
  str <- string "0" <|> nat
  return $ Num $ readInt 10 $ sign ++ str
  where
  nat = do
    d <- oneOf $ split "" "123456789"
    ds <- many $ oneOf $ split "" "0123456789"
    return $ joinWith "" $ d:ds

bool :: Parser String Atom
bool = do
  f <|> t
  where
  f = string "false" *> return (Bool false)
  t = string "true" *> return (Bool true)

name :: Parser String String
name = do
  str <- some $ oneOf $ split "" "_abcdefghijklmnopqrstuvwxyz'"
  return $ joinWith "" str

atom :: Parser String Atom
atom = do
  num <|> try bool <|> (Name <$> name) <?> "Atom (Number, Boolean, Name)"

---------------------------------------
-- Parsers for the 'Expr' type
---------------------------------------

list :: forall a. Parser String a -> Parser String [a]
list p = do
  string "["
  eatSpaces
  ls <- p `sepBy` (try (eatSpaces *> string ","))
  eatSpaces
  string "]"
  return ls

app :: Parser String Expr -> Parser String Expr
app expr = do
  str <- name
  exprs <- some (try $ eatSpaces *> expr)
  return $ App str exprs

bracket :: forall a. Parser String a -> Parser String a
bracket p = do
  string "("
  eatSpaces
  e <- p
  eatSpaces
  string ")"
  return e

section :: Parser String Expr -> Parser String Expr
section expr = do
  mop1 <- optionMaybe $ choice ops
  eatSpaces
  e <- optionMaybe $ base expr
  eatSpaces
  mop2 <- optionMaybe $ choice ops
  match mop1 e mop2
  where
  match (Just op) (Just e)  (Nothing) = return $ SectR op e
  match (Nothing) (Just e)  (Just op) = return $ SectL e op
  match (Nothing) (Just e)  (Nothing) = return e
  match (Just op) (Nothing) (Nothing) = return $ (App (show op) [])
  match _         _         _         = fail "Neither section nor expression!"
  ops =
    [ op (string "+" *> notFollowedBy (string "+")) Add
    , op (string "-" *> notFollowedBy num) Sub
    , op (string "*")     Mul
    , op (string "`div`") Div
    , op (string ":")     Cons
    , op (string "++")    Append
    , op (string "&&")    And
    , op (string "||")    Or
    ]

base :: Parser String Expr -> Parser String Expr
base expr =  (List <$> list expr)
         <|> (bracket $ section expr)
         <|> (Atom <$> atom)

termApp :: Parser String Expr -> Parser String Expr
termApp expr = try (app (base expr)) <|> base expr

op :: forall a. Parser String a -> Op -> Parser String Op
op opParser opConstructor = try $
  (eatSpaces *> opParser *> eatSpaces *> return opConstructor)

term7l :: Parser String Expr -> Parser String Expr
term7l expr = chainl1 (termApp expr) (mulP <|> divP)
  where
  mulP = Binary <$> op (string "*") Mul
  divP = Binary <$> op (string "`div`") Div

term6l :: Parser String Expr -> Parser String Expr
term6l expr = chainl1 (term7l expr) (addP <|> subP)
  where
  addP = Binary <$> op (string "+" *> notFollowedBy (string "+")) Add
  subP = Binary <$> op (string "-") Sub

term5r :: Parser String Expr -> Parser String Expr
term5r expr = chainr1 (term6l expr) (consP <|> appendP)
  where
  consP = Binary <$> op (string ":") Cons
  appendP = Binary <$> op (string "++") Append

term3r :: Parser String Expr -> Parser String Expr
term3r expr = chainr1 (term5r expr) (Binary <$> op (string "&&") And)

term2r :: Parser String Expr -> Parser String Expr
term2r expr = chainr1 (term3r expr) (Binary <$> op (string "||") Or)

expr :: Parser String Expr
expr = fix1 $ \expr -> term2r expr

---------------------------------------
-- Parsers for the 'Binding' type
---------------------------------------

lit :: Parser String Binding
lit = Lit <$> atom

listLit :: Parser String Binding -> Parser String Binding
listLit binding = ListLit <$> list binding

consLit :: Parser String Binding -> Parser String Binding
consLit binding = bracket recurse
  where
  recurse = fix1 $ \recurse -> try (cons recurse) <|> binding
  cons recurse = do
    b <- binding
    eatSpaces
    string ":"
    eatSpaces
    bs <- recurse
    return $ ConsLit b bs

binding :: Parser String Binding
binding = fix1 $ \binding -> lit <|> consLit binding <|> listLit binding


Chinese desc

Chinese desc

module KanColle.Expedition.Minimal where

import Prelude
import Data.Monoid
import Data.Array
import qualified Data.Array.Unsafe as AU
import Data.Foldable
import qualified Data.String as Str

import KanColle.SType

import KanColle.Expedition
import KanColle.Expedition.Base
import KanColle.Expedition.Cost
import KanColle.Expedition.Requirement
import KanColle.Util
import Data.Maybe

type ShipMaxCost =
  { fuel :: Int
  , ammo :: Int
  }

-- | minimal cost of an expedition, just for the purpose of estimation
-- | despite that we are trying to provide a possible ship composition
-- | that minimizes the cost, the suggestion might not actually be possible
-- | due to many factors (e.g. other running expeditions are using the same ship,
-- | or you have not yet obtained the ship)
newtype ECost = ECost
  { shipCost :: Array ShipMaxCost
  , fleet :: Fleet (note :: Maybe String)
  }

getECost :: ECost -> { shipCost :: Array ShipMaxCost
                     , fleet :: Fleet (note :: Maybe String)}
getECost (ECost ec) = ec

instance eCostSemigroup :: Semigroup ECost where
  append (ECost a) (ECost b) =
      ECost { shipCost: a.shipCost <> b.shipCost
            , fleet: a.fleet <> b.fleet }

instance eCostMonoid :: Monoid ECost where
  mempty = ECost { shipCost: mempty, fleet: mempty }

dummyShip :: SType -> Ship (note :: Maybe String)
dummyShip s =
    { ammo: 400, morale: 100
    , stype: s, level: 150
    , drumCount: 4
    , note: Nothing }

shipWithNote :: SType -> String -> Ship (note :: Maybe String)
shipWithNote s n = (dummyShip s) { note= Just n }

mkECost :: SType -> Int -> Int -> ECost
mkECost s f a = ECost
    { shipCost: [{ fuel: f, ammo: a }]
    , fleet: [dummyShip s]
    }

mkECostWithNote :: SType -> Int -> Int -> String -> ECost
mkECostWithNote s f a n = ECost
    { shipCost: [{ fuel: f, ammo: a }]
    , fleet: [shipWithNote s n]
    }

-- | minimal DD cost, achivable by taking any of Mutsuki class ships
ddCost :: Int -> ECost
ddCost n = times n mutsukiClass
  where
    mutsukiClass = mkECostWithNote DD 15 15 "睦月级(改/改二皆可)"

-- | minimal SS/SSV cost, achivable by taking
-- | Maruyu and I-168 (Kai) / I-58 / I-19 / I-8 / U-511 / Ro-500
ssCost :: Int -> ECost
ssCost n = case n of
    1 -> maruyu
    _ -> maruyu <> times (n-1) nonSSV
  where
    maruyu = mkECostWithNote SS 10 10 "马战神"
    nonSSV = mkECostWithNote SS 10 20 "非马战神SS"

-- | minimal CVL cost, achivable by taking
-- | Houshou / Shouhou class (without Kai).
-- | Input is expected to be within [1..3]
-- | as the minimal expedition
-- | never requires more than 3 CVLs at a time
cvlCost :: Int -> ECost
cvlCost n = case n of
    1 -> houshou
    _ -> houshou <> times (n-1) shouhou
  where
    houshou = mkECostWithNote CVL 25 25 "凤翔"
    shouhou = mkECostWithNote CVL 35 35 "祥凤级"

-- | minimal AV cost, input takes value [1..4]
avCost :: Int -> ECost
avCost n = if n <= 3
    then
      times n chitoseOrMizuho
    else
      -- since the input <= 4, this must be the branch where n == 4
      times 3 chitoseOrMizuho <> akitsushima
  where
    chitoseOrMizuho = mkECostWithNote AV 35 35 "千岁级/瑞穗"
    akitsushima = mkECostWithNote AV 50 10 "秋津洲"

-- | minimal BBV cost, input takes value [1..4]
-- | achivable by taking any non-Kai-Ni BBV
bbvCost :: Int -> ECost
bbvCost n = times n fusouOrIse
  where
    fusouOrIse = mkECostWithNote BBV 95 105 "扶桑级改/伊势级改"

-- | minimal CA cost, achivable by taking
-- | Furutaka class + Aoba class, takes [1..4]
caCost :: Int -> ECost
caCost n = times n (mkECostWithNote CA 35 50 "古鹰级/青叶级")

-- | minimal CL cost, achivable by taking
-- | Tenryuu class + non-Kai Kuma class
clCost :: Int -> ECost
clCost n = if n <= 2
    then times n tenryuu
    else times 2 tenryuu <> times (n-2) kuma
  where
    tenryuu = mkECostWithNote CL 25 20 "天龙级"
    kuma = mkECostWithNote CL 25 25 "球磨级"

-- | the sole submarine tender (AS) is Taigei
taigei :: ECost
taigei = mkECostWithNote AS 35 10 "大鲸"

-- | the sole training cruiser (CT) is Katori
katori :: ECost
katori = mkECostWithNote CT 35 20 "香取"

-- | fill in submarines to meet a ship number requirement
fillSS :: Int -> ECost -> ECost
fillSS n v@(ECost ec) = if l >= n
    then v
    else v <> ssCost (n-l)
  where
    l = length ec.fleet

getExpeditionMinCost :: Int -> ECost
getExpeditionMinCost v = case v of
    1 -> fillSS 2 mempty
    2 -> fillSS 4 mempty
    3 -> fillSS 3 mempty
    4 -> clCost 1 <> ddCost 2
    5 -> fillSS 4 (clCost 1 <> ddCost 2)
    6 -> fillSS 4 mempty
    7 -> fillSS 6 mempty
    8 -> fillSS 6 mempty

    9 -> fillSS 4 (clCost 1 <> ddCost 2)
    10 -> fillSS 3 (clCost 2)
    11 -> fillSS 4 (ddCost 2)
    12 -> fillSS 4 (ddCost 2)
    13 -> fillSS 6 (clCost 1 <> ddCost 4)
    14 -> fillSS 6 (clCost 1 <> ddCost 3)
    15 -> fillSS 6 (cvlCost 2 <> ddCost 2)
    16 -> fillSS 6 (clCost 1 <> ddCost 2)

    17 -> fillSS 6 (clCost 1 <> ddCost 3)
    18 -> fillSS 6 (cvlCost 3 <> ddCost 2)
    19 -> fillSS 6 (bbvCost 2 <> ddCost 2)
    20 -> ssCost 1 <> clCost 1
    21 -> clCost 1 <> ddCost 4
    22 -> fillSS 6 (caCost 1 <> clCost 1 <> ddCost 2)
    23 -> fillSS 6 (bbvCost 2 <> ddCost 2)
    24 -> fillSS 6 (clCost 1 <> ddCost 4)

    25 -> caCost 2 <> ddCost 2
    26 -> cvlCost 1 <> clCost 1 <> ddCost 2
    27 -> ssCost 2
    28 -> ssCost 3
    29 -> ssCost 3
    30 -> ssCost 4
    31 -> ssCost 4
    32 -> katori <> ddCost 2

    35 -> fillSS 6 (cvlCost 2 <> caCost 1 <> ddCost 1)
    36 -> fillSS 6 (avCost 2 <> clCost 1 <> ddCost 1)
    37 -> clCost 1 <> ddCost 5
    38 -> fillSS 6 (ddCost 5)
    39 -> taigei <> ssCost 4
    40 -> fillSS 6 (clCost 1 <> avCost 2 <> ddCost 2)

    _ -> mempty

pprFleetNotes :: Fleet (note :: Maybe String) -> String
pprFleetNotes xs = if null notes
    then "<N/A>"
    else
      let grouppedNotes = map formatNote (group notes)
          formatNote note = "{" <> AU.head note <> "}x" <> show (length note)
      in Str.joinWith ", " grouppedNotes
  where
    notes = mapMaybe (\x -> x.note) xs

-- | generate markdown string for pretty printing the minimal cost table
minimalCostMarkdownTable :: String
minimalCostMarkdownTable = header <> "\n" <> Str.joinWith "\n" rows
  where
    header = "Expedition Id | Fuel | Ammo | Minimal Cost Fleet Composition" <> "\n"
          <> " --- | --- | --- | ---"
    rows = map mkRow allExpeditionIds
    mkRow eId = Str.joinWith " | " [show eId, show fuelCosts, show ammoCosts, notes]
      where
        notes = pprFleetNotes minCost.fleet
        cost = getExpeditionCost eId
        minCost = getECost (getExpeditionMinCost eId)
        costVec = map (\sc -> calcCost cost sc) minCost.shipCost
        fuelCosts = sum (map (\x -> x.fuel) costVec)
        ammoCosts = sum (map (\x -> x.ammo) costVec)

module KanColle.Expedition.Minimal where

import Prelude
import Data.Monoid
import Data.Array
import qualified Data.Array.Unsafe as AU
import Data.Foldable
import qualified Data.String as Str

import KanColle.SType

import KanColle.Expedition
import KanColle.Expedition.Base
import KanColle.Expedition.Cost
import KanColle.Expedition.Requirement
import KanColle.Util
import Data.Maybe

type ShipMaxCost =
  { fuel :: Int
  , ammo :: Int
  }

-- | minimal cost of an expedition, just for the purpose of estimation
-- | despite that we are trying to provide a possible ship composition
-- | that minimizes the cost, the suggestion might not actually be possible
-- | due to many factors (e.g. other running expeditions are using the same ship,
-- | or you have not yet obtained the ship)
newtype ECost = ECost
  { shipCost :: Array ShipMaxCost
  , fleet :: Fleet (note :: Maybe String)
  }

getECost :: ECost -> { shipCost :: Array ShipMaxCost
                     , fleet :: Fleet (note :: Maybe String)}
getECost (ECost ec) = ec

instance eCostSemigroup :: Semigroup ECost where
  append (ECost a) (ECost b) =
      ECost { shipCost: a.shipCost <> b.shipCost
            , fleet: a.fleet <> b.fleet }

instance eCostMonoid :: Monoid ECost where
  mempty = ECost { shipCost: mempty, fleet: mempty }

dummyShip :: SType -> Ship (note :: Maybe String)
dummyShip s =
    { ammo: 400, morale: 100
    , stype: s, level: 150
    , drumCount: 4
    , note: Nothing }

shipWithNote :: SType -> String -> Ship (note :: Maybe String)
shipWithNote s n = (dummyShip s) { note= Just n }

mkECost :: SType -> Int -> Int -> ECost
mkECost s f a = ECost
    { shipCost: [{ fuel: f, ammo: a }]
    , fleet: [dummyShip s]
    }

mkECostWithNote :: SType -> Int -> Int -> String -> ECost
mkECostWithNote s f a n = ECost
    { shipCost: [{ fuel: f, ammo: a }]
    , fleet: [shipWithNote s n]
    }

-- | minimal DD cost, achivable by taking any of Mutsuki class ships
ddCost :: Int -> ECost
ddCost n = times n mutsukiClass
  where
    mutsukiClass = mkECostWithNote DD 15 15 "Mutsuki class (Kai / Kai 2 are ok)"

-- | minimal SS/SSV cost, achivable by taking
-- | Maruyu and I-168 (Kai) / I-58 / I-19 / I-8 / U-511 / Ro-500
ssCost :: Int -> ECost
ssCost n = case n of
    1 -> maruyu
    _ -> maruyu <> times (n-1) nonSSV
  where
    maruyu = mkECostWithNote SS 10 10 "Maruyu"
    nonSSV = mkECostWithNote SS 10 20 "any non-Maruyu SS"

-- | minimal CVL cost, achivable by taking
-- | Houshou / Shouhou class (without Kai).
-- | Input is expected to be within [1..3]
-- | as the minimal expedition
-- | never requires more than 3 CVLs at a time
cvlCost :: Int -> ECost
cvlCost n = case n of
    1 -> houshou
    _ -> houshou <> times (n-1) shouhou
  where
    houshou = mkECostWithNote CVL 25 25 "Houshou"
    shouhou = mkECostWithNote CVL 35 35 "Shouhou class"

-- | minimal AV cost, input takes value [1..4]
avCost :: Int -> ECost
avCost n = if n <= 3
    then
      times n chitoseOrMizuho
    else
      -- since the input <= 4, this must be the branch where n == 4
      times 3 chitoseOrMizuho <> akitsushima
  where
    chitoseOrMizuho = mkECostWithNote AV 35 35 "Chitose class / Mizuho"
    akitsushima = mkECostWithNote AV 50 10 "Akitsushima"

-- | minimal BBV cost, input takes value [1..4]
-- | achivable by taking any non-Kai-Ni BBV
bbvCost :: Int -> ECost
bbvCost n = times n fusouOrIse
  where
    fusouOrIse = mkECostWithNote BBV 95 105 "Fushou class Kai / Ise class Kai"

-- | minimal CA cost, achivable by taking
-- | Furutaka class + Aoba class, takes [1..4]
caCost :: Int -> ECost
caCost n = times n (mkECostWithNote CA 35 50 "Furutaka class / Aoba class")

-- | minimal CL cost, achivable by taking
-- | Tenryuu class + non-Kai Kuma class
clCost :: Int -> ECost
clCost n = if n <= 2
    then times n tenryuu
    else times 2 tenryuu <> times (n-2) kuma
  where
    tenryuu = mkECostWithNote CL 25 20 "Tenryuu class"
    kuma = mkECostWithNote CL 25 25 "Kuma class"

-- | the sole submarine tender (AS) is Taigei
taigei :: ECost
taigei = mkECostWithNote AS 35 10 "Taigei"

-- | the sole training cruiser (CT) is Katori
katori :: ECost
katori = mkECostWithNote CT 35 20 "Katori"

-- | fill in submarines to meet a ship number requirement
fillSS :: Int -> ECost -> ECost
fillSS n v@(ECost ec) = if l >= n
    then v
    else v <> ssCost (n-l)
  where
    l = length ec.fleet

getExpeditionMinCost :: Int -> ECost
getExpeditionMinCost v = case v of
    1 -> fillSS 2 mempty
    2 -> fillSS 4 mempty
    3 -> fillSS 3 mempty
    4 -> clCost 1 <> ddCost 2
    5 -> fillSS 4 (clCost 1 <> ddCost 2)
    6 -> fillSS 4 mempty
    7 -> fillSS 6 mempty
    8 -> fillSS 6 mempty

    9 -> fillSS 4 (clCost 1 <> ddCost 2)
    10 -> fillSS 3 (clCost 2)
    11 -> fillSS 4 (ddCost 2)
    12 -> fillSS 4 (ddCost 2)
    13 -> fillSS 6 (clCost 1 <> ddCost 4)
    14 -> fillSS 6 (clCost 1 <> ddCost 3)
    15 -> fillSS 6 (cvlCost 2 <> ddCost 2)
    16 -> fillSS 6 (clCost 1 <> ddCost 2)

    17 -> fillSS 6 (clCost 1 <> ddCost 3)
    18 -> fillSS 6 (cvlCost 3 <> ddCost 2)
    19 -> fillSS 6 (bbvCost 2 <> ddCost 2)
    20 -> ssCost 1 <> clCost 1
    21 -> clCost 1 <> ddCost 4
    22 -> fillSS 6 (caCost 1 <> clCost 1 <> ddCost 2)
    23 -> fillSS 6 (bbvCost 2 <> ddCost 2)
    24 -> fillSS 6 (clCost 1 <> ddCost 4)

    25 -> caCost 2 <> ddCost 2
    26 -> cvlCost 1 <> clCost 1 <> ddCost 2
    27 -> ssCost 2
    28 -> ssCost 3
    29 -> ssCost 3
    30 -> ssCost 4
    31 -> ssCost 4
    32 -> katori <> ddCost 2

    35 -> fillSS 6 (cvlCost 2 <> caCost 1 <> ddCost 1)
    36 -> fillSS 6 (avCost 2 <> clCost 1 <> ddCost 1)
    37 -> clCost 1 <> ddCost 5
    38 -> fillSS 6 (ddCost 5)
    39 -> taigei <> ssCost 4
    40 -> fillSS 6 (clCost 1 <> avCost 2 <> ddCost 2)

    _ -> mempty

pprFleetNotes :: Fleet (note :: Maybe String) -> String
pprFleetNotes xs = if null notes
    then "<N/A>"
    else
      let grouppedNotes = map formatNote (group notes)
          formatNote note = "{" <> AU.head note <> "}x" <> show (length note)
      in Str.joinWith ", " grouppedNotes
  where
    notes = mapMaybe (\x -> x.note) xs

-- | generate markdown string for pretty printing the minimal cost table
minimalCostMarkdownTable :: String
minimalCostMarkdownTable = header <> "\n" <> Str.joinWith "\n" rows
  where
    header = "Expedition Id | Fuel | Ammo | Minimal Cost Fleet Composition" <> "\n"
          <> " --- | --- | --- | ---"
    rows = map mkRow allExpeditionIds
    mkRow eId = Str.joinWith " | " [show eId, show fuelCosts, show ammoCosts, notes]
      where
        notes = pprFleetNotes minCost.fleet
        cost = getExpeditionCost eId
        minCost = getECost (getExpeditionMinCost eId)
        costVec = map (\sc -> calcCost cost sc) minCost.shipCost
        fuelCosts = sum (map (\x -> x.fuel) costVec)
        ammoCosts = sum (map (\x -> x.ammo) costVec)


resolve ImplicitImport

resolve ImplicitImport

{-
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.ChartOptions.Common where

import SlamData.Prelude (Maybe(Just, Nothing), Tuple(Tuple), ($), (∘), fromMaybe, foldl, (<$>), map, (==), lmap, pure, zero, join, (<>), maybe, (>>=), snd, fst, flip, (>=>), bind, show)

import Data.Argonaut (JCursor)
import Data.Array (catMaybes, cons, (!!))
import Data.Array as A
import Data.Int (toNumber)
import Data.Lens (view)
import Data.List (List(..), replicate, length)
import Data.List as L
import Data.Map (Map)
import Data.Map as M

import Color (Color, toRGBA, fromHexString, hsla, toHSLA)

import ECharts (AxisRec, AxisLabel(..), TextStyle(..), textStyleDefault, axisLabelDefault)

import SlamData.Form.Select (_value)
import SlamData.Workspace.Card.Chart.Aggregation (Aggregation(..), runAggregation)
import SlamData.Workspace.Card.Chart.Axis as Ax
import SlamData.Workspace.Card.Chart.ChartConfiguration (ChartConfiguration, JSelect)
import SlamData.Workspace.Card.Chart.Semantics (Semantics, printSemantics, semanticsToNumber)

type ChartAxises =
  { dimensions ∷ Array (List (Maybe String))
  , series ∷ Array (List (Maybe String))
  , measures ∷ Array (List (Maybe Number))
  , aggregations ∷ Array (Maybe Aggregation)
  }

colors ∷ Array String
colors =
  [ "#93A9A6"
  , "#CDA71F"
  , "#EB6F76"
  , "#66B35B"
  , "#BD97E2"
  , "#5B5925"
  , "#884A6F"
  , "#51B3F6"
  , "#CCA067"
  , "#398465"
  , "#3C607A"
  , "#81463C"
  , "#B65F33"
  , "#9AAE31"
  , "#CE8B9E"
  , "#6C6356"
  , "#95A779"
  , "#44AECB"
  , "#E987C2"
  , "#8A7EA0"
  , "#3D6C2F"
  , "#40B994"
  , "#87984A"
  , "#C1A088"
  , "#9B6E2D"
  , "#428C8D"
  , "#B8766A"
  , "#EB8666"
  , "#DF883E"
  , "#BB6273"
  , "#C994BF"
  , "#929DE0"
  , "#7BA5CB"
  , "#AE9093"
  , "#66557B"
  , "#936370"
  , "#3C6D64"
  , "#84693F"
  , "#C19744"
  , "#E77AA1"
  , "#5D555F"
  , "#4078A2"
  , "#3FAFAF"
  , "#698B99"
  , "#486A4C"
  , "#7EA48B"
  , "#B57E57"
  , "#8C72AA"
  , "#609050"
  , "#56B379"
  , "#489F8B"
  , "#714D4A"
  , "#9A8867"
  , "#93B66B"
  , "#7DA93F"
  , "#877424"
  , "#C75D56"
  , "#B774AC"
  , "#7B7A3E"
  , "#73581C"
  , "#398EA3"
  , "#964734"
  , "#DF8D89"
  , "#AF97CC"
  , "#96951F"
  , "#A37791"
  , "#7C4D2E"
  , "#78865F"
  , "#216B74"
  , "#935524"
  , "#6FAFB6"
  , "#75AB76"
  , "#A48B50"
  , "#D28DD0"
  , "#BE9AAF"
  , "#AD8D22"
  , "#D89576"
  , "#964860"
  , "#9B9A61"
  , "#4DAADB"
  , "#A9628D"
  , "#98943B"
  , "#486366"
  , "#6D7E2B"
  , "#CF9A2F"
  , "#827A8B"
  , "#876A69"
  , "#495F23"
  , "#677F45"
  , "#805845"
  , "#A2544D"
  , "#8C5157"
  , "#6B6C9E"
  , "#236443"
  , "#919B82"
  , "#CC8E55"
  , "#3E8555"
  , "#A08A7A"
  , "#767870"
  , "#6D9643"
  , "#87658F"
  , "#3BB069"
  , "#6A5D42"
  , "#586249"
  , "#1F7769"
  , "#6DAF8E"
  , "#8FA7BE"
  , "#B7A82C"
  , "#A09DA0"
  , "#7D8AA6"
  , "#78A3E0"
  , "#719186"
  , "#765771"
  , "#A37EA7"
  , "#8E8CBC"
  , "#A76840"
  , "#49934B"
  , "#A27C62"
  , "#3DA27B"
  , "#A9AC53"
  , "#6685B4"
  , "#5F728A"
  , "#CB6B4A"
  , "#9F8DD3"
  , "#B7A66E"
  , "#A998B3"
  , "#85A362"
  , "#595146"
  ]

getShadeColor ∷ String → Number → Color
getShadeColor hex alpha =
  setAlpha
    (lightenTo
      (fromMaybe
        (hsla 0.0 0.0 0.0 1.0)
        (fromHexString hex))
      0.95)
    alpha
  where
  lightenTo :: Color → Number → Color
  lightenTo col l' = hsla c.h c.s l' c.a
    where
    c = toHSLA col

  setAlpha :: Color → Number → Color
  setAlpha col a' = hsla c.h c.s c.l a'
    where
    c = toHSLA col

toRGBAString ∷ Color → String
toRGBAString col = "rgba(" <> show c.r <> ", "
                   <> show c.g <> ", "
                   <> show c.b <> ", "
                   <> show c.a <> ")"
  where c = toRGBA col

buildChartAxises ∷ M.Map JCursor Ax.Axis → ChartConfiguration → ChartAxises
buildChartAxises axisMap conf =
  { dimensions: dimensions
  , series: series
  , measures: measures
  , aggregations: aggregations
  }
  where
  dimensions ∷ Array (List (Maybe String))
  dimensions = map (map (map printSemantics)) $ getAxises conf.dimensions

  series ∷ Array (List (Maybe String))
  series = map (map (map printSemantics)) $ getAxises conf.series

  measures ∷ Array (List (Maybe Number))
  measures = map (map (flip bind semanticsToNumber)) $ getAxises conf.measures

  getAxises ∷ Array JSelect → Array (List (Maybe Semantics))
  getAxises sels =
    map Ax.runAxis $ catMaybes $ map (view _value >=> flip M.lookup axisMap) sels

  aggregations ∷ Array (Maybe Aggregation)
  aggregations = map (view _value) conf.aggregations

type Key = Tuple String SeriesKey
type SeriesKey = Maybe (Tuple String (Maybe String))

keyCategory ∷ Key → String
keyCategory (Tuple cat _) = cat

keyMbSeries1 ∷ Key → Maybe String
keyMbSeries1 (Tuple _ mbT) = mbT >>= (pure ∘ fst)

keyMbSeries2 ∷ Key → Maybe String
keyMbSeries2 (Tuple _ mbT) = mbT >>= snd

mkKey ∷ String → Maybe String → Maybe String → Key
mkKey cat f s =
  Tuple cat (f >>= \f → pure $ Tuple f s)

keyName ∷ Key → String
keyName k =
  (fromMaybe "" (keyMbSeries1 k)) <> (maybe "" (":" <> _) (keyMbSeries2 k))

type LabeledPoints = M.Map Key (Array Number)
type PieBarData = M.Map Key Number

pieBarData ∷ ChartAxises → PieBarData
pieBarData axises =
  aggregate agg $ pieBarRawData categories firstSeries secondSeries values M.empty
  where
  agg ∷ Aggregation
  agg = fromMaybe Sum $ join (axises.aggregations !! 0)

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

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

  firstSeries ∷ List (Maybe String)
  firstSeries = fromMaybe nothings $ axises.series !! 1

  secondSeries ∷ List (Maybe String)
  secondSeries = fromMaybe nothings $ axises.series !! 2

  nothings ∷ forall a. List (Maybe a)
  nothings = replicate (length values) Nothing

pieBarRawData
  ∷ List (Maybe String) → List (Maybe String) → List (Maybe String)
  → List (Maybe Number) → LabeledPoints → LabeledPoints
pieBarRawData Nil _ _ _ acc = acc
pieBarRawData _ Nil _ _ acc = acc
pieBarRawData _ _ Nil _ acc = acc
pieBarRawData _ _ _ Nil acc = acc
pieBarRawData (Cons Nothing _) _ _ _ acc = acc
pieBarRawData (Cons (Just category) cs) (Cons mbFirstSerie fss)
  (Cons mbSecondSerie sss) (Cons mbValue vs) acc =
  pieBarRawData cs fss sss vs $ M.alter (alterFn val) key acc
  where
  key ∷ Key
  key = mkKey category mbFirstSerie mbSecondSerie

  val ∷ Number
  val = fromMaybe zero mbValue

  alterFn ∷ Number → Maybe (Array Number) → Maybe (Array Number)
  alterFn v vals = pure $ cons v $ fromMaybe [] vals

aggregate ∷ Aggregation → LabeledPoints → PieBarData
aggregate agg acc = map (runAggregation agg) acc

-- Having array of pairs Key → Number and array of categories (String)
-- 1. drop any pair theat has no category from second argument
-- 2. group by category
-- 3. apply first argument to groupped maps
-- 4. make final map from category to array of values
commonNameMap
  ∷ (Array (Map String Number) → Array (Map String Number)) → Array String
  → Array (Tuple Key Number) → Map String (Array Number)
commonNameMap fn catVals = mapByCategories ∘ fn ∘ groupByCategories
  where
  groupByCategories ∷ Array (Tuple Key Number) → Array (Map String Number)
  groupByCategories arr = map (markAndFilterCategory arr) catVals

  markAndFilterCategory
    ∷ Array (Tuple Key Number) → String → Map String Number
  markAndFilterCategory arr cat =
      M.fromList
    $ L.toList
    $ map (lmap keyName)
    $ A.filter (\(Tuple k _) → keyCategory k == cat)
    $ arr

  mapByCategories
    ∷ Array (Map String Number) → Map String (Array Number)
  mapByCategories arr =
    map A.reverse $ foldl foldFn M.empty (L.fromList ∘ M.toList <$> arr)

  foldFn
    ∷ Map String (Array Number)
    → Array (Tuple String Number)
    → Map String (Array Number)
  foldFn m tpls = foldl (\m (Tuple k n) → M.alter (alterNamed n) k m) m tpls

  alterNamed ∷ Number → Maybe (Array Number) → Maybe (Array Number)
  alterNamed n ns = Just $ A.cons n $ fromMaybe [] ns

mixAxisLabelAngleAndFontSize ∷ Int → Int → AxisRec → AxisRec
mixAxisLabelAngleAndFontSize angle size r =
  r { axisLabel = Just $ AxisLabel axisLabelDefault
      { rotate = Just $ toNumber angle
      , textStyle = Just $ TextStyle textStyleDefault
        { fontSize = Just $ toNumber size
        , fontFamily = Just "Ubuntu sans"
        }
      }
    }

{-
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.ChartOptions.Common where

import SlamData.Prelude

import Data.Argonaut (JCursor)
import Data.Array (catMaybes, cons, (!!))
import Data.Array as A
import Data.Int (toNumber)
import Data.Lens (view)
import Data.List (List(..), replicate, length)
import Data.List as L
import Data.Map (Map)
import Data.Map as M

import Color

import ECharts (AxisRec, AxisLabel(..), TextStyle(..), textStyleDefault, axisLabelDefault)

import SlamData.Form.Select (_value)
import SlamData.Workspace.Card.Chart.Aggregation (Aggregation(..), runAggregation)
import SlamData.Workspace.Card.Chart.Axis as Ax
import SlamData.Workspace.Card.Chart.ChartConfiguration (ChartConfiguration, JSelect)
import SlamData.Workspace.Card.Chart.Semantics (Semantics, printSemantics, semanticsToNumber)

type ChartAxises =
  { dimensions ∷ Array (List (Maybe String))
  , series ∷ Array (List (Maybe String))
  , measures ∷ Array (List (Maybe Number))
  , aggregations ∷ Array (Maybe Aggregation)
  }

colors ∷ Array String
colors =
  [ "#93A9A6"
  , "#CDA71F"
  , "#EB6F76"
  , "#66B35B"
  , "#BD97E2"
  , "#5B5925"
  , "#884A6F"
  , "#51B3F6"
  , "#CCA067"
  , "#398465"
  , "#3C607A"
  , "#81463C"
  , "#B65F33"
  , "#9AAE31"
  , "#CE8B9E"
  , "#6C6356"
  , "#95A779"
  , "#44AECB"
  , "#E987C2"
  , "#8A7EA0"
  , "#3D6C2F"
  , "#40B994"
  , "#87984A"
  , "#C1A088"
  , "#9B6E2D"
  , "#428C8D"
  , "#B8766A"
  , "#EB8666"
  , "#DF883E"
  , "#BB6273"
  , "#C994BF"
  , "#929DE0"
  , "#7BA5CB"
  , "#AE9093"
  , "#66557B"
  , "#936370"
  , "#3C6D64"
  , "#84693F"
  , "#C19744"
  , "#E77AA1"
  , "#5D555F"
  , "#4078A2"
  , "#3FAFAF"
  , "#698B99"
  , "#486A4C"
  , "#7EA48B"
  , "#B57E57"
  , "#8C72AA"
  , "#609050"
  , "#56B379"
  , "#489F8B"
  , "#714D4A"
  , "#9A8867"
  , "#93B66B"
  , "#7DA93F"
  , "#877424"
  , "#C75D56"
  , "#B774AC"
  , "#7B7A3E"
  , "#73581C"
  , "#398EA3"
  , "#964734"
  , "#DF8D89"
  , "#AF97CC"
  , "#96951F"
  , "#A37791"
  , "#7C4D2E"
  , "#78865F"
  , "#216B74"
  , "#935524"
  , "#6FAFB6"
  , "#75AB76"
  , "#A48B50"
  , "#D28DD0"
  , "#BE9AAF"
  , "#AD8D22"
  , "#D89576"
  , "#964860"
  , "#9B9A61"
  , "#4DAADB"
  , "#A9628D"
  , "#98943B"
  , "#486366"
  , "#6D7E2B"
  , "#CF9A2F"
  , "#827A8B"
  , "#876A69"
  , "#495F23"
  , "#677F45"
  , "#805845"
  , "#A2544D"
  , "#8C5157"
  , "#6B6C9E"
  , "#236443"
  , "#919B82"
  , "#CC8E55"
  , "#3E8555"
  , "#A08A7A"
  , "#767870"
  , "#6D9643"
  , "#87658F"
  , "#3BB069"
  , "#6A5D42"
  , "#586249"
  , "#1F7769"
  , "#6DAF8E"
  , "#8FA7BE"
  , "#B7A82C"
  , "#A09DA0"
  , "#7D8AA6"
  , "#78A3E0"
  , "#719186"
  , "#765771"
  , "#A37EA7"
  , "#8E8CBC"
  , "#A76840"
  , "#49934B"
  , "#A27C62"
  , "#3DA27B"
  , "#A9AC53"
  , "#6685B4"
  , "#5F728A"
  , "#CB6B4A"
  , "#9F8DD3"
  , "#B7A66E"
  , "#A998B3"
  , "#85A362"
  , "#595146"
  ]

getShadeColor ∷ String → Number → Color
getShadeColor hex alpha =
  setAlpha
    (lightenTo
      (fromMaybe
        (hsla 0.0 0.0 0.0 1.0)
        (fromHexString hex))
      0.95)
    alpha
  where
  lightenTo :: Color → Number → Color
  lightenTo col l' = hsla c.h c.s l' c.a
    where
    c = toHSLA col

  setAlpha :: Color → Number → Color
  setAlpha col a' = hsla c.h c.s c.l a'
    where
    c = toHSLA col

toRGBAString ∷ Color → String
toRGBAString col = "rgba(" <> show c.r <> ", "
                   <> show c.g <> ", "
                   <> show c.b <> ", "
                   <> show c.a <> ")"
  where c = toRGBA col

buildChartAxises ∷ M.Map JCursor Ax.Axis → ChartConfiguration → ChartAxises
buildChartAxises axisMap conf =
  { dimensions: dimensions
  , series: series
  , measures: measures
  , aggregations: aggregations
  }
  where
  dimensions ∷ Array (List (Maybe String))
  dimensions = map (map (map printSemantics)) $ getAxises conf.dimensions

  series ∷ Array (List (Maybe String))
  series = map (map (map printSemantics)) $ getAxises conf.series

  measures ∷ Array (List (Maybe Number))
  measures = map (map (flip bind semanticsToNumber)) $ getAxises conf.measures

  getAxises ∷ Array JSelect → Array (List (Maybe Semantics))
  getAxises sels =
    map Ax.runAxis $ catMaybes $ map (view _value >=> flip M.lookup axisMap) sels

  aggregations ∷ Array (Maybe Aggregation)
  aggregations = map (view _value) conf.aggregations

type Key = Tuple String SeriesKey
type SeriesKey = Maybe (Tuple String (Maybe String))

keyCategory ∷ Key → String
keyCategory (Tuple cat _) = cat

keyMbSeries1 ∷ Key → Maybe String
keyMbSeries1 (Tuple _ mbT) = mbT >>= (pure ∘ fst)

keyMbSeries2 ∷ Key → Maybe String
keyMbSeries2 (Tuple _ mbT) = mbT >>= snd

mkKey ∷ String → Maybe String → Maybe String → Key
mkKey cat f s =
  Tuple cat (f >>= \f → pure $ Tuple f s)

keyName ∷ Key → String
keyName k =
  (fromMaybe "" (keyMbSeries1 k)) <> (maybe "" (":" <> _) (keyMbSeries2 k))

type LabeledPoints = M.Map Key (Array Number)
type PieBarData = M.Map Key Number

pieBarData ∷ ChartAxises → PieBarData
pieBarData axises =
  aggregate agg $ pieBarRawData categories firstSeries secondSeries values M.empty
  where
  agg ∷ Aggregation
  agg = fromMaybe Sum $ join (axises.aggregations !! 0)

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

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

  firstSeries ∷ List (Maybe String)
  firstSeries = fromMaybe nothings $ axises.series !! 1

  secondSeries ∷ List (Maybe String)
  secondSeries = fromMaybe nothings $ axises.series !! 2

  nothings ∷ forall a. List (Maybe a)
  nothings = replicate (length values) Nothing

pieBarRawData
  ∷ List (Maybe String) → List (Maybe String) → List (Maybe String)
  → List (Maybe Number) → LabeledPoints → LabeledPoints
pieBarRawData Nil _ _ _ acc = acc
pieBarRawData _ Nil _ _ acc = acc
pieBarRawData _ _ Nil _ acc = acc
pieBarRawData _ _ _ Nil acc = acc
pieBarRawData (Cons Nothing _) _ _ _ acc = acc
pieBarRawData (Cons (Just category) cs) (Cons mbFirstSerie fss)
  (Cons mbSecondSerie sss) (Cons mbValue vs) acc =
  pieBarRawData cs fss sss vs $ M.alter (alterFn val) key acc
  where
  key ∷ Key
  key = mkKey category mbFirstSerie mbSecondSerie

  val ∷ Number
  val = fromMaybe zero mbValue

  alterFn ∷ Number → Maybe (Array Number) → Maybe (Array Number)
  alterFn v vals = pure $ cons v $ fromMaybe [] vals

aggregate ∷ Aggregation → LabeledPoints → PieBarData
aggregate agg acc = map (runAggregation agg) acc

-- Having array of pairs Key → Number and array of categories (String)
-- 1. drop any pair theat has no category from second argument
-- 2. group by category
-- 3. apply first argument to groupped maps
-- 4. make final map from category to array of values
commonNameMap
  ∷ (Array (Map String Number) → Array (Map String Number)) → Array String
  → Array (Tuple Key Number) → Map String (Array Number)
commonNameMap fn catVals = mapByCategories ∘ fn ∘ groupByCategories
  where
  groupByCategories ∷ Array (Tuple Key Number) → Array (Map String Number)
  groupByCategories arr = map (markAndFilterCategory arr) catVals

  markAndFilterCategory
    ∷ Array (Tuple Key Number) → String → Map String Number
  markAndFilterCategory arr cat =
      M.fromList
    $ L.toList
    $ map (lmap keyName)
    $ A.filter (\(Tuple k _) → keyCategory k == cat)
    $ arr

  mapByCategories
    ∷ Array (Map String Number) → Map String (Array Number)
  mapByCategories arr =
    map A.reverse $ foldl foldFn M.empty (L.fromList ∘ M.toList <$> arr)

  foldFn
    ∷ Map String (Array Number)
    → Array (Tuple String Number)
    → Map String (Array Number)
  foldFn m tpls = foldl (\m (Tuple k n) → M.alter (alterNamed n) k m) m tpls

  alterNamed ∷ Number → Maybe (Array Number) → Maybe (Array Number)
  alterNamed n ns = Just $ A.cons n $ fromMaybe [] ns

mixAxisLabelAngleAndFontSize ∷ Int → Int → AxisRec → AxisRec
mixAxisLabelAngleAndFontSize angle size r =
  r { axisLabel = Just $ AxisLabel axisLabelDefault
      { rotate = Just $ toNumber angle
      , textStyle = Just $ TextStyle textStyleDefault
        { fontSize = Just $ toNumber size
        , fontFamily = Just "Ubuntu sans"
        }
      }
    }


heatmap triggerItem

heatmap triggerItem

{-
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.Setups.Chart.Heatmap.Eval
  ( eval
  , module SlamData.Workspace.Card.Setups.Chart.Heatmap.Model
  ) where

import SlamData.Prelude

import Color as C

import Data.Argonaut (Json, decodeJson, (.?))
import Data.Array as A
import Data.Foreign as Frn
import Data.Lens ((^?))
import Data.List as L
import Data.Map as M
import Data.Int as Int
import Data.Set as Set

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.CardType.ChartType (ChartType(Heatmap))
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Setups.Axis as Ax
import SlamData.Workspace.Card.Setups.Chart.ColorScheme (colors, getColorScheme)
import SlamData.Workspace.Card.Setups.Chart.Common as SCC
import SlamData.Workspace.Card.Setups.Chart.Common.Positioning as BCP
import SlamData.Workspace.Card.Setups.Chart.Common.Tooltip as CCT
import SlamData.Workspace.Card.Setups.Chart.Heatmap.Model (Model, ModelR)
import SlamData.Workspace.Card.Setups.Common.Eval (type (>>))
import SlamData.Workspace.Card.Setups.Common.Eval as BCE
import SlamData.Workspace.Card.Setups.Dimension as D
import SlamData.Workspace.Card.Setups.Semantics as Sem

import SqlSquare as Sql

import Utils.Foldable (enumeratedFor_)

eval ∷ ∀ m. BCE.ChartSetupEval ModelR m
eval = BCE.chartSetupEval (SCC.buildBasicSql buildProjections buildGroupBy) buildPort

type HeatmapSeries =
  { x ∷ Maybe Number
  , y ∷ Maybe Number
  , w ∷ Maybe Number
  , h ∷ Maybe Number
  , name ∷ Maybe String
  , fontSize ∷ Maybe Int
  , items ∷ (String × String) >> Number
  }

type Item =
  { abscissa ∷ String
  , ordinate ∷ String
  , measure ∷ Number
  , series ∷ Maybe String
  }

decodeItem ∷ Json → Either String Item
decodeItem = decodeJson >=> \obj → do
  abscissa ← CCT.formatForeign ∘ jsonToForeign <$> obj .? "abscissa"
  ordinate ← CCT.formatForeign ∘ jsonToForeign <$> obj .? "ordinate"
  measure ← Sem.requiredNumber zero <$> obj .? "measure"
  series ← Sem.maybeString <$> obj .? "series"
  pure { abscissa, ordinate, measure, series }
  where
  jsonToForeign ∷ Json → Frn.Foreign
  jsonToForeign = Frn.toForeign

buildProjections ∷ ModelR → L.List (Sql.Projection Sql.Sql)
buildProjections r = L.fromFoldable
  [ r.abscissa # SCC.jcursorPrj # Sql.as "abscissa"
  , r.ordinate # SCC.jcursorPrj # Sql.as "ordinate"
  , r.value # SCC.jcursorPrj # Sql.as "measure" # SCC.applyTransform r.value
  , r.series # maybe SCC.nullPrj SCC.jcursorPrj # Sql.as "series"
  ]

buildGroupBy ∷ ModelR → Maybe (Sql.GroupBy Sql.Sql)
buildGroupBy r =
  SCC.groupBy $ L.fromFoldable $ A.catMaybes
    [ r.series <#> SCC.jcursorSql
    , Just r.abscissa <#> SCC.jcursorSql
    , Just r.ordinate <#> SCC.jcursorSql
    ]

buildPort ∷ ModelR → Ax.Axes → Array Json → Port.Port
buildPort m axes jarr =
  Port.ChartInstructions
    { options: buildOptions axes m $ buildData m jarr
    , chartType: Heatmap
    }

buildData ∷ ModelR → Array Json → Array HeatmapSeries
buildData r =
  BCP.adjustRectangularPositions
  ∘ series
  ∘ foldMap (foldMap A.singleton ∘ decodeItem)

  where
  series ∷ Array Item → Array HeatmapSeries
  series =
    BCE.groupOn _.series
      >>> map \(name × items) →
            { name
            , x: Nothing
            , y: Nothing
            , w: Nothing
            , h: Nothing
            , fontSize: Nothing
            , items: M.fromFoldable $ toPoint <$> items
            }

  toPoint ∷ Item → (String × String) × Number
  toPoint item = (item.abscissa × item.ordinate) × item.measure

buildOptions ∷ Ax.Axes → ModelR → Array HeatmapSeries → DSL OptionI
buildOptions axes r heatmapData = do
  E.tooltip do
    E.triggerItem
    E.textStyle do
      E.fontFamily "Ubuntu, sans"
      E.fontSize 12
    E.axisPointer do
      E.crossAxisPointer
      E.crossStyle do
        E.color $ C.rgba 170 170 170 0.6
        E.widthNum 0.2
        E.solidLine
    E.formatterItem \item →
      CCT.tableRows
        [ D.jcursorLabel r.abscissa × CCT.formatAssocProp "abscissa" item
        , D.jcursorLabel r.ordinate × CCT.formatAssocProp "ordinate" item
        , D.jcursorLabel r.value × CCT.formatAssocProp "value" item
        ]

  E.animationEnabled false

  BCP.rectangularTitles heatmapData
    $ maybe "" D.jcursorLabel r.series

  BCP.rectangularGrids heatmapData

  E.xAxes xAxes

  E.yAxes yAxes

  E.colors colors

  E.visualMap $ E.continuous do
    E.min r.minValue
    E.max r.maxValue
    E.calculable true
    E.orient ET.Horizontal
    E.itemWidth 15.0
    E.leftCenter
    E.bottom $ ET.Percent zero
    E.padding zero
    E.inRange $ E.colors
      if r.isColorSchemeReversed
        then A.reverse $ getColorScheme r.colorScheme
        else getColorScheme r.colorScheme

  E.series series

  where
  xValues ∷ HeatmapSeries → Array String
  xValues serie =
    sortX $ A.fromFoldable $ Set.fromFoldable $ map fst $ M.keys serie.items

  yValues ∷ HeatmapSeries → Array String
  yValues serie =
    sortY $ A.fromFoldable $ Set.fromFoldable $ map snd $ M.keys serie.items

  series ∷ ∀ i. DSL (heatMap ∷ ETP.I|i)
  series = enumeratedFor_ heatmapData \(ix × serie) → E.heatMap do
    for_ serie.name E.name
    E.xAxisIndex ix
    E.yAxisIndex ix

    E.buildItems
      $ enumeratedFor_ (xValues serie)  \(xIx × abscissa) →
          enumeratedFor_ (yValues serie) \(yIx × ordinate) →
            for_ (M.lookup (abscissa × ordinate) serie.items) \value → E.addItem do
              BCE.assoc { abscissa, ordinate, value }
              E.buildValues do
                E.addValue $ Int.toNumber xIx
                E.addValue $ Int.toNumber yIx
                E.addValue value

  mkAxis ∷ ∀ i. Int → DSL (ETP.AxisI (gridIndex ∷ ETP.I|i))
  mkAxis ix = do
    E.axisType ET.Category
    E.gridIndex ix
    E.axisLabel do
      E.textStyle do
        E.fontFamily "Ubuntu, sans"
    E.axisLine $ E.lineStyle do
      E.width 1
    E.splitLine $ E.lineStyle do
      E.width 1
    E.splitArea E.hidden

  abscissaAxisType =
    fromMaybe Ax.Category
    $ Ax.axisType <$> (r.abscissa ^? D._value ∘ D._projection) <*> pure axes
  ordinateAxisType =
    fromMaybe Ax.Category
    $ Ax.axisType <$> (r.ordinate ^? D._value ∘ D._projection) <*> pure axes

  abscissaAxisCfg = Ax.axisConfiguration abscissaAxisType
  ordinateAxisCfg = Ax.axisConfiguration ordinateAxisType

  xAxes ∷ ∀ i. DSL (addXAxis ∷ ETP.I|i)
  xAxes = enumeratedFor_ heatmapData \(ix × serie) → E.addXAxis do
    mkAxis ix
    E.items $ map ET.strItem $ xValues serie

  yAxes ∷ ∀ i. DSL (addYAxis ∷ ETP.I|i)
  yAxes = enumeratedFor_ heatmapData \(ix × serie) → E.addYAxis do
    mkAxis ix
    E.items $ map ET.strItem $ yValues serie

  sortX ∷ Array String → Array String
  sortX = A.sortBy $ Ax.compareWithAxisType abscissaAxisType

  sortY ∷ Array String → Array String
  sortY = A.sortBy $ Ax.compareWithAxisType ordinateAxisType

{-
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.Setups.Chart.Heatmap.Eval
  ( eval
  , module SlamData.Workspace.Card.Setups.Chart.Heatmap.Model
  ) where

import SlamData.Prelude

import Color as C

import Data.Argonaut (Json, decodeJson, (.?))
import Data.Array as A
import Data.Foreign as Frn
import Data.Lens ((^?))
import Data.List as L
import Data.Map as M
import Data.Int as Int
import Data.Set as Set

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.CardType.ChartType (ChartType(Heatmap))
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Setups.Axis as Ax
import SlamData.Workspace.Card.Setups.Chart.ColorScheme (colors, getColorScheme)
import SlamData.Workspace.Card.Setups.Chart.Common as SCC
import SlamData.Workspace.Card.Setups.Chart.Common.Positioning as BCP
import SlamData.Workspace.Card.Setups.Chart.Common.Tooltip as CCT
import SlamData.Workspace.Card.Setups.Chart.Heatmap.Model (Model, ModelR)
import SlamData.Workspace.Card.Setups.Common.Eval (type (>>))
import SlamData.Workspace.Card.Setups.Common.Eval as BCE
import SlamData.Workspace.Card.Setups.Dimension as D
import SlamData.Workspace.Card.Setups.Semantics as Sem

import SqlSquare as Sql

import Utils.Foldable (enumeratedFor_)

eval ∷ ∀ m. BCE.ChartSetupEval ModelR m
eval = BCE.chartSetupEval (SCC.buildBasicSql buildProjections buildGroupBy) buildPort

type HeatmapSeries =
  { x ∷ Maybe Number
  , y ∷ Maybe Number
  , w ∷ Maybe Number
  , h ∷ Maybe Number
  , name ∷ Maybe String
  , fontSize ∷ Maybe Int
  , items ∷ (String × String) >> Number
  }

type Item =
  { abscissa ∷ String
  , ordinate ∷ String
  , measure ∷ Number
  , series ∷ Maybe String
  }

decodeItem ∷ Json → Either String Item
decodeItem = decodeJson >=> \obj → do
  abscissa ← CCT.formatForeign ∘ jsonToForeign <$> obj .? "abscissa"
  ordinate ← CCT.formatForeign ∘ jsonToForeign <$> obj .? "ordinate"
  measure ← Sem.requiredNumber zero <$> obj .? "measure"
  series ← Sem.maybeString <$> obj .? "series"
  pure { abscissa, ordinate, measure, series }
  where
  jsonToForeign ∷ Json → Frn.Foreign
  jsonToForeign = Frn.toForeign

buildProjections ∷ ModelR → L.List (Sql.Projection Sql.Sql)
buildProjections r = L.fromFoldable
  [ r.abscissa # SCC.jcursorPrj # Sql.as "abscissa"
  , r.ordinate # SCC.jcursorPrj # Sql.as "ordinate"
  , r.value # SCC.jcursorPrj # Sql.as "measure" # SCC.applyTransform r.value
  , r.series # maybe SCC.nullPrj SCC.jcursorPrj # Sql.as "series"
  ]

buildGroupBy ∷ ModelR → Maybe (Sql.GroupBy Sql.Sql)
buildGroupBy r =
  SCC.groupBy $ L.fromFoldable $ A.catMaybes
    [ r.series <#> SCC.jcursorSql
    , Just r.abscissa <#> SCC.jcursorSql
    , Just r.ordinate <#> SCC.jcursorSql
    ]

buildPort ∷ ModelR → Ax.Axes → Array Json → Port.Port
buildPort m axes jarr =
  Port.ChartInstructions
    { options: buildOptions axes m $ buildData m jarr
    , chartType: Heatmap
    }

buildData ∷ ModelR → Array Json → Array HeatmapSeries
buildData r =
  foldMap (foldMap A.singleton ∘ decodeItem)
    >>> series
    >>> BCP.adjustRectangularPositions

  where
  series ∷ Array Item → Array HeatmapSeries
  series =
    BCE.groupOn _.series
      >>> map \(name × items) →
            { name
            , x: Nothing
            , y: Nothing
            , w: Nothing
            , h: Nothing
            , fontSize: Nothing
            , items: M.fromFoldable $ toPoint <$> items
            }

  toPoint ∷ Item → (String × String) × Number
  toPoint item = (item.abscissa × item.ordinate) × item.measure

buildOptions ∷ Ax.Axes → ModelR → Array HeatmapSeries → DSL OptionI
buildOptions axes r heatmapData = do
  E.tooltip do
    E.triggerAxis
    E.textStyle do
      E.fontFamily "Ubuntu, sans"
      E.fontSize 12
    E.axisPointer do
      E.crossAxisPointer
      E.crossStyle do
        E.color $ C.rgba 170 170 170 0.6
        E.widthNum 0.2
        E.solidLine
    E.formatterItem \item →
      CCT.tableRows
        [ D.jcursorLabel r.abscissa × CCT.formatAssocProp "abscissa" item
        , D.jcursorLabel r.ordinate × CCT.formatAssocProp "ordinate" item
        , D.jcursorLabel r.value × CCT.formatAssocProp "value" item
        ]

  E.animationEnabled false

  BCP.rectangularTitles heatmapData
    $ maybe "" D.jcursorLabel r.series

  BCP.rectangularGrids heatmapData

  E.xAxes xAxes

  E.yAxes yAxes

  E.colors colors

  E.visualMap $ E.continuous do
    E.min r.minValue
    E.max r.maxValue
    E.calculable true
    E.orient ET.Horizontal
    E.itemWidth 15.0
    E.leftCenter
    E.bottom $ ET.Percent zero
    E.padding zero
    E.inRange $ E.colors
      if r.isColorSchemeReversed
        then A.reverse $ getColorScheme r.colorScheme
        else getColorScheme r.colorScheme

  E.series series

  where
  xValues ∷ HeatmapSeries → Array String
  xValues serie =
    sortX $ A.fromFoldable $ Set.fromFoldable $ map fst $ M.keys serie.items

  yValues ∷ HeatmapSeries → Array String
  yValues serie =
    sortY $ A.fromFoldable $ Set.fromFoldable $ map snd $ M.keys serie.items

  series ∷ ∀ i. DSL (heatMap ∷ ETP.I|i)
  series = enumeratedFor_ heatmapData \(ix × serie) → E.heatMap do
    for_ serie.name E.name
    E.xAxisIndex ix
    E.yAxisIndex ix

    E.buildItems
      $ enumeratedFor_ (xValues serie)  \(xIx × abscissa) →
          enumeratedFor_ (yValues serie) \(yIx × ordinate) →
            for_ (M.lookup (abscissa × ordinate) serie.items) \value → E.addItem do
              BCE.assoc { abscissa, ordinate, value }
              E.buildValues do
                E.addValue $ Int.toNumber xIx
                E.addValue $ Int.toNumber yIx
                E.addValue value

  mkAxis ∷ ∀ i. Int → DSL (ETP.AxisI (gridIndex ∷ ETP.I|i))
  mkAxis ix = do
    E.axisType ET.Category
    E.gridIndex ix
    E.axisLabel do
      E.textStyle do
        E.fontFamily "Ubuntu, sans"
    E.axisLine $ E.lineStyle do
      E.width 1
    E.splitLine $ E.lineStyle do
      E.width 1
    E.splitArea E.hidden

  abscissaAxisType =
    fromMaybe Ax.Category
    $ Ax.axisType <$> (r.abscissa ^? D._value ∘ D._projection) <*> pure axes
  ordinateAxisType =
    fromMaybe Ax.Category
    $ Ax.axisType <$> (r.ordinate ^? D._value ∘ D._projection) <*> pure axes

  abscissaAxisCfg = Ax.axisConfiguration abscissaAxisType
  ordinateAxisCfg = Ax.axisConfiguration ordinateAxisType

  xAxes ∷ ∀ i. DSL (addXAxis ∷ ETP.I|i)
  xAxes = enumeratedFor_ heatmapData \(ix × serie) → E.addXAxis do
    mkAxis ix
    E.items $ map ET.strItem $ xValues serie

  yAxes ∷ ∀ i. DSL (addYAxis ∷ ETP.I|i)
  yAxes = enumeratedFor_ heatmapData \(ix × serie) → E.addYAxis do
    mkAxis ix
    E.items $ map ET.strItem $ yValues serie

  sortX ∷ Array String → Array String
  sortX = A.sortBy $ Ax.compareWithAxisType abscissaAxisType

  sortY ∷ Array String → Array String
  sortY = A.sortBy $ Ax.compareWithAxisType ordinateAxisType


Updated signatures of all functions

Updated signatures of all functions

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.ST
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events (unsafeEventNumberProp)
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Constants
import Checkers.Types

createGrid :: Int -> Int -> Int -> Grid
createGrid width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          color = if ((even x) && (odd y)) || ((even y) && (odd x))
                  then colorSquareOne
                  else colorSquareTwo
          hasPlayerOne = (y < layers) && (((even y) && (odd x)) || ((even x) && (odd y)))
          hasPlayerTwo = (y >= height - layers) && (((even y) && (odd x)) || ((even x) && (odd y)))
          piece = if hasPlayerOne
                  then Just { color: colorPlayerOne, king: false }
                  else
                    if hasPlayerTwo
                    then Just { color: colorPlayerTwo, king: false }
                    else Nothing
      return { x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

createState :: Int -> Int -> Int -> State
createState width height layers = { grid: (createGrid width height layers), currentPlayer: 1 }

findPiece :: Grid -> Coordinate -> Maybe Int
findPiece grid (Tuple x y) = findIndex (\e -> e.x == x && e.y == y) grid.squares

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -1 : (singleton 1)
  j <- -1 : (singleton 1)
  return (Tuple (x + i) (y + j))

isOnSquare :: Tuple Number Number -> Square -> Number -> Number -> Boolean
isOnSquare (Tuple ox oy) square x y =
  (square.rx + ox) < x && x < (square.rx + ox) + renderSize &&
  (square.ry + oy) < y && y < (square.ry + oy) + renderSize

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (findPiece grid from)
      toIndex = fromJust (findPiece grid to)
      originalSquare = fromJust (grid.squares !! fromIndex)
      afterMove = fromJust (modifyAt toIndex (setPiece originalSquare.piece) grid.squares)
      newSquares = fromJust (modifyAt fromIndex (setPiece Nothing) afterMove)

renderSquare :: forall e.
                  Tuple Number Number ->
                  Context2D ->
                  Maybe DOMEvent ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
renderSquare offset ctx event _ square = do
  withContext ctx $ do
    setFillStyle square.color ctx
    fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  case square.piece of
    Just piece -> do
      withContext ctx $ do
        setFillStyle piece.color ctx
        let arcPiece = { x: square.rx + 0.5 * renderSize,
                         y: square.ry + 0.5 * renderSize,
                         r: (renderSize / 2.0) * 0.8,
                         start: 0.0,
                         end: 2.0 * pi }
        fillPath ctx $ arc ctx arcPiece
        case event of
          Nothing -> return unit
          Just e -> do
            ux <- unsafeEventNumberProp "clientX" e
            uy <- unsafeEventNumberProp "clientY" e
            case isOnSquare offset square (toNumber ux) (toNumber uy) of
              true -> do
                setLineWidth highlightWidth ctx
                strokePath ctx $ arc ctx arcPiece
                return unit
              false -> return unit
            return unit
        return unit
    _ -> return unit

render :: forall s e.
            Tuple Number Number ->
            Context2D ->
            STRef s State ->
            Maybe DOMEvent ->
            Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
render offset ctx st event = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare offset ctx event) unit state.grid.squares
  withContext ctx $ do
    setStrokeStyle "black" ctx
    strokeRect ctx { x: 0.5,
                     y: 0.5,
                     w: (toNumber state.grid.width) * renderSize - 0.5,
                     h: (toNumber state.grid.height) * renderSize - 0.5 }
  return unit

renderPage :: forall s e.
                Tuple Number Number ->
                STRef s State ->
                Maybe DOMEvent ->
                Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
renderPage offset st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render offset ctx st event
      return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
main = do
  st <- newSTRef (createState defaultWidth defaultHeight layerCount)
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      addMouseEventListener MouseMoveEvent (\e -> renderPage offset st (Just e)) canvas
      renderPage offset st Nothing
      return unit
    _ -> return unit

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.ST
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events (unsafeEventNumberProp)
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Constants
import Checkers.Types

createGrid :: Int -> Int -> Int -> Grid
createGrid width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          color = if ((even x) && (odd y)) || ((even y) && (odd x))
                  then colorSquareOne
                  else colorSquareTwo
          hasPlayerOne = (y < layers) && (((even y) && (odd x)) || ((even x) && (odd y)))
          hasPlayerTwo = (y >= height - layers) && (((even y) && (odd x)) || ((even x) && (odd y)))
          piece = if hasPlayerOne
                  then Just { color: colorPlayerOne, king: false }
                  else
                    if hasPlayerTwo
                    then Just { color: colorPlayerTwo, king: false }
                    else Nothing
      return { x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

createState :: Int -> Int -> Int -> State
createState width height layers = { grid: (createGrid width height layers), currentPlayer: 1 }

findPiece :: Grid -> Coordinate -> Maybe Int
findPiece grid (Tuple x y) = findIndex (\e -> e.x == x && e.y == y) grid.squares

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -1 : (singleton 1)
  j <- -1 : (singleton 1)
  return (Tuple (x + i) (y + j))

isOnSquare :: Tuple Number Number -> Square -> Number -> Number -> Boolean
isOnSquare (Tuple ox oy) square x y =
  (square.rx + ox) < x && x < (square.rx + ox) + renderSize &&
  (square.ry + oy) < y && y < (square.ry + oy) + renderSize

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (findPiece grid from)
      toIndex = fromJust (findPiece grid to)
      originalSquare = fromJust (grid.squares !! fromIndex)
      afterMove = fromJust (modifyAt toIndex (setPiece originalSquare.piece) grid.squares)
      newSquares = fromJust (modifyAt fromIndex (setPiece Nothing) afterMove)

renderSquare :: forall e. Tuple Number Number -> Context2D -> Maybe DOMEvent -> Unit -> Square -> Eff (canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
renderSquare offset ctx event _ square = do
  withContext ctx $ do
    setFillStyle square.color ctx
    fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  case square.piece of
    Just piece -> do
      withContext ctx $ do
        setFillStyle piece.color ctx
        let arcPiece = { x: square.rx + 0.5 * renderSize,
                         y: square.ry + 0.5 * renderSize,
                         r: (renderSize / 2.0) * 0.8,
                         start: 0.0,
                         end: 2.0 * pi }
        fillPath ctx $ arc ctx arcPiece
        case event of
          Nothing -> return unit
          Just e -> do
            ux <- unsafeEventNumberProp "clientX" e
            uy <- unsafeEventNumberProp "clientY" e
            case isOnSquare offset square (toNumber ux) (toNumber uy) of
              true -> do
                setLineWidth highlightWidth ctx
                strokePath ctx $ arc ctx arcPiece
                return unit
              false -> return unit
            return unit
        return unit
    _ -> return unit

render :: forall s e. Tuple Number Number -> Context2D -> STRef s State -> Maybe DOMEvent -> Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
render offset ctx st event = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare offset ctx event) unit state.grid.squares
  withContext ctx $ do
    setStrokeStyle "black" ctx
    strokeRect ctx { x: 0.5,
                     y: 0.5,
                     w: (toNumber state.grid.width) * renderSize - 0.5,
                     h: (toNumber state.grid.height) * renderSize - 0.5 }
  return unit

renderPage offset st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render offset ctx st event
      return unit
    _ -> return unit
  return unit

main = do
  st <- newSTRef (createState defaultWidth defaultHeight layerCount)
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      addMouseEventListener MouseMoveEvent (\e -> renderPage offset st (Just e)) canvas
      renderPage offset st Nothing
      return unit
    _ -> return unit


Add tests for pow

Add tests for pow

module Test.Data.Int (testInt) where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)

import Data.Int (odd, even, fromString, floor, ceil, round, toNumber,
                 fromNumber, fromStringAs, binary, octal, hexadecimal,
                 radix, toStringAs, pow)
import Data.Maybe (Maybe(..), fromJust)
import Partial.Unsafe (unsafePartial)

import Test.Assert (ASSERT, assert)

testInt :: Eff (console :: CONSOLE, assert :: ASSERT) Unit
testInt = do

  log "fromNumber should coerce integer values"
  assert $ fromNumber 1.0 == Just 1
  assert $ fromNumber 42.0 == Just 42
  assert $ fromNumber 0.0 == Just 0

  log "fromNumber should fail on float inputs"
  assert $ fromNumber 0.9 == Nothing
  assert $ fromNumber (-0.9) == Nothing

  log "toNumber should coerce any integer to a number"
  assert $ toNumber 1 == 1.0
  assert $ toNumber (-1) == -1.0
  assert $ toNumber 0 == 0.0

  log "round should choose the closest integer"
  assert $ round 0.3 == 0
  assert $ round 0.7 == 1

  log "ceil should round up"
  assert $ ceil 0.3 == 1
  assert $ ceil 0.7 == 1

  log "floor should round down"
  assert $ floor 0.3 == 0
  assert $ floor 0.7 == 0

  log "round, ceil, and floor should clamp values outside the Int range"
  let testClamping f = do
        let low = toNumber bottom - 1.5
        assert $ f low == bottom

        let high = toNumber top + 1.5
        assert $ f high == top

  testClamping round
  testClamping ceil
  testClamping floor

  log "fromString should read integers"
  assert $ fromString "0" == Just 0
  assert $ fromString "9467" == Just 9467
  assert $ fromString "-6" == Just (-6)
  assert $ fromString "+6" == Just 6

  log "fromString should fail to read floats"
  assert $ fromString "0.1" == Nothing
  assert $ fromString "42.000000000000001" == Nothing

  log "fromString should fail to read integers outside of the int32 range"
  assert $ fromString "2147483648" == Nothing
  assert $ fromString "-2147483649" == Nothing

  log "fromString should fail to read strings with other non-integer values"
  assert $ fromString "" == Nothing
  assert $ fromString "a" == Nothing
  assert $ fromString "5a" == Nothing
  assert $ fromString "42,12" == Nothing

  log "fromStringAs should read integers in different bases"
  assert $ fromStringAs binary "100" == Just 4
  assert $ fromStringAs hexadecimal "100" == Just 256
  assert $ fromStringAs hexadecimal "EF" == Just 239
  assert $ fromStringAs hexadecimal "+ef" == Just 239
  assert $ fromStringAs hexadecimal "-ef" == Just (-239)
  assert $ fromStringAs hexadecimal "+7fffffff" == Just 2147483647
  assert $ fromStringAs hexadecimal "-80000000" == Just (-2147483648)
  assert $ fromStringAs binary "10" == Just 2
  assert $ fromStringAs (unsafePartial $ fromJust $ radix 3) "10" == Just 3
  assert $ fromStringAs (unsafePartial $ fromJust $ radix 11) "10" == Just 11
  assert $ fromStringAs (unsafePartial $ fromJust $ radix 12) "10" == Just 12
  assert $ fromStringAs (unsafePartial $ fromJust $ radix 36) "10" == Just 36

  log "fromStringAs should fail on unknown digits"
  assert $ fromStringAs binary "12" == Nothing
  assert $ fromStringAs octal "8" == Nothing
  assert $ fromStringAs hexadecimal "1g" == Nothing

  log "toStringAs should transform to a different base"
  assert $ toStringAs hexadecimal 255 == "ff"
  assert $ toStringAs binary 4 == "100"
  assert $ toStringAs binary (-4) == "-100"
  assert $ toStringAs hexadecimal 2147483647 == "7fffffff"

  log "zero is even"
  assert $ even 0 == true

  log "even numbers are even"
  assert $ even 2 == true
  assert $ even 4 == true
  assert $ even 100 == true

  log "odd numbers are not even"
  assert $ even 1 == false
  assert $ even 3 == false
  assert $ even 73 == false

  log "zero is not odd"
  assert $ odd 0 == false

  log "odd numbers are odd"
  assert $ odd 1 == true
  assert $ odd 3 == true
  assert $ odd 73 == true

  log "even numbers are not odd"
  assert $ odd 2 == false
  assert $ odd 4 == false
  assert $ odd 100 == false

  log "pow"
  assert $ pow 2 2 == 4
  assert $ pow 5 3 == 125
  assert $ pow 26 0 == 1
  assert $ pow 0 32 == 0
  assert $ pow 2 (-1) == 0
  assert $ pow 1 (-2) == 1
  assert $ pow 2 (-2) == 0
  assert $ pow (-2) (-2) == 0
  assert $ pow (-2) 2 == 4
  assert $ pow (-2) 3 == (-8)

module Test.Data.Int (testInt) where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)

import Data.Int (odd, even, fromString, floor, ceil, round, toNumber,
                 fromNumber, fromStringAs, binary, octal, hexadecimal,
                 radix, toStringAs)
import Data.Maybe (Maybe(..), fromJust)
import Partial.Unsafe (unsafePartial)

import Test.Assert (ASSERT, assert)

testInt :: Eff (console :: CONSOLE, assert :: ASSERT) Unit
testInt = do

  log "fromNumber should coerce integer values"
  assert $ fromNumber 1.0 == Just 1
  assert $ fromNumber 42.0 == Just 42
  assert $ fromNumber 0.0 == Just 0

  log "fromNumber should fail on float inputs"
  assert $ fromNumber 0.9 == Nothing
  assert $ fromNumber (-0.9) == Nothing

  log "toNumber should coerce any integer to a number"
  assert $ toNumber 1 == 1.0
  assert $ toNumber (-1) == -1.0
  assert $ toNumber 0 == 0.0

  log "round should choose the closest integer"
  assert $ round 0.3 == 0
  assert $ round 0.7 == 1

  log "ceil should round up"
  assert $ ceil 0.3 == 1
  assert $ ceil 0.7 == 1

  log "floor should round down"
  assert $ floor 0.3 == 0
  assert $ floor 0.7 == 0

  log "round, ceil, and floor should clamp values outside the Int range"
  let testClamping f = do
        let low = toNumber bottom - 1.5
        assert $ f low == bottom

        let high = toNumber top + 1.5
        assert $ f high == top

  testClamping round
  testClamping ceil
  testClamping floor

  log "fromString should read integers"
  assert $ fromString "0" == Just 0
  assert $ fromString "9467" == Just 9467
  assert $ fromString "-6" == Just (-6)
  assert $ fromString "+6" == Just 6

  log "fromString should fail to read floats"
  assert $ fromString "0.1" == Nothing
  assert $ fromString "42.000000000000001" == Nothing

  log "fromString should fail to read integers outside of the int32 range"
  assert $ fromString "2147483648" == Nothing
  assert $ fromString "-2147483649" == Nothing

  log "fromString should fail to read strings with other non-integer values"
  assert $ fromString "" == Nothing
  assert $ fromString "a" == Nothing
  assert $ fromString "5a" == Nothing
  assert $ fromString "42,12" == Nothing

  log "fromStringAs should read integers in different bases"
  assert $ fromStringAs binary "100" == Just 4
  assert $ fromStringAs hexadecimal "100" == Just 256
  assert $ fromStringAs hexadecimal "EF" == Just 239
  assert $ fromStringAs hexadecimal "+ef" == Just 239
  assert $ fromStringAs hexadecimal "-ef" == Just (-239)
  assert $ fromStringAs hexadecimal "+7fffffff" == Just 2147483647
  assert $ fromStringAs hexadecimal "-80000000" == Just (-2147483648)
  assert $ fromStringAs binary "10" == Just 2
  assert $ fromStringAs (unsafePartial $ fromJust $ radix 3) "10" == Just 3
  assert $ fromStringAs (unsafePartial $ fromJust $ radix 11) "10" == Just 11
  assert $ fromStringAs (unsafePartial $ fromJust $ radix 12) "10" == Just 12
  assert $ fromStringAs (unsafePartial $ fromJust $ radix 36) "10" == Just 36

  log "fromStringAs should fail on unknown digits"
  assert $ fromStringAs binary "12" == Nothing
  assert $ fromStringAs octal "8" == Nothing
  assert $ fromStringAs hexadecimal "1g" == Nothing

  log "toStringAs should transform to a different base"
  assert $ toStringAs hexadecimal 255 == "ff"
  assert $ toStringAs binary 4 == "100"
  assert $ toStringAs binary (-4) == "-100"
  assert $ toStringAs hexadecimal 2147483647 == "7fffffff"

  log "zero is even"
  assert $ even 0 == true

  log "even numbers are even"
  assert $ even 2 == true
  assert $ even 4 == true
  assert $ even 100 == true

  log "odd numbers are not even"
  assert $ even 1 == false
  assert $ even 3 == false
  assert $ even 73 == false

  log "zero is not odd"
  assert $ odd 0 == false

  log "odd numbers are odd"
  assert $ odd 1 == true
  assert $ odd 3 == true
  assert $ odd 73 == true

  log "even numbers are not odd"
  assert $ odd 2 == false
  assert $ odd 4 == false
  assert $ odd 100 == false


Remove more comments

Remove more comments

module Docopt.Parser.State where

import Prelude

type ParserState = {
  indentation :: Int -- The active indentation level
, line        :: Int -- The active line
}
--
-- instance showParserState :: Show ParserState where
--   show (ParserState { indentation: indent, line: line }) =
--     "(" ++ (show line) ++ "|" ++ (show indent) ++ ")"