Added case in pickUp that prevenst pickin up items if the player is carrying too much

module Main where

import Data.Char
import Data.String hiding (length, drop)
import Data.Maybe
import Data.Tuple
import Data.Array ((!!), (..), map, updateAt, modifyAt, range, length, head, filter, drop, deleteAt, delete)
import Data.Foldable
import qualified Data.Map as M
import Control.Monad.Eff
import qualified Control.Monad.JQuery as J
import Debug.Trace
import Math

import Graphics.CanvasConsole
import RandomGen
import GameState
import GameData
import Drawing
import Utils
import Level
import Astar
import Line

strlen = Data.String.length

-- Uses skill and gets experience.
useSkill :: SkillType
         -> Number -- Odds of success when unskilled (0 - 99)
         -> Number -- Experience gained
         -> GameState
         -> { success :: Boolean, game :: GameState }
useSkill skillType odds expr g@(Game state) = { success: success, game: addExp gen.game }
    where
        gen       = randInt 0 100 g
        finalOdds = odds * pow 1.2 (fromMaybe 0 $ (\s -> s.level) <$> M.lookup skillType state.skills)
        success   = gen.n < finalOdds
        addExp g@(Game state) | success = -- Skill increases with successes
            let skill        = fromMaybe { level: 0, prog: 0 } $ M.lookup skillType state.skills
                updatedSkill = increaseSkill skill
                gotLevel     = updatedSkill.level > skill.level
            in addLevelUpMsg gotLevel updatedSkill.level $ Game state { skills = M.insert skillType updatedSkill state.skills }
        addExp g@(Game state) | otherwise = g -- No experience gained

        expRequired :: Number -> Number
        expRequired lvl = 100 + 50 * lvl

        addLevelUpMsg :: Boolean -> Number -> GameState -> GameState
        addLevelUpMsg true newlvl = addMsg $ "Your " ++ show skillType ++ " skill increased to " ++ show newlvl ++ "."
        addLevelUpMsg _ _         = id

        increaseSkill :: Skill -> Skill
        increaseSkill skill | skill.prog + expr >= expRequired skill.level =
            skill { level = skill.level + 1, prog = skill.prog + expr - expRequired skill.level }
        increaseSkill skill | otherwise =
            skill { prog = skill.prog + expr }

-- Updates blinking timer.
updateBlinkTimer :: Number -> GameState -> GameState
updateBlinkTimer dt (Game state) | state.blinkTimer > 0.5 = Game state { blink = not state.blink, blinkTimer = 0 }
updateBlinkTimer dt (Game state) | otherwise              = Game state { blinkTimer = state.blinkTimer + dt }

-- onUpdate is called as often as possible.
onUpdate :: Console -> Number -> GameState -> ConsoleEff GameState
onUpdate console dt g@(Game state) | playerCannotAct state.level state.player && state.freeFallTimer > 0.1 =
    drawGame console <<< updateBlinkTimer dt <<< updateWorld true (calcSpeed g) $ Game state { freeFallTimer = 0 }
onUpdate console dt g@(Game state) | otherwise =
    blinkDraw console <<< updateBlinkTimer dt $ Game state { freeFallTimer = state.freeFallTimer + dt }
onUpdate console _ g = drawGame console g

-- Gets creature information from creature at index i.
get :: forall a. Number -> GameState -> a -> (Creature -> a) -> a
get i (Game state) d getter = fromMaybe d $ getter <$> state.npcs !! i

-- Modify creature at index i with a function.
modifyCreatureAt :: Number -> GameState -> (Creature -> Creature) -> GameState
modifyCreatureAt i (Game state) f = Game state { npcs = modifyAt i f state.npcs }

