ensure hp arr length is correct

ensure hp arr length is correct

module KanColle.DamageAnalysis.DamageAnalysis
  ( analyzeBattle
  , analyzeNightBattle

  , analyzeSTFBattle
  , analyzeCTFBattle
  , analyzeTECFBattle
  , analyzeCombinedNightBattle
  ) where

import Prelude
import Data.Array
import Data.Maybe
import Data.Unfoldable
import KanColle.KCAPI.Battle
import KanColle.Util

import KanColle.DamageAnalysis.DamageVector
import KanColle.DamageAnalysis.Stages
import KanColle.DamageAnalysis.Types

rawSplit :: forall a. Array a -> LR (Array a)
rawSplit = fleetSplit true

normalSplit :: forall a. Array a -> LR (Array a)
normalSplit = fleetSplit false

ensureHpsLen :: Int -> Array (Maybe Int) -> Array (Maybe Int)
ensureHpsLen expectLen xs = case expectLen `compare` actualLen of
    LT -> throwWith "ensureHpsLen: array length is longer than expected"
    EQ -> xs
    GT -> (xs <> replicate (expectLen - actualLen) Nothing)
  where
    actualLen = length xs

-- get initial fleet info
getInitFleet :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo Ship
getInitFleet ds battle = { main: allyShips, enemy: enemyShips }
  where
    nowHps = rawSplit (ensureHpsLen (1+12) $ getInitHps battle)
    allyNowHps = nowHps.left
    enemyNowHps = nowHps.right

    maxHps = rawSplit (ensureHpsLen (1+12) $ getMaxHps battle)
    allyMaxHps = maxHps.left
    enemyMaxHps = maxHps.right

    mkShip (Just hp) (Just fullHp) = Just { hp: hp, fullHp: fullHp, sunk: hp <= 0, dameCon: Nothing }
    mkShip _ _ = Nothing

    addDameCon (Just ship) dc = Just (ship { dameCon = dc })
    addDameCon _ _ = Nothing

    allyShips :: FleetInfo Ship
    allyShips = zipWith addDameCon (zipWith mkShip allyNowHps allyMaxHps) ds

    enemyShips :: FleetInfo Ship
    enemyShips = zipWith mkShip enemyNowHps enemyMaxHps

getInitFleetCombined :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo Ship
getInitFleetCombined ds battle =
    { main: initFleet.main
    , escort: escortShips
    , enemy: initFleet.enemy
    }
  where
    dsSplitted = normalSplit ds
    dsMain = dsSplitted.left
    dsEscort = dsSplitted.right

    initFleet = getInitFleet dsMain battle

    escortNowHps = unsafeArrTail (ensureHpsLen (1+6) $ getInitHpsCombined battle)
    escortMaxHps = unsafeArrTail (ensureHpsLen (1+6) $ getMaxHpsCombined battle)

    mkShip (Just hp) (Just fullHp) = Just { hp: hp, fullHp: fullHp, sunk: hp <= 0, dameCon: Nothing }
    mkShip _ _ = Nothing

    addDameCon (Just ship) dc = Just (ship { dameCon = dc })
    addDameCon _ _ = Nothing

    escortShips :: FleetInfo Ship
    escortShips = zipWith addDameCon (zipWith mkShip escortNowHps escortMaxHps) dsEscort

analyzeBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeBattle = analyzeBattleBy battleDV

analyzeNightBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeNightBattle = analyzeBattleBy nightBattleDV

analyzeBattleBy :: (Battle -> NormalDamageVector)
                -> Array (Maybe DameCon)
                -> Battle
                -> NormalFleetInfo ShipResult
analyzeBattleBy getDVFromBattle ds battle =
    dupAsNormalBattle (zipWith getShipResult')
      `appNormalBattle` initFleet
      `appNormalBattle` finalFleet
  where
    initFleet = getInitFleet ds battle
    finalFleet :: NormalFleetInfo Ship
    finalFleet = applyNormalDamageVector (getDVFromBattle battle) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

analyzeCombinedBattleBy :: (Battle -> CombinedDamageVector)
                -> Array (Maybe DameCon)
                -> Battle
                -> CombinedFleetInfo ShipResult
analyzeCombinedBattleBy getDVFromBattle ds battle =
    dupAsCombinedBattle (zipWith getShipResult')
      `appCombinedBattle` initFleet
      `appCombinedBattle` finalFleet
  where
    initFleet = getInitFleetCombined ds battle
    finalFleet = applyCombinedDamageVector (getDVFromBattle battle) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

analyzeSTFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeSTFBattle = analyzeCombinedBattleBy battleSurfaceTaskForceDV

analyzeCTFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeCTFBattle = analyzeCombinedBattleBy battleCarrierTaskForceDV

analyzeTECFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeTECFBattle = analyzeCTFBattle

analyzeCombinedNightBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeCombinedNightBattle ds b =
    dupAsNormalBattle (zipWith getShipResult')
      `appNormalBattle` initFleet
      `appNormalBattle` finalFleet
  where
    nightBattleInfo = getInitFleetCombined (replicate 6 Nothing <> ds) b
    initFleet =
      { main: nightBattleInfo.escort
      , enemy: nightBattleInfo.enemy
      }
    finalFleet :: NormalFleetInfo Ship
    finalFleet = applyNormalDamageVector (nightBattleDV b) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

module KanColle.DamageAnalysis.DamageAnalysis
  ( analyzeBattle
  , analyzeNightBattle

  , analyzeSTFBattle
  , analyzeCTFBattle
  , analyzeTECFBattle
  , analyzeCombinedNightBattle
  ) where

import Prelude
import Data.Array
import Data.Maybe
import Data.Unfoldable
import KanColle.KCAPI.Battle
import KanColle.Util

import KanColle.DamageAnalysis.DamageVector
import KanColle.DamageAnalysis.Stages
import KanColle.DamageAnalysis.Types

rawSplit :: forall a. Array a -> LR (Array a)
rawSplit = fleetSplit true

normalSplit :: forall a. Array a -> LR (Array a)
normalSplit = fleetSplit false

-- get initial fleet info
getInitFleet :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo Ship
getInitFleet ds battle = { main: allyShips, enemy: enemyShips }
  where
    nowHps = rawSplit (getInitHps battle)
    allyNowHps = nowHps.left
    enemyNowHps = nowHps.right

    maxHps = rawSplit (getMaxHps battle)
    allyMaxHps = maxHps.left
    enemyMaxHps = maxHps.right

    mkShip (Just hp) (Just fullHp) = Just { hp: hp, fullHp: fullHp, sunk: hp <= 0, dameCon: Nothing }
    mkShip _ _ = Nothing

    addDameCon (Just ship) dc = Just (ship { dameCon = dc })
    addDameCon _ _ = Nothing

    allyShips :: FleetInfo Ship
    allyShips = zipWith addDameCon (zipWith mkShip allyNowHps allyMaxHps) ds

    enemyShips :: FleetInfo Ship
    enemyShips = zipWith mkShip enemyNowHps enemyMaxHps

getInitFleetCombined :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo Ship
getInitFleetCombined ds battle =
    { main: initFleet.main
    , escort: escortShips
    , enemy: initFleet.enemy
    }
  where
    dsSplitted = normalSplit ds
    dsMain = dsSplitted.left
    dsEscort = dsSplitted.right

    initFleet = getInitFleet dsMain battle

    escortNowHps = unsafeArrTail (getInitHpsCombined battle)
    escortMaxHps = unsafeArrTail (getMaxHpsCombined battle)

    mkShip (Just hp) (Just fullHp) = Just { hp: hp, fullHp: fullHp, sunk: hp <= 0, dameCon: Nothing }
    mkShip _ _ = Nothing

    addDameCon (Just ship) dc = Just (ship { dameCon = dc })
    addDameCon _ _ = Nothing

    escortShips :: FleetInfo Ship
    escortShips = zipWith addDameCon (zipWith mkShip escortNowHps escortMaxHps) dsEscort

analyzeBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeBattle = analyzeBattleBy battleDV

analyzeNightBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeNightBattle = analyzeBattleBy nightBattleDV

analyzeBattleBy :: (Battle -> NormalDamageVector)
                -> Array (Maybe DameCon)
                -> Battle
                -> NormalFleetInfo ShipResult
analyzeBattleBy getDVFromBattle ds battle =
    dupAsNormalBattle (zipWith getShipResult')
      `appNormalBattle` initFleet
      `appNormalBattle` finalFleet
  where
    initFleet = getInitFleet ds battle
    finalFleet :: NormalFleetInfo Ship
    finalFleet = applyNormalDamageVector (getDVFromBattle battle) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

analyzeCombinedBattleBy :: (Battle -> CombinedDamageVector)
                -> Array (Maybe DameCon)
                -> Battle
                -> CombinedFleetInfo ShipResult
analyzeCombinedBattleBy getDVFromBattle ds battle =
    dupAsCombinedBattle (zipWith getShipResult')
      `appCombinedBattle` initFleet
      `appCombinedBattle` finalFleet
  where
    initFleet = getInitFleetCombined ds battle
    finalFleet = applyCombinedDamageVector (getDVFromBattle battle) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

analyzeSTFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeSTFBattle = analyzeCombinedBattleBy battleSurfaceTaskForceDV

analyzeCTFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeCTFBattle = analyzeCombinedBattleBy battleCarrierTaskForceDV

analyzeTECFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeTECFBattle = analyzeCTFBattle

analyzeCombinedNightBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeCombinedNightBattle ds b =
    dupAsNormalBattle (zipWith getShipResult')
      `appNormalBattle` initFleet
      `appNormalBattle` finalFleet
  where
    nightBattleInfo = getInitFleetCombined (replicate 6 Nothing <> ds) b
    initFleet =
      { main: nightBattleInfo.escort
      , enemy: nightBattleInfo.enemy
      }
    finalFleet :: NormalFleetInfo Ship
    finalFleet = applyNormalDamageVector (nightBattleDV b) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2


Add JS AST traversals

Add JS AST traversals

module Language.PureScript.CodeGen.JS.AST where

import Data.Array (map)
import Data.Either
import Data.Foldable (foldl)
import Data.Maybe
import Data.Tuple

-- |
-- Built-in unary operators
--
data UnaryOperator
  -- |
  -- Numeric negation
  --
  = Negate
  -- |
  -- Boolean negation
  --
  | Not
  -- |
  -- Bitwise negation
  --
  | BitwiseNot
  -- |
  -- Numeric unary \'plus\'
  --
  | Positive

instance showUnaryOperator :: Show UnaryOperator where
  show Negate = "Negate"
  show Not = "Not"
  show BitwiseNot = "BitwiseNot"
  show Positive = "Positive"

instance eqUnaryOperator :: Eq UnaryOperator where
  (==) Negate     Negate     = true
  (==) Not        Not        = true
  (==) BitwiseNot BitwiseNot = true
  (==) Positive   Positive   = true
  (==) _          _          = false
  (/=) u1         u2         = not (u1 == u2)

-- |
-- Built-in binary operators
--
data BinaryOperator
  -- |
  -- Numeric addition
  --
  = Add
  -- |
  -- Numeric subtraction
  --
  | Subtract
  -- |
  -- Numeric multiplication
  --
  | Multiply
  -- |
  -- Numeric division
  --
  | Divide
  -- |
  -- Remainder
  --
  | Modulus
  -- |
  -- Generic equality test
  --
  | EqualTo
  -- |
  -- Generic inequality test
  --
  | NotEqualTo
  -- |
  -- Numeric less-than
  --
  | LessThan
  -- |
  -- Numeric less-than-or-equal
  --
  | LessThanOrEqualTo
  -- |
  -- Numeric greater-than
  --
  | GreaterThan
  -- |
  -- Numeric greater-than-or-equal
  --
  | GreaterThanOrEqualTo
  -- |
  -- Boolean and
  --
  | And
  -- |
  -- Boolean or
  --
  | Or
  -- |
  -- Bitwise and
  --
  | BitwiseAnd
  -- |
  -- Bitwise or
  --
  | BitwiseOr
  -- |
  -- Bitwise xor
  --
  | BitwiseXor
  -- |
  -- Bitwise left shift
  --
  | ShiftLeft
  -- |
  -- Bitwise right shift
  --
  | ShiftRight
  -- |
  -- Bitwise right shift with zero-fill
  --
  | ZeroFillShiftRight

instance showBinaryOperator :: Show BinaryOperator where
  show Add                   = "Add"
  show Subtract              = "Subtract"
  show Multiply              = "Multiply"
  show Divide                = "Divide"
  show Modulus               = "Modulus"
  show EqualTo               = "EqualTo"
  show NotEqualTo            = "NotEqualTo"
  show LessThan              = "LessThan"
  show LessThanOrEqualTo     = "LessThanOrEqualTo"
  show GreaterThan           = "GreaterThan"
  show GreaterThanOrEqualTo  = "GreaterThanOrEqualTo"
  show And                   = "And"
  show Or                    = "Or"
  show BitwiseAnd            = "BitwiseAnd"
  show BitwiseOr             = "BitwiseOr"
  show BitwiseXor            = "BitwiseXor"
  show ShiftLeft             = "ShiftLeft"
  show ShiftRight            = "ShiftRight"
  show ZeroFillShiftRight    = "ZeroFillShiftRight"

instance eqBinaryOperator :: Eq BinaryOperator where
  (==) Add                  Add                  = true
  (==) Subtract             Subtract             = true
  (==) Multiply             Multiply             = true
  (==) Divide               Divide               = true
  (==) Modulus              Modulus              = true
  (==) EqualTo              EqualTo              = true
  (==) NotEqualTo           NotEqualTo           = true
  (==) LessThan             LessThan             = true
  (==) LessThanOrEqualTo    LessThanOrEqualTo    = true
  (==) GreaterThan          GreaterThan          = true
  (==) GreaterThanOrEqualTo GreaterThanOrEqualTo = true
  (==) And                  And                  = true
  (==) Or                   Or                   = true
  (==) BitwiseAnd           BitwiseAnd           = true
  (==) BitwiseOr            BitwiseOr            = true
  (==) BitwiseXor           BitwiseXor           = true
  (==) ShiftLeft            ShiftLeft            = true
  (==) ShiftRight           ShiftRight           = true
  (==) ZeroFillShiftRight   ZeroFillShiftRight   = true
  (==) _                    _                    = false
  (/=) b1                   b2                   = not (b1 == b2)

-- |
-- Data type for simplified Javascript expressions
--
data JS
  -- |
  -- A numeric literal
  --
  = JSNumericLiteral Number
  -- |
  -- A string literal
  --
  | JSStringLiteral String
  -- |
  -- A boolean literal
  --
  | JSBooleanLiteral Boolean
  -- |
  -- A unary operator application
  --
  | JSUnary UnaryOperator JS
  -- |
  -- A binary operator application
  --
  | JSBinary BinaryOperator JS JS
  -- |
  -- An array literal
  --
  | JSArrayLiteral [JS]
  -- |
  -- An array indexer expression
  --
  | JSIndexer JS JS
  -- |
  -- An object literal
  --
  | JSObjectLiteral [Tuple String JS]
  -- |
  -- An object property accessor expression
  --
  | JSAccessor String JS
  -- |
  -- A function introduction (optional name, arguments, body)
  --
  | JSFunction (Maybe String) [String] JS
  -- |
  -- Function application
  --
  | JSApp JS [JS]
  -- |
  -- Variable
  --
  | JSVar String
  -- |
  -- Conditional expression
  --
  | JSConditional JS JS JS
  -- |
  -- A block of expressions in braces
  --
  | JSBlock [JS]
  -- |
  -- A variable introduction and optional initialization
  --
  | JSVariableIntroduction String (Maybe JS)
  -- |
  -- A variable assignment
  --
  | JSAssignment JS JS
  -- |
  -- While loop
  --
  | JSWhile JS JS
  -- |
  -- For loop
  --
  | JSFor String JS JS JS
  -- |
  -- ForIn loop
  --
  | JSForIn String JS JS
  -- |
  -- If-then-else statement
  --
  | JSIfElse JS JS (Maybe JS)
  -- |
  -- Return statement
  --
  | JSReturn JS
  -- |
  -- Throw statement
  --
  | JSThrow JS
  -- |
  -- Type-Of operator
  --
  | JSTypeOf JS
  -- |
  -- Labelled statement
  --
  | JSLabel String JS
  -- |
  -- Break statement
  --
  | JSBreak String
  -- |
  -- Continue statement
  --
  | JSContinue String
  -- |
  -- Raw Javascript (for an inline foreign import declarations)
  --
  | JSRaw String

instance showJS :: Show JS where
  show (JSNumericLiteral n) = "JSNumericLiteral (" ++ show n ++ ")"
  show (JSStringLiteral s) = "JSStringLiteral (" ++ show s ++ ")"
  show (JSBooleanLiteral b) = "JSBooleanLiteral (" ++ show b ++ ")"
  show (JSUnary op js) = "JSUnary (" ++ show op ++ ") (" ++ show js ++ ")"
  show (JSBinary op js1 js2) = "JSBinary (" ++ show op ++ ") (" ++ show js1 ++ ") (" ++ show js2 ++ ")"
  show (JSArrayLiteral js) = "JSArrayLiteral (" ++ show js ++ ")"
  show (JSIndexer js1 js2) = "JSIndexer (" ++ show js1 ++ ") (" ++ show js2 ++ ")"
  show (JSObjectLiteral ps) = "JSObjectLiteral (" ++ show ps ++ ")"
  show (JSAccessor prop js) = "JSAccessor (" ++ show prop ++ ") (" ++ show js ++ ")"
  show (JSFunction nm args js) = "JSFunction (" ++ show nm ++ ") (" ++ show args ++ ") (" ++ show js ++ ")"
  show (JSApp js args) = "JSApp (" ++ show js ++ ") (" ++ show args ++ ")"
  show (JSVar nm) = "JSVar (" ++ show nm ++ ")"
  show (JSConditional js1 js2 js3) = "JSConditional (" ++ show js1 ++ ") (" ++ show js2 ++ ") (" ++ show js3 ++ ")"
  show (JSBlock js) = "JSBlock (" ++ show js ++ ")"
  show (JSVariableIntroduction nm js) = "JSVariableIntroduction (" ++ show nm ++ ") (" ++ show js ++ ")"
  show (JSAssignment js1 js2) = "JSAssignment (" ++ show js1 ++ ") (" ++ show js2 ++ ")"
  show (JSWhile js1 js2) = "JSWhile (" ++ show js1 ++ ") (" ++ show js2 ++ ")"
  show (JSFor nm js1 js2 js3) = "JSFor (" ++ show nm ++ ") (" ++ show js1 ++ ") (" ++ show js2 ++ ") (" ++ show js3 ++ ")"
  show (JSForIn nm js1 js2) = "JSForIn String (" ++ show nm ++ ") (" ++ show js1 ++ ") (" ++ show js2 ++ ")"
  show (JSIfElse js1 js2 js3) = "JSIfElse (" ++ show js1 ++ ") (" ++ show js2 ++ ") (" ++ show js3 ++ ")"
  show (JSReturn js) = "JSReturn (" ++ show js ++ ")"
  show (JSThrow js) = "JSThrow (" ++ show js ++ ")"
  show (JSTypeOf js) = "JSTypeOf (" ++ show js ++ ")"
  show (JSLabel lbl js) = "JSLabel (" ++ show lbl ++ ") (" ++ show js ++ ")"
  show (JSBreak lbl) = "JSBreak (" ++ show lbl ++ ")"
  show (JSContinue lbl) = "JSContinue (" ++ show lbl ++ ")"
  show (JSRaw js) = "JSRaw (" ++ show js ++ ")"

--
-- Traversals
--

everywhereOnJS :: (JS -> JS) -> JS -> JS
everywhereOnJS f = go
  where
  go :: JS -> JS
  go (JSUnary op j) = f (JSUnary op (go j))
  go (JSBinary op j1 j2) = f (JSBinary op (go j1) (go j2))
  go (JSArrayLiteral js) = f (JSArrayLiteral (map go js))
  go (JSIndexer j1 j2) = f (JSIndexer (go j1) (go j2))
  go (JSObjectLiteral js) = f (JSObjectLiteral (map ((<$>) go) js))
  go (JSAccessor prop j) = f (JSAccessor prop (go j))
  go (JSFunction name args j) = f (JSFunction name args (go j))
  go (JSApp j js) = f (JSApp (go j) (map go js))
  go (JSConditional j1 j2 j3) = f (JSConditional (go j1) (go j2) (go j3))
  go (JSBlock js) = f (JSBlock (map go js))
  go (JSVariableIntroduction name j) = f (JSVariableIntroduction name ((<$>) go j))
  go (JSAssignment j1 j2) = f (JSAssignment (go j1) (go j2))
  go (JSWhile j1 j2) = f (JSWhile (go j1) (go j2))
  go (JSFor name j1 j2 j3) = f (JSFor name (go j1) (go j2) (go j3))
  go (JSForIn name j1 j2) = f (JSForIn name (go j1) (go j2))
  go (JSIfElse j1 j2 j3) = f (JSIfElse (go j1) (go j2) ((<$>) go j3))
  go (JSReturn js) = f (JSReturn (go js))
  go (JSThrow js) = f (JSThrow (go js))
  go (JSTypeOf js) = f (JSTypeOf (go js))
  go (JSLabel name js) = f (JSLabel name (go js))
  go other = f other

everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS
everywhereOnJSTopDown f = go <<< f
  where
  go :: JS -> JS
  go (JSUnary op j) = JSUnary op (go (f j))
  go (JSBinary op j1 j2) = JSBinary op (go (f j1)) (go (f j2))
  go (JSArrayLiteral js) = JSArrayLiteral (map (go <<< f) js)
  go (JSIndexer j1 j2) = JSIndexer (go (f j1)) (go (f j2))
  go (JSObjectLiteral js) = JSObjectLiteral (map ((<$>) (go <<< f)) js)
  go (JSAccessor prop j) = JSAccessor prop (go (f j))
  go (JSFunction name args j) = JSFunction name args (go (f j))
  go (JSApp j js) = JSApp (go (f j)) (map (go <<< f) js)
  go (JSConditional j1 j2 j3) = JSConditional (go (f j1)) (go (f j2)) (go (f j3))
  go (JSBlock js) = JSBlock (map (go <<< f) js)
  go (JSVariableIntroduction name j) = JSVariableIntroduction name ((go <<< f) <$> j)
  go (JSAssignment j1 j2) = JSAssignment (go (f j1)) (go (f j2))
  go (JSWhile j1 j2) = JSWhile (go (f j1)) (go (f j2))
  go (JSFor name j1 j2 j3) = JSFor name (go (f j1)) (go (f j2)) (go (f j3))
  go (JSForIn name j1 j2) = JSForIn name (go (f j1)) (go (f j2))
  go (JSIfElse j1 j2 j3) = JSIfElse (go (f j1)) (go (f j2)) ((go <<< f) <$> j3)
  go (JSReturn j) = JSReturn (go (f j))
  go (JSThrow j) = JSThrow (go (f j))
  go (JSTypeOf j) = JSTypeOf (go (f j))
  go (JSLabel name j) = JSLabel name (go (f j))
  go other = f other

everythingOnJS :: forall r. (r -> r -> r) -> (JS -> r) -> JS -> r
everythingOnJS (<>) f = go
  where
  go j@(JSUnary _ j1) = f j <> go j1
  go j@(JSBinary _ j1 j2) = f j <> go j1 <> go j2
  go j@(JSArrayLiteral js) = foldl (<>) (f j) (map go js)
  go j@(JSIndexer j1 j2) = f j <> go j1 <> go j2
  go j@(JSObjectLiteral js) = foldl (<>) (f j) (map (go <<< snd) js)
  go j@(JSAccessor _ j1) = f j <> go j1
  go j@(JSFunction _ _ j1) = f j <> go j1
  go j@(JSApp j1 js) = foldl (<>) (f j <> go j1) (map go js)
  go j@(JSConditional j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
  go j@(JSBlock js) = foldl (<>) (f j) (map go js)
  go j@(JSVariableIntroduction _ (Just j1)) = f j <> go j1
  go j@(JSAssignment j1 j2) = f j <> go j1 <> go j2
  go j@(JSWhile j1 j2) = f j <> go j1 <> go j2
  go j@(JSFor _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
  go j@(JSForIn _ j1 j2) = f j <> go j1 <> go j2
  go j@(JSIfElse j1 j2 Nothing) = f j <> go j1 <> go j2
  go j@(JSIfElse j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3
  go j@(JSReturn j1) = f j <> go j1
  go j@(JSThrow j1) = f j <> go j1
  go j@(JSTypeOf j1) = f j <> go j1
  go j@(JSLabel _ j1) = f j <> go j1
  go other = f other

module Language.PureScript.CodeGen.JS.AST where

import Data.Either
import Data.Maybe
import Data.Tuple

-- |
-- Built-in unary operators
--
data UnaryOperator
  -- |
  -- Numeric negation
  --
  = Negate
  -- |
  -- Boolean negation
  --
  | Not
  -- |
  -- Bitwise negation
  --
  | BitwiseNot
  -- |
  -- Numeric unary \'plus\'
  --
  | Positive

instance showUnaryOperator :: Show UnaryOperator where
  show Negate = "Negate"
  show Not = "Not"
  show BitwiseNot = "BitwiseNot"
  show Positive = "Positive"

instance eqUnaryOperator :: Eq UnaryOperator where
  (==) Negate     Negate     = true
  (==) Not        Not        = true
  (==) BitwiseNot BitwiseNot = true
  (==) Positive   Positive   = true
  (==) _          _          = false
  (/=) u1         u2         = not (u1 == u2)

-- |
-- Built-in binary operators
--
data BinaryOperator
  -- |
  -- Numeric addition
  --
  = Add
  -- |
  -- Numeric subtraction
  --
  | Subtract
  -- |
  -- Numeric multiplication
  --
  | Multiply
  -- |
  -- Numeric division
  --
  | Divide
  -- |
  -- Remainder
  --
  | Modulus
  -- |
  -- Generic equality test
  --
  | EqualTo
  -- |
  -- Generic inequality test
  --
  | NotEqualTo
  -- |
  -- Numeric less-than
  --
  | LessThan
  -- |
  -- Numeric less-than-or-equal
  --
  | LessThanOrEqualTo
  -- |
  -- Numeric greater-than
  --
  | GreaterThan
  -- |
  -- Numeric greater-than-or-equal
  --
  | GreaterThanOrEqualTo
  -- |
  -- Boolean and
  --
  | And
  -- |
  -- Boolean or
  --
  | Or
  -- |
  -- Bitwise and
  --
  | BitwiseAnd
  -- |
  -- Bitwise or
  --
  | BitwiseOr
  -- |
  -- Bitwise xor
  --
  | BitwiseXor
  -- |
  -- Bitwise left shift
  --
  | ShiftLeft
  -- |
  -- Bitwise right shift
  --
  | ShiftRight
  -- |
  -- Bitwise right shift with zero-fill
  --
  | ZeroFillShiftRight

instance showBinaryOperator :: Show BinaryOperator where
  show Add                   = "Add"
  show Subtract              = "Subtract"
  show Multiply              = "Multiply"
  show Divide                = "Divide"
  show Modulus               = "Modulus"
  show EqualTo               = "EqualTo"
  show NotEqualTo            = "NotEqualTo"
  show LessThan              = "LessThan"
  show LessThanOrEqualTo     = "LessThanOrEqualTo"
  show GreaterThan           = "GreaterThan"
  show GreaterThanOrEqualTo  = "GreaterThanOrEqualTo"
  show And                   = "And"
  show Or                    = "Or"
  show BitwiseAnd            = "BitwiseAnd"
  show BitwiseOr             = "BitwiseOr"
  show BitwiseXor            = "BitwiseXor"
  show ShiftLeft             = "ShiftLeft"
  show ShiftRight            = "ShiftRight"
  show ZeroFillShiftRight    = "ZeroFillShiftRight"

instance eqBinaryOperator :: Eq BinaryOperator where
  (==) Add                  Add                  = true
  (==) Subtract             Subtract             = true
  (==) Multiply             Multiply             = true
  (==) Divide               Divide               = true
  (==) Modulus              Modulus              = true
  (==) EqualTo              EqualTo              = true
  (==) NotEqualTo           NotEqualTo           = true
  (==) LessThan             LessThan             = true
  (==) LessThanOrEqualTo    LessThanOrEqualTo    = true
  (==) GreaterThan          GreaterThan          = true
  (==) GreaterThanOrEqualTo GreaterThanOrEqualTo = true
  (==) And                  And                  = true
  (==) Or                   Or                   = true
  (==) BitwiseAnd           BitwiseAnd           = true
  (==) BitwiseOr            BitwiseOr            = true
  (==) BitwiseXor           BitwiseXor           = true
  (==) ShiftLeft            ShiftLeft            = true
  (==) ShiftRight           ShiftRight           = true
  (==) ZeroFillShiftRight   ZeroFillShiftRight   = true
  (==) _                    _                    = false
  (/=) b1                   b2                   = not (b1 == b2)

-- |
-- Data type for simplified Javascript expressions
--
data JS
  -- |
  -- A numeric literal
  --
  = JSNumericLiteral Number
  -- |
  -- A string literal
  --
  | JSStringLiteral String
  -- |
  -- A boolean literal
  --
  | JSBooleanLiteral Boolean
  -- |
  -- A unary operator application
  --
  | JSUnary UnaryOperator JS
  -- |
  -- A binary operator application
  --
  | JSBinary BinaryOperator JS JS
  -- |
  -- An array literal
  --
  | JSArrayLiteral [JS]
  -- |
  -- An array indexer expression
  --
  | JSIndexer JS JS
  -- |
  -- An object literal
  --
  | JSObjectLiteral [Tuple String JS]
  -- |
  -- An object property accessor expression
  --
  | JSAccessor String JS
  -- |
  -- A function introduction (optional name, arguments, body)
  --
  | JSFunction (Maybe String) [String] JS
  -- |
  -- Function application
  --
  | JSApp JS [JS]
  -- |
  -- Variable
  --
  | JSVar String
  -- |
  -- Conditional expression
  --
  | JSConditional JS JS JS
  -- |
  -- A block of expressions in braces
  --
  | JSBlock [JS]
  -- |
  -- A variable introduction and optional initialization
  --
  | JSVariableIntroduction String (Maybe JS)
  -- |
  -- A variable assignment
  --
  | JSAssignment JS JS
  -- |
  -- While loop
  --
  | JSWhile JS JS
  -- |
  -- For loop
  --
  | JSFor String JS JS JS
  -- |
  -- ForIn loop
  --
  | JSForIn String JS JS
  -- |
  -- If-then-else statement
  --
  | JSIfElse JS JS (Maybe JS)
  -- |
  -- Return statement
  --
  | JSReturn JS
  -- |
  -- Throw statement
  --
  | JSThrow JS
  -- |
  -- Type-Of operator
  --
  | JSTypeOf JS
  -- |
  -- Labelled statement
  --
  | JSLabel String JS
  -- |
  -- Break statement
  --
  | JSBreak String
  -- |
  -- Continue statement
  --
  | JSContinue String
  -- |
  -- Raw Javascript (for an inline foreign import declarations)
  --
  | JSRaw String

instance showJS :: Show JS where
  show (JSNumericLiteral n) = "JSNumericLiteral (" ++ show n ++ ")"
  show (JSStringLiteral s) = "JSStringLiteral (" ++ show s ++ ")"
  show (JSBooleanLiteral b) = "JSBooleanLiteral (" ++ show b ++ ")"
  show (JSUnary op js) = "JSUnary (" ++ show op ++ ") (" ++ show js ++ ")"
  show (JSBinary op js1 js2) = "JSBinary (" ++ show op ++ ") (" ++ show js1 ++ ") (" ++ show js2 ++ ")"
  show (JSArrayLiteral js) = "JSArrayLiteral (" ++ show js ++ ")"
  show (JSIndexer js1 js2) = "JSIndexer (" ++ show js1 ++ ") (" ++ show js2 ++ ")"
  show (JSObjectLiteral ps) = "JSObjectLiteral (" ++ show ps ++ ")"
  show (JSAccessor prop js) = "JSAccessor (" ++ show prop ++ ") (" ++ show js ++ ")"
  show (JSFunction nm args js) = "JSFunction (" ++ show nm ++ ") (" ++ show args ++ ") (" ++ show js ++ ")"
  show (JSApp js args) = "JSApp (" ++ show js ++ ") (" ++ show args ++ ")"
  show (JSVar nm) = "JSVar (" ++ show nm ++ ")"
  show (JSConditional js1 js2 js3) = "JSConditional (" ++ show js1 ++ ") (" ++ show js2 ++ ") (" ++ show js3 ++ ")"
  show (JSBlock js) = "JSBlock (" ++ show js ++ ")"
  show (JSVariableIntroduction nm js) = "JSVariableIntroduction (" ++ show nm ++ ") (" ++ show js ++ ")"
  show (JSAssignment js1 js2) = "JSAssignment (" ++ show js1 ++ ") (" ++ show js2 ++ ")"
  show (JSWhile js1 js2) = "JSWhile (" ++ show js1 ++ ") (" ++ show js2 ++ ")"
  show (JSFor nm js1 js2 js3) = "JSFor (" ++ show nm ++ ") (" ++ show js1 ++ ") (" ++ show js2 ++ ") (" ++ show js3 ++ ")"
  show (JSForIn nm js1 js2) = "JSForIn String (" ++ show nm ++ ") (" ++ show js1 ++ ") (" ++ show js2 ++ ")"
  show (JSIfElse js1 js2 js3) = "JSIfElse (" ++ show js1 ++ ") (" ++ show js2 ++ ") (" ++ show js3 ++ ")"
  show (JSReturn js) = "JSReturn (" ++ show js ++ ")"
  show (JSThrow js) = "JSThrow (" ++ show js ++ ")"
  show (JSTypeOf js) = "JSTypeOf (" ++ show js ++ ")"
  show (JSLabel lbl js) = "JSLabel (" ++ show lbl ++ ") (" ++ show js ++ ")"
  show (JSBreak lbl) = "JSBreak (" ++ show lbl ++ ")"
  show (JSContinue lbl) = "JSContinue (" ++ show lbl ++ ")"
  show (JSRaw js) = "JSRaw (" ++ show js ++ ")"


[CSM-483] Linear-time chunk concatenation

module Daedalus.BackendApi where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Eff.Exception (error, Error, EXCEPTION)
import Control.Monad.Eff.Ref.Unsafe (unsafeRunRef)
import Control.Monad.Eff.Ref (modifyRef, newRef, readRef)
import Control.Monad.Error.Class (throwError)
import Daedalus.Types (CId, _address, _ccoin, CAccount, CTx, CAccountMeta, CTxId, CTxMeta, _ctxIdValue, WalletError, CProfile, CAccountInit, CUpdateInfo, SoftwareVersion, CWalletRedeem, SyncProgress, CInitialized, CPassPhrase, _passPhrase, CCoin, CPaperVendWalletRedeem, Wal, CWallet, CWalletInit, walletAddressToUrl, CAccountId, CAddress, Addr, CWalletMeta)
import Data.Argonaut.Parser (jsonParser)
import Data.Argonaut.Generic.Aeson (decodeJson, encodeJson)
import Data.Bifunctor (lmap)
import Data.Either (either, Either(Left))
import Data.Functor (void)
import Data.FormURLEncoded (fromArray, encode)
import Data.Generic (class Generic, gShow)
import Data.HTTP.Method (Method(GET, POST, PUT, DELETE))
import Data.Maybe (Maybe)
import Data.Monoid (mempty)
import Data.String (joinWith)
import Data.List.Lazy (cons, nil, reverse, toUnfoldable)
import Data.Tuple (Tuple (..))
import Data.StrMap (fromFoldable)
import Daedalus.TLS (TLSOptions)
import Node.HTTP.Client (method, path, request, statusCode, statusMessage, Response, responseAsStream, headers, RequestHeaders (..), Request, requestAsStream)
import Data.Options ((:=))
import Node.Encoding (Encoding (UTF8))
import Node.Stream (onDataString, onEnd, onError, writeString, end)
import Node.HTTP (HTTP)

-- HELPERS

type URLPath = Tuple (Array String) QueryParams
type URL = String
type QueryParam = Tuple String (Maybe String)
type QueryParams = Array QueryParam
type FilePath = String

noQueryParam :: Array String -> URLPath
noQueryParam = flip Tuple mempty

queryParams :: Array String -> QueryParams -> URLPath
queryParams = Tuple

qParam :: String -> Maybe String -> QueryParam
qParam = Tuple

mkUrl :: URLPath -> URL
mkUrl (Tuple urlPath params) = joinWith "/" urlPath <> "?" <> encode (fromArray params)

backendApi :: URLPath -> URL
backendApi = mkUrl <<< lmap ((<>) ["/api"])

data ApiError
    = HTTPStatusError Response
    | JSONDecodingError String
    | ServerError WalletError

instance showApiError :: Show ApiError where
    show (HTTPStatusError res) =
        "HTTPStatusError: " <> show (statusCode res) <> " msg: " <> statusMessage res
    show (JSONDecodingError e) =
        "JSONDecodingError: " <> show e
    show (ServerError e) =
        "ServerError: " <> gShow e

-- REQUESTS HELPERS

decodeResult :: forall a. Generic a => String -> Either Error a
decodeResult = either (Left <<< mkJSONError) (lmap mkServerError) <<< decodeJson <=< lmap error <<< jsonParser
  where
    mkJSONError = error <<< show <<< JSONDecodingError
    mkServerError = error <<< show <<< ServerError

responseToString :: forall eff. Response -> Aff (http :: HTTP, exception :: EXCEPTION | eff) String
responseToString res = makeAff $ \withError withSuccess -> do
    let stream = responseAsStream res
    onError stream withError
    buf <- unsafeRunRef $ newRef nil
    onDataString stream UTF8 $ \strChunk -> do
        void $ unsafeRunRef $ modifyRef buf (cons strChunk)
    onEnd stream $ do
        strChunksReversed <- unsafeRunRef $ readRef buf
        let s = (joinWith "" <<< toUnfoldable <<< reverse) strChunksReversed
        withSuccess s

makeRequest :: forall eff a. Generic a => (Request -> Eff (http :: HTTP, exception :: EXCEPTION | eff) Unit)
    -> TLSOptions -> URLPath -> Aff (http :: HTTP, exception :: EXCEPTION | eff) a
makeRequest withReq tls urlPath = do
    -- FIXME: exceptin shouldn't happen here?
    res <- makeAff $ const $ withReq <=< request (tls <> path := backendApi urlPath)
    when (isHttpError res) $
        throwError <<< error <<< show $ HTTPStatusError res
    rawData <- responseToString res
    either throwError pure $ decodeResult rawData
  where
    isHttpError res = statusCode res >= 400

plainRequest :: forall eff a. Generic a => TLSOptions -> URLPath -> Aff (http :: HTTP, exception :: EXCEPTION | eff) a
plainRequest = makeRequest $ flip end (pure unit) <<< requestAsStream

bodyRequest :: forall eff a b. Generic a => Generic b => TLSOptions -> URLPath -> b -> Aff (http :: HTTP, exception :: EXCEPTION | eff) a
bodyRequest tls urlPath body = makeRequest flushBody (tls <> headers := reqHeaders) urlPath
  where
    flushBody req = do
        let writeStream = requestAsStream req
        _ <- writeString writeStream UTF8 (show $ encodeJson body) $ pure unit
        end writeStream $ pure unit
    -- TODO: use Data.MediaType.Common here
    reqHeaders = RequestHeaders $ fromFoldable [Tuple "Content-Type" "application/json"]

getR :: forall eff a. Generic a => TLSOptions -> URLPath -> Aff (http :: HTTP, exception :: EXCEPTION | eff) a
getR tls = plainRequest $ tls <> method := (show GET)

postR :: forall eff a. Generic a => TLSOptions -> URLPath -> Aff (http :: HTTP, exception :: EXCEPTION | eff) a
postR tls = plainRequest $ tls <> method := (show POST)

postRBody :: forall eff a b. Generic a => Generic b => TLSOptions -> URLPath -> b -> Aff (http :: HTTP, exception :: EXCEPTION | eff) a
postRBody tls urlPath = flip bodyRequest urlPath $ tls <> method  := (show POST)

putRBody :: forall eff a b. Generic a => Generic b => TLSOptions -> URLPath -> b -> Aff (http :: HTTP, exception :: EXCEPTION | eff) a
putRBody tls urlPath = flip bodyRequest urlPath $ tls <> method  := (show PUT)

deleteR :: forall eff a. Generic a => TLSOptions -> URLPath -> Aff (http :: HTTP, exception :: EXCEPTION | eff) a
deleteR tls = plainRequest $ tls <> method := (show DELETE)

-- REQUESTS
--------------------------------------------------------------------------------
-- Test ------------------------------------------------------------------------
testReset :: forall eff. TLSOptions -> Aff (http :: HTTP, exception :: EXCEPTION | eff) Unit
testReset tls = postR tls $ noQueryParam ["test", "reset"]
--------------------------------------------------------------------------------
-- Wallets ---------------------------------------------------------------------
getWallet :: forall eff. TLSOptions -> CId Wal -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CWallet
getWallet tls addr = getR tls $ noQueryParam ["wallets", _address addr]

getWallets :: forall eff. TLSOptions -> Aff (http :: HTTP, exception :: EXCEPTION | eff) (Array CWallet)
getWallets tls = getR tls $ noQueryParam ["wallets"]

newWallet :: forall eff. TLSOptions -> Maybe CPassPhrase -> CWalletInit -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CWallet
newWallet tls pass = postRBody tls $ queryParams ["wallets", "new"] [qParam "passphrase" $ _passPhrase <$> pass]

updateWallet :: forall eff. TLSOptions -> CId Wal -> CWalletMeta -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CWallet
updateWallet tls wId = putRBody tls $ noQueryParam ["wallets", _address wId]

restoreWallet :: forall eff. TLSOptions -> Maybe CPassPhrase -> CWalletInit -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CWallet
restoreWallet tls pass = postRBody tls $ queryParams ["wallets", "restore"] [qParam "passphrase" $ _passPhrase <$> pass]

renameWalletSet :: forall eff. TLSOptions -> CId Wal -> String -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CWallet
renameWalletSet tls wSetId name = postR tls $ noQueryParam ["wallets", "rename", _address wSetId, name]

importWallet :: forall eff. TLSOptions -> Maybe CPassPhrase -> FilePath -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CWallet
importWallet tls pass = postRBody tls $ queryParams ["wallets", "keys"] [qParam "passphrase" $ _passPhrase <$> pass]

changeWalletPass :: forall eff. TLSOptions -> CId Wal -> Maybe CPassPhrase -> Maybe CPassPhrase -> Aff (http :: HTTP, exception :: EXCEPTION | eff) Unit
changeWalletPass tls wSetId old new = postR tls $ queryParams ["wallets", "password", _address wSetId] [qParam "old" $ _passPhrase <$> old, qParam "new" $ _passPhrase <$> new]

deleteWallet :: forall eff. TLSOptions -> CId Wal -> Aff (http :: HTTP, exception :: EXCEPTION | eff) Unit
deleteWallet tls wSetId = deleteR tls $ noQueryParam ["wallets", _address wSetId]
--------------------------------------------------------------------------------
-- Accounts --------------------------------------------------------------------

getAccount :: forall eff. TLSOptions -> CAccountId -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CAccount
getAccount tls wId = getR tls $ noQueryParam ["accounts", walletAddressToUrl wId]

getAccounts :: forall eff. TLSOptions -> Maybe (CId Wal) -> Aff (http :: HTTP, exception :: EXCEPTION | eff) (Array CAccount)
getAccounts tls addr = getR tls $ queryParams ["accounts"] [qParam "accountId" $ _address <$> addr]

updateAccount :: forall eff. TLSOptions -> CAccountId -> CAccountMeta -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CAccount
updateAccount tls wId = putRBody tls $ noQueryParam ["accounts", walletAddressToUrl wId]

newAccount :: forall eff. TLSOptions -> Maybe CPassPhrase -> CAccountInit -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CAccount
newAccount tls pass = postRBody tls $ queryParams ["accounts"] [qParam "passphrase" $ _passPhrase <$> pass]

deleteAccount :: forall eff. TLSOptions -> CAccountId -> Aff (http :: HTTP, exception :: EXCEPTION | eff) Unit
deleteAccount tls wId = deleteR tls $ noQueryParam ["accounts", walletAddressToUrl wId]

--------------------------------------------------------------------------------
-- Wallet addresses ------------------------------------------------------------

newAddress :: forall eff. TLSOptions -> Maybe CPassPhrase -> CAccountId -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CAddress
newAddress tls pass = postRBody tls $ queryParams ["addresses"] [qParam "passphrase" $ _passPhrase <$> pass]

--------------------------------------------------------------------------------
-- Addresses -------------------------------------------------------------------

isValidAddress :: forall eff. TLSOptions -> String -> Aff (http :: HTTP, exception :: EXCEPTION | eff) Boolean
isValidAddress tls addr = getR tls $ noQueryParam ["addresses", addr]

--------------------------------------------------------------------------------
-- Profiles --------------------------------------------------------------------
getProfile :: forall eff. TLSOptions -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CProfile
getProfile tls = getR tls $ noQueryParam ["profile"]

updateProfile :: forall eff. TLSOptions -> CProfile -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CProfile
updateProfile tls = postRBody tls $ noQueryParam ["profile"]
--------------------------------------------------------------------------------
-- Transactions ----------------------------------------------------------------
newPayment :: forall eff. TLSOptions -> Maybe CPassPhrase -> CAccountId -> CId Addr -> CCoin -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CTx
newPayment tls pass addrFrom addrTo amount = postR tls $ queryParams ["txs", "payments", walletAddressToUrl addrFrom, _address addrTo, _ccoin amount] [qParam "passphrase" $ _passPhrase <$> pass]

txFee :: forall eff. TLSOptions -> CAccountId -> CId Addr -> CCoin -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CCoin
txFee tls addrFrom addrTo amount = getR tls $ noQueryParam ["txs", "fee", walletAddressToUrl addrFrom, _address addrTo, _ccoin amount]

updateTransaction :: forall eff. TLSOptions -> CAccountId -> CTxId -> CTxMeta -> Aff (http :: HTTP, exception :: EXCEPTION | eff) Unit
updateTransaction tls addr ctxId = postRBody tls $ noQueryParam ["txs", "payments", walletAddressToUrl addr, _ctxIdValue ctxId]

getHistory
  :: forall eff.
     TLSOptions
  -> Maybe (CId Wal)
  -> Maybe CAccountId
  -> Maybe (CId Addr)
  -> Maybe Int
  -> Maybe Int
  -> Aff (http :: HTTP, exception :: EXCEPTION | eff) (Tuple (Array CTx) Int)
getHistory tls walletId accountId addr skip limit =
  getR tls $ queryParams
  ["txs", "histories"]
  [ qParam "walletId" $ _address <$> walletId
  , qParam "accountId" $ walletAddressToUrl <$> accountId
  , qParam "address" $ _address <$> addr
  , qParam "skip" $ show <$> skip
  , qParam "limit" $ show <$> limit
  ]

--------------------------------------------------------------------------------
-- Updates ---------------------------------------------------------------------
nextUpdate :: forall eff. TLSOptions -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CUpdateInfo
nextUpdate tls = getR tls $ noQueryParam ["update"]

postponeUpdate :: forall eff. TLSOptions -> Aff (http :: HTTP, exception :: EXCEPTION | eff) Unit
postponeUpdate tls = postR tls $ noQueryParam ["update", "postpone"]

applyUpdate :: forall eff. TLSOptions -> Aff (http :: HTTP, exception :: EXCEPTION | eff) Unit
applyUpdate tls = postR tls $ noQueryParam ["update", "apply"]

--------------------------------------------------------------------------------
-- Redemptions -----------------------------------------------------------------
redeemAda :: forall eff. TLSOptions -> Maybe CPassPhrase -> CWalletRedeem -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CTx
redeemAda tls pass = postRBody tls $ queryParams ["redemptions", "ada"] [qParam "passphrase" $ _passPhrase <$> pass]

redeemAdaPaperVend :: forall eff. TLSOptions -> Maybe CPassPhrase -> CPaperVendWalletRedeem -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CTx
redeemAdaPaperVend tls pass = postRBody tls $ queryParams ["papervend", "redemptions", "ada"] [qParam "passphrase" $ _passPhrase <$> pass]

--------------------------------------------------------------------------------
-- REPORTING -------------------------------------------------------------------
reportInit :: forall eff. TLSOptions -> CInitialized -> Aff (http :: HTTP, exception :: EXCEPTION | eff) Unit
reportInit tls = postRBody tls $ noQueryParam ["reporting", "initialized"]

--------------------------------------------------------------------------------
-- SETTINGS --------------------------------------------------------------------
blockchainSlotDuration :: forall eff. TLSOptions -> Aff (http :: HTTP, exception :: EXCEPTION | eff) Int
blockchainSlotDuration tls = getR tls $ noQueryParam ["settings", "slots", "duration"]

systemVersion :: forall eff. TLSOptions -> Aff (http :: HTTP, exception :: EXCEPTION | eff) SoftwareVersion
systemVersion tls = getR tls $ noQueryParam ["settings", "version"]

syncProgress :: forall eff. TLSOptions -> Aff (http :: HTTP, exception :: EXCEPTION | eff) SyncProgress
syncProgress tls = getR tls $ noQueryParam ["settings", "sync", "progress"]

--------------------------------------------------------------------------------
-- JSON BACKUP -----------------------------------------------------------------
importBackupJSON :: forall eff. TLSOptions -> String -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CWallet
importBackupJSON tls = postRBody tls $ noQueryParam ["backup", "import"]

exportBackupJSON :: forall eff. TLSOptions -> CId Wal -> String -> Aff (http :: HTTP, exception :: EXCEPTION | eff) Unit
exportBackupJSON tls addr = postRBody tls $ noQueryParam ["backup", "export", _address addr]

module Daedalus.BackendApi where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Eff.Exception (error, Error, EXCEPTION)
import Control.Monad.Eff.Ref.Unsafe (unsafeRunRef)
import Control.Monad.Eff.Ref (modifyRef, newRef, readRef)
import Control.Monad.Error.Class (throwError)
import Daedalus.Types (CId, _address, _ccoin, CAccount, CTx, CAccountMeta, CTxId, CTxMeta, _ctxIdValue, WalletError, CProfile, CAccountInit, CUpdateInfo, SoftwareVersion, CWalletRedeem, SyncProgress, CInitialized, CPassPhrase, _passPhrase, CCoin, CPaperVendWalletRedeem, Wal, CWallet, CWalletInit, walletAddressToUrl, CAccountId, CAddress, Addr, CWalletMeta)
import Data.Argonaut.Parser (jsonParser)
import Data.Argonaut.Generic.Aeson (decodeJson, encodeJson)
import Data.Bifunctor (lmap)
import Data.Either (either, Either(Left))
import Data.Functor (void)
import Data.FormURLEncoded (fromArray, encode)
import Data.Generic (class Generic, gShow)
import Data.HTTP.Method (Method(GET, POST, PUT, DELETE))
import Data.Maybe (Maybe)
import Data.Monoid (mempty)
import Data.String (joinWith)
import Data.Tuple (Tuple (..))
import Data.StrMap (fromFoldable)
import Daedalus.TLS (TLSOptions)
import Node.HTTP.Client (method, path, request, statusCode, statusMessage, Response, responseAsStream, headers, RequestHeaders (..), Request, requestAsStream)
import Data.Options ((:=))
import Node.Encoding (Encoding (UTF8))
import Node.Stream (onDataString, onEnd, onError, writeString, end)
import Node.HTTP (HTTP)

-- HELPERS

type URLPath = Tuple (Array String) QueryParams
type URL = String
type QueryParam = Tuple String (Maybe String)
type QueryParams = Array QueryParam
type FilePath = String

noQueryParam :: Array String -> URLPath
noQueryParam = flip Tuple mempty

queryParams :: Array String -> QueryParams -> URLPath
queryParams = Tuple

qParam :: String -> Maybe String -> QueryParam
qParam = Tuple

mkUrl :: URLPath -> URL
mkUrl (Tuple urlPath params) = joinWith "/" urlPath <> "?" <> encode (fromArray params)

backendApi :: URLPath -> URL
backendApi = mkUrl <<< lmap ((<>) ["/api"])

data ApiError
    = HTTPStatusError Response
    | JSONDecodingError String
    | ServerError WalletError

instance showApiError :: Show ApiError where
    show (HTTPStatusError res) =
        "HTTPStatusError: " <> show (statusCode res) <> " msg: " <> statusMessage res
    show (JSONDecodingError e) =
        "JSONDecodingError: " <> show e
    show (ServerError e) =
        "ServerError: " <> gShow e

-- REQUESTS HELPERS

decodeResult :: forall a. Generic a => String -> Either Error a
decodeResult = either (Left <<< mkJSONError) (lmap mkServerError) <<< decodeJson <=< lmap error <<< jsonParser
  where
    mkJSONError = error <<< show <<< JSONDecodingError
    mkServerError = error <<< show <<< ServerError

responseToString :: forall eff. Response -> Aff (http :: HTTP, exception :: EXCEPTION | eff) String
responseToString res = makeAff $ \withError withSuccess -> do
    let stream = responseAsStream res
    onError stream withError
    buf <- unsafeRunRef $ newRef ""
    onDataString stream UTF8 $ \strChunk -> do
        void $ unsafeRunRef $ modifyRef buf (\s -> s <> strChunk)
    onEnd stream $ do
        s <- unsafeRunRef $ readRef buf
        withSuccess s

makeRequest :: forall eff a. Generic a => (Request -> Eff (http :: HTTP, exception :: EXCEPTION | eff) Unit)
    -> TLSOptions -> URLPath -> Aff (http :: HTTP, exception :: EXCEPTION | eff) a
makeRequest withReq tls urlPath = do
    -- FIXME: exceptin shouldn't happen here?
    res <- makeAff $ const $ withReq <=< request (tls <> path := backendApi urlPath)
    when (isHttpError res) $
        throwError <<< error <<< show $ HTTPStatusError res
    rawData <- responseToString res
    either throwError pure $ decodeResult rawData
  where
    isHttpError res = statusCode res >= 400

plainRequest :: forall eff a. Generic a => TLSOptions -> URLPath -> Aff (http :: HTTP, exception :: EXCEPTION | eff) a
plainRequest = makeRequest $ flip end (pure unit) <<< requestAsStream

bodyRequest :: forall eff a b. Generic a => Generic b => TLSOptions -> URLPath -> b -> Aff (http :: HTTP, exception :: EXCEPTION | eff) a
bodyRequest tls urlPath body = makeRequest flushBody (tls <> headers := reqHeaders) urlPath
  where
    flushBody req = do
        let writeStream = requestAsStream req
        _ <- writeString writeStream UTF8 (show $ encodeJson body) $ pure unit
        end writeStream $ pure unit
    -- TODO: use Data.MediaType.Common here
    reqHeaders = RequestHeaders $ fromFoldable [Tuple "Content-Type" "application/json"]

getR :: forall eff a. Generic a => TLSOptions -> URLPath -> Aff (http :: HTTP, exception :: EXCEPTION | eff) a
getR tls = plainRequest $ tls <> method := (show GET)

postR :: forall eff a. Generic a => TLSOptions -> URLPath -> Aff (http :: HTTP, exception :: EXCEPTION | eff) a
postR tls = plainRequest $ tls <> method := (show POST)

postRBody :: forall eff a b. Generic a => Generic b => TLSOptions -> URLPath -> b -> Aff (http :: HTTP, exception :: EXCEPTION | eff) a
postRBody tls urlPath = flip bodyRequest urlPath $ tls <> method  := (show POST)

putRBody :: forall eff a b. Generic a => Generic b => TLSOptions -> URLPath -> b -> Aff (http :: HTTP, exception :: EXCEPTION | eff) a
putRBody tls urlPath = flip bodyRequest urlPath $ tls <> method  := (show PUT)

deleteR :: forall eff a. Generic a => TLSOptions -> URLPath -> Aff (http :: HTTP, exception :: EXCEPTION | eff) a
deleteR tls = plainRequest $ tls <> method := (show DELETE)

-- REQUESTS
--------------------------------------------------------------------------------
-- Test ------------------------------------------------------------------------
testReset :: forall eff. TLSOptions -> Aff (http :: HTTP, exception :: EXCEPTION | eff) Unit
testReset tls = postR tls $ noQueryParam ["test", "reset"]
--------------------------------------------------------------------------------
-- Wallets ---------------------------------------------------------------------
getWallet :: forall eff. TLSOptions -> CId Wal -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CWallet
getWallet tls addr = getR tls $ noQueryParam ["wallets", _address addr]

getWallets :: forall eff. TLSOptions -> Aff (http :: HTTP, exception :: EXCEPTION | eff) (Array CWallet)
getWallets tls = getR tls $ noQueryParam ["wallets"]

newWallet :: forall eff. TLSOptions -> Maybe CPassPhrase -> CWalletInit -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CWallet
newWallet tls pass = postRBody tls $ queryParams ["wallets", "new"] [qParam "passphrase" $ _passPhrase <$> pass]

updateWallet :: forall eff. TLSOptions -> CId Wal -> CWalletMeta -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CWallet
updateWallet tls wId = putRBody tls $ noQueryParam ["wallets", _address wId]

restoreWallet :: forall eff. TLSOptions -> Maybe CPassPhrase -> CWalletInit -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CWallet
restoreWallet tls pass = postRBody tls $ queryParams ["wallets", "restore"] [qParam "passphrase" $ _passPhrase <$> pass]

renameWalletSet :: forall eff. TLSOptions -> CId Wal -> String -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CWallet
renameWalletSet tls wSetId name = postR tls $ noQueryParam ["wallets", "rename", _address wSetId, name]

importWallet :: forall eff. TLSOptions -> Maybe CPassPhrase -> FilePath -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CWallet
importWallet tls pass = postRBody tls $ queryParams ["wallets", "keys"] [qParam "passphrase" $ _passPhrase <$> pass]

changeWalletPass :: forall eff. TLSOptions -> CId Wal -> Maybe CPassPhrase -> Maybe CPassPhrase -> Aff (http :: HTTP, exception :: EXCEPTION | eff) Unit
changeWalletPass tls wSetId old new = postR tls $ queryParams ["wallets", "password", _address wSetId] [qParam "old" $ _passPhrase <$> old, qParam "new" $ _passPhrase <$> new]

deleteWallet :: forall eff. TLSOptions -> CId Wal -> Aff (http :: HTTP, exception :: EXCEPTION | eff) Unit
deleteWallet tls wSetId = deleteR tls $ noQueryParam ["wallets", _address wSetId]
--------------------------------------------------------------------------------
-- Accounts --------------------------------------------------------------------

getAccount :: forall eff. TLSOptions -> CAccountId -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CAccount
getAccount tls wId = getR tls $ noQueryParam ["accounts", walletAddressToUrl wId]

getAccounts :: forall eff. TLSOptions -> Maybe (CId Wal) -> Aff (http :: HTTP, exception :: EXCEPTION | eff) (Array CAccount)
getAccounts tls addr = getR tls $ queryParams ["accounts"] [qParam "accountId" $ _address <$> addr]

updateAccount :: forall eff. TLSOptions -> CAccountId -> CAccountMeta -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CAccount
updateAccount tls wId = putRBody tls $ noQueryParam ["accounts", walletAddressToUrl wId]

newAccount :: forall eff. TLSOptions -> Maybe CPassPhrase -> CAccountInit -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CAccount
newAccount tls pass = postRBody tls $ queryParams ["accounts"] [qParam "passphrase" $ _passPhrase <$> pass]

deleteAccount :: forall eff. TLSOptions -> CAccountId -> Aff (http :: HTTP, exception :: EXCEPTION | eff) Unit
deleteAccount tls wId = deleteR tls $ noQueryParam ["accounts", walletAddressToUrl wId]

--------------------------------------------------------------------------------
-- Wallet addresses ------------------------------------------------------------

newAddress :: forall eff. TLSOptions -> Maybe CPassPhrase -> CAccountId -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CAddress
newAddress tls pass = postRBody tls $ queryParams ["addresses"] [qParam "passphrase" $ _passPhrase <$> pass]

--------------------------------------------------------------------------------
-- Addresses -------------------------------------------------------------------

isValidAddress :: forall eff. TLSOptions -> String -> Aff (http :: HTTP, exception :: EXCEPTION | eff) Boolean
isValidAddress tls addr = getR tls $ noQueryParam ["addresses", addr]

--------------------------------------------------------------------------------
-- Profiles --------------------------------------------------------------------
getProfile :: forall eff. TLSOptions -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CProfile
getProfile tls = getR tls $ noQueryParam ["profile"]

updateProfile :: forall eff. TLSOptions -> CProfile -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CProfile
updateProfile tls = postRBody tls $ noQueryParam ["profile"]
--------------------------------------------------------------------------------
-- Transactions ----------------------------------------------------------------
newPayment :: forall eff. TLSOptions -> Maybe CPassPhrase -> CAccountId -> CId Addr -> CCoin -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CTx
newPayment tls pass addrFrom addrTo amount = postR tls $ queryParams ["txs", "payments", walletAddressToUrl addrFrom, _address addrTo, _ccoin amount] [qParam "passphrase" $ _passPhrase <$> pass]

txFee :: forall eff. TLSOptions -> CAccountId -> CId Addr -> CCoin -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CCoin
txFee tls addrFrom addrTo amount = getR tls $ noQueryParam ["txs", "fee", walletAddressToUrl addrFrom, _address addrTo, _ccoin amount]

updateTransaction :: forall eff. TLSOptions -> CAccountId -> CTxId -> CTxMeta -> Aff (http :: HTTP, exception :: EXCEPTION | eff) Unit
updateTransaction tls addr ctxId = postRBody tls $ noQueryParam ["txs", "payments", walletAddressToUrl addr, _ctxIdValue ctxId]

getHistory
  :: forall eff.
     TLSOptions
  -> Maybe (CId Wal)
  -> Maybe CAccountId
  -> Maybe (CId Addr)
  -> Maybe Int
  -> Maybe Int
  -> Aff (http :: HTTP, exception :: EXCEPTION | eff) (Tuple (Array CTx) Int)
getHistory tls walletId accountId addr skip limit =
  getR tls $ queryParams
  ["txs", "histories"]
  [ qParam "walletId" $ _address <$> walletId
  , qParam "accountId" $ walletAddressToUrl <$> accountId
  , qParam "address" $ _address <$> addr
  , qParam "skip" $ show <$> skip
  , qParam "limit" $ show <$> limit
  ]

--------------------------------------------------------------------------------
-- Updates ---------------------------------------------------------------------
nextUpdate :: forall eff. TLSOptions -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CUpdateInfo
nextUpdate tls = getR tls $ noQueryParam ["update"]

postponeUpdate :: forall eff. TLSOptions -> Aff (http :: HTTP, exception :: EXCEPTION | eff) Unit
postponeUpdate tls = postR tls $ noQueryParam ["update", "postpone"]

applyUpdate :: forall eff. TLSOptions -> Aff (http :: HTTP, exception :: EXCEPTION | eff) Unit
applyUpdate tls = postR tls $ noQueryParam ["update", "apply"]

--------------------------------------------------------------------------------
-- Redemptions -----------------------------------------------------------------
redeemAda :: forall eff. TLSOptions -> Maybe CPassPhrase -> CWalletRedeem -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CTx
redeemAda tls pass = postRBody tls $ queryParams ["redemptions", "ada"] [qParam "passphrase" $ _passPhrase <$> pass]

redeemAdaPaperVend :: forall eff. TLSOptions -> Maybe CPassPhrase -> CPaperVendWalletRedeem -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CTx
redeemAdaPaperVend tls pass = postRBody tls $ queryParams ["papervend", "redemptions", "ada"] [qParam "passphrase" $ _passPhrase <$> pass]

--------------------------------------------------------------------------------
-- REPORTING -------------------------------------------------------------------
reportInit :: forall eff. TLSOptions -> CInitialized -> Aff (http :: HTTP, exception :: EXCEPTION | eff) Unit
reportInit tls = postRBody tls $ noQueryParam ["reporting", "initialized"]

--------------------------------------------------------------------------------
-- SETTINGS --------------------------------------------------------------------
blockchainSlotDuration :: forall eff. TLSOptions -> Aff (http :: HTTP, exception :: EXCEPTION | eff) Int
blockchainSlotDuration tls = getR tls $ noQueryParam ["settings", "slots", "duration"]

systemVersion :: forall eff. TLSOptions -> Aff (http :: HTTP, exception :: EXCEPTION | eff) SoftwareVersion
systemVersion tls = getR tls $ noQueryParam ["settings", "version"]

syncProgress :: forall eff. TLSOptions -> Aff (http :: HTTP, exception :: EXCEPTION | eff) SyncProgress
syncProgress tls = getR tls $ noQueryParam ["settings", "sync", "progress"]

--------------------------------------------------------------------------------
-- JSON BACKUP -----------------------------------------------------------------
importBackupJSON :: forall eff. TLSOptions -> String -> Aff (http :: HTTP, exception :: EXCEPTION | eff) CWallet
importBackupJSON tls = postRBody tls $ noQueryParam ["backup", "import"]

exportBackupJSON :: forall eff. TLSOptions -> CId Wal -> String -> Aff (http :: HTTP, exception :: EXCEPTION | eff) Unit
exportBackupJSON tls addr = postRBody tls $ noQueryParam ["backup", "export", _address addr]


Remove confusing references to psc-ide-server


make the asteroids spin.

make the asteroids spin.

{- -*- Mode: Haskell -*- -}

module Asteroids where

import Math
import Debug.Trace
import Control.Monad
import Control.MonadPlus
import Control.Monad.Eff
import Control.Monad.Eff.Random
import Control.Monad.ST
import Graphics.Canvas

import Data.Array
import Data.Tuple
import Data.Foldable
import Data.Maybe.Unsafe
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Data.DOM.Simple.Events

data Phase = GameOver | Playing Ship | Crashing Ship Number | Respawning Number

type Moveable m = {
      x    :: Number
    , y    :: Number
    , dx   :: Number
    , dy   :: Number
    , r    :: Number | m }

type Ship = {
      x    :: Number
    , y    :: Number
    , dx   :: Number
    , dy   :: Number
    , r    :: Number
    , dir  :: Number
    }

type Asteroid = {
      x    :: Number
    , y    :: Number
    , dx   :: Number
    , dy   :: Number
    , r    :: Number
    , path :: [Number]
    , spin :: Number
    , dir  :: Number
    }

type Missile = {
      x    :: Number
    , y    :: Number
    , dx   :: Number
    , dy   :: Number
    , r    :: Number
    , fuse :: Number
    }

type Controls = {
      thrust :: Number
    , left   :: Boolean
    , right  :: Boolean
    }

type State = {
      w         :: Number
    , h         :: Number
    , phase     :: Phase
    , nships    :: Number
    , score     :: Number
    , asteroids :: [Asteroid]
    , missiles  :: [Missile]
    , controls  :: Controls
    }

main :: forall s e. Eff ( st :: ST s, dom :: DOM, canvas :: Canvas, random :: Random, trace :: Trace | e ) Unit
main = do
  w <- innerWidth globalWindow
  h <- innerHeight globalWindow

  let ship = defaultShip w h
      controls = { thrust: 0, left: false, right: false }

  asteroids <- replicateM 10 (randomAsteroid w h)

  st <- newSTRef { w: w, h: h
                 , phase: GameOver
                 , nships: 3
                 , score: 0
                 , asteroids: asteroids
                 , missiles: [ ]
                 , controls: controls }

  resize st
  addUIEventListener ResizeEvent (resize0 st) globalWindow

  addKeyboardEventListener KeydownEvent (keydown st) globalWindow
  addKeyboardEventListener KeyupEvent (keyup st) globalWindow
  addKeyboardEventListener KeypressEvent (keypress st) globalWindow

  setInterval globalWindow 33 $ tick st

  return unit

-- |Returns a new ship in the middle of the canvas.
defaultShip :: Number -> Number -> Ship
defaultShip w h = { x: w / 2, y: w / 2, dir: 0, dx: 0, dy: 0, r: 10 }

-- |The maximum speed we'll allow for a ship.
maxSpeed = 6.0

twoPi = 2 * pi

-- |Creates a randomly located asteroid somewhere on the canvas.
randomAsteroid :: forall e. Number -> Number -> Eff ( random :: Random | e ) Asteroid
randomAsteroid w h = do
  x  <- randomRange 0 w
  y  <- randomRange 0 h
  dx <- (*) <$> (randomRange 1 2) <*> randomSign
  dy <- (*) <$> (randomRange 1 2) <*> randomSign
  path <- replicateM 12 (randomRange 0.7 1.1)
  spin <- randomRange (-0.1) 0.1
  return { x: x, y: y, dx: dx, dy: dy, r: 50, path: path, spin: spin, dir: 0 }
      where randomRange lo hi = (\n -> lo + n * (hi - lo)) <$> random
            randomSign = (\n -> if n < 0.5 then (-1) else 1) <$> random

-- |Thunk to attach resize to the ResizeEvent
-- XXX WTF? Why do I need this?
resize0 :: forall s e. STRef s State -> DOMEvent -> (Eff (st :: ST s, dom :: DOM, canvas :: Canvas | e) Unit)
resize0 st _ = resize st

-- |Handles window resizing by stretching the canvas to fit the
-- viewport and updating our notion of how large the canvas is.
resize :: forall s e. STRef s State -> (Eff (st :: ST s, dom :: DOM, canvas :: Canvas | e) Unit)
resize st = do
  state <- readSTRef st
  w <- innerWidth globalWindow
  h <- innerHeight globalWindow
  canvas <- getCanvasElementById "canvas"
  setCanvasWidth w canvas
  setCanvasHeight h canvas
  modifySTRef st $ (\state -> state { w = w, h = h })
  return unit

-- |Handles key presses for keys that can be held down.
keydown :: forall s e. STRef s State -> DOMEvent -> Eff (st :: ST s, dom :: DOM | e) Unit
keydown st event = do
  code <- keyCode event
  modifySTRef st $ \state ->
      let controls = case code of
                       65  -> state.controls { left = true }
                       83  -> state.controls { right = true }
                       75  -> state.controls { thrust = 0.5 }
                       _   -> state.controls
      in state { controls = controls }

  return unit

-- |Handles key releases for keys that can be held down.
keyup :: forall s e. STRef s State -> DOMEvent -> Eff (st :: ST s, dom :: DOM | e) Unit
keyup st event = do
  code <- keyCode event
  modifySTRef st $ \state ->
      let controls = case code of
                       65  -> state.controls { left = false }
                       83  -> state.controls { right = false }
                       75  -> state.controls { thrust = 0.0 }
                       _   -> state.controls
      in state { controls = controls }

  return unit

-- |Handles single key presses.
keypress :: forall s e. STRef s State -> DOMEvent -> Eff (st :: ST s, dom :: DOM, random :: Random | e) Unit
keypress st event = do
  state <- readSTRef st
  k <- key event
  case state.phase of
    Playing ship | (k == "l" || k == "L") -> do
      let x = ship.x
          y = ship.y
          dx = ship.dx + 8 * cos (ship.dir - pi/2)
          dy = ship.dy + 8 * sin (ship.dir - pi/2)
          missile = { x: x, y: y, dx: dx, dy: dy, r: 1, fuse: 50 }

      writeSTRef st $ state { missiles = (missile : state.missiles) }
      return unit

    GameOver | (k == " ") -> do
      asteroids <- replicateM 10 (randomAsteroid state.w state.h)
      writeSTRef st $ state { phase     = Respawning 11
                            , nships    = 3
                            , score     = 0
                            , asteroids = asteroids
                            }
      return unit

    _ -> return unit

-- |Handles a single animation frame.
tick :: forall s e. STRef s State -> Eff (st :: ST s, random :: Random, canvas :: Canvas | e ) Unit
tick st = do
  state <- readSTRef st
  state' <- update state
  writeSTRef st state'
  render state

-- |Updates the world state.
update :: forall s e. State -> Eff (st :: ST s, random :: Random | e) State
update state = do
  let -- These asteroids haven't been hit.
      asteroids = do
        a <- state.asteroids
        guard $ not (any (flip hittest $ a) state.missiles)
        [move state.w state.h $ spin a]

      -- These asteroids have been hit: split 'em.
      asteroids' = do
        a <- state.asteroids
        case filter (flip hittest $ a) state.missiles of
          (m : ms) ->
              if a.r >= 20
              then let dx = m.dx / 10
                       dy = m.dy / 10
                   in [ a { dx = (dx + 1.5 * a.dy), dy = (dy + 1.5 * a.dx), r = a.r / 2 },
                        a { dx = (dx - 1.5 * a.dy), dy = (dy - 1.5 * a.dx), r = a.r / 2 } ]
              else [ ]

          _ -> [ ]

      asteroids'' = asteroids ++ asteroids'

      -- Remove any missiles that hit something.
      missiles = do
        m <- state.missiles
        guard $ not (any (hittest m) state.asteroids)
        let m' = burn m
        guard $ m'.fuse > 0
        [move state.w state.h m']

  case state.phase of
    Playing ship | length asteroids'' > 0 -> do
      let c = state.controls

          -- Update the ship based on any controls.
          dir = ship.dir + (if c.right then (pi / 16) else 0.0) + (if c.left then (-pi / 16) else 0.0)
          dx = clamp (-maxSpeed) maxSpeed (ship.dx + c.thrust * cos (dir - pi/2))
          dy = clamp (-maxSpeed) maxSpeed (ship.dy + c.thrust * sin (dir - pi/2))
          x = (state.w + ship.x + ship.dx) % state.w
          y = (state.h + ship.y + ship.dy) % state.h
          ship' = ship { x = x, y = y, dx = dx, dy = dy, dir = dir }

          -- Accumulate points for any hit asteroids
          points = sum $ do
            a <- state.asteroids
            guard $ any (flip hittest $ a) state.missiles
            [if a.r >= 50 then 20 else if a.r >= 25 then 50 else 100]

          -- Did the ship crash?
          crash = any (hittest ship') asteroids

      return $ state { phase     = if crash then Crashing ship' 0 else Playing ship'
                     , nships    = if crash then state.nships - 1 else state.nships
                     , missiles  = missiles
                     , asteroids = asteroids''
                     , score     = state.score + points
                     }

    Playing ship -> do
      asteroids <- replicateM 10 (randomAsteroid state.w state.h)
      return $ state { phase     = Respawning 33
                     , asteroids = asteroids
                     , missiles  = [ ] }

    Crashing ship step -> do
      let ship' = ship { x = (state.w + ship.x + ship.dx) % state.w,
                         y = (state.h + ship.y + ship.dy) % state.h }
          phase = if step > 33 then
                      if state.nships > 0 then Respawning 33 else GameOver
                  else Crashing ship' (step + 1)

      return $ state { phase     = phase
                     , missiles  = missiles
                     , asteroids = asteroids'' }

    Respawning n | n > 0 -> do
      return $ state { phase = Respawning (n-1)
                     , missiles  = missiles
                     , asteroids = asteroids'' }

    Respawning n -> do
      let center = (defaultShip state.w state.h) { r = 40 }
          phase = if any (hittest center) state.asteroids
                  then Respawning n
                  else Playing (defaultShip state.w state.h)

      return $ state { phase     = phase
                     , missiles  = missiles
                     , asteroids = asteroids'' }

    GameOver -> do
      return $ state { missiles  = missiles
                     , asteroids = asteroids'' }

-- |Ticks down the fuse on a missile.
burn :: forall m. { fuse :: Number | m } -> { fuse :: Number | m }
burn missile = missile { fuse = missile.fuse - 1.0 }

-- |Checks to see if two Moveable's have collided.
hittest :: forall m n. Moveable m -> Moveable n -> Boolean
hittest a b =
    let dx = a.x - b.x
        dy = a.y - b.y
    in sqrt ((dx * dx) + (dy * dy)) <= (a.r + b.r)

-- |Clamps the value of `x` between `lo` and `hi`.
clamp :: Number -> Number -> Number -> Number
clamp lo hi x = max lo (min hi x)

spin :: Asteroid -> Asteroid
spin a = let spin = a.dir + a.spin in a { dir = if spin > twoPi then spin - twoPi else spin }

-- |Moves a Moveable by updating it's `x` and `y` coordinates by `dx`
-- and `dy`, respectively.
move :: forall m. Number -> Number -> Moveable m -> Moveable m
move w h obj = obj { x = (w + obj.x + obj.dx) % w
                   , y = (h + obj.y + obj.dy) % h }

-- |Renders the current state.
render :: forall e. State -> Eff ( canvas :: Canvas | e ) Unit
render state = do
  canvas <- getCanvasElementById "canvas"
  ctx <- getContext2D canvas
  setFillStyle "#000000" ctx
  fillPath ctx $ rect ctx { x: 0, y: 0, w: state.w, h: state.h }

  -- Draw the score
  save ctx
  setFillStyle "#ffffff" ctx
  setFont "16px Hyperspace" ctx
  fillText ctx (show state.score) 10 20
  restore ctx

  -- Draw the remaining ships
  forE 1 state.nships $ \i -> do
      let ship = (defaultShip 0 0) { x = 20 * i, y = 40 }
      renderShip ctx ship "#ffffff" false
      return unit

  case state.phase of
    Playing ship    -> renderShip ctx ship "#ffffff" (state.controls.thrust /= 0)
    Respawning _    -> renderShip ctx (defaultShip state.w state.h) "#555555" false
    Crashing ship i -> renderCrash ctx ship i
    GameOver        -> renderGameOver ctx state.w state.h

  foldM (renderAsteroid ctx) unit state.asteroids
  foldM (renderMissile ctx) unit state.missiles
  return unit

-- |Renders a ship.
renderShip :: forall e. Context2D -> Ship -> String -> Boolean -> Eff ( canvas :: Canvas | e ) Unit
renderShip ctx ship color engines = do
  save ctx
  translate { translateX: ship.x, translateY: ship.y } ctx
  rotate ship.dir ctx
  setLineWidth 1 ctx
  setStrokeStyle color ctx
  beginPath ctx
  moveTo ctx 0 (-10)
  lineTo ctx (-7) 10
  lineTo ctx 0 8
  lineTo ctx 7 10
  lineTo ctx 0 (-10)
  stroke ctx

  when engines $ do
    moveTo ctx (-4) 11
    lineTo ctx 0 15
    lineTo ctx 4 11
    stroke ctx
    return unit

  restore ctx
  return unit

-- |Renders an exploding ship.
renderCrash :: forall e. Context2D -> Ship -> Number -> Eff ( canvas :: Canvas | e ) Unit
renderCrash ctx ship i = do
  save ctx
  translate { translateX: ship.x, translateY: ship.y } ctx
  rotate ship.dir ctx
  setLineWidth 1 ctx
  setStrokeStyle "#ffffff" ctx

  save ctx
  translate { translateX: -i, translateY: -i } ctx
  rotate (i * pi / 60) ctx
  beginPath ctx
  moveTo ctx 0 (-10)
  lineTo ctx (-7) 10
  stroke ctx
  restore ctx

  save ctx
  translate { translateX: i, translateY: -i } ctx
  rotate ((-i) * pi / 30) ctx
  beginPath ctx
  moveTo ctx 0 (-10)
  lineTo ctx 7 10
  stroke ctx
  restore ctx

  save ctx
  translate { translateX: -i, translateY: i } ctx
  rotate ((-i) * pi / 20) ctx
  beginPath ctx
  moveTo ctx (-7) 10
  lineTo ctx 0 8
  stroke ctx
  restore ctx

  save ctx
  translate { translateX: i, translateY: i } ctx
  rotate (i * pi / 15) ctx
  beginPath ctx
  moveTo ctx 0 8
  lineTo ctx 7 10
  stroke ctx
  restore ctx

  restore ctx

  return unit

-- |Renders an asteroid.
renderAsteroid :: forall e. Context2D -> Unit -> Asteroid -> Eff ( canvas :: Canvas | e ) Unit
renderAsteroid ctx _ asteroid = do
  save ctx

  setLineWidth 1 ctx
  translate { translateX: asteroid.x, translateY: asteroid.y } ctx
  rotate asteroid.dir ctx

  setStrokeStyle "#ffffff" ctx
  beginPath ctx

  let n = length asteroid.path
      steps = map ((*) (twoPi / n)) (1 .. n)
      theta = fromJust $ last steps
      off = fromJust $ last asteroid.path

  moveTo ctx (asteroid.r * off * cos theta) (asteroid.r * off * sin theta)

  for_ (zip asteroid.path steps) $ \(Tuple off theta) -> do
                                  let x = asteroid.r * off * cos theta
                                      y = asteroid.r * off * sin theta
                                  lineTo ctx x y

  stroke ctx

  restore ctx
  return unit

-- |Renders a missile.
renderMissile :: forall e. Context2D -> Unit -> Missile -> Eff ( canvas :: Canvas | e ) Unit
renderMissile ctx _ missile = do
  save ctx
  setFillStyle "#ffffff" ctx
  fillPath ctx $ arc ctx { x: missile.x, y: missile.y, r: 2, start: 0, end: twoPi }
  restore ctx
  return unit

-- |Renders the GAME OVER screen.
renderGameOver :: forall e. Context2D -> Number -> Number -> Eff ( canvas :: Canvas | e ) Unit
renderGameOver ctx w h = do
  save ctx
  setFillStyle "#ffffff" ctx

  centerText "Game Over" 64 (-40)
  centerText "Controls" 20 0
  centerText "A = Rotate Left, S = Rotate Right" 14 20
  centerText "K = Thrust, L = Fire" 14 40
  centerText "Press the space bar to start" 16 120

  restore ctx
  return unit
      where centerText text pixels y = do
              setFont ((show pixels) ++ "px Hyperspace") ctx
              metrics <- measureText ctx text
              fillText ctx text (w / 2 - metrics.width / 2) (y + h / 2)

{- -*- Mode: Haskell -*- -}

module Asteroids where

import Math
import Debug.Trace
import Control.Monad
import Control.MonadPlus
import Control.Monad.Eff
import Control.Monad.Eff.Random
import Control.Monad.ST
import Graphics.Canvas

import Data.Array
import Data.Tuple
import Data.Foldable
import Data.Maybe.Unsafe
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Data.DOM.Simple.Events

data Phase = GameOver | Playing Ship | Crashing Ship Number | Respawning Number

type Moveable m = {
      x    :: Number
    , y    :: Number
    , dx   :: Number
    , dy   :: Number
    , r    :: Number | m }

type Ship = {
      x    :: Number
    , y    :: Number
    , dx   :: Number
    , dy   :: Number
    , r    :: Number
    , dir  :: Number
    }

type Asteroid = {
      x    :: Number
    , y    :: Number
    , dx   :: Number
    , dy   :: Number
    , r    :: Number
    , path :: [Number]
    }

type Missile = {
      x    :: Number
    , y    :: Number
    , dx   :: Number
    , dy   :: Number
    , r    :: Number
    , fuse :: Number
    }

type Controls = {
      thrust :: Number
    , left   :: Boolean
    , right  :: Boolean
    }

type State = {
      w         :: Number
    , h         :: Number
    , phase     :: Phase
    , nships    :: Number
    , score     :: Number
    , asteroids :: [Asteroid]
    , missiles  :: [Missile]
    , controls  :: Controls
    }

main :: forall s e. Eff ( st :: ST s, dom :: DOM, canvas :: Canvas, random :: Random, trace :: Trace | e ) Unit
main = do
  w <- innerWidth globalWindow
  h <- innerHeight globalWindow

  let ship = defaultShip w h
      controls = { thrust: 0, left: false, right: false }

  asteroids <- replicateM 10 (randomAsteroid w h)

  st <- newSTRef { w: w, h: h
                 , phase: GameOver
                 , nships: 3
                 , score: 0
                 , asteroids: asteroids
                 , missiles: [ ]
                 , controls: controls }

  resize st
  addUIEventListener ResizeEvent (resize0 st) globalWindow

  addKeyboardEventListener KeydownEvent (keydown st) globalWindow
  addKeyboardEventListener KeyupEvent (keyup st) globalWindow
  addKeyboardEventListener KeypressEvent (keypress st) globalWindow

  setInterval globalWindow 33 $ tick st

  return unit

-- |Returns a new ship in the middle of the canvas.
defaultShip :: Number -> Number -> Ship
defaultShip w h = { x: w / 2, y: w / 2, dir: 0, dx: 0, dy: 0, r: 10 }

-- |The maximum speed we'll allow for a ship.
maxSpeed = 6.0

-- |Creates a randomly located asteroid somewhere on the canvas.
randomAsteroid :: forall e. Number -> Number -> Eff ( random :: Random | e ) Asteroid
randomAsteroid w h = do
  x  <- randomRange 0 w
  y  <- randomRange 0 h
  dx <- (*) <$> (randomRange 1 2) <*> randomSign
  dy <- (*) <$> (randomRange 1 2) <*> randomSign
  path <- replicateM 12 (randomRange 0.7 1.1)
  return { x: x, y: y, dx: dx, dy: dy, r: 50, path: path }
      where randomRange lo hi = (\n -> lo + n * (hi - lo)) <$> random
            randomSign = (\n -> if n < 0.5 then (-1) else 1) <$> random

-- |Thunk to attach resize to the ResizeEvent
-- XXX WTF? Why do I need this?
resize0 :: forall s e. STRef s State -> DOMEvent -> (Eff (st :: ST s, dom :: DOM, canvas :: Canvas | e) Unit)
resize0 st _ = resize st

-- |Handles window resizing by stretching the canvas to fit the
-- viewport and updating our notion of how large the canvas is.
resize :: forall s e. STRef s State -> (Eff (st :: ST s, dom :: DOM, canvas :: Canvas | e) Unit)
resize st = do
  state <- readSTRef st
  w <- innerWidth globalWindow
  h <- innerHeight globalWindow
  canvas <- getCanvasElementById "canvas"
  setCanvasWidth w canvas
  setCanvasHeight h canvas
  modifySTRef st $ (\state -> state { w = w, h = h })
  return unit

-- |Handles key presses for keys that can be held down.
keydown :: forall s e. STRef s State -> DOMEvent -> Eff (st :: ST s, dom :: DOM | e) Unit
keydown st event = do
  code <- keyCode event
  modifySTRef st $ \state ->
      let controls = case code of
                       65  -> state.controls { left = true }
                       83  -> state.controls { right = true }
                       75  -> state.controls { thrust = 0.5 }
                       _   -> state.controls
      in state { controls = controls }

  return unit

-- |Handles key releases for keys that can be held down.
keyup :: forall s e. STRef s State -> DOMEvent -> Eff (st :: ST s, dom :: DOM | e) Unit
keyup st event = do
  code <- keyCode event
  modifySTRef st $ \state ->
      let controls = case code of
                       65  -> state.controls { left = false }
                       83  -> state.controls { right = false }
                       75  -> state.controls { thrust = 0.0 }
                       _   -> state.controls
      in state { controls = controls }

  return unit

-- |Handles single key presses.
keypress :: forall s e. STRef s State -> DOMEvent -> Eff (st :: ST s, dom :: DOM, random :: Random | e) Unit
keypress st event = do
  state <- readSTRef st
  k <- key event
  case state.phase of
    Playing ship | (k == "l" || k == "L") -> do
      let x = ship.x
          y = ship.y
          dx = ship.dx + 8 * cos (ship.dir - pi/2)
          dy = ship.dy + 8 * sin (ship.dir - pi/2)
          missile = { x: x, y: y, dx: dx, dy: dy, r: 1, fuse: 50 }

      writeSTRef st $ state { missiles = (missile : state.missiles) }
      return unit

    GameOver | (k == " ") -> do
      asteroids <- replicateM 10 (randomAsteroid state.w state.h)
      writeSTRef st $ state { phase     = Respawning 11
                            , nships    = 3
                            , score     = 0
                            , asteroids = asteroids
                            }
      return unit

    _ -> return unit

-- |Handles a single animation frame.
tick :: forall s e. STRef s State -> Eff (st :: ST s, random :: Random, canvas :: Canvas | e ) Unit
tick st = do
  state <- readSTRef st
  state' <- update state
  writeSTRef st state'
  render state

-- |Updates the world state.
update :: forall s e. State -> Eff (st :: ST s, random :: Random | e) State
update state = do
  let -- These asteroids haven't been hit.
      asteroids = do
        a <- state.asteroids
        guard $ not (any (flip hittest $ a) state.missiles)
        [move state.w state.h a]

      -- These asteroids have been hit: split 'em.
      asteroids' = do
        a <- state.asteroids
        case filter (flip hittest $ a) state.missiles of
          (m : ms) ->
              if a.r >= 20
              then let dx = m.dx / 10
                       dy = m.dy / 10
                   in [ a { dx = (dx + 1.5 * a.dy), dy = (dy + 1.5 * a.dx), r = a.r / 2 },
                        a { dx = (dx - 1.5 * a.dy), dy = (dy - 1.5 * a.dx), r = a.r / 2 } ]
              else [ ]

          _ -> [ ]

      asteroids'' = asteroids ++ asteroids'

      -- Remove any missiles that hit something.
      missiles = do
        m <- state.missiles
        guard $ not (any (hittest m) state.asteroids)
        let m' = burn m
        guard $ m'.fuse > 0
        [move state.w state.h m']

  case state.phase of
    Playing ship | length asteroids'' > 0 -> do
      let c = state.controls

          -- Update the ship based on any controls.
          dir = ship.dir + (if c.right then (pi / 16) else 0.0) + (if c.left then (-pi / 16) else 0.0)
          dx = clamp (-maxSpeed) maxSpeed (ship.dx + c.thrust * cos (dir - pi/2))
          dy = clamp (-maxSpeed) maxSpeed (ship.dy + c.thrust * sin (dir - pi/2))
          x = (state.w + ship.x + ship.dx) % state.w
          y = (state.h + ship.y + ship.dy) % state.h
          ship' = ship { x = x, y = y, dx = dx, dy = dy, dir = dir }

          -- Accumulate points for any hit asteroids
          points = sum $ do
            a <- state.asteroids
            guard $ any (flip hittest $ a) state.missiles
            [if a.r >= 50 then 20 else if a.r >= 25 then 50 else 100]

          -- Did the ship crash?
          crash = any (hittest ship') asteroids

      return $ state { phase     = if crash then Crashing ship' 0 else Playing ship'
                     , nships    = if crash then state.nships - 1 else state.nships
                     , missiles  = missiles
                     , asteroids = asteroids''
                     , score     = state.score + points
                     }

    Playing ship -> do
      asteroids <- replicateM 10 (randomAsteroid state.w state.h)
      return $ state { phase     = Respawning 33
                     , asteroids = asteroids
                     , missiles  = [ ] }

    Crashing ship step -> do
      let ship' = ship { x = (state.w + ship.x + ship.dx) % state.w,
                         y = (state.h + ship.y + ship.dy) % state.h }
          phase = if step > 33 then
                      if state.nships > 0 then Respawning 33 else GameOver
                  else Crashing ship' (step + 1)

      return $ state { phase     = phase
                     , missiles  = missiles
                     , asteroids = asteroids'' }

    Respawning n | n > 0 -> do
      return $ state { phase = Respawning (n-1)
                     , missiles  = missiles
                     , asteroids = asteroids'' }

    Respawning n -> do
      let center = (defaultShip state.w state.h) { r = 40 }
          phase = if any (hittest center) state.asteroids
                  then Respawning n
                  else Playing (defaultShip state.w state.h)

      return $ state { phase     = phase
                     , missiles  = missiles
                     , asteroids = asteroids'' }

    GameOver -> do
      return $ state { missiles  = missiles
                     , asteroids = asteroids'' }

-- |Ticks down the fuse on a missile.
burn :: forall m. { fuse :: Number | m } -> { fuse :: Number | m }
burn missile = missile { fuse = missile.fuse - 1.0 }

-- |Checks to see if two Moveable's have collided.
hittest :: forall m n. Moveable m -> Moveable n -> Boolean
hittest a b =
    let dx = a.x - b.x
        dy = a.y - b.y
    in sqrt ((dx * dx) + (dy * dy)) <= (a.r + b.r)

-- |Clamps the value of `x` between `lo` and `hi`.
clamp :: Number -> Number -> Number -> Number
clamp lo hi x = max lo (min hi x)

-- |Moves a Moveable by updating it's `x` and `y` coordinates by `dx`
-- and `dy`, respectively.
move :: forall m. Number -> Number -> Moveable m -> Moveable m
move w h obj = obj { x = (w + obj.x + obj.dx) % w
                   , y = (h + obj.y + obj.dy) % h }

-- |Renders the current state.
render :: forall e. State -> Eff ( canvas :: Canvas | e ) Unit
render state = do
  canvas <- getCanvasElementById "canvas"
  ctx <- getContext2D canvas
  setFillStyle "#000000" ctx
  fillPath ctx $ rect ctx { x: 0, y: 0, w: state.w, h: state.h }

  -- Draw the score
  save ctx
  setFillStyle "#ffffff" ctx
  setFont "16px Hyperspace" ctx
  fillText ctx (show state.score) 10 20
  restore ctx

  -- Draw the remaining ships
  forE 1 state.nships $ \i -> do
      let ship = (defaultShip 0 0) { x = 20 * i, y = 40 }
      renderShip ctx ship "#ffffff" false
      return unit

  case state.phase of
    Playing ship    -> renderShip ctx ship "#ffffff" (state.controls.thrust /= 0)
    Respawning _    -> renderShip ctx (defaultShip state.w state.h) "#555555" false
    Crashing ship i -> renderCrash ctx ship i
    GameOver        -> renderGameOver ctx state.w state.h

  foldM (renderAsteroid ctx) unit state.asteroids
  foldM (renderMissile ctx) unit state.missiles
  return unit

-- |Renders a ship.
renderShip :: forall e. Context2D -> Ship -> String -> Boolean -> Eff ( canvas :: Canvas | e ) Unit
renderShip ctx ship color engines = do
  save ctx
  translate { translateX: ship.x, translateY: ship.y } ctx
  rotate ship.dir ctx
  setLineWidth 1 ctx
  setStrokeStyle color ctx
  beginPath ctx
  moveTo ctx 0 (-10)
  lineTo ctx (-7) 10
  lineTo ctx 0 8
  lineTo ctx 7 10
  lineTo ctx 0 (-10)
  stroke ctx

  when engines $ do
    moveTo ctx (-4) 11
    lineTo ctx 0 15
    lineTo ctx 4 11
    stroke ctx
    return unit

  restore ctx
  return unit

-- |Renders an exploding ship.
renderCrash :: forall e. Context2D -> Ship -> Number -> Eff ( canvas :: Canvas | e ) Unit
renderCrash ctx ship i = do
  save ctx
  translate { translateX: ship.x, translateY: ship.y } ctx
  rotate ship.dir ctx
  setLineWidth 1 ctx
  setStrokeStyle "#ffffff" ctx

  save ctx
  translate { translateX: -i, translateY: -i } ctx
  rotate (i * pi / 60) ctx
  beginPath ctx
  moveTo ctx 0 (-10)
  lineTo ctx (-7) 10
  stroke ctx
  restore ctx

  save ctx
  translate { translateX: i, translateY: -i } ctx
  rotate ((-i) * pi / 30) ctx
  beginPath ctx
  moveTo ctx 0 (-10)
  lineTo ctx 7 10
  stroke ctx
  restore ctx

  save ctx
  translate { translateX: -i, translateY: i } ctx
  rotate ((-i) * pi / 20) ctx
  beginPath ctx
  moveTo ctx (-7) 10
  lineTo ctx 0 8
  stroke ctx
  restore ctx

  save ctx
  translate { translateX: i, translateY: i } ctx
  rotate (i * pi / 15) ctx
  beginPath ctx
  moveTo ctx 0 8
  lineTo ctx 7 10
  stroke ctx
  restore ctx

  restore ctx

  return unit

-- |Renders an asteroid.
renderAsteroid :: forall e. Context2D -> Unit -> Asteroid -> Eff ( canvas :: Canvas | e ) Unit
renderAsteroid ctx _ asteroid = do
  save ctx

  setLineWidth 1 ctx
  translate { translateX: asteroid.x, translateY: asteroid.y } ctx
  setStrokeStyle "#ffffff" ctx
  beginPath ctx

  let n = length asteroid.path
      steps = map ((*) (2 * pi / n)) (1 .. n)
      theta = fromJust $ last steps
      off = fromJust $ last asteroid.path

  moveTo ctx (asteroid.r * off * cos theta) (asteroid.r * off * sin theta)

  for_ (zip asteroid.path steps) $ \(Tuple off theta) -> do
                                  let x = asteroid.r * off * cos theta
                                      y = asteroid.r * off * sin theta
                                  lineTo ctx x y

  stroke ctx

  restore ctx
  return unit

-- |Renders a missile.
renderMissile :: forall e. Context2D -> Unit -> Missile -> Eff ( canvas :: Canvas | e ) Unit
renderMissile ctx _ missile = do
  save ctx
  setFillStyle "#ffffff" ctx
  fillPath ctx $ arc ctx { x: missile.x, y: missile.y, r: 2, start: 0, end: 2 * pi }
  restore ctx
  return unit

-- |Renders the GAME OVER screen.
renderGameOver :: forall e. Context2D -> Number -> Number -> Eff ( canvas :: Canvas | e ) Unit
renderGameOver ctx w h = do
  save ctx
  setFillStyle "#ffffff" ctx

  centerText "Game Over" 64 (-40)
  centerText "Controls" 20 0
  centerText "A = Rotate Left, S = Rotate Right" 14 20
  centerText "K = Thrust, L = Fire" 14 40
  centerText "Press the space bar to start" 16 120

  restore ctx
  return unit
      where centerText text pixels y = do
              setFont ((show pixels) ++ "px Hyperspace") ctx
              metrics <- measureText ctx text
              fillText ctx text (w / 2 - metrics.width / 2) (y + h / 2)


Got channels communicating with airconsole.

module AirConsolePong.ScreenMain where

import Prelude (Unit, negate, discard, bind, pure, unit, (<$>))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Timer (TIMER)
import AirConsole.Global ( getAirConsoleGlobal , orientationLandscape
                         , onConnect , onReady , onMessage , onDisconnect
                         )
import AirConsolePong.Views.FFI (updateCanvasDim, showStuff)
import AirConsolePong.Views.ScreenStart (view , drawGame)
import AirConsolePong.GameModel (initialGameState)
import AirConsolePong.GameUpdate (gameLogic)
import Data.Maybe (Maybe(Just, Nothing))
import DOM (DOM)
import Graphics.Canvas (CANVAS, getCanvasElementById)
import Signal (foldp, runSignal, sampleOn)
import Signal.DOM (animationFrame)
import Signal.Channel (channel, send, subscribe, Channel, CHANNEL)

type Input = { p1 :: { move :: Number }
             , p2 :: { move :: Number }
             , ball :: { x :: Number, y :: Number }
             }

startGame
    :: forall eff
     . Channel Input
    -> Eff ( dom :: DOM
           , timer :: TIMER
           , console :: CONSOLE
           , canvas :: CANVAS | eff
           ) Unit
startGame channel = do
    mcanvas <- getCanvasElementById "game-canvas"
    case mcanvas of
        Just canvas -> do
            _ <- updateCanvasDim canvas
            frames <- animationFrame
            let inputs = subscribe channel
            let game = foldp gameLogic initialGameState (sampleOn frames inputs)
            runSignal (drawGame canvas true <$> game)
            pure unit
        Nothing -> pure unit

main
    :: forall e
     . Eff ( channel :: CHANNEL
           , dom :: DOM
           , canvas :: CANVAS
           , console :: CONSOLE
           , timer :: TIMER | e
           ) Unit
main = do
    ac <- getAirConsoleGlobal { orientation: orientationLandscape }
    ch <- channel { p1: { move: 0.0 }
                  , p2: { move: 0.0 }
                  , ball: { x: 0.5, y: 0.2 }
                  }
    view ac
    _ <- onConnect (\d -> log "on Connection") ac
    _ <- onMessage (\d x -> do
                        log "Message: "
                        showStuff d
                        showStuff x
                        send ch { p1: { move: 1.0 }
                                , p2: { move: -1.0 }
                                , ball: { x: 0.5, y: 0.2 }
                                }
                   ) ac
    _ <- onReady (\d -> log "on Ready") ac
    _ <- onDisconnect (\d -> log "on Disconnect") ac
    startGame ch
    log "Running"

module AirConsolePong.ScreenMain where

import Prelude (Unit, discard, bind, pure, unit, ($), (<$>))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Timer (TIMER)
import AirConsole.Global ( getAirConsoleGlobal , orientationLandscape
                         , onConnect , onReady , onMessage , onDisconnect
                         )
import AirConsole.Types (AirConsoleGlobal)
import AirConsolePong.Views.FFI (updateCanvasDim)
import AirConsolePong.Views.ScreenStart (view , drawGame)
import AirConsolePong.GameModel (initialGameState)
import AirConsolePong.GameUpdate (gameLogic)
import Data.Maybe (Maybe(Just, Nothing))
import DOM (DOM)
import Graphics.Canvas (CANVAS, getCanvasElementById)
import Signal (constant, foldp, runSignal, sampleOn)
import Signal.DOM (animationFrame)
-- import Signal.Channel (channel, send, subscribe, CHANNEL)

startGame
    :: forall eff
     . AirConsoleGlobal
    -> Eff ( dom :: DOM
           , timer :: TIMER
           , console :: CONSOLE
           , canvas :: CANVAS | eff
           ) Unit
startGame ac = do
    mcanvas <- getCanvasElementById "game-canvas"
    case mcanvas of
        Just canvas -> do
            _ <- updateCanvasDim canvas
            frames <- animationFrame
            let inputs = constant { p1: { move: 0.0 }
                                  , p2: { move: 0.0 }
                                  , ball: { x: 0.5, y: 0.2 }
                                  }
            let game = foldp gameLogic initialGameState (sampleOn frames inputs)
            runSignal (drawGame canvas true <$> game)
            pure unit
        Nothing -> pure unit

main :: forall e. Eff (dom :: DOM, canvas :: CANVAS, console :: CONSOLE, timer :: TIMER | e) Unit
main = do
    ac <- getAirConsoleGlobal { orientation: orientationLandscape }
    view ac
    _ <- onConnect (\d -> log "on Connection") ac
    _ <- onMessage (\d x -> do
                        log "Blah"
                        pure $ constant x
                   ) ac
    _ <- onReady (\d -> log "on Ready") ac
    _ <- onDisconnect (\d -> log "on Disconnect") ac
    startGame ac
    log "Running"


Despair on HList type

Despair on HList type

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

module HList
  ( HList
  , cons
  , empty
  ) where

import Data.Tuple.Nested (Tuple2)
import Prelude (Unit, unit)

data HList a = HNil | HCons a HList _

-- data HList h l = HNil | HList h (HList l)

cons :: forall a b l1 l2. a -> HList a l1 -> HList b l2
cons a HNil = HCons a HNil
cons a (HCons b t) = HCons a (HCons b t)

empty :: forall a b. HList a b
empty = HNil

map :: forall a b l1 l2. (a -> b) -> HList l1 -> HList l2
map fn (HCons a (HCons b t)) = cons (fn a) (map fn (HCons b t))
map fn (HCons a HNil) = cons (fn a) HNil

module HList
  ( HList
  , cons
  , empty
  ) where

import Data.Tuple.Nested (Tuple2)
import Prelude (Unit, unit)

data HList h l = HNil | HList h l

cons :: forall a b l1 l2. a -> HList a l1 -> HList b l2
cons a HNil = HList a HNil
cons a (HList b t) = HList a (HList b t)

empty :: forall a b. HList a b
empty = HNil

map :: forall a b l1 l2. (a -> b) -> HList l1 -> HList l2
map fn (HList a (HList b t)) = cons (fn a) (map fn (HList b t))
map fn (HList a HNil) = cons (fn a) HNil