-- Updates all npcs.
updateCreatures :: Number -> GameState -> GameState
updateCreatures advance g@(Game state') =
    foldl (\g' i -> updateCreature i (advTime i g')) g (0 .. (length state'.npcs - 1))
    where
        -- Updaters are not allowed to remove creatures.
        -- Dead creatures will be cleaned up later.

        -- Advances game time for creature at index i.
        advTime :: Number -> GameState -> GameState
        advTime i game = modifyCreatureAt i game $ \c -> c { time = c.time + advance }

        -- Updates creature at index i until it runs out of time.
        updateCreature :: Number -> GameState -> GameState
        updateCreature i game | get i game 0 (\c -> c.time) >= get i game 0 (calcNpcSpeed game) =
            updateCreature i (modifyCreatureAt i (updateCreatureOnce i game) (\c -> c { time = c.time - calcNpcSpeed game c }))
        updateCreature i game | otherwise = game

        -- Creature at index i does a single action.
        updateCreatureOnce :: Number -> GameState -> GameState
        updateCreatureOnce i g@(Game state) =
            let spotRoll     = randInt 0 99 g
                newAlertAI   = updateAlertness spotRoll.n (get i g NoAI (\c -> c.ai))
                changedAlert = modifyCreatureAt i spotRoll.game (\c ->c { ai = newAlertAI })
            in updateAI changedAlert newAlertAI -- add updatePhysics?
            where
                -- Creature position
                cpos :: Point
                cpos = get i g zerop (\c -> c.pos)

                lookingAtPlayer :: Boolean
                lookingAtPlayer | get i g false (\c -> c.dir.x == 0)                               = true
                lookingAtPlayer | get i g false (\c -> c.dir.x < 0) && cpos.x > state.player.pos.x = true
                lookingAtPlayer | get i g false (\c -> c.dir.x > 0) && cpos.x < state.player.pos.x = true
                lookingAtPlayer | otherwise = false

                canSeePlayer :: Boolean
                canSeePlayer = lookingAtPlayer && (distanceSq cpos state.player.pos < 10 * 10) && (lineOfSight state.level cpos state.player.pos)

                canHide :: Number -> Boolean
                canHide roll = roll < (40 * pow 1.2 (fromMaybe 0 $ (\s -> s.level) <$> M.lookup Sneak state.skills))

                updateAlertness :: Number -> AI -> AI
                updateAlertness roll (AI NoAlert st)  | canSeePlayer = AI MightSee st
                updateAlertness roll (AI NoAlert st)  | otherwise    = AI NoAlert st
                updateAlertness roll (AI MightSee st) | canSeePlayer && not (canHide roll) = AI (Suspicious 1) st
                updateAlertness roll (AI MightSee st) | otherwise                          = AI NoAlert st
                updateAlertness roll (AI (Suspicious n) st) | n == 0                = AI NoAlert st
                updateAlertness roll (AI (Suspicious n) st) | not canSeePlayer      = AI (Suspicious (n - 1)) st
                updateAlertness roll (AI (Suspicious n) st) | canSeePlayer && n < 4 = AI (Suspicious (n + 1)) st
                updateAlertness roll (AI (Suspicious n) st) | otherwise             = AI (Alert 10) st
                updateAlertness roll (AI (Alert n) st) | canSeePlayer = AI (Alert 10) st
                updateAlertness roll (AI (Alert n) st) | n == 0       = AI NoAlert st
                updateAlertness roll (AI (Alert n) st) | otherwise    = AI (Alert (n - 1)) st
                updateAlertness _ x = x

                newPatrolPoint :: GameState -> { p :: Point, game :: GameState }
                newPatrolPoint g' = let points = validPatrolPoints
                                        gen    = randInt 0 (length points - 1) g'
                                    in { p: fromMaybe zerop (points !! gen.n), game: gen.game }

                validPatrolPoints :: [Point]
                validPatrolPoints = filter canWalkOn $ levelPoints state.level
                    where
                        canWalkOn p = isValidMove state.level p && not (isValidMove state.level (p .+. {x: 0, y: 1}))

                updateAI :: GameState -> AI -> GameState
                updateAI g (AI (Alert _) _)      = mover g $ moveToPlayer
                updateAI g (AI (Suspicious _) _) = mover g $ moveToPlayer
                updateAI g (AI _ (Idle p))       = mover g $ moveToPoint p
                updateAI g (AI a (Patrol p)) =
                    if length (pathToPoint g cpos p) <= 2 then
                        let gen = newPatrolPoint g
                        in modifyCreatureAt i gen.game (\c -> c { ai = AI a (Patrol gen.p) })
                    else mover g $ moveToPoint p
                updateAI g _ = g

                mover :: GameState -> (Creature -> Point) -> GameState
                mover g@(Game state) f = let nextPoint = get i g zerop f
                            in if state.player.pos .==. nextPoint then
                                -- get doesn't really get anything from creature, I'm just exploiting
                                -- it's type to make the attack.
                                -- get :: Number -> GameState -> GameState -> (Creature -> GameState) -> Gamestate
                                get i g g (flip npcAttack g)
                            else modifyCreatureAt i g $ walk nextPoint

                walk :: Point -> Creature -> Creature
                walk p c = c { pos = p, dir = p .-. c.pos }

                moveToPoint :: Point -> Creature -> Point
                moveToPoint p c = case head (pathToPoint g c.pos p) of
                                   Just p'  -> p'
                                   Nothing -> c.pos

                moveToPlayer :: Creature -> Point
                moveToPlayer c = case head (pathToPlayer g c.pos) of
                                   Just p'  -> p'
                                   Nothing -> c.pos

        pathToPoint :: GameState -> Point -> Point -> [Point]
        pathToPoint (Game state) start end = findPath state.pathfinder start end

        pathToPlayer :: GameState -> Point -> [Point]
        pathToPlayer g@(Game state) start = pathToPoint g start (groundProject state.player.pos)
            where
                -- Projects position to ground or climbable tile.
                groundProject :: Point -> Point
                groundProject p | isClimbable state.level (p .+. {x:0, y:0}) = p
                groundProject p | isValidMove state.level (p .+. {x:0, y:1}) = groundProject (p .+. {x:0, y:1})
                groundProject p | otherwise = p

updatePhysics :: forall r. GameState -> { pos :: Point, vel :: Point | r } -> { pos :: Point, vel :: Point | r }
updatePhysics g@(Game state) c | inFreeFall state.level c = move g fc (unitp fc.vel)
    where
        projectedMovement p = p.pos .+. unitp p.vel

        -- 1. update gravity
        gc = c { vel = { x: c.vel.x, y: c.vel.y + 1 } }

        -- 2. check collision
        newpos = projectedMovement gc
        blocked = not $ isValidMove state.level newpos
        finalVelX = if blocked then 0 else gc.vel.x

        -- 3. calculate final velocity
        fc = c { vel = { x: finalVelX, y: gc.vel.y } }
updatePhysics _ c = c { vel = zerop }

npcWeapon :: Creature -> Item
npcWeapon _ = { itemType: Weapon { weaponType: Sword, material: Iron, prefix: [Masterwork] }, pos: zerop, vel: zerop }

-- todo: get player weapon from equipment
playerWeapon :: GameState -> Item
playerWeapon _ = { itemType: Weapon { weaponType: Axe, material: Iron, prefix: [Masterwork] }, pos: zerop, vel: zerop }

playerAttack :: Number -> GameState -> GameState
playerAttack i g@(Game state) = let attack = playerHit g
                                in if attack.hit then addMsg ("You hit " ++ (get i g "" (\c -> show c.ctype)) ++ "!") $ modifyCreatureAt i attack.game (takeDamage (playerWeapon g) state.player)
                                   else addMsg ("You missed " ++ get i g "" (\c -> show c.ctype) ++ "!") attack.game

npcAttack :: Creature -> GameState -> GameState
npcAttack c g = let attack = npcHit c g
                in if attack.hit then addMsg (show c.ctype ++ " hit you!") <<< (\(Game st) -> Game st { player = takeDamage (npcWeapon c) c st.player }) $ attack.game
                else addMsg (show c.ctype ++ " tried to attack you, but missed.") attack.game

baseHitChance :: Creature -> Number
baseHitChance c = 50 + 5 * (statModf c.stats.dex)

playerHit :: GameState -> { hit :: Boolean, game :: GameState }
playerHit g@(Game state) = let u = useSkill WeaponSkill (baseHitChance state.player) 20 g
                           in { hit: u.success, game: u.game }

npcHit :: Creature -> GameState -> { hit :: Boolean, game :: GameState }
npcHit c g = let u = randInt 0 99 g in { hit: u.n < baseHitChance c, game: u.game }

takeDamage :: Item -> Creature -> Creature -> Creature
takeDamage weapon attacker defender = defender { stats = defender.stats { hp = defender.stats.hp - damage } }
    where
        damage = (itemStat weapon).damage + statModf attacker.stats.str

-- Moves an object that has position. Checks collisions with solid tiles.
move :: forall r. GameState -> { pos :: Point | r } -> Point -> { pos :: Point | r }
move (Game state) c delta =
    if blocked then c else c { pos = newpos }
    where
        newpos  = clampPos $ c.pos .+. delta
        blocked = not $ isValidMove state.level newpos
        w (Level level) = level.width
        h (Level level) = level.height

        clampPos :: Point -> Point
        clampPos pos = { x: clamp pos.x 0 (w state.level - 1), y: clamp pos.y 0 (h state.level - 1) }

-- Updates the game world.
updateWorld :: Boolean -- Update player also?
            -> Number  -- How many time units the game world advances
            -> GameState -> GameState
updateWorld updatePlayer advance =
    updateCreatures advance >>> (if updatePlayer then updatePlayerPhysics else id) >>> updateItemPhysics
    where
        updatePlayerPhysics (Game state) | isClimbable state.level state.player.pos =
            Game state
        updatePlayerPhysics (Game state) | otherwise =
            Game state { player = updatePhysics (Game state) state.player }

        updateItemPhysics (Game state) = Game state { items = map (updatePhysics (Game state)) state.items }

-- Sets tile at point p to tile t. Recalculates pathfinding graph.
setTile' :: Point -> Tile -> GameState -> GameState
setTile' p t (Game state) = let newlevel = setTile state.level p t
                            in Game state { level = newlevel, pathfinder = makePathfinder (levelWeights newlevel) }

canGrab :: forall r. Level -> { pos :: Point, vel :: Point | r } -> Boolean
canGrab level c = climb || (isFree {x:0, y: 1} && (ledge (-1) || ledge 1))
    where
        climb = isClimbable level c.pos
        ledge dx = isFree {x: dx, y: -1} && blocked {x: dx, y: 0}
        isFree delta  = isValidMove level (c.pos .+. delta)
        blocked = not <<< isFree

playerCannotAct :: forall r. Level -> { pos :: Point, vel :: Point | r } -> Boolean
playerCannotAct level c = inFreeFall level c && not (canGrab level c)

movePlayer :: Point -> GameState -> GameState
movePlayer delta g@(Game state) = let blockIndex = enemyBlocks state.npcs 0
    in if blockIndex >= 0 then
        updateWorld false (itemStat $ playerWeapon g).attackSpeed $ playerAttack blockIndex g
        else if canMove then
            updateWorld false (calcSpeed g) <<< useMoveSkill $ Game state { player = move (Game state) state.player { vel = zerop } delta }
            else checkTile <<< fromMaybe Air <<< getTile state.level $ newpos
    where
        useMoveSkill :: GameState -> GameState
        useMoveSkill g@(Game state) | state.move == RunMode && not (delta .==. zerop) = (useSkill Athletics 50 2 g).game
        useMoveSkill g@(Game state) | state.move == SneakMode && canGetSneakSkill g && not (delta .==. zerop) = (useSkill Sneak 100 5 g).game
        useMoveSkill g@(Game state) | otherwise = g

        canGetSneakSkill :: GameState -> Boolean
        canGetSneakSkill (Game state) = any (\c -> lineOfSight state.level c.pos state.player.pos) $ filter (\c -> noAlert c.ai) state.npcs

        noAlert :: AI -> Boolean
        noAlert (AI NoAlert _)  = true
        noAlert (AI MightSee _) = true
        noAlert _               = false

        newpos  = state.player.pos .+. delta
        canMove = isValidMove state.level newpos

        enemyBlocks (c:cs) i | c.pos .==. newpos = i
        enemyBlocks (c:cs) i | otherwise         = enemyBlocks cs (i + 1)
        enemyBlocks [] _                         = -1

        checkTile :: Tile -> GameState
        checkTile DoorClosed = updateWorld false 500 $ addMsg "You open the door." $ setTile' newpos DoorOpen g
        checkTile DoorLocked = updateWorld false 2000 $ pickLock
        checkTile _          = g

        pickLock :: GameState
        pickLock = let use = useSkill Lockpick 10 20 g
                   in if use.success then addMsg "The door is locked. You managed to pick the lock." $ setTile' newpos DoorClosed use.game
                   else addMsg "The door is locked. You fail to pick the lock." use.game

playerJump :: GameState -> Number -> GameState
playerJump g@(Game state) xdir | not (isValidMove state.level (state.player.pos .+. {x: xdir, y: -1})) =
    movePlayer {x: xdir, y: -1} g
playerJump g@(Game state) xdir | isValidMove state.level (state.player.pos .+. {x: xdir, y: -1}) && not (isValidMove state.level (state.player.pos .+. {x: xdir, y: 0})) =
    movePlayer {x: xdir, y: -1} g
playerJump g@(Game state) xdir | isClimbable state.level (state.player.pos .+. {x: xdir, y: -1}) =
    movePlayer {x: xdir, y: -1} g
playerJump g@(Game state) xdir | otherwise =
    Game state { player = state.player { vel = {x: xdir, y: -3} } }

movementkeys :: M.Map Number Point
movementkeys = M.fromList [numpad 8 // {x:  0, y: -1}
                          ,numpad 2 // {x:  0, y:  1}
                          ,numpad 4 // {x: -1, y:  0}
                          ,numpad 6 // {x:  1, y:  0}
                          ,numpad 5 // {x:  0, y:  0}
                          ,numpad 1 // {x: -1, y:  1}
                          ,numpad 3 // {x:  1, y:  1}]

numberkeys :: [Number]
numberkeys = (48 .. 57) ++ (96 .. 105)

numbers :: M.Map Number Number
numbers = M.fromList [48 // 0, 49 // 1, 50 // 2, 51 // 3, 52  // 4, 53  // 5, 54  // 6, 55  // 7, 56  // 8, 57  // 9
                     ,96 // 0, 97 // 1, 98 // 2, 99 // 3, 100 // 4, 101 // 5, 102 // 6, 103 // 7, 104 // 8, 105 // 9]

-- Player tries to pick up an item.
pickUp :: Point -> GameState -> GameState
pickUp point (Game state) =
    case head (filter (\i -> i.pos .==. point) state.items) of
        Just ( { itemType = Loot { value = points } } ) -> addMsg ("You found " ++ show points ++ " $!") $ Game state { items = deleteItem state.items point, points = state.points + points }
        Just item -> case ( ( carryingWeight (M.values state.equipments) + carryingWeight state.inventory ) / maxCarryingCapacity state.player ) < 110 of
                         true  -> addMsg ("You acquired: " ++ show item.itemType) $ Game state { items = deleteItem state.items point, inventory = item : state.inventory }
                         false -> addMsg "You can't carry that much weight!" $ Game state
        Nothing   -> Game state
    where
        deleteItem :: [Item] -> Point -> [Item]
        deleteItem (x:xs) delPos | x.pos .==. delPos = xs
        deleteItem (x:xs) delPos | otherwise = x : deleteItem xs delPos
        deleteItem [] _ = []

-- Player tries to drop item while in inventory.
dropItem :: Number -> GameState -> GameState
dropItem itemNumber g@(Game state@{ window = InventoryW wi, inventory = inv, items = itemsOnGround }) =
    case (!!) inv i of
        (Just item) -> addMsg ("You dropped: " ++ show item.itemType) $ (Game state { inventory = deleteAt i 1 inv, items = (item { pos = state.player.pos }) : itemsOnGround, window = InventoryW wi { index = 0 } })
        Nothing -> g
    where
        i = itemNumber + wi.index * 10
dropItem _ g = g

-- Remove some equipment in particular slot
removeOldEquip :: EquipmentSlot -> M.Map EquipmentSlot Item -> M.Map EquipmentSlot Item
removeOldEquip slot eq =
    case M.lookup slot eq of
        Just item -> M.delete slot eq
        Nothing   -> eq

-- Equip function (used while in inventory and equipment slot is chosen).
equip :: Number -> GameState -> GameState
equip i g@(Game state@{ equipments = eq, window = InventoryW { equip = (Just slot) }, inventory = inv }) =
    case (!!) inv i of
        Just item -> case isValidEquip item.itemType slot of
                        true  -> Game state { equipments = M.insert slot item eq , inventory = deleteAt i 1 inv, window = EquipW }
                        false -> addMsg ("Can't equip that item " ++ show slot) g
        Nothing -> addMsg "There is no item in there." g
equip _ g = g

onKeyPress :: Console -> GameState -> Number -> ConsoleEff GameState
onKeyPress console g@(Game state) _   | playerCannotAct state.level state.player = return g

-- Change page in inventory with + and -
onKeyPress console (Game state@{ window = InventoryW iw, inventory = inv }) key | (key == 187 || key == 107) && floor ((length inv) / 10) <= iw.index = drawGame console $ Game state { window = InventoryW iw { index = 0 } }
onKeyPress console (Game state@{ window = InventoryW iw, inventory = inv }) key | (key == 187 || key == 107)                                          = drawGame console $ Game state { window = InventoryW iw { index = (iw.index + 1) } }
onKeyPress console (Game state@{ window = InventoryW iw, inventory = inv }) key | (key == 189 || key == 109) && iw.index == 0                         = drawGame console $ Game state { window = InventoryW iw { index = (floor ((length inv) / 10)) } }
onKeyPress console (Game state@{ window = InventoryW iw, inventory = inv }) key | (key == 189 || key == 109)                                          = drawGame console $ Game state { window = InventoryW iw { index = (iw.index - 1) } }

-- Choosing equipment slot in equipment window
onKeyPress console g@(Game state@{ window = EquipW , equipments = eq , inventory = inv }) key | elem key numberkeys =
    case (!!) allEquipmentSlots number of
        Just slot  -> case M.lookup slot eq of
                          Just item -> drawGame console $ (Game state { window = EquipW, equipments = removeOldEquip slot eq, inventory = item : inv })
                          Nothing   -> drawGame console $ (Game state { window = InventoryW { index: 0, command: NoCommand, equip: Just slot } })
        Nothing  -> return g
        where
            number :: Number
            number =
                case M.lookup key numbers of
                    Just n  -> n
                    Nothing -> -1

-- Using command in inventory
onKeyPress console (Game state@{ window = InventoryW iw })                      key | key == 68           = drawGame console $ Game state { window = InventoryW { index: iw.index, command: Drop, equip: Nothing } }
onKeyPress console g@(Game state@{ window = InventoryW iw@{ command = Drop, equip = Nothing } }) key | elem key numberkeys =
    case M.lookup key numbers of
        Just number -> drawGame console $ dropItem number (Game state { window = InventoryW iw { command = NoCommand } })
        Nothing     -> return g

-- Equipping item while in inventory window (when equip option is valid)
onKeyPress console g@(Game state@{ window = InventoryW iw@{ equip = slot } }) key | elem key numberkeys =
    case M.lookup key numbers of
        Just number -> drawGame console $ equip number g
        Nothing     -> return g

-- Change game states window with s, i and e (GameW, EquipW and InventoryW) TODO: add skillwindow
onKeyPress console (Game state@{ window = InventoryW iw }) key | key == makeCharCode "I" = drawGame console $ Game state { window = GameW }
onKeyPress console (Game state@{ window = EquipW  })       key | key == makeCharCode "I" = drawGame console $ Game state { window = InventoryW { index: 0, command: NoCommand, equip: Nothing } }
onKeyPress console (Game state@{ window = SkillW })        key | key == makeCharCode "I" = drawGame console $ Game state { window = InventoryW { index: 0, command: NoCommand, equip: Nothing } }
onKeyPress console (Game state@{ window = GameW })         key | key == makeCharCode "I" = drawGame console $ Game state { window = InventoryW { index: 0, command: NoCommand, equip: Nothing } }
onKeyPress console (Game state@{ window = InventoryW iw }) key | key == makeCharCode "E" = drawGame console $ Game state { window = EquipW }
onKeyPress console (Game state@{ window = EquipW })        key | key == makeCharCode "E" = drawGame console $ Game state { window = GameW }
onKeyPress console (Game state@{ window = SkillW })        key | key == makeCharCode "E" = drawGame console $ Game state { window = EquipW }
onKeyPress console (Game state@{ window = GameW })         key | key == makeCharCode "E" = drawGame console $ Game state { window = EquipW }
onKeyPress console (Game state@{ window = InventoryW iw }) key | key == makeCharCode "A" = drawGame console $ Game state { window = SkillW }
onKeyPress console (Game state@{ window = EquipW })        key | key == makeCharCode "A" = drawGame console $ Game state { window = SkillW }
onKeyPress console (Game state@{ window = SkillW })        key | key == makeCharCode "A" = drawGame console $ Game state { window = GameW }
onKeyPress console (Game state@{ window = GameW })         key | key == makeCharCode "A" = drawGame console $ Game state { window = SkillW }

-- Esc closes inventory, equipment or skill window and returns the player to the game window
onKeyPress console (Game state) key | key == 27 = drawGame console $ Game state { window = GameW }

-- Change movement mode
onKeyPress console (Game state@{ move = move }) key | key == makeCharCode "R" && move == RunMode = drawGame console $ Game state { move = NormalMode }
onKeyPress console (Game state@{ move = move }) key | key == makeCharCode "R" && move /= RunMode = drawGame console $ Game state { move = RunMode }
onKeyPress console (Game state@{ move = move }) key | key == makeCharCode "S" && move == SneakMode = drawGame console $ Game state { move = NormalMode }
onKeyPress console (Game state@{ move = move }) key | key == makeCharCode "S" && move /= SneakMode = drawGame console $ Game state { move = SneakMode }

onKeyPress console g@(Game state@{ window = GameW }) key | key == numpad 7               = drawGame console $ playerJump g (-1)
onKeyPress console g@(Game state@{ window = GameW }) key | key == numpad 9               = drawGame console $ playerJump g 1
onKeyPress console g@(Game state@{ window = GameW }) key | key == numpad 8               = drawGame console $ playerJump g 0
onKeyPress console g@(Game state@{ window = GameW }) key | key == makeCharCode "G"       = drawGame console $ pickUp (state.player.pos) g
onKeyPress console g@(Game state@{ window = GameW }) key =
    case M.lookup key movementkeys of
        Just delta -> drawGame console $ movePlayer delta g
        Nothing    -> return g

onKeyPress console MainMenu key                              | key == 13       = return $ NameCreation { playerName: "" }
onKeyPress console (NameCreation { playerName = pname }) key | key == 13       = return $ CharCreation { playerName: pname }
onKeyPress console (NameCreation { playerName = xs })    key | key == 8        = return $ NameCreation { playerName: (take (strlen xs - 1) xs) }
onKeyPress console (NameCreation { playerName = "" })    key                   = return $ NameCreation { playerName: (fromCharArray [fromCharCode key]) }
onKeyPress console (NameCreation { playerName = xs })    key | strlen xs > 15  = return $ NameCreation { playerName: xs }
onKeyPress console (NameCreation { playerName = xs })    key                   = return $ NameCreation { playerName: (xs ++ (fromCharArray [fromCharCode key])) }
onKeyPress console (CharCreation { playerName = xs })    key | key == 65       = return $ initialState xs
onKeyPress _ st _ = return st

main = J.ready $ withConsole 80 25 MainMenu {onKeyPress: onKeyPress, onUpdate: onUpdate}

module Main where

import Data.Char
import Data.String hiding (length, drop)
import Data.Maybe
import Data.Tuple
import Data.Array ((!!), (..), map, updateAt, modifyAt, range, length, head, filter, drop, deleteAt, delete)
import Data.Foldable
import qualified Data.Map as M
import Control.Monad.Eff
import qualified Control.Monad.JQuery as J
import Debug.Trace
import Math

import Graphics.CanvasConsole
import RandomGen
import GameState
import GameData
import Drawing
import Utils
import Level
import Astar
import Line

strlen = Data.String.length

-- Uses skill and gets experience.
useSkill :: SkillType
         -> Number -- Odds of success when unskilled (0 - 99)
         -> Number -- Experience gained
         -> GameState
         -> { success :: Boolean, game :: GameState }
useSkill skillType odds expr g@(Game state) = { success: success, game: addExp gen.game }
    where
        gen       = randInt 0 100 g
        finalOdds = odds * pow 1.2 (fromMaybe 0 $ (\s -> s.level) <$> M.lookup skillType state.skills)
        success   = gen.n < finalOdds
        addExp g@(Game state) | success = -- Skill increases with successes
            let skill        = fromMaybe { level: 0, prog: 0 } $ M.lookup skillType state.skills
                updatedSkill = increaseSkill skill
                gotLevel     = updatedSkill.level > skill.level
            in addLevelUpMsg gotLevel updatedSkill.level $ Game state { skills = M.insert skillType updatedSkill state.skills }
        addExp g@(Game state) | otherwise = g -- No experience gained

        expRequired :: Number -> Number
        expRequired lvl = 100 + 50 * lvl

        addLevelUpMsg :: Boolean -> Number -> GameState -> GameState
        addLevelUpMsg true newlvl = addMsg $ "Your " ++ show skillType ++ " skill increased to " ++ show newlvl ++ "."
        addLevelUpMsg _ _         = id

        increaseSkill :: Skill -> Skill
        increaseSkill skill | skill.prog + expr >= expRequired skill.level =
            skill { level = skill.level + 1, prog = skill.prog + expr - expRequired skill.level }
        increaseSkill skill | otherwise =
            skill { prog = skill.prog + expr }

-- Updates blinking timer.
updateBlinkTimer :: Number -> GameState -> GameState
updateBlinkTimer dt (Game state) | state.blinkTimer > 0.5 = Game state { blink = not state.blink, blinkTimer = 0 }
updateBlinkTimer dt (Game state) | otherwise              = Game state { blinkTimer = state.blinkTimer + dt }

-- onUpdate is called as often as possible.
onUpdate :: Console -> Number -> GameState -> ConsoleEff GameState
onUpdate console dt g@(Game state) | playerCannotAct state.level state.player && state.freeFallTimer > 0.1 =
    drawGame console <<< updateBlinkTimer dt <<< updateWorld true (calcSpeed g) $ Game state { freeFallTimer = 0 }
onUpdate console dt g@(Game state) | otherwise =
    blinkDraw console <<< updateBlinkTimer dt $ Game state { freeFallTimer = state.freeFallTimer + dt }
onUpdate console _ g = drawGame console g

-- Gets creature information from creature at index i.
get :: forall a. Number -> GameState -> a -> (Creature -> a) -> a
get i (Game state) d getter = fromMaybe d $ getter <$> state.npcs !! i

-- Modify creature at index i with a function.
modifyCreatureAt :: Number -> GameState -> (Creature -> Creature) -> GameState
modifyCreatureAt i (Game state) f = Game state { npcs = modifyAt i f state.npcs }

-- Updates all npcs.
updateCreatures :: Number -> GameState -> GameState
updateCreatures advance g@(Game state') =
    foldl (\g' i -> updateCreature i (advTime i g')) g (0 .. (length state'.npcs - 1))
    where
        -- Updaters are not allowed to remove creatures.
        -- Dead creatures will be cleaned up later.

        -- Advances game time for creature at index i.
        advTime :: Number -> GameState -> GameState
        advTime i game = modifyCreatureAt i game $ \c -> c { time = c.time + advance }

        -- Updates creature at index i until it runs out of time.
        updateCreature :: Number -> GameState -> GameState
        updateCreature i game | get i game 0 (\c -> c.time) >= get i game 0 (calcNpcSpeed game) =
            updateCreature i (modifyCreatureAt i (updateCreatureOnce i game) (\c -> c { time = c.time - calcNpcSpeed game c }))
        updateCreature i game | otherwise = game

        -- Creature at index i does a single action.
        updateCreatureOnce :: Number -> GameState -> GameState
        updateCreatureOnce i g@(Game state) =
            let spotRoll     = randInt 0 99 g
                newAlertAI   = updateAlertness spotRoll.n (get i g NoAI (\c -> c.ai))
                changedAlert = modifyCreatureAt i spotRoll.game (\c ->c { ai = newAlertAI })
            in updateAI changedAlert newAlertAI -- add updatePhysics?
            where
                -- Creature position
                cpos :: Point
                cpos = get i g zerop (\c -> c.pos)

                lookingAtPlayer :: Boolean
                lookingAtPlayer | get i g false (\c -> c.dir.x == 0)                               = true
                lookingAtPlayer | get i g false (\c -> c.dir.x < 0) && cpos.x > state.player.pos.x = true
                lookingAtPlayer | get i g false (\c -> c.dir.x > 0) && cpos.x < state.player.pos.x = true
                lookingAtPlayer | otherwise = false

                canSeePlayer :: Boolean
                canSeePlayer = lookingAtPlayer && (distanceSq cpos state.player.pos < 10 * 10) && (lineOfSight state.level cpos state.player.pos)

                canHide :: Number -> Boolean
                canHide roll = roll < (40 * pow 1.2 (fromMaybe 0 $ (\s -> s.level) <$> M.lookup Sneak state.skills))

                updateAlertness :: Number -> AI -> AI
                updateAlertness roll (AI NoAlert st)  | canSeePlayer = AI MightSee st
                updateAlertness roll (AI NoAlert st)  | otherwise    = AI NoAlert st
                updateAlertness roll (AI MightSee st) | canSeePlayer && not (canHide roll) = AI (Suspicious 1) st
                updateAlertness roll (AI MightSee st) | otherwise                          = AI NoAlert st
                updateAlertness roll (AI (Suspicious n) st) | n == 0                = AI NoAlert st
                updateAlertness roll (AI (Suspicious n) st) | not canSeePlayer      = AI (Suspicious (n - 1)) st
                updateAlertness roll (AI (Suspicious n) st) | canSeePlayer && n < 4 = AI (Suspicious (n + 1)) st
                updateAlertness roll (AI (Suspicious n) st) | otherwise             = AI (Alert 10) st
                updateAlertness roll (AI (Alert n) st) | canSeePlayer = AI (Alert 10) st
                updateAlertness roll (AI (Alert n) st) | n == 0       = AI NoAlert st
                updateAlertness roll (AI (Alert n) st) | otherwise    = AI (Alert (n - 1)) st
                updateAlertness _ x = x

                newPatrolPoint :: GameState -> { p :: Point, game :: GameState }
                newPatrolPoint g' = let points = validPatrolPoints
                                        gen    = randInt 0 (length points - 1) g'
                                    in { p: fromMaybe zerop (points !! gen.n), game: gen.game }

                validPatrolPoints :: [Point]
                validPatrolPoints = filter canWalkOn $ levelPoints state.level
                    where
                        canWalkOn p = isValidMove state.level p && not (isValidMove state.level (p .+. {x: 0, y: 1}))

                updateAI :: GameState -> AI -> GameState
                updateAI g (AI (Alert _) _)      = mover g $ moveToPlayer
                updateAI g (AI (Suspicious _) _) = mover g $ moveToPlayer
                updateAI g (AI _ (Idle p))       = mover g $ moveToPoint p
                updateAI g (AI a (Patrol p)) =
                    if length (pathToPoint g cpos p) <= 2 then
                        let gen = newPatrolPoint g
                        in modifyCreatureAt i gen.game (\c -> c { ai = AI a (Patrol gen.p) })
                    else mover g $ moveToPoint p
                updateAI g _ = g

                mover :: GameState -> (Creature -> Point) -> GameState
                mover g@(Game state) f = let nextPoint = get i g zerop f
                            in if state.player.pos .==. nextPoint then
                                -- get doesn't really get anything from creature, I'm just exploiting
                                -- it's type to make the attack.
                                -- get :: Number -> GameState -> GameState -> (Creature -> GameState) -> Gamestate
                                get i g g (flip npcAttack g)
                            else modifyCreatureAt i g $ walk nextPoint

                walk :: Point -> Creature -> Creature
                walk p c = c { pos = p, dir = p .-. c.pos }

                moveToPoint :: Point -> Creature -> Point
                moveToPoint p c = case head (pathToPoint g c.pos p) of
                                   Just p'  -> p'
                                   Nothing -> c.pos

                moveToPlayer :: Creature -> Point
                moveToPlayer c = case head (pathToPlayer g c.pos) of
                                   Just p'  -> p'
                                   Nothing -> c.pos

        pathToPoint :: GameState -> Point -> Point -> [Point]
        pathToPoint (Game state) start end = findPath state.pathfinder start end

        pathToPlayer :: GameState -> Point -> [Point]
        pathToPlayer g@(Game state) start = pathToPoint g start (groundProject state.player.pos)
            where
                -- Projects position to ground or climbable tile.
                groundProject :: Point -> Point
                groundProject p | isClimbable state.level (p .+. {x:0, y:0}) = p
                groundProject p | isValidMove state.level (p .+. {x:0, y:1}) = groundProject (p .+. {x:0, y:1})
                groundProject p | otherwise = p

updatePhysics :: forall r. GameState -> { pos :: Point, vel :: Point | r } -> { pos :: Point, vel :: Point | r }
updatePhysics g@(Game state) c | inFreeFall state.level c = move g fc (unitp fc.vel)
    where
        projectedMovement p = p.pos .+. unitp p.vel

        -- 1. update gravity
        gc = c { vel = { x: c.vel.x, y: c.vel.y + 1 } }

        -- 2. check collision
        newpos = projectedMovement gc
        blocked = not $ isValidMove state.level newpos
        finalVelX = if blocked then 0 else gc.vel.x

        -- 3. calculate final velocity
        fc = c { vel = { x: finalVelX, y: gc.vel.y } }
updatePhysics _ c = c { vel = zerop }

npcWeapon :: Creature -> Item
npcWeapon _ = { itemType: Weapon { weaponType: Sword, material: Iron, prefix: [Masterwork] }, pos: zerop, vel: zerop }

-- todo: get player weapon from equipment
playerWeapon :: GameState -> Item
playerWeapon _ = { itemType: Weapon { weaponType: Axe, material: Iron, prefix: [Masterwork] }, pos: zerop, vel: zerop }

playerAttack :: Number -> GameState -> GameState
playerAttack i g@(Game state) = let attack = playerHit g
                                in if attack.hit then addMsg ("You hit " ++ (get i g "" (\c -> show c.ctype)) ++ "!") $ modifyCreatureAt i attack.game (takeDamage (playerWeapon g) state.player)
                                   else addMsg ("You missed " ++ get i g "" (\c -> show c.ctype) ++ "!") attack.game

npcAttack :: Creature -> GameState -> GameState
npcAttack c g = let attack = npcHit c g
                in if attack.hit then addMsg (show c.ctype ++ " hit you!") <<< (\(Game st) -> Game st { player = takeDamage (npcWeapon c) c st.player }) $ attack.game
                else addMsg (show c.ctype ++ " tried to attack you, but missed.") attack.game

baseHitChance :: Creature -> Number
baseHitChance c = 50 + 5 * (statModf c.stats.dex)

playerHit :: GameState -> { hit :: Boolean, game :: GameState }
playerHit g@(Game state) = let u = useSkill WeaponSkill (baseHitChance state.player) 20 g
                           in { hit: u.success, game: u.game }

npcHit :: Creature -> GameState -> { hit :: Boolean, game :: GameState }
npcHit c g = let u = randInt 0 99 g in { hit: u.n < baseHitChance c, game: u.game }

takeDamage :: Item -> Creature -> Creature -> Creature
takeDamage weapon attacker defender = defender { stats = defender.stats { hp = defender.stats.hp - damage } }
    where
        damage = (itemStat weapon).damage + statModf attacker.stats.str

-- Moves an object that has position. Checks collisions with solid tiles.
move :: forall r. GameState -> { pos :: Point | r } -> Point -> { pos :: Point | r }
move (Game state) c delta =
    if blocked then c else c { pos = newpos }
    where
        newpos  = clampPos $ c.pos .+. delta
        blocked = not $ isValidMove state.level newpos
        w (Level level) = level.width
        h (Level level) = level.height

        clampPos :: Point -> Point
        clampPos pos = { x: clamp pos.x 0 (w state.level - 1), y: clamp pos.y 0 (h state.level - 1) }

-- Updates the game world.
updateWorld :: Boolean -- Update player also?
            -> Number  -- How many time units the game world advances
            -> GameState -> GameState
updateWorld updatePlayer advance =
    updateCreatures advance >>> (if updatePlayer then updatePlayerPhysics else id) >>> updateItemPhysics
    where
        updatePlayerPhysics (Game state) | isClimbable state.level state.player.pos =
            Game state
        updatePlayerPhysics (Game state) | otherwise =
            Game state { player = updatePhysics (Game state) state.player }

        updateItemPhysics (Game state) = Game state { items = map (updatePhysics (Game state)) state.items }

-- Sets tile at point p to tile t. Recalculates pathfinding graph.
setTile' :: Point -> Tile -> GameState -> GameState
setTile' p t (Game state) = let newlevel = setTile state.level p t
                            in Game state { level = newlevel, pathfinder = makePathfinder (levelWeights newlevel) }

canGrab :: forall r. Level -> { pos :: Point, vel :: Point | r } -> Boolean
canGrab level c = climb || (isFree {x:0, y: 1} && (ledge (-1) || ledge 1))
    where
        climb = isClimbable level c.pos
        ledge dx = isFree {x: dx, y: -1} && blocked {x: dx, y: 0}
        isFree delta  = isValidMove level (c.pos .+. delta)
        blocked = not <<< isFree

playerCannotAct :: forall r. Level -> { pos :: Point, vel :: Point | r } -> Boolean
playerCannotAct level c = inFreeFall level c && not (canGrab level c)

movePlayer :: Point -> GameState -> GameState
movePlayer delta g@(Game state) = let blockIndex = enemyBlocks state.npcs 0
    in if blockIndex >= 0 then
        updateWorld false (itemStat $ playerWeapon g).attackSpeed $ playerAttack blockIndex g
        else if canMove then
            updateWorld false (calcSpeed g) <<< useMoveSkill $ Game state { player = move (Game state) state.player { vel = zerop } delta }
            else checkTile <<< fromMaybe Air <<< getTile state.level $ newpos
    where
        useMoveSkill :: GameState -> GameState
        useMoveSkill g@(Game state) | state.move == RunMode && not (delta .==. zerop) = (useSkill Athletics 50 2 g).game
        useMoveSkill g@(Game state) | state.move == SneakMode && canGetSneakSkill g && not (delta .==. zerop) = (useSkill Sneak 100 5 g).game
        useMoveSkill g@(Game state) | otherwise = g

        canGetSneakSkill :: GameState -> Boolean
        canGetSneakSkill (Game state) = any (\c -> lineOfSight state.level c.pos state.player.pos) $ filter (\c -> noAlert c.ai) state.npcs

        noAlert :: AI -> Boolean
        noAlert (AI NoAlert _)  = true
        noAlert (AI MightSee _) = true
        noAlert _               = false

        newpos  = state.player.pos .+. delta
        canMove = isValidMove state.level newpos

        enemyBlocks (c:cs) i | c.pos .==. newpos = i
        enemyBlocks (c:cs) i | otherwise         = enemyBlocks cs (i + 1)
        enemyBlocks [] _                         = -1

        checkTile :: Tile -> GameState
        checkTile DoorClosed = updateWorld false 500 $ addMsg "You open the door." $ setTile' newpos DoorOpen g
        checkTile DoorLocked = updateWorld false 2000 $ pickLock
        checkTile _          = g

        pickLock :: GameState
        pickLock = let use = useSkill Lockpick 10 20 g
                   in if use.success then addMsg "The door is locked. You managed to pick the lock." $ setTile' newpos DoorClosed use.game
                   else addMsg "The door is locked. You fail to pick the lock." use.game

playerJump :: GameState -> Number -> GameState
playerJump g@(Game state) xdir | not (isValidMove state.level (state.player.pos .+. {x: xdir, y: -1})) =
    movePlayer {x: xdir, y: -1} g
playerJump g@(Game state) xdir | isValidMove state.level (state.player.pos .+. {x: xdir, y: -1}) && not (isValidMove state.level (state.player.pos .+. {x: xdir, y: 0})) =
    movePlayer {x: xdir, y: -1} g
playerJump g@(Game state) xdir | isClimbable state.level (state.player.pos .+. {x: xdir, y: -1}) =
    movePlayer {x: xdir, y: -1} g
playerJump g@(Game state) xdir | otherwise =
    Game state { player = state.player { vel = {x: xdir, y: -3} } }

movementkeys :: M.Map Number Point
movementkeys = M.fromList [numpad 8 // {x:  0, y: -1}
                          ,numpad 2 // {x:  0, y:  1}
                          ,numpad 4 // {x: -1, y:  0}
                          ,numpad 6 // {x:  1, y:  0}
                          ,numpad 5 // {x:  0, y:  0}
                          ,numpad 1 // {x: -1, y:  1}
                          ,numpad 3 // {x:  1, y:  1}]

numberkeys :: [Number]
numberkeys = (48 .. 57) ++ (96 .. 105)

numbers :: M.Map Number Number
numbers = M.fromList [48 // 0, 49 // 1, 50 // 2, 51 // 3, 52  // 4, 53  // 5, 54  // 6, 55  // 7, 56  // 8, 57  // 9
                     ,96 // 0, 97 // 1, 98 // 2, 99 // 3, 100 // 4, 101 // 5, 102 // 6, 103 // 7, 104 // 8, 105 // 9]

-- Player tries to pick up an item.
pickUp :: Point -> GameState -> GameState
pickUp point (Game state) =
    case head (filter (\i -> i.pos .==. point) state.items) of
        Just ( { itemType = Loot { value = points } } ) -> addMsg ("You found " ++ show points ++ " $!") $ Game state { items = deleteItem state.items point, points = state.points + points }
        Just item -> addMsg ("You acquired: " ++ show item.itemType) $ Game state { items = deleteItem state.items point, inventory = item : state.inventory }
        Nothing   -> Game state
    where
        deleteItem :: [Item] -> Point -> [Item]
        deleteItem (x:xs) delPos | x.pos .==. delPos = xs
        deleteItem (x:xs) delPos | otherwise = x : deleteItem xs delPos
        deleteItem [] _ = []

-- Player tries to drop item while in inventory.
dropItem :: Number -> GameState -> GameState
dropItem itemNumber g@(Game state@{ window = InventoryW wi, inventory = inv, items = itemsOnGround }) =
    case (!!) inv i of
        (Just item) -> addMsg ("You dropped: " ++ show item.itemType) $ (Game state { inventory = deleteAt i 1 inv, items = (item { pos = state.player.pos }) : itemsOnGround, window = InventoryW wi { index = 0 } })
        Nothing -> g
    where
        i = itemNumber + wi.index * 10
dropItem _ g = g

-- Remove some equipment in particular slot
removeOldEquip :: EquipmentSlot -> M.Map EquipmentSlot Item -> M.Map EquipmentSlot Item
removeOldEquip slot eq =
    case M.lookup slot eq of
        Just item -> M.delete slot eq
        Nothing   -> eq

-- Equip function (used while in inventory and equipment slot is chosen).
equip :: Number -> GameState -> GameState
equip i g@(Game state@{ equipments = eq, window = InventoryW { equip = (Just slot) }, inventory = inv }) =
    case (!!) inv i of
        Just item -> case isValidEquip item.itemType slot of
                        true  -> Game state { equipments = M.insert slot item eq , inventory = deleteAt i 1 inv, window = EquipW }
                        false -> addMsg ("Can't equip that item " ++ show slot) g
        Nothing -> addMsg "There is no item in there." g
equip _ g = g

onKeyPress :: Console -> GameState -> Number -> ConsoleEff GameState
onKeyPress console g@(Game state) _   | playerCannotAct state.level state.player = return g

-- Change page in inventory with + and -
onKeyPress console (Game state@{ window = InventoryW iw, inventory = inv }) key | (key == 187 || key == 107) && floor ((length inv) / 10) <= iw.index = drawGame console $ Game state { window = InventoryW iw { index = 0 } }
onKeyPress console (Game state@{ window = InventoryW iw, inventory = inv }) key | (key == 187 || key == 107)                                          = drawGame console $ Game state { window = InventoryW iw { index = (iw.index + 1) } }
onKeyPress console (Game state@{ window = InventoryW iw, inventory = inv }) key | (key == 189 || key == 109) && iw.index == 0                         = drawGame console $ Game state { window = InventoryW iw { index = (floor ((length inv) / 10)) } }
onKeyPress console (Game state@{ window = InventoryW iw, inventory = inv }) key | (key == 189 || key == 109)                                          = drawGame console $ Game state { window = InventoryW iw { index = (iw.index - 1) } }

-- Choosing equipment slot in equipment window
onKeyPress console g@(Game state@{ window = EquipW , equipments = eq , inventory = inv }) key | elem key numberkeys =
    case (!!) allEquipmentSlots number of
        Just slot  -> case M.lookup slot eq of
                          Just item -> drawGame console $ (Game state { window = EquipW, equipments = removeOldEquip slot eq, inventory = item : inv })
                          Nothing   -> drawGame console $ (Game state { window = InventoryW { index: 0, command: NoCommand, equip: Just slot } })
        Nothing  -> return g
        where
            number :: Number
            number =
                case M.lookup key numbers of
                    Just n  -> n
                    Nothing -> -1

-- Using command in inventory
onKeyPress console (Game state@{ window = InventoryW iw })                      key | key == 68           = drawGame console $ Game state { window = InventoryW { index: iw.index, command: Drop, equip: Nothing } }
onKeyPress console g@(Game state@{ window = InventoryW iw@{ command = Drop, equip = Nothing } }) key | elem key numberkeys =
    case M.lookup key numbers of
        Just number -> drawGame console $ dropItem number (Game state { window = InventoryW iw { command = NoCommand } })
        Nothing     -> return g

-- Equipping item while in inventory window (when equip option is valid)
onKeyPress console g@(Game state@{ window = InventoryW iw@{ equip = slot } }) key | elem key numberkeys =
    case M.lookup key numbers of
        Just number -> drawGame console $ equip number g
        Nothing     -> return g

-- Change game states window with s, i and e (GameW, EquipW and InventoryW) TODO: add skillwindow
onKeyPress console (Game state@{ window = InventoryW iw }) key | key == makeCharCode "I" = drawGame console $ Game state { window = GameW }
onKeyPress console (Game state@{ window = EquipW  })       key | key == makeCharCode "I" = drawGame console $ Game state { window = InventoryW { index: 0, command: NoCommand, equip: Nothing } }
onKeyPress console (Game state@{ window = SkillW })        key | key == makeCharCode "I" = drawGame console $ Game state { window = InventoryW { index: 0, command: NoCommand, equip: Nothing } }
onKeyPress console (Game state@{ window = GameW })         key | key == makeCharCode "I" = drawGame console $ Game state { window = InventoryW { index: 0, command: NoCommand, equip: Nothing } }
onKeyPress console (Game state@{ window = InventoryW iw }) key | key == makeCharCode "E" = drawGame console $ Game state { window = EquipW }
onKeyPress console (Game state@{ window = EquipW })        key | key == makeCharCode "E" = drawGame console $ Game state { window = GameW }
onKeyPress console (Game state@{ window = SkillW })        key | key == makeCharCode "E" = drawGame console $ Game state { window = EquipW }
onKeyPress console (Game state@{ window = GameW })         key | key == makeCharCode "E" = drawGame console $ Game state { window = EquipW }
onKeyPress console (Game state@{ window = InventoryW iw }) key | key == makeCharCode "A" = drawGame console $ Game state { window = SkillW }
onKeyPress console (Game state@{ window = EquipW })        key | key == makeCharCode "A" = drawGame console $ Game state { window = SkillW }
onKeyPress console (Game state@{ window = SkillW })        key | key == makeCharCode "A" = drawGame console $ Game state { window = GameW }
onKeyPress console (Game state@{ window = GameW })         key | key == makeCharCode "A" = drawGame console $ Game state { window = SkillW }

-- Esc closes inventory, equipment or skill window and returns the player to the game window
onKeyPress console (Game state) key | key == 27 = drawGame console $ Game state { window = GameW }

-- Change movement mode
onKeyPress console (Game state@{ move = move }) key | key == makeCharCode "R" && move == RunMode = drawGame console $ Game state { move = NormalMode }
onKeyPress console (Game state@{ move = move }) key | key == makeCharCode "R" && move /= RunMode = drawGame console $ Game state { move = RunMode }
onKeyPress console (Game state@{ move = move }) key | key == makeCharCode "S" && move == SneakMode = drawGame console $ Game state { move = NormalMode }
onKeyPress console (Game state@{ move = move }) key | key == makeCharCode "S" && move /= SneakMode = drawGame console $ Game state { move = SneakMode }

onKeyPress console g@(Game state@{ window = GameW }) key | key == numpad 7               = drawGame console $ playerJump g (-1)
onKeyPress console g@(Game state@{ window = GameW }) key | key == numpad 9               = drawGame console $ playerJump g 1
onKeyPress console g@(Game state@{ window = GameW }) key | key == numpad 8               = drawGame console $ playerJump g 0
onKeyPress console g@(Game state@{ window = GameW }) key | key == makeCharCode "G"       = drawGame console $ pickUp (state.player.pos) g
onKeyPress console g@(Game state@{ window = GameW }) key =
    case M.lookup key movementkeys of
        Just delta -> drawGame console $ movePlayer delta g
        Nothing    -> return g

onKeyPress console MainMenu key                              | key == 13       = return $ NameCreation { playerName: "" }
onKeyPress console (NameCreation { playerName = pname }) key | key == 13       = return $ CharCreation { playerName: pname }
onKeyPress console (NameCreation { playerName = xs })    key | key == 8        = return $ NameCreation { playerName: (take (strlen xs - 1) xs) }
onKeyPress console (NameCreation { playerName = "" })    key                   = return $ NameCreation { playerName: (fromCharArray [fromCharCode key]) }
onKeyPress console (NameCreation { playerName = xs })    key | strlen xs > 15  = return $ NameCreation { playerName: xs }
onKeyPress console (NameCreation { playerName = xs })    key                   = return $ NameCreation { playerName: (xs ++ (fromCharArray [fromCharCode key])) }
onKeyPress console (CharCreation { playerName = xs })    key | key == 65       = return $ initialState xs
onKeyPress _ st _ = return st

main = J.ready $ withConsole 80 25 MainMenu {onKeyPress: onKeyPress, onUpdate: onUpdate}


improve fairness of chooseInt

improve fairness of chooseInt

module Test.QuickCheck.LCG
  (
    Gen(),
    GenState(),
    GenOut(),
    Size(),
    LCG(),
    repeatable,
    sized,
    stateful,
    resize,
    runGen,
    evalGen,
    perturbGen,
    uniform
  ) where

import Control.Monad.Eff
import Control.Monad.Eff.Random
import Data.Maybe
import Data.Tuple
import Data.Foldable
import Data.Traversable
import Data.Monoid.Sum
import qualified Data.Array as A
import qualified Math as M

type LCG = Number
type Size = Number

type GenState = { newSeed :: LCG, size :: Size }

type GenOut a = { state :: GenState, value :: a }

data Gen a = Gen (GenState -> GenOut a)

repeatable :: forall a b. (a -> Gen b) -> Gen (a -> b)
repeatable f = Gen $ \s -> { value: \a -> (runGen (f a) s).value, state: s }

stateful :: forall a. (GenState -> Gen a) -> Gen a
stateful f = Gen (\s -> runGen (f s) s)

variant :: forall a. LCG -> Gen a -> Gen a
variant n g = Gen $ \s -> runGen g s { newSeed = n }

sized :: forall a. (Size -> Gen a) -> Gen a
sized f = stateful (\s -> f s.size)

resize :: forall a. Size -> Gen a -> Gen a
resize sz g = Gen $ \s -> runGen g s { size = sz }

choose :: Number -> Number -> Gen Number
choose a b = (*) (max - min) >>> (+) min <$> uniform where
  min = M.min a b
  max = M.max a b

chooseInt :: Number -> Number -> Gen Number
chooseInt a b = M.floor <$> choose (M.ceil a) (M.floor b + 0.999999999)

oneOf :: forall a. Gen a -> [Gen a] -> Gen a
oneOf x xs = do
  n <- chooseInt 0 (A.length xs)
  if n == 0 then x else fromMaybe x (xs A.!! (n - 1))

frequency :: forall a. Tuple Number (Gen a) -> [Tuple Number (Gen a)] -> Gen a
frequency x xs = let
    xxs   = x : xs
    total = runSum $ fold (((Sum <<< fst) <$> xxs) :: [Sum])
    pick n d [] = d
    pick n d ((Tuple k x) : xs) = if n <= k then x else pick (n - k) d xs
  in do
    n <- chooseInt 1 total
    pick n (snd x) xxs

listOf :: forall a. Gen a -> Gen [a]
listOf g = sized $ \n ->
  do k <- chooseInt 0 n
     vectorOf k g

listOf1 :: forall a. Gen a -> Gen (Tuple a [a])
listOf1 g = sized $ \n ->
  do k  <- chooseInt 0 n
     x  <- g
     xs <- vectorOf (k - 1) g
     return $ Tuple x xs

vectorOf :: forall a. Number -> Gen a -> Gen [a]
vectorOf k g = sequence $ const g <$> (A.range 1 k)

elements :: forall a. a -> [a] -> Gen a
elements x xs = do
  n <- chooseInt 0 (A.length xs)
  pure if n == 0 then x else fromMaybe x (xs A.!! (n - 1))

runGen :: forall a. Gen a -> GenState -> GenOut a
runGen (Gen f) = f

evalGen :: forall a. Gen a -> GenState -> a
evalGen gen st = (runGen gen st).value
--
-- Magic Numbers
--

lcgM :: Number
lcgM = 1103515245

lcgC :: Number
lcgC = 12345

lcgN :: Number
lcgN = 1 `shl` 30

lcgNext :: Number -> Number
lcgNext n = (lcgM * n + lcgC) % lcgN

lcgStep :: Gen Number
lcgStep = Gen f where
  f s = { value: s.newSeed, state: s { newSeed = lcgNext s.newSeed } }

uniform :: Gen Number
uniform = (\n -> n / (1 `shl` 30)) <$> lcgStep

foreign import float32ToInt32
  "function float32ToInt32(n) {\
  \  var arr = new ArrayBuffer(4);\
  \  var fv = new Float32Array(arr);\
  \  var iv = new Int32Array(arr);\
  \  fv[0] = n;\
  \  return iv[0];\
  \}" :: Number -> Number

perturbGen :: forall a. Number -> Gen a -> Gen a
perturbGen n (Gen f) = Gen $ \s -> f (s { newSeed = lcgNext (float32ToInt32 n) + s.newSeed })

instance functorGen :: Functor Gen where
  (<$>) f (Gen g) = Gen $ \s -> case g s of
    { value = value, state = state } -> { value: f value, state: state }

instance applyGen :: Apply Gen where
  (<*>) (Gen f) (Gen x) = Gen $ \s ->
    case f s of
      { value = f', state = s' } -> case x s' of
        { value = x', state = s'' } -> { value: f' x', state: s'' }

instance applicativeGen :: Applicative Gen where
  pure a = Gen (\s -> { value: a, state: s })

instance bindGen :: Bind Gen where
  (>>=) (Gen f) g = Gen $ \s -> case f s of
    { value = value, state = state } -> runGen (g value) state

instance monadGen :: Monad Gen

module Test.QuickCheck.LCG
  (
    Gen(),
    GenState(),
    GenOut(),
    Size(),
    LCG(),
    repeatable,
    sized,
    stateful,
    resize,
    runGen,
    evalGen,
    perturbGen,
    uniform
  ) where

import Control.Monad.Eff
import Control.Monad.Eff.Random
import Data.Maybe
import Data.Tuple
import Data.Foldable
import Data.Traversable
import Data.Monoid.Sum
import qualified Data.Array as A
import qualified Math as M

type LCG = Number
type Size = Number

type GenState = { newSeed :: LCG, size :: Size }

type GenOut a = { state :: GenState, value :: a }

data Gen a = Gen (GenState -> GenOut a)

repeatable :: forall a b. (a -> Gen b) -> Gen (a -> b)
repeatable f = Gen $ \s -> { value: \a -> (runGen (f a) s).value, state: s }

stateful :: forall a. (GenState -> Gen a) -> Gen a
stateful f = Gen (\s -> runGen (f s) s)

variant :: forall a. LCG -> Gen a -> Gen a
variant n g = Gen $ \s -> runGen g s { newSeed = n }

sized :: forall a. (Size -> Gen a) -> Gen a
sized f = stateful (\s -> f s.size)

resize :: forall a. Size -> Gen a -> Gen a
resize sz g = Gen $ \s -> runGen g s { size = sz }

choose :: Number -> Number -> Gen Number
choose a b = (*) (max - min) >>> (+) min <$> uniform where
  min = M.min a b
  max = M.max a b

chooseInt :: Number -> Number -> Gen Number
chooseInt a b = M.round <$> choose a b

oneOf :: forall a. Gen a -> [Gen a] -> Gen a
oneOf x xs = do
  n <- chooseInt 0 (A.length xs)
  if n == 0 then x else fromMaybe x (xs A.!! (n - 1))

frequency :: forall a. Tuple Number (Gen a) -> [Tuple Number (Gen a)] -> Gen a
frequency x xs = let
    xxs   = x : xs
    total = runSum $ fold (((Sum <<< fst) <$> xxs) :: [Sum])
    pick n d [] = d
    pick n d ((Tuple k x) : xs) = if n <= k then x else pick (n - k) d xs
  in do
    n <- chooseInt 1 total
    pick n (snd x) xxs

listOf :: forall a. Gen a -> Gen [a]
listOf g = sized $ \n ->
  do k <- chooseInt 0 n
     vectorOf k g

listOf1 :: forall a. Gen a -> Gen (Tuple a [a])
listOf1 g = sized $ \n ->
  do k  <- chooseInt 0 n
     x  <- g
     xs <- vectorOf (k - 1) g
     return $ Tuple x xs

vectorOf :: forall a. Number -> Gen a -> Gen [a]
vectorOf k g = sequence $ const g <$> (A.range 1 k)

elements :: forall a. a -> [a] -> Gen a
elements x xs = do
  n <- chooseInt 0 (A.length xs)
  pure if n == 0 then x else fromMaybe x (xs A.!! (n - 1))

runGen :: forall a. Gen a -> GenState -> GenOut a
runGen (Gen f) = f

evalGen :: forall a. Gen a -> GenState -> a
evalGen gen st = (runGen gen st).value
--
-- Magic Numbers
--

lcgM :: Number
lcgM = 1103515245

lcgC :: Number
lcgC = 12345

lcgN :: Number
lcgN = 1 `shl` 30

lcgNext :: Number -> Number
lcgNext n = (lcgM * n + lcgC) % lcgN

lcgStep :: Gen Number
lcgStep = Gen f where
  f s = { value: s.newSeed, state: s { newSeed = lcgNext s.newSeed } }

uniform :: Gen Number
uniform = (\n -> n / (1 `shl` 30)) <$> lcgStep

foreign import float32ToInt32
  "function float32ToInt32(n) {\
  \  var arr = new ArrayBuffer(4);\
  \  var fv = new Float32Array(arr);\
  \  var iv = new Int32Array(arr);\
  \  fv[0] = n;\
  \  return iv[0];\
  \}" :: Number -> Number

perturbGen :: forall a. Number -> Gen a -> Gen a
perturbGen n (Gen f) = Gen $ \s -> f (s { newSeed = lcgNext (float32ToInt32 n) + s.newSeed })

instance functorGen :: Functor Gen where
  (<$>) f (Gen g) = Gen $ \s -> case g s of
    { value = value, state = state } -> { value: f value, state: state }

instance applyGen :: Apply Gen where
  (<*>) (Gen f) (Gen x) = Gen $ \s ->
    case f s of
      { value = f', state = s' } -> case x s' of
        { value = x', state = s'' } -> { value: f' x', state: s'' }

instance applicativeGen :: Applicative Gen where
  pure a = Gen (\s -> { value: a, state: s })

instance bindGen :: Bind Gen where
  (>>=) (Gen f) g = Gen $ \s -> case f s of
    { value = value, state = state } -> runGen (g value) state

instance monadGen :: Monad Gen


more cleanup.

more cleanup.

module Openspace.Ui.Stream where

import Rx.Observable
import Data.Either
import Control.Monad.Eff
import Control.Monad.ST
import DOM

import Openspace.Ui.Render
import Openspace.Ui.Emitter
import Openspace.Ui.Parser
import Openspace.Types
import Openspace.Engine
import Openspace.Network.Socket

netStream :: forall eff. Socket -> Eff( net :: Net | eff ) (Observable Action)
netStream socket = do
  onReceive <- "message" `socketObserver'` socket
  return $ actionFromForeign parseAction id <$> onReceive

dragStream :: forall eff. Eff( dom :: DOM| eff) (Observable Action)
dragStream = do
  emitters <- getEmitters
  let lookup = emitterLookup emitters
      dragOverSlot = (\e -> case parseSlot (getDetail e) of
                         Right s -> AssignTopic s
                         Left e -> UnassignTopic
                     ) <$> lookup "dragOverSlot"

      dragOverTrash = const DeleteTopic <$> lookup "dragOverTrash"

      -- HTML 5 fires dragLeave before dragEnd occurs
      -- TODO: Find a cleaner solution
      dragLeave = delay 30 $ const UnassignTopic
                  <$> lookup "dragLeaveSlot" `merge` lookup "dragLeaveTrash"

      dragOver = dragLeave `merge` dragOverSlot `merge` dragOverTrash

      dragStart = parseTopic <<< getDetail
                  <$> lookup "dragStartTopic" `merge` lookup "dragStartGridTopic"

      dragTopic = do Right t <- dragStart
                     action <- dragOver
                     lookup "dragEndTopic" `merge` lookup "dragEndGridTopic"
                     return $ action t
  return dragTopic

uiStream :: forall eff. Eff( dom :: DOM | eff ) (Observable Action)
uiStream = do
  emitters <- getEmitters
  let lookup = emitterLookup emitters
      addTopic    = (actionFromForeign parseTopic AddTopic) <<< getDetail
                    <$> lookup "addTopic"
      addRoom     = (actionFromForeign parseRoom AddRoom) <<< getDetail
                    <$> lookup "addRoom"
      removeRoom  = (actionFromForeign parseRoom DeleteRoom) <<< getDetail
                    <$> lookup "deleteRoom"
      addBlock    = (actionFromForeign parseBlock AddBlock) <<< getDetail
                    <$> lookup "addBlock"
      deleteBlock = (actionFromForeign parseBlock DeleteBlock) <<< getDetail
                    <$> lookup "deleteBlock"
      changeGrid = addRoom `merge` removeRoom `merge` addBlock `merge` deleteBlock
  dragTopic <- dragStream
  return $ addTopic `merge` dragTopic `merge` changeGrid

main = do
  -- TODO: getSocket :: Either SockErr Socket
  -- let sockEmitter = getSocket "http://localhost:3000"
  -- until Websocket support is given by the server
  let sockEmitter = EmptySocket
  -- Initial State
  appSt <- newSTRef myState1
  -- Initial Render
  renderMenu (show <$> topicTypes)
  readSTRef appSt >>= renderApp
  -- Observable Action
  ui  <- uiStream
  net <- netStream sockEmitter
  -- Broadcast the UI Observable
  unwrap $ (\a -> emitAction sockEmitter (serialize a)) <$> ui
  -- Evaluate Action Observables
  let actions = ui `merge` net
  subscribe actions (\a -> modifySTRef appSt (evalAction a) >>= renderApp)

module Openspace.Ui.Stream where

import Rx.Observable
import Data.Either
import Control.Monad.Eff
import Control.Monad.ST
import DOM

import Openspace.Ui.Render
import Openspace.Ui.Emitter
import Openspace.Ui.Parser
import Openspace.Types
import Openspace.Engine
import Openspace.Network.Socket

netStream :: forall eff. Socket -> Eff( net :: Net | eff ) (Observable Action)
netStream socket = do
  onReceive <- "message" `socketObserver'` socket
  return $ actionFromForeign parseAction id <$> onReceive

dragStream :: forall eff. Eff( dom :: DOM| eff) (Observable Action)
dragStream = do
  emitters <- getEmitters
  let lookup = emitterLookup emitters
      dragOverSlot = (\e -> case parseSlot (getDetail e) of
                         Right s -> AssignTopic s
                         Left e -> UnassignTopic
                     ) <$> lookup "dragOverSlot"

      dragOverTrash = (const DeleteTopic) <$> (lookup "dragOverTrash")

  -- HTML 5 fires dragLeave before dragEnd occurs
  -- TODO: Find a cleaner solution
      dragLeave = delay 30 $ (const UnassignTopic)
                  <$> ((lookup "dragLeaveSlot") `merge` (lookup "dragLeaveTrash"))

      dragOver = dragLeave `merge` dragOverSlot `merge` dragOverTrash

      dragStart = (parseTopic <<< getDetail)
                  <$> (lookup "dragStartTopic" `merge` lookup "dragStartGridTopic")

      dragTopic = do Right t <- dragStart
                     action <- dragOver
                     lookup "dragEndTopic" `merge` lookup "dragEndGridTopic"
                     return $ action t
  return dragTopic

uiStream :: forall eff. Eff( dom :: DOM | eff ) (Observable Action)
uiStream = do
  emitters <- getEmitters
  let lookup = emitterLookup emitters
      addTopic    = (actionFromForeign parseTopic AddTopic) <<< getDetail
                    <$> lookup "addTopic"
      addRoom     = (actionFromForeign parseRoom AddRoom) <<< getDetail
                    <$> lookup "addRoom"
      removeRoom  = (actionFromForeign parseRoom DeleteRoom) <<< getDetail
                    <$> lookup "deleteRoom"
      addBlock    = (actionFromForeign parseBlock AddBlock) <<< getDetail
                    <$> lookup "addBlock"
      deleteBlock = (actionFromForeign parseBlock DeleteBlock) <<< getDetail
                    <$> lookup "deleteBlock"
      changeGrid = addRoom `merge` removeRoom `merge` addBlock `merge` deleteBlock
  dragTopic <- dragStream
  return $ addTopic `merge` dragTopic `merge` changeGrid

main = do
  -- TODO: getSocket :: Either SockErr Socket
  -- let sockEmitter = getSocket "http://localhost:3000"
  -- until Websocket support is given by the server
  let sockEmitter = EmptySocket
  -- Initial State
  appSt <- newSTRef myState1
  -- Initial Render
  renderMenu (show <$> topicTypes)
  readSTRef appSt >>= renderApp
  -- Observable Action
  ui  <- uiStream
  net <- netStream sockEmitter
  -- Broadcast the UI Observable
  unwrap $ (\a -> emitAction sockEmitter (serialize a)) <$> ui
  -- Evaluate Action Observables
  let actions = ui `merge` net
  subscribe actions (\a -> modifySTRef appSt (evalAction a) >>= renderApp)


Always print to stderr

Always print to stderr

module Psa.Printer.Default
  ( renderWarning
  , renderError
  , renderStats
  , renderVerboseStats
  , print
  ) where

import Prelude (Unit, ($), (+), (-), (<>), show, (==), (<<<), map, (<*>), (<$>), bind)
import Data.Array as Array
import Data.Foldable (sum, maximum)
import Data.Maybe (fromMaybe)
import Data.Monoid (mempty)
import Data.String as Str
import Data.String.Regex as Regex
import Data.StrMap as StrMap
import Data.Tuple (Tuple(..))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console as Console
import Ansi.Output (foreground, dim)
import Ansi.Codes as Ansi
import Psa.Types (Lines, Position, PsaAnnotedError, PsaOptions, PsaPath(..))
import Psa.Output (OutputStats, Output)
import Psa.Printer (Rendered, AnsiText, ansiLength, renderSource, plain, style, indent, line, para, renderAnsi, renderRow)
import Psa.Util (replicate, iter_)

-- | Prints output to the console.
print :: forall eff. PsaOptions -> Output -> Eff (console :: Console.CONSOLE | eff) Unit
print options output = do
  iter_ output.warnings \i warning -> do
    Console.error $ toString (renderWarning lenWarnings (i + 1) warning)
    Console.error ""

  iter_ output.errors \i error -> do
    Console.error $ toString (renderError lenErrors (i + 1) error)
    Console.error ""

  Console.error $ toString (renderStats' output.stats)

  where
  lenWarnings = Array.length output.warnings
  lenErrors = Array.length output.errors
  toString = renderRow (Str.joinWith "" <<< map (renderAnsi options.ansi))
  renderStats' = if options.verboseStats then renderVerboseStats else renderStats

renderWarning :: Int -> Int -> PsaAnnotedError -> Rendered
renderWarning = render (foreground Ansi.Yellow)

renderError :: Int -> Int -> PsaAnnotedError -> Rendered
renderError = render (foreground Ansi.Red)

render :: Array Ansi.GraphicsParam -> Int -> Int -> PsaAnnotedError -> Rendered
render gfx total index { error, path, position, source } =
  para
    [ line $
        [ renderStatus gfx total index error.errorCode
        , plain " "
        , renderPath path
        ] <> fromMaybe mempty (renderPosition <$> position)
    , emptyLine
    , indented
         $ fromMaybe mempty (renderSource' <$> position <*> source)
        <> toLines error.message
    ]

toLines :: String -> Rendered
toLines = para <<< map (line <<< Array.singleton <<< plain) <<< Str.split "\n"

emptyLine :: Rendered
emptyLine = line [ plain "" ]

indented :: Rendered -> Rendered
indented = indent [ plain "  " ]

renderStatus :: Array Ansi.GraphicsParam -> Int -> Int -> String -> AnsiText
renderStatus gfx total index code =
  style gfx $ "[" <> show index <> "/" <> show total <> " " <> code <> "]"

renderPath :: PsaPath -> AnsiText
renderPath (Src f) = plain f
renderPath (Lib f) = plain f
renderPath _       = plain ""

renderPosition :: Position -> Array AnsiText
renderPosition pos =
  [ style dim ":"
  , plain (show pos.startLine)
  , style dim ":"
  , plain (show pos.startColumn)
  ]

renderSource' :: Position -> Lines -> Rendered
renderSource' pos lines = renderSource pos lines <> emptyLine

renderStats :: OutputStats -> Rendered
renderStats stats =
  renderStatCols
    [ [ style (foreground Ansi.Yellow) "Warnings" ]
    , [ style (foreground Ansi.Red) "Errors" ]
    ]
    [ renderStat srcWarnings
    , renderStat srcErrors
    ]
    [ renderStat libWarnings
    , renderStat libErrors
    ]
    [ renderStat allWarnings
    , renderStat allErrors
    ]
  where
  sumRatio (Tuple a b) _ (Tuple c d) = Tuple (a + c) (b + d)
  srcWarnings = StrMap.fold sumRatio (Tuple 0 0) stats.srcWarnings
  srcErrors   = StrMap.fold sumRatio (Tuple 0 0) stats.srcErrors
  libWarnings = StrMap.fold sumRatio (Tuple 0 0) stats.libWarnings
  libErrors   = StrMap.fold sumRatio (Tuple 0 0) stats.libErrors
  allWarnings = StrMap.fold sumRatio (Tuple 0 0) stats.allWarnings
  allErrors   = StrMap.fold sumRatio (Tuple 0 0) stats.allErrors

renderVerboseStats :: OutputStats -> Rendered
renderVerboseStats stats =
  renderStatCols
    (warningLabels <> errorLabels)
    (srcWarnings <> srcErrors)
    (libWarnings <> libErrors)
    (allWarnings <> allErrors)
  where
  warnings = Array.sort (StrMap.keys stats.allWarnings)
  errors   = Array.sort (StrMap.keys stats.allErrors)

  warningLabels = Array.singleton <<< style (foreground Ansi.Yellow) <$> warnings
  errorLabels   = Array.singleton <<< style (foreground Ansi.Red) <$> errors

  getStat key x = fromMaybe (Tuple 0 0) $ StrMap.lookup key x
  getStats ks x = (\k -> renderStat $ getStat k x) <$> ks

  srcWarnings = getStats warnings stats.srcWarnings
  srcErrors   = getStats errors   stats.srcErrors
  libWarnings = getStats warnings stats.libWarnings
  libErrors   = getStats errors   stats.libErrors
  allWarnings = getStats warnings stats.allWarnings
  allErrors   = getStats errors   stats.allErrors

renderStatCols :: Array (Array AnsiText) -> Array (Array AnsiText) -> Array (Array AnsiText) -> Array (Array AnsiText) -> Rendered
renderStatCols col1 col2 col3 col4 = para $
  catRow `map`
    alignLeft ([[ plain "" ]] <> col1)
  `Array.zipWith ($)`
    alignLeft ([[ plain "Src" ]] <> col2)
  `Array.zipWith ($)`
    alignLeft ([[ plain "Lib" ]] <> col3)
  `Array.zipWith ($)`
    alignLeft ([[ plain "All" ]] <> col4)

  where
  gutter = [ plain "   " ]
  catRow c1 c2 c3 c4 =
    line $ c1 <> gutter <> c2 <> gutter <> c3 <> gutter <> c4

  lineLength = sum <<< map ansiLength
  alignRight = align \a as -> Array.cons a as
  alignLeft  = align \a as -> Array.snoc as a
  align f ls = map pad ls where
    max = fromMaybe 0 $ maximum (map lineLength ls)
    pad l = f (plain $ replicate (max - lineLength l) " ") l

renderStat :: Tuple Int Int -> Array AnsiText
renderStat (Tuple 0 0) = [ style (foreground Ansi.Green) "0" ]
renderStat (Tuple a b) | a == b = [ plain $ show a ]
renderStat (Tuple a b) =
  [ plain $ show a
  , style dim $ "/" <> show b
  ]

module Psa.Printer.Default
  ( renderWarning
  , renderError
  , renderStats
  , renderVerboseStats
  , print
  ) where

import Prelude (Unit, ($), (+), (-), (<>), show, (==), (<<<), map, (<*>), (<$>), bind)
import Data.Array as Array
import Data.Foldable (sum, maximum)
import Data.Maybe (fromMaybe)
import Data.Monoid (mempty)
import Data.String as Str
import Data.String.Regex as Regex
import Data.StrMap as StrMap
import Data.Tuple (Tuple(..))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console as Console
import Ansi.Output (foreground, dim)
import Ansi.Codes as Ansi
import Psa.Types (Lines, Position, PsaAnnotedError, PsaOptions, PsaPath(..))
import Psa.Output (OutputStats, Output)
import Psa.Printer (Rendered, AnsiText, ansiLength, renderSource, plain, style, indent, line, para, renderAnsi, renderRow)
import Psa.Util (replicate, iter_)

-- | Prints output to the console. Errors and warnings will be directed to
-- | stderr, while statistics will be directed to stdout.
print :: forall eff. PsaOptions -> Output -> Eff (console :: Console.CONSOLE | eff) Unit
print options output = do
  iter_ output.warnings \i warning -> do
    Console.error $ toString (renderWarning lenWarnings (i + 1) warning)
    Console.error ""

  iter_ output.errors \i error -> do
    Console.error $ toString (renderError lenErrors (i + 1) error)
    Console.error ""

  if options.verboseStats
    then Console.log $ toString (renderVerboseStats output.stats)
    else Console.log $ toString (renderStats output.stats)

  where
  lenWarnings = Array.length output.warnings
  lenErrors = Array.length output.errors
  toString = renderRow (Str.joinWith "" <<< map (renderAnsi options.ansi))

renderWarning :: Int -> Int -> PsaAnnotedError -> Rendered
renderWarning = render (foreground Ansi.Yellow)

renderError :: Int -> Int -> PsaAnnotedError -> Rendered
renderError = render (foreground Ansi.Red)

render :: Array Ansi.GraphicsParam -> Int -> Int -> PsaAnnotedError -> Rendered
render gfx total index { error, path, position, source } =
  para
    [ line $
        [ renderStatus gfx total index error.errorCode
        , plain " "
        , renderPath path
        ] <> fromMaybe mempty (renderPosition <$> position)
    , emptyLine
    , indented
         $ fromMaybe mempty (renderSource' <$> position <*> source)
        <> toLines error.message
    ]

toLines :: String -> Rendered
toLines = para <<< map (line <<< Array.singleton <<< plain) <<< Str.split "\n"

emptyLine :: Rendered
emptyLine = line [ plain "" ]

indented :: Rendered -> Rendered
indented = indent [ plain "  " ]

renderStatus :: Array Ansi.GraphicsParam -> Int -> Int -> String -> AnsiText
renderStatus gfx total index code =
  style gfx $ "[" <> show index <> "/" <> show total <> " " <> code <> "]"

renderPath :: PsaPath -> AnsiText
renderPath (Src f) = plain f
renderPath (Lib f) = plain f
renderPath _       = plain ""

renderPosition :: Position -> Array AnsiText
renderPosition pos =
  [ style dim ":"
  , plain (show pos.startLine)
  , style dim ":"
  , plain (show pos.startColumn)
  ]

renderSource' :: Position -> Lines -> Rendered
renderSource' pos lines = renderSource pos lines <> emptyLine

renderStats :: OutputStats -> Rendered
renderStats stats =
  renderStatCols
    [ [ style (foreground Ansi.Yellow) "Warnings" ]
    , [ style (foreground Ansi.Red) "Errors" ]
    ]
    [ renderStat srcWarnings
    , renderStat srcErrors
    ]
    [ renderStat libWarnings
    , renderStat libErrors
    ]
    [ renderStat allWarnings
    , renderStat allErrors
    ]
  where
  sumRatio (Tuple a b) _ (Tuple c d) = Tuple (a + c) (b + d)
  srcWarnings = StrMap.fold sumRatio (Tuple 0 0) stats.srcWarnings
  srcErrors   = StrMap.fold sumRatio (Tuple 0 0) stats.srcErrors
  libWarnings = StrMap.fold sumRatio (Tuple 0 0) stats.libWarnings
  libErrors   = StrMap.fold sumRatio (Tuple 0 0) stats.libErrors
  allWarnings = StrMap.fold sumRatio (Tuple 0 0) stats.allWarnings
  allErrors   = StrMap.fold sumRatio (Tuple 0 0) stats.allErrors

renderVerboseStats :: OutputStats -> Rendered
renderVerboseStats stats =
  renderStatCols
    (warningLabels <> errorLabels)
    (srcWarnings <> srcErrors)
    (libWarnings <> libErrors)
    (allWarnings <> allErrors)
  where
  warnings = Array.sort (StrMap.keys stats.allWarnings)
  errors   = Array.sort (StrMap.keys stats.allErrors)

  warningLabels = Array.singleton <<< style (foreground Ansi.Yellow) <$> warnings
  errorLabels   = Array.singleton <<< style (foreground Ansi.Red) <$> errors

  getStat key x = fromMaybe (Tuple 0 0) $ StrMap.lookup key x
  getStats ks x = (\k -> renderStat $ getStat k x) <$> ks

  srcWarnings = getStats warnings stats.srcWarnings
  srcErrors   = getStats errors   stats.srcErrors
  libWarnings = getStats warnings stats.libWarnings
  libErrors   = getStats errors   stats.libErrors
  allWarnings = getStats warnings stats.allWarnings
  allErrors   = getStats errors   stats.allErrors

renderStatCols :: Array (Array AnsiText) -> Array (Array AnsiText) -> Array (Array AnsiText) -> Array (Array AnsiText) -> Rendered
renderStatCols col1 col2 col3 col4 = para $
  catRow `map`
    alignLeft ([[ plain "" ]] <> col1)
  `Array.zipWith ($)`
    alignLeft ([[ plain "Src" ]] <> col2)
  `Array.zipWith ($)`
    alignLeft ([[ plain "Lib" ]] <> col3)
  `Array.zipWith ($)`
    alignLeft ([[ plain "All" ]] <> col4)

  where
  gutter = [ plain "   " ]
  catRow c1 c2 c3 c4 =
    line $ c1 <> gutter <> c2 <> gutter <> c3 <> gutter <> c4

  lineLength = sum <<< map ansiLength
  alignRight = align \a as -> Array.cons a as
  alignLeft  = align \a as -> Array.snoc as a
  align f ls = map pad ls where
    max = fromMaybe 0 $ maximum (map lineLength ls)
    pad l = f (plain $ replicate (max - lineLength l) " ") l

renderStat :: Tuple Int Int -> Array AnsiText
renderStat (Tuple 0 0) = [ style (foreground Ansi.Green) "0" ]
renderStat (Tuple a b) | a == b = [ plain $ show a ]
renderStat (Tuple a b) =
  [ plain $ show a
  , style dim $ "/" <> show b
  ]


Use quietly at the top level

Use quietly at the top level

module Control.Monad.Cont.Extras where

import Data.Array ()
import Data.Maybe
import Data.Tuple

import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Ref

import Control.Monad.Trans
import Control.Monad.Cont.Trans

type WithRef eff = Eff (ref :: Ref | eff)

type ContRef eff = ContT Unit (WithRef eff)

foldC :: forall eff a r. (r -> a -> Tuple Boolean r) -> r -> ContRef eff a -> ContRef eff r
foldC f r0 c = do
  current <- lift $ newRef r0
  callCC $ \k -> quietly $ do
    a <- c
    r <- lift $ readRef current
    case f r a of
      Tuple emit next -> do
        when emit $ k next
        lift $ writeRef current next

  where
  quietly :: forall m a. (Monad m) => ContT Unit m Unit -> ContT Unit m a
  quietly = withContT (\_ _ -> return unit)

collect :: forall eff a. ContRef eff (Maybe a) -> ContRef eff [a]
collect = foldC f []
  where
  f xs Nothing = Tuple true xs
  f xs (Just x) = Tuple false (xs ++ [x])

module Control.Monad.Cont.Extras where

import Data.Array ()
import Data.Maybe
import Data.Tuple

import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Ref

import Control.Monad.Trans
import Control.Monad.Cont.Trans

type WithRef eff = Eff (ref :: Ref | eff)

type ContRef eff = ContT Unit (WithRef eff)

foldC :: forall eff a r. (r -> a -> Tuple Boolean r) -> r -> ContRef eff a -> ContRef eff r
foldC f r0 c = do
  current <- lift $ newRef r0
  callCC $ \k -> do
    a <- c
    r <- lift $ readRef current
    case f r a of
      Tuple emit next -> do
        when emit $ k next
        quietly $ lift $ writeRef current next

  where
  quietly :: forall m a. (Monad m) => ContT Unit m Unit -> ContT Unit m a
  quietly = withContT (\_ _ -> return unit)

collect :: forall eff a. ContRef eff (Maybe a) -> ContRef eff [a]
collect = foldC f []
  where
  f xs Nothing = Tuple true xs
  f xs (Just x) = Tuple false (xs ++ [x])


Display status icons

Display status icons

foo

module App.View where

import Text.Smolder.HTML

import App.State (Event(..), State)
import App.State.FileInputs as FileInputs
import App.State.Files as Files
import App.State.Signers as Signers
import Data.Map (toUnfoldable)
import Data.Maybe (Maybe(..), maybe)
import Data.Traversable (for_)
import Data.Tuple (Tuple(..))
import Lib.SignHash.Types (HashSigner(..), ProofMethod, ProofVerification(..))
import Prelude (Unit, discard, show, unit, ($), (<>))
import Pux.DOM.Events (onChange, onDragOver, onDrop)
import Pux.DOM.HTML (HTML, child)
import Text.Smolder.HTML.Attributes (className, for, id, type')
import Text.Smolder.Markup (text, (!), (#!))

view :: State -> HTML Event
view { file, signer } =
  do
    div ! className "content" $ do
      h1 $ text "SignHash"
      hr
      child FileInput viewFileInput unit
      hr
      h4 $ text "File status"
      div fileStatus
      case file of
        Nothing -> text $ ""
        Just value -> do
          h4 $ text "Signers"
          div signerStatus

  where
    fileStatus = case file of
      Nothing ->
        div $ text "Please provide a file"
      Just value -> viewFile value

    signerStatus = case signer of
      Nothing -> div $ text loading
      Just value -> child Signer viewSigner value

viewFileInput :: Unit -> HTML FileInputs.Event
viewFileInput _ =
  div do
    label
      ! for "file-upload"
      ! className "file-upload"
      #! onDrop FileInputs.newFilesEvent
      #! onDragOver (FileInputs.PreventDefault FileInputs.NoOp)
      $ div do
        h3 $ text "Click or drag and drop files"

    input
      ! id "file-upload"
      ! type' "file"
      #! onChange FileInputs.newFilesEvent

viewFile :: Files.State -> HTML Event
viewFile { meta, result, signer } =
  table ! className "u-full-width" $ tbody $ do
    renderRow "FileName" meta.name
    renderRow "Size" $ show meta.size <> " Bytes"
    renderRow "SHA256" $ maybe loading _.hash result
    renderRow "Signer address" $ maybe loading renderSigner signer

  where
    renderRow label value =
      tr $ do
        th $ text label
        td $ text value

    renderSigner (HashSigner address) = address
    renderSigner NoSigner = "Not signed"

viewSigner :: Signers.State -> HTML Signers.Event
viewSigner { address, proofs } = do
  div $ do
    h5 $ text $ "#" <> address
    viewProofs proofs

viewProofs :: Signers.SignerProofs -> HTML Signers.Event
viewProofs proofs =
  table ! className "u-full-width" $ do
    thead $ tr do
      th $ text "Method"
      th $ text "Status"
      th $ text "Details"
    tbody $ for_ unfolded renderProof
  where
    unfolded :: Array (Tuple ProofMethod Signers.ProofState)
    unfolded = toUnfoldable proofs

    renderProof (Tuple method state) = do
      tr do
        td $ text $ show method
        td $ renderIcon icon
        td $ text $ msg
      where
        (Tuple icon msg) = proofDetails state

    proofDetails Signers.Pending =
      Tuple "fa fa-spinner" ""
    proofDetails Signers.NetworkError =
      Tuple "fa fa-exclamation-triangle" "Network error"
    proofDetails (Signers.Finished (Verified msg)) =
      Tuple "fa fa-check" msg
    proofDetails (Signers.Finished (Unverified msg)) =
      Tuple "fa fa-exclamation-circle" $ "Failed: " <> msg
    proofDetails (Signers.Finished Unavailable) =
      Tuple "fa fa-ban" "No proof defined"

renderIcon :: forall a. String -> HTML a
renderIcon name = i ! className ("fa-lg " <> name) $ text ""

loading :: String
loading = "Loading..."

module App.View where

import App.State (Event(..), State)
import App.State.FileInputs as FileInputs
import App.State.Files as Files
import App.State.Signers as Signers
import Data.Map (toUnfoldable)
import Data.Maybe (Maybe(..), maybe)
import Data.Traversable (for_)
import Data.Tuple (Tuple(..))
import Lib.SignHash.Types (HashSigner(..), ProofMethod, ProofVerification(..))
import Prelude (Unit, discard, show, unit, ($), (<>))
import Pux.DOM.Events (onChange, onDragOver, onDrop)
import Pux.DOM.HTML (HTML, child)
import Text.Smolder.HTML
import Text.Smolder.HTML.Attributes (className, for, id, type')
import Text.Smolder.Markup (text, (!), (#!))

loading :: String
loading = "Loading..."

renderRow :: forall a. String -> String -> HTML a
renderRow label value =
  tr $ do
    th $ text label
    td $ text value

view :: State -> HTML Event
view { file, signer } =
  do
    div ! className "content" $ do
      h1 $ text "SignHash"
      hr
      child FileInput viewFileInput unit
      hr
      h4 $ text "File status"
      div fileStatus
      hr
      h4 $ text "Signers"
      div signerStatus

  where
    fileStatus = case file of
      Nothing ->
        div $ text "Please provide a file"
      Just value -> viewFile value

    signerStatus = case signer of
      Nothing -> div $ text "No signer"
      Just value -> child Signer viewSigner value

viewFileInput :: Unit -> HTML FileInputs.Event
viewFileInput _ =
  div do
    label
      ! for "file-upload"
      ! className "file-upload"
      #! onDrop FileInputs.newFilesEvent
      #! onDragOver (FileInputs.PreventDefault FileInputs.NoOp)
      $ div do
        h3 $ text "Click or drag and drop files"

    input
      ! id "file-upload"
      ! type' "file"
      #! onChange FileInputs.newFilesEvent

viewFile :: Files.State -> HTML Event
viewFile { meta, result, signer } =
  table ! className "u-full-width" $ tbody $ do
    renderRow "FileName" meta.name
    renderRow "Size" $ show meta.size <> " Bytes"
    renderRow "SHA256" $ maybe loading _.hash result
    renderRow "Signer address" $ maybe loading renderSigner signer

  where
    renderSigner (HashSigner address) = address
    renderSigner NoSigner = "Not signed"

viewSigner :: Signers.State -> HTML Signers.Event
viewSigner { address, proofs } = do
  div $ do
    h5 $ text $ "#" <> address
    viewProofs proofs

viewProofs :: Signers.SignerProofs -> HTML Signers.Event
viewProofs proofs =
  table ! className "u-full-width" $ do
    thead $ tr do
      th $ text "Method"
      th $ text "Verification"
    tbody $ for_ unfolded renderProof
  where
    unfolded :: Array (Tuple ProofMethod Signers.ProofState)
    unfolded = toUnfoldable proofs

    renderProof (Tuple method state) = do
      tr do
        td $ text $ show method
        td $ text $ viewProofState state

    viewProofState Signers.Pending = "Pending..."
    viewProofState Signers.NetworkError = "Network error"
    viewProofState (Signers.Finished (Verified msg)) =
      "Verified: " <> msg
    viewProofState (Signers.Finished (Unverified msg)) =
      "Verification failed: " <> msg
    viewProofState (Signers.Finished Unavailable) =
      "No proof defined"