Added new level

Added new level

module Level where

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

            ,{ name: "a small castle"
             , plan: castleLevel
             , itemPos: []
             , lootPos: [p 9 16, p 10 16, p 11 16]
             , npcPos: [patrol (p 59 9)]
             , startPos: {x: 2, y: 15}}]
    where
        p x y = {x: x, y: y}

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

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

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

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

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

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

module Level where

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

            ,{ name: "a small castle"
             , plan: castleLevel
             , itemPos: []
             , lootPos: [p 9 16, p 10 16, p 11 16]
             , npcPos: [patrol (p 59 9)]
             , startPos: {x: 2, y: 15}}]
    where
        p x y = {x: x, y: y}

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

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

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

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

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

emptyLevel2 :: [String]
emptyLevel2 =
    ["................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"################################################################################"]


better font

better font

module Style where

import Math (floor)
import LevelMap (mapSize, tileSize)
import Types (PlayerId(..))

fontName = "Righteous"
fontUrl = "https://fonts.googleapis.com/css?family=" <> fontName

backgroundColor = "#34344e"
fontColor = "#dfd1a5"
tileColor = "hsl(200, 80%, 40%)"
littleDotColor = "#eecccc"

playerColor :: PlayerId -> String
playerColor pId =
  case pId of
     P1 -> "hsl(0, 100%, 60%)"
     P2 -> "hsl(90, 100%, 60%)"
     P3 -> "hsl(180, 100%, 60%)"
     P4 -> "hsl(270, 100%, 60%)"

pxPerTile = 35
pxPerBlock = pxPerTile / tileSize
canvasSize = pxPerBlock * mapSize

playerRadius = floor (pxPerTile / 2.2)
littleDotRadius = pxPerBlock

-- parameters for corners of tiles
cornerSize = floor (pxPerTile / 3)
cornerMid = floor (cornerSize / 2)
cornerRadius = cornerMid

module Style where

import Math (floor)
import LevelMap (mapSize, tileSize)
import Types (PlayerId(..))

fontName = "Raleway"
fontUrl = "https://fonts.googleapis.com/css?family=" <> fontName

backgroundColor = "#34344e"
fontColor = "#dfd1a5"
tileColor = "hsl(200, 80%, 40%)"
littleDotColor = "#eecccc"

playerColor :: PlayerId -> String
playerColor pId =
  case pId of
     P1 -> "hsl(0, 100%, 60%)"
     P2 -> "hsl(90, 100%, 60%)"
     P3 -> "hsl(180, 100%, 60%)"
     P4 -> "hsl(270, 100%, 60%)"

pxPerTile = 35
pxPerBlock = pxPerTile / tileSize
canvasSize = pxPerBlock * mapSize

playerRadius = floor (pxPerTile / 2.2)
littleDotRadius = pxPerBlock

-- parameters for corners of tiles
cornerSize = floor (pxPerTile / 3)
cornerMid = floor (cornerSize / 2)
cornerRadius = cornerMid


Adding validation for patch

Adding validation for patch

module Patch ( addPatch ) where

import Data.String.Regex
import Data.Maybe
import Data.Either
import Prelude

type ValuePatch =
  {
    op :: String
  , path :: String
  , value :: String
  }

pathReg = regex "^(/[a-zA-Z0-9]*)+$" noFlags

isPath :: String -> Boolean
isPath x = map (\y -> test y x) pathReg

isValue :: forall a. a -> Boolean
isValue x = true

addPatch :: String -> String -> Either String ValuePatch
addPatch x y
  | isPath x /= true = Left "The path is not valid"
  | isValue y /= true = Left "The value is not valid"
  | otherwise = Right ({
    op: "add"
  , path: x
  , value: y
  })

module Patch ( addPatch ) where

import Data.String.Regex
import Data.Maybe
import Data.Either
import Prelude

type ValuePatch =
  {
    op :: String
  , path :: String
  , value :: String
  }

pathReg = regex "^(/[a-zA-Z0-9]*)+$" noFlags

isPatch :: String -> Either String Boolean
isPatch x = flip test x <$> pathReg

addPatch :: String -> String -> Maybe ValuePatch
addPatch path value = if true then
  Just ({
    op: "add"
  , path: path
  , value: value
  }) else Nothing


Remove 'Test.purs'

Remove 'Test.purs'

module Tests where

import Data.Either
import Data.Maybe

import AST
import Parser
import Evaluator

testEnv :: Env
testEnv = defsToEnv $ case (Parser.parseDefs defs) of Right env -> env
  where
  defs = """
    double x = x + x
    fact 0 = 1
    fact n = n * fact (n - 1)
    fib 0 a b = a
    fib n a b = fib (n - 1) b (a + b)
    """

testExpr :: String -> Expr
testExpr str = case (Parser.parseExpr str) of Right expr -> expr

test :: String -> Path -> Maybe Expr
test str path = evalPath1 testEnv path (testExpr str)


Fix bools check in ch 13

Fix bools check in ch 13

module Main where

import Data.Array
import Data.Function (on)
import Data.Foldable (foldr)

import Merge
import Tree

import Test.QuickCheck
import Test.QuickCheck.Gen

isSorted :: forall a. (Ord a) => [a] -> Boolean
isSorted (x1 : t@(x2 : xs)) = x1 <= x2 && isSorted t
isSorted _ = true

isSubarrayOf :: forall a. (Eq a) => [a] -> [a] -> Boolean
isSubarrayOf xs ys = xs `intersect` ys == xs

newtype Sorted a = Sorted [a]

sorted :: forall a. Sorted a -> [a]
sorted (Sorted xs) = xs

instance arbSorted :: (Arbitrary a, Ord a) => Arbitrary (Sorted a) where
  arbitrary = Sorted <<< sort <$> arbitrary

numbers :: [Number] -> [Number]
numbers = id

numberToBool :: (Number -> Boolean) -> Number -> Boolean
numberToBool = id

instance arbTree :: (Arbitrary a, Ord a) => Arbitrary (Tree a) where
  arbitrary = fromArray <<< sorted <$> arbitrary

instance coarbTree :: (CoArbitrary a) => CoArbitrary (Tree a) where
  coarbitrary Leaf = id
  coarbitrary (Branch l a r) =
    coarbitrary l <<<
    coarbitrary a <<<
    coarbitrary r

treeOfNumber :: Tree Number -> Tree Number
treeOfNumber = id

main = do
  -- Tests for module 'Merge'

  quickCheck $ \xs ys -> isSorted $ merge (sorted xs) (sorted ys)
  quickCheck $ \xs ys -> xs `isSubarrayOf` merge xs ys

  quickCheck $ \xs ys -> isSorted $ numbers $ mergePoly (sorted xs) (sorted ys)
  quickCheck $ \xs ys -> numbers xs `isSubarrayOf` mergePoly xs ys

  quickCheck $ \xs ys f -> isSorted $ map f $ mergeWith (numberToBool f) (sortBy (compare `on` f) xs) (sortBy (compare `on` f) ys)
  quickCheck $ \xs ys f -> xs `isSubarrayOf` mergeWith (numberToBool f) xs ys

  -- Tests for module 'Tree'

  quickCheck $ \t a -> member a $ insert a (t :: Tree Number)
  quickCheck $ \t xs -> isSorted $ toArray $ foldr insert t $ numbers xs

  quickCheck $ \f g t ->
    anywhere (\s -> f s || g s) t ==
      anywhere f (treeOfNumber t) || anywhere g t

module Main where

import Data.Array
import Data.Function (on)
import Data.Foldable (foldr)

import Merge
import Tree

import Test.QuickCheck
import Test.QuickCheck.Gen

isSorted :: forall a. (Ord a) => [a] -> Boolean
isSorted (x1 : t@(x2 : xs)) = x1 <= x2 && isSorted t
isSorted _ = true

isSubarrayOf :: forall a. (Eq a) => [a] -> [a] -> Boolean
isSubarrayOf xs ys = ys `intersect` xs == xs

newtype Sorted a = Sorted [a]

sorted :: forall a. Sorted a -> [a]
sorted (Sorted xs) = xs

instance arbSorted :: (Arbitrary a, Ord a) => Arbitrary (Sorted a) where
  arbitrary = Sorted <<< sort <$> arbitrary

numbers :: [Number] -> [Number]
numbers = id

numberToBool :: (Number -> Boolean) -> Number -> Boolean
numberToBool = id

instance arbTree :: (Arbitrary a, Ord a) => Arbitrary (Tree a) where
  arbitrary = fromArray <<< sorted <$> arbitrary

instance coarbTree :: (CoArbitrary a) => CoArbitrary (Tree a) where
  coarbitrary Leaf = id
  coarbitrary (Branch l a r) =
    coarbitrary l <<<
    coarbitrary a <<<
    coarbitrary r

treeOfNumber :: Tree Number -> Tree Number
treeOfNumber = id

main = do
  -- Tests for module 'Merge'

  quickCheck $ \xs ys -> isSorted $ merge (sorted xs) (sorted ys)
  quickCheck $ \xs ys -> xs `isSubarrayOf` merge xs ys

  quickCheck $ \xs ys -> isSorted $ numbers $ mergePoly (sorted xs) (sorted ys)
  quickCheck $ \xs ys -> numbers xs `isSubarrayOf` mergePoly xs ys

  quickCheck $ \xs ys f -> isSorted $ map f $ mergeWith (numberToBool f) (sortBy (compare `on` f) xs) (sortBy (compare `on` f) ys)
  quickCheck $ \xs ys f -> xs `isSubarrayOf` mergeWith (numberToBool f) xs ys

  -- Tests for module 'Tree'

  quickCheck $ \t a -> member a $ insert a (t :: Tree Number)
  quickCheck $ \t xs -> isSorted $ toArray $ foldr insert t $ numbers xs

  quickCheck $ \f g t ->
    anywhere (\s -> f s || g s) t ==
      anywhere f (treeOfNumber t) || anywhere g t


review: kill test type alias

review: kill test type alias

module Test.Main where

import Prelude
import Effect (Effect)
import Effect.Console (log)
import Data.Maybe (Maybe(..))
import Data.Traversable (traverse)
import Node.Buffer (BufferValueType(..), toArray, concat', fromArray, fill, copy, readString, fromString, toString, read, write, create, getAtOffset)
import Node.Encoding (Encoding(..))
import Test.Assert (assert')

main :: Effect Unit
main = do
  log "Effect Uniting..."

  log "Reading and writing"
  testReadWrite

  log "fromArray"
  testFromArray

  log "toArray"
  testToArray

  log "fromString"
  testFromString

  log "toString"
  testToString

  log "readString"
  testReadString

  log "copy"
  testCopy

  log "fill"
  testFill

  log "concat'"
  testConcat'

  log "getAtOffset"
  testGetAtOffset

testReadWrite :: Effect Unit
testReadWrite = do
  buf <- create 1
  let val = 42
  write UInt8 val 0 buf
  readVal <- read UInt8 0 buf

  assertEq val readVal

testFromArray :: Effect Unit
testFromArray = do
  buf <- fromArray [1,2,3,4,5]
  readVal <- read UInt8 2 buf

  assertEq 3 readVal

testToArray :: Effect Unit
testToArray = do
  let val = [1,2,67,3,3,7,8,3,4,237]

  buf    <- fromArray val
  valOut <- toArray buf

  assertEq val valOut

testFromString :: Effect Unit
testFromString = do
  let str = "hello, world"

  buf <- fromString str ASCII
  val <- read UInt8 6 buf

  assertEq val 32 -- ASCII space

testToString :: Effect Unit
testToString = do
  let str = "hello, world"

  buf    <- fromString str ASCII
  strOut <- toString ASCII buf

  assertEq str strOut

testReadString :: Effect Unit
testReadString = do
  let str = "hello, world"

  buf    <- fromString str ASCII
  strOut <- readString ASCII 7 12 buf

  assertEq "world" strOut

testCopy :: Effect Unit
testCopy = do
  buf1 <- fromArray [1,2,3,4,5]
  buf2 <- fromArray [10,9,8,7,6]

  copied <- copy 0 3 buf1 2 buf2
  out    <- toArray buf2

  assertEq copied 3
  assertEq out [10,9,1,2,3]

testFill :: Effect Unit
testFill = do
  buf <- fromArray [1,1,1,1,1]
  fill 42 2 4 buf
  out <- toArray buf

  assertEq [1,1,42,42,1] out

testConcat' :: Effect Unit
testConcat' = do
  bufs <- traverse fromArray $ map (\x -> [x, x+1, x+2]) [0,3,6,9,12]
  buf  <- concat' bufs 15
  out  <- toArray buf

  assertEq [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14] out

testGetAtOffset :: Effect Unit
testGetAtOffset = do
  buf  <- fromArray [1, 2, 3, 4]
  assertEq (Just 2) =<< getAtOffset 1 buf
  assertEq Nothing  =<< getAtOffset 4 buf
  assertEq Nothing  =<< getAtOffset (-1) buf

assertEq :: forall a. Eq a => Show a => a -> a -> Effect Unit
assertEq x y =
  if x == y
    then pure unit
    else let msg = show x <> " and " <> show y <> " were not equal."
         in assert' msg false

module Test.Main where

import Prelude
import Effect (Effect)
import Effect.Console (log)
import Data.Maybe (Maybe(..))
import Data.Traversable (traverse)
import Node.Buffer (BufferValueType(..), toArray, concat', fromArray, fill, copy, readString, fromString, toString, read, write, create, getAtOffset)
import Node.Encoding (Encoding(..))
import Test.Assert (assert')

type Test = Effect Unit

main :: Test
main = do
  log "Testing..."

  log "Reading and writing"
  testReadWrite

  log "fromArray"
  testFromArray

  log "toArray"
  testToArray

  log "fromString"
  testFromString

  log "toString"
  testToString

  log "readString"
  testReadString

  log "copy"
  testCopy

  log "fill"
  testFill

  log "concat'"
  testConcat'

  log "getAtOffset"
  testGetAtOffset

testReadWrite :: Test
testReadWrite = do
  buf <- create 1
  let val = 42
  write UInt8 val 0 buf
  readVal <- read UInt8 0 buf

  assertEq val readVal

testFromArray :: Test
testFromArray = do
  buf <- fromArray [1,2,3,4,5]
  readVal <- read UInt8 2 buf

  assertEq 3 readVal

testToArray :: Test
testToArray = do
  let val = [1,2,67,3,3,7,8,3,4,237]

  buf    <- fromArray val
  valOut <- toArray buf

  assertEq val valOut

testFromString :: Test
testFromString = do
  let str = "hello, world"

  buf <- fromString str ASCII
  val <- read UInt8 6 buf

  assertEq val 32 -- ASCII space

testToString :: Test
testToString = do
  let str = "hello, world"

  buf    <- fromString str ASCII
  strOut <- toString ASCII buf

  assertEq str strOut

testReadString :: Test
testReadString = do
  let str = "hello, world"

  buf    <- fromString str ASCII
  strOut <- readString ASCII 7 12 buf

  assertEq "world" strOut

testCopy :: Test
testCopy = do
  buf1 <- fromArray [1,2,3,4,5]
  buf2 <- fromArray [10,9,8,7,6]

  copied <- copy 0 3 buf1 2 buf2
  out    <- toArray buf2

  assertEq copied 3
  assertEq out [10,9,1,2,3]

testFill :: Test
testFill = do
  buf <- fromArray [1,1,1,1,1]
  fill 42 2 4 buf
  out <- toArray buf

  assertEq [1,1,42,42,1] out

testConcat' :: Test
testConcat' = do
  bufs <- traverse fromArray $ map (\x -> [x, x+1, x+2]) [0,3,6,9,12]
  buf  <- concat' bufs 15
  out  <- toArray buf

  assertEq [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14] out

testGetAtOffset :: Test
testGetAtOffset = do
  buf  <- fromArray [1, 2, 3, 4]
  assertEq (Just 2) =<< getAtOffset 1 buf
  assertEq Nothing  =<< getAtOffset 4 buf
  assertEq Nothing  =<< getAtOffset (-1) buf

assertEq :: forall a. Eq a => Show a => a -> a -> Test
assertEq x y =
  if x == y
    then pure unit
    else let msg = show x <> " and " <> show y <> " were not equal."
         in assert' msg false


Remove redundant test case

Remove redundant test case

module Test.Main where

import Prelude
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Eff.Ref (REF)
import DOM (DOM)
import OutWatch (VDOM)
import Test.DomEventSpec (domEventSuite)
import Test.LifecycleHookSpec (lifecycleHookSuite)
import Test.OutWatchDomSpec (outWatchDomSuite)
import Test.ScenarioTestSpec (scenarioSuite)
import Test.Unit.Console (TESTOUTPUT)
import Test.Unit.Main (exit, runTest)

main :: forall e. Eff (console :: CONSOLE, testOutput :: TESTOUTPUT, avar :: AVAR, dom :: DOM, vdom :: VDOM, random :: RANDOM, ref :: REF, err :: EXCEPTION | e) Unit
main = do
  runTest do
    lifecycleHookSuite
    outWatchDomSuite
    domEventSuite
    scenarioSuite
  (exit 0)

module Test.Main where

import Prelude
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Eff.Ref (REF)
import DOM (DOM)
import OutWatch (VDOM)
import Test.DomEventSpec (domEventSuite)
import Test.LifecycleHookSpec (lifecycleHookSuite)
import Test.OutWatchDomSpec (outWatchDomSuite)
import Test.ScenarioTestSpec (scenarioSuite)
import Test.Unit (TestSuite, suite, test)
import Test.Unit.Assert (assert)
import Test.Unit.Console (TESTOUTPUT)
import Test.Unit.Main (exit, runTest)

main :: forall e. Eff (console :: CONSOLE, testOutput :: TESTOUTPUT, avar :: AVAR, dom :: DOM, vdom :: VDOM, random :: RANDOM, ref :: REF, err :: EXCEPTION | e) Unit
main = do
  runTest do
    lifecycleHookSuite
    outWatchDomSuite
    domEventSuite
    scenarioSuite
  (exit 0)

attributeSuite :: TestSuite (console :: CONSOLE, testOutput :: TESTOUTPUT, avar :: AVAR, dom :: DOM, vdom :: VDOM, random :: RANDOM)
attributeSuite =
  suite "Snabbdom" do
        test "DOM patching" do
            let message = "Hello World"
            assert "Message should be patched into the DOM" (2 == 2)


Work on general Track type

Work on general Track type

module Genetics.Browser.Renderer.Renderer
       where

import Prelude
import Math as Math
import Control.Monad.Eff (Eff)
import Data.Bifunctor (class Bifunctor)
import Data.Foldable (foldr)
import Data.Foreign (Foreign, F)
import Data.Lens.Iso (iso)
import Data.Lens.Types (Iso')
import Data.Profunctor (class Profunctor)
import Genetics.Browser.Feature (Feature(..), ScreenFeature, featureToScreen)
import Genetics.Browser.Glyph (Glyph, circle, fill, stroke)
import Genetics.Browser.Types (View, Quant)
import Genetics.Browser.Units (class HCoordinate)
import Global (infinity)
import Unsafe.Coerce (unsafeCoerce)

newtype BDFeature = BDFeature Foreign

-- don't think this can be a functor. Feature c r is both covariant and contravariant...
-- well, this one absolutely cannot be a functor.
data Track eff c r = Track
                     (String -> c -> c -> Eff eff (Feature c r))
                     (Iso' (Feature c r) BDFeature)
                     (Feature c r -> Array (Glyph Unit))

-- Would be nice with some way to tag the `b` value as something that gets serialized. idk
-- same way with `f` being a functor. oh well
-- i guess it's an isomorphism sort of. eh.
data Track2 f a b = Track2
                    (f a)
                    (Iso' a b)
                    (a -> Glyph Unit)

type Glyphifier conf c r = conf -> Feature c r -> Glyph Unit
-- glyphify :: ∀ c r. Feature c r -> Glyph Unit
-- glyphify = ?g

-- glyphify after transforming into canvas coordinate s
glyphifyGWAS :: (Number -> Number) -> Glyphifier { col :: String } Number {score :: Number}
glyphifyGWAS f {col} (Feature chr xl _ r) = do
  stroke col
  fill col
  circle { x: xl, y: f r.score } 3.0

-- this is basically just (writeGlyph <<< glyphifyFeature <<< toScreen)
-- though we need to send some configuration around.
-- featureToForeign :: ∀ c r. View -> Feature c r -> Foreign
-- featureToForeign = ?f2f

quant :: ∀ c r. (r -> Number) -> Array (Feature c r) -> Quant
quant f = foldr (\(Feature _ _ _ r) {min, max} -> let y = f r in
                  { min: Math.max y min
                  , max: Math.min y max
                  }) { min: (-infinity), max: infinity }

-- render :: View -> Array ForeignFeature -> ForeignGlyph

module Genetics.Browser.Renderer.Renderer
       where

import Prelude
import Math as Math
import Data.Foldable (foldr)
import Data.Foreign (Foreign, F)
import Data.Profunctor (class Profunctor)
import Genetics.Browser.Feature (Feature(..), ScreenFeature, featureToScreen)
import Genetics.Browser.Glyph (Glyph, circle, fill, stroke)
import Genetics.Browser.Types (View, Quant)
import Genetics.Browser.Units (class HCoordinate)
import Global (infinity)

-- a Track r a b can parse a's into r's, and then r's into b's.
-- however... this doesn't quite cover what a track does.
-- a track /fetches/ and parses. Meaning the first argument to the data constructor
-- should really be an Eff (??) r ... or an Aff?
-- so I suppose that means it should be any contravariant functor?
-- is Eff contravariant? I doubt it.
-- indeed, it doesn't make much sense for this to be structured like it is.
-- we want something that produces r's. That's it.
-- so it's another bifunctor, really!
data Track r a b = Track (a -> r) (r -> b)

data Track' r f b = Track' (f r) (r -> b)
-- then we need to use a smart constructor?

type BDTrack r = Track r Foreign (Glyph Unit)

instance functorTrack :: Functor (Track r a) where
  map f (Track p r) = Track p (f <$> r)

instance profunctorTrack :: Profunctor (Track r) where
  dimap f g (Track parse render) = Track (parse <<< f) (render >>> g)

-- rather, it's something that can fetch from a and render to a track.
-- we don't even need a b - rather, the b doesn't define the output, not exactly.
-- it could rather define the features kept in it.
-- what would the a be? a fetcher?
-- an URI?
-- an (a -> b)?

-- renderTrack :: ∀ a b. Track a b -> Foreign
-- renderTrack = ?r

-- first we parse the feature
-- readFeature :: ∀ c r. Foreign -> F (Feature c r)
-- readFeature = ?r

-- glyphifyFeature :: ∀ conf r. conf -> ScreenFeature r -> Glyph Unit
-- glyphifyFeature = ?g

type Glyphifier conf c r = conf -> Feature c r -> Glyph Unit
-- glyphify :: ∀ c r. Feature c r -> Glyph Unit
-- glyphify = ?g

-- glyphify after transforming into canvas coordinate s
-- glyphifyGWAS :: (Number -> Number) -> Glyphifier { col :: String } Number (score :: Number)
glyphifyGWAS :: _
glyphifyGWAS f {col} (Feature chr xl _ r) = do
  stroke col
  fill col
  circle { x: xl, y: f r.score } 3.0

-- this is basically just (writeGlyph <<< glyphifyFeature <<< toScreen)
-- though we need to send some configuration around.
-- featureToForeign :: ∀ c r. View -> Feature c r -> Foreign
-- featureToForeign = ?f2f

quant :: ∀ c r. (r -> Number) -> Array (Feature c r) -> Quant
quant f = foldr (\(Feature _ _ _ r) {min, max} -> let y = f r in
                  { min: Math.max y min
                  , max: Math.min y max
                  }) { min: (-infinity), max: infinity }

-- render :: View -> Array ForeignFeature -> ForeignGlyph


Fix typo

Fix typo

-- | This module defines a data type and various functions for creating and
-- | manipulating JSON values. The README contains additional documentation
-- | for this module.
module Data.Argonaut.Core
  ( Json
  , caseJson
  , caseJsonNull
  , caseJsonBoolean
  , caseJsonNumber
  , caseJsonString
  , caseJsonArray
  , caseJsonObject
  , isNull
  , isBoolean
  , isNumber
  , isString
  , isArray
  , isObject
  , fromBoolean
  , fromNumber
  , fromString
  , fromArray
  , fromObject
  , toNull
  , toBoolean
  , toNumber
  , toString
  , toArray
  , toObject
  , jsonNull
  , jsonTrue
  , jsonFalse
  , jsonZero
  , jsonEmptyString
  , jsonEmptyArray
  , jsonSingletonArray
  , jsonEmptyObject
  , jsonSingletonObject
  , stringify
  ) where

import Prelude

import Data.Function.Uncurried (Fn5, runFn5, Fn7, runFn7)
import Data.Maybe (Maybe(..))
import Foreign.Object (Object)
import Foreign.Object as Obj

-- | The type of JSON data. The underlying representation is the same as what
-- | would be returned from JavaScript's `JSON.parse` function; that is,
-- | ordinary JavaScript booleans, strings, arrays, objects, etc.
foreign import data Json :: Type

instance eqJson :: Eq Json where
  eq j1 j2 = compare j1 j2 == EQ

instance ordJson :: Ord Json where
  compare a b = runFn5 _compare EQ GT LT a b

-- | The type of null values inside JSON data. There is exactly one value of
-- | this type: in JavaScript, it is written `null`. This module exports this
-- | value as `jsonNull`.
foreign import data JNull :: Type

instance eqJNull :: Eq JNull where
  eq _ _ = true

instance ordJNull :: Ord JNull where
  compare _ _ = EQ

-- | Case analysis for `Json` values. See the README for more information.
caseJson
  :: forall a
   . (Unit -> a)
  -> (Boolean -> a)
  -> (Number -> a)
  -> (String -> a)
  -> (Array Json -> a)
  -> (Object Json -> a)
  -> Json -> a
caseJson a b c d e f json = runFn7 _caseJson a b c d e f json

-- | A simpler version of `caseJson` which accepts a callback for when the
-- | `Json` argument was null, and a default value for all other cases.
caseJsonNull :: forall a. a -> (Unit -> a) -> Json -> a
caseJsonNull d f j = runFn7 _caseJson f (const d) (const d) (const d) (const d) (const d) j

-- | A simpler version of `caseJson` which accepts a callback for when the
-- | `Json` argument was a `Boolean`, and a default value for all other cases.
caseJsonBoolean :: forall a. a -> (Boolean -> a) -> Json -> a
caseJsonBoolean d f j = runFn7 _caseJson (const d) f (const d) (const d) (const d) (const d) j

-- | A simpler version of `caseJson` which accepts a callback for when the
-- | `Json` argument was a `Number`, and a default value for all other cases.
caseJsonNumber :: forall a. a -> (Number -> a) -> Json -> a
caseJsonNumber d f j = runFn7 _caseJson (const d) (const d) f (const d) (const d) (const d) j

-- | A simpler version of `caseJson` which accepts a callback for when the
-- | `Json` argument was a `String`, and a default value for all other cases.
caseJsonString :: forall a. a -> (String -> a) -> Json -> a
caseJsonString d f j = runFn7 _caseJson (const d) (const d) (const d) f (const d) (const d) j

-- | A simpler version of `caseJson` which accepts a callback for when the
-- | `Json` argument was a `Array Json`, and a default value for all other cases.
caseJsonArray :: forall a. a -> (Array Json -> a) -> Json -> a
caseJsonArray d f j = runFn7 _caseJson (const d) (const d) (const d) (const d) f (const d) j

-- | A simpler version of `caseJson` which accepts a callback for when the
-- | `Json` argument was an `Object`, and a default value for all other cases.
caseJsonObject :: forall a. a -> (Object Json -> a) -> Json -> a
caseJsonObject d f j = runFn7 _caseJson (const d) (const d) (const d) (const d) (const d) f j

verbJsonType :: forall a b. b -> (a -> b) -> (b -> (a -> b) -> Json -> b) -> Json -> b
verbJsonType def f g = g def f

-- Tests

isJsonType :: forall a. (Boolean -> (a -> Boolean) -> Json -> Boolean) -> Json -> Boolean
isJsonType = verbJsonType false (const true)

-- | Check if the provided `Json` is the `null` value
isNull :: Json -> Boolean
isNull = isJsonType caseJsonNull

-- | Check if the provided `Json` is a `Boolean`
isBoolean :: Json -> Boolean
isBoolean = isJsonType caseJsonBoolean

-- | Check if the provided `Json` is a `Number`
isNumber :: Json -> Boolean
isNumber = isJsonType caseJsonNumber

-- | Check if the provided `Json` is a `String`
isString :: Json -> Boolean
isString = isJsonType caseJsonString

-- | Check if the provided `Json` is an `Array`
isArray :: Json -> Boolean
isArray = isJsonType caseJsonArray

-- | Check if the provided `Json` is an `Object`
isObject :: Json -> Boolean
isObject = isJsonType caseJsonObject

-- Decoding

toJsonType
  :: forall a
   . (Maybe a -> (a -> Maybe a) -> Json -> Maybe a)
  -> Json
  -> Maybe a
toJsonType = verbJsonType Nothing Just

-- | Convert `Json` to the `Unit` value if the `Json` is the null value
toNull :: Json -> Maybe Unit
toNull = toJsonType caseJsonNull

-- | Convert `Json` to a `Boolean` value, if the `Json` is a boolean.
toBoolean :: Json -> Maybe Boolean
toBoolean = toJsonType caseJsonBoolean

-- | Convert `Json` to a `Number` value, if the `Json` is a number.
toNumber :: Json -> Maybe Number
toNumber = toJsonType caseJsonNumber

-- | Convert `Json` to a `String` value, if the `Json` is a string. To write a
-- | `Json` value to a JSON string, see `stringify`.
toString :: Json -> Maybe String
toString = toJsonType caseJsonString

-- | Convert `Json` to an `Array` of `Json` values, if the `Json` is an array.
toArray :: Json -> Maybe (Array Json)
toArray = toJsonType caseJsonArray

-- | Convert `Json` to an `Object` of `Json` values, if the `Json` is an object.
toObject :: Json -> Maybe (Object Json)
toObject = toJsonType caseJsonObject

-- Encoding

-- | Construct `Json` from a `Boolean` value
foreign import fromBoolean :: Boolean -> Json

-- | Construct `Json` from a `Number` value
foreign import fromNumber :: Number -> Json

-- | Construct `Json` from a `String` value. If you would like to parse a string
-- | of JSON into valid `Json`, see `jsonParser`.
foreign import fromString :: String -> Json

-- | Construct `Json` from an array of `Json` values
foreign import fromArray :: Array Json -> Json

-- | Construct `Json` from an object with `Json` values
foreign import fromObject :: Object Json -> Json

-- Defaults

-- | The JSON null value represented as `Json`
foreign import jsonNull :: Json

-- | The true boolean value represented as `Json`
jsonTrue :: Json
jsonTrue = fromBoolean true

-- | The false boolean value represented as `Json`
jsonFalse :: Json
jsonFalse = fromBoolean false

-- | The number zero represented as `Json`
jsonZero :: Json
jsonZero = fromNumber 0.0

-- | An empty string represented as `Json`
jsonEmptyString :: Json
jsonEmptyString = fromString ""

-- | An empty array represented as `Json`
jsonEmptyArray :: Json
jsonEmptyArray = fromArray []

-- | An empty object represented as `Json`
jsonEmptyObject :: Json
jsonEmptyObject = fromObject Obj.empty

-- | Constructs a `Json` array value containing only the provided value
jsonSingletonArray :: Json -> Json
jsonSingletonArray j = fromArray [j]

-- | Constructs a `Json` object value containing only the provided key and value
jsonSingletonObject :: String -> Json -> Json
jsonSingletonObject key val = fromObject (Obj.singleton key val)

-- | Converts a `Json` value to a JSON string. To retrieve a string from a `Json`
-- | string value, see `fromString`.
foreign import stringify :: Json -> String

foreign import _caseJson
  :: forall z
   . Fn7
      (Unit -> z)
      (Boolean -> z)
      (Number -> z)
      (String -> z)
      (Array Json -> z)
      (Object Json -> z)
      Json
      z

foreign import _compare :: Fn5 Ordering Ordering Ordering Json Json Ordering

-- | This module defines a data type and various functions for creating and
-- | manipulating JSON values. The README contains additional documentation
-- | for this module.
module Data.Argonaut.Core
  ( Json
  , caseJson
  , caseJsonNull
  , caseJsonBoolean
  , caseJsonNumber
  , caseJsonString
  , caseJsonArray
  , caseJsonObject
  , isNull
  , isBoolean
  , isNumber
  , isString
  , isArray
  , isObject
  , fromBoolean
  , fromNumber
  , fromString
  , fromArray
  , fromObject
  , toNull
  , toBoolean
  , toNumber
  , toString
  , toArray
  , toObject
  , jsonNull
  , jsonTrue
  , jsonFalse
  , jsonZero
  , jsonEmptyString
  , jsonEmptyArray
  , jsonSingletonArray
  , jsonEmptyObject
  , jsonSingletonObject
  , stringify
  ) where

import Prelude

import Data.Function.Uncurried (Fn5, runFn5, Fn7, runFn7)
import Data.Maybe (Maybe(..))
import Foreign.Object (Object)
import Foreign.Object as Obj

-- | The type of JSON data. The underlying representation is the same as what
-- | would be returned from JavaScript's `JSON.parse` function; that is,
-- | ordinary JavaScript booleans, strings, arrays, objects, etc.
foreign import data Json :: Type

instance eqJson :: Eq Json where
  eq j1 j2 = compare j1 j2 == EQ

instance ordJson :: Ord Json where
  compare a b = runFn5 _compare EQ GT LT a b

-- | The type of null values inside JSON data. There is exactly one value of
-- | this type: in JavaScript, it is written `null`. This module exports this
-- | value as `jsonNull`.
foreign import data JNull :: Type

instance eqJNull :: Eq JNull where
  eq _ _ = true

instance ordJNull :: Ord JNull where
  compare _ _ = EQ

-- | Case analysis for `Json` values. See the README for more information.
caseJson
  :: forall a
   . (Unit -> a)
  -> (Boolean -> a)
  -> (Number -> a)
  -> (String -> a)
  -> (Array Json -> a)
  -> (Object Json -> a)
  -> Json -> a
caseJson a b c d e f json = runFn7 _caseJson a b c d e f json

-- | A simpler version of `caseJson` which accepts a callback for when the
-- | `Json` argument was null, and a default value for all other cases.
caseJsonNull :: forall a. a -> (Unit -> a) -> Json -> a
caseJsonNull d f j = runFn7 _caseJson f (const d) (const d) (const d) (const d) (const d) j

-- | A simpler version of `caseJson` which accepts a callback for when the
-- | `Json` argument was a `Boolean`, and a default value for all other cases.
caseJsonBoolean :: forall a. a -> (Boolean -> a) -> Json -> a
caseJsonBoolean d f j = runFn7 _caseJson (const d) f (const d) (const d) (const d) (const d) j

-- | A simpler version of `caseJson` which accepts a callback for when the
-- | `Json` argument was a `Number`, and a default value for all other cases.
caseJsonNumber :: forall a. a -> (Number -> a) -> Json -> a
caseJsonNumber d f j = runFn7 _caseJson (const d) (const d) f (const d) (const d) (const d) j

-- | A simpler version of `caseJson` which accepts a callback for when the
-- | `Json` argument was a `String`, and a default value for all other cases.
caseJsonString :: forall a. a -> (String -> a) -> Json -> a
caseJsonString d f j = runFn7 _caseJson (const d) (const d) (const d) f (const d) (const d) j

-- | A simpler version of `caseJson` which accepts a callback for when the
-- | `Json` argument was a `Array Json`, and a default value for all other cases.
caseJsonArray :: forall a. a -> (Array Json -> a) -> Json -> a
caseJsonArray d f j = runFn7 _caseJson (const d) (const d) (const d) (const d) f (const d) j

-- | A simpler version of `caseJson` which accepts a callback for when the
-- | `Json` argument was an `Object`, and a default value for all other cases.
caseJsonObject :: forall a. a -> (Object Json -> a) -> Json -> a
caseJsonObject d f j = runFn7 _caseJson (const d) (const d) (const d) (const d) (const d) f j

verbJsonType :: forall a b. b -> (a -> b) -> (b -> (a -> b) -> Json -> b) -> Json -> b
verbJsonType def f g = g def f

-- Tests

isJsonType :: forall a. (Boolean -> (a -> Boolean) -> Json -> Boolean) -> Json -> Boolean
isJsonType = verbJsonType false (const true)

-- | Check if the provided `Json` is the `null` value
isNull :: Json -> Boolean
isNull = isJsonType caseJsonNull

-- | Check if the provided `Json` is a `Boolean`
isBoolean :: Json -> Boolean
isBoolean = isJsonType caseJsonBoolean

-- | Check if the provided `Json` is a `Number`
isNumber :: Json -> Boolean
isNumber = isJsonType caseJsonNumber

-- | Check if the provided `Json` is a `String`
isString :: Json -> Boolean
isString = isJsonType caseJsonString

-- | Check if the provided `Json` is an `Array`
isArray :: Json -> Boolean
isArray = isJsonType caseJsonArray

-- | Check if the provided `Json` is an `Object`
isObject :: Json -> Boolean
isObject = isJsonType caseJsonObject

-- Decoding

toJsonType
  :: forall a
   . (Maybe a -> (a -> Maybe a) -> Json -> Maybe a)
  -> Json
  -> Maybe a
toJsonType = verbJsonType Nothing Just

-- | Convert `Json` to the `Unit` value if the `Json` is the null value
toNull :: Json -> Maybe Unit
toNull = toJsonType caseJsonNull

-- | Convert `Json` to a `Boolean` value, if the `Json` is a boolean.
toBoolean :: Json -> Maybe Boolean
toBoolean = toJsonType caseJsonBoolean

-- | Convert `Json` to a `Number` value, if the `Json` is a number.
toNumber :: Json -> Maybe Number
toNumber = toJsonType caseJsonNumber

-- | Convert `Json` to a `String` value, if the `Json` is a string. To write a
-- | `Json` value to a JSON string, see `stringify`.
toString :: Json -> Maybe String
toString = toJsonType caseJsonString

-- | Convert `Json` to an `Array` of `Json` values, if the `Json` is an array.
toArray :: Json -> Maybe (Array Json)
toArray = toJsonType caseJsonArray

-- | Convert `Json` to an `Object` of `Json` values, if the `Json` is an array.
toObject :: Json -> Maybe (Object Json)
toObject = toJsonType caseJsonObject

-- Encoding

-- | Construct `Json` from a `Boolean` value
foreign import fromBoolean :: Boolean -> Json

-- | Construct `Json` from a `Number` value
foreign import fromNumber :: Number -> Json

-- | Construct `Json` from a `String` value. If you would like to parse a string
-- | of JSON into valid `Json`, see `jsonParser`.
foreign import fromString :: String -> Json

-- | Construct `Json` from an array of `Json` values
foreign import fromArray :: Array Json -> Json

-- | Construct `Json` from an object with `Json` values
foreign import fromObject :: Object Json -> Json

-- Defaults

-- | The JSON null value represented as `Json`
foreign import jsonNull :: Json

-- | The true boolean value represented as `Json`
jsonTrue :: Json
jsonTrue = fromBoolean true

-- | The false boolean value represented as `Json`
jsonFalse :: Json
jsonFalse = fromBoolean false

-- | The number zero represented as `Json`
jsonZero :: Json
jsonZero = fromNumber 0.0

-- | An empty string represented as `Json`
jsonEmptyString :: Json
jsonEmptyString = fromString ""

-- | An empty array represented as `Json`
jsonEmptyArray :: Json
jsonEmptyArray = fromArray []

-- | An empty object represented as `Json`
jsonEmptyObject :: Json
jsonEmptyObject = fromObject Obj.empty

-- | Constructs a `Json` array value containing only the provided value
jsonSingletonArray :: Json -> Json
jsonSingletonArray j = fromArray [j]

-- | Constructs a `Json` object value containing only the provided key and value
jsonSingletonObject :: String -> Json -> Json
jsonSingletonObject key val = fromObject (Obj.singleton key val)

-- | Converts a `Json` value to a JSON string. To retrieve a string from a `Json`
-- | string value, see `fromString`.
foreign import stringify :: Json -> String

foreign import _caseJson
  :: forall z
   . Fn7
      (Unit -> z)
      (Boolean -> z)
      (Number -> z)
      (String -> z)
      (Array Json -> z)
      (Object Json -> z)
      Json
      z

foreign import _compare :: Fn5 Ordering Ordering Ordering Json Json Ordering


Use purescript-spec for GlyphPosition instance tests

module Test.Main where

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Random (RANDOM)
import DOM (DOM)
import DOM.Node.Types as DOM
import Data.Argonaut (Json, jsonParser, toArray)
import Data.Either (Either(..))
import Data.Foreign (Foreign)
import Data.Maybe (Maybe(..), fromJust)
import Data.Traversable (traverse_)
import Genetics.Browser.Cytoscape as Cy
import Genetics.Browser.Cytoscape.Collection (contains, emptyCollection, filter, isEdge, isNode)
import Genetics.Browser.Cytoscape.Types (CY)
import Genetics.Browser.Feature (Feature(..), ScreenFeature, featureToScreen)
import Genetics.Browser.Glyph (Glyph, circle, fill, rect, stroke)
import Genetics.Browser.GlyphF.Canvas as Canvas
import Genetics.Browser.GlyphF.SVG as SVG
import Genetics.Browser.GlyphPosition (GlyphPosition)
import Genetics.Browser.Units (Bp(..), MBp(..))
import Graphics.Canvas (CANVAS, getCanvasElementById, getContext2D, translate)
import Partial.Unsafe (unsafePartial)
import Prelude
import Test.QuickCheck.Laws (QC)
import Test.QuickCheck.Laws.Data as Data
import Test.Spec (Spec, describe, it)
import Test.Spec.Assertions (fail, shouldEqual, shouldNotEqual)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Spec.Runner (run)
import Test.Units as Units
import Type.Proxy (Proxy(..))

foreign import testGlyphPos :: Foreign -> String
foreign import showGlyphSVG :: Foreign -> Unit
foreign import addElementToDiv :: ∀ eff. String -> DOM.Element -> Eff ( dom :: DOM | eff ) Unit
foreign import setOnLoad :: ∀ eff. Eff eff Unit -> Eff eff Unit

exGlyph :: Glyph Unit
exGlyph = do
  stroke "#ff0000"
  fill "#333333"
  rect {x: 0.0, y: 0.0} {x: 20.0, y: 140.0}
  stroke "#00ff00"
  fill "#777777"
  circle {x: 48.0, y: 30.0} 5.356
  stroke "#0000ff"
  fill "#aaaaaa"
  rect {x: 0.0, y: 10.0} {x: 400.0, y: 15.0}

exFeature1 :: Feature MBp Unit
exFeature1 = Feature "1" (MBp (-5.0)) (MBp 5.0) unit
exFeature2 :: Feature MBp Unit
exFeature2 = Feature "1" (MBp 10.0) (MBp 20.0) unit
exFeature3 :: Feature Bp Unit
exFeature3 = Feature "1" (Bp 60000.0) (Bp 61000.0) unit

glyph1 :: Glyph Unit
glyph1 = glyphify 0.0 (featureToScreen (MBp 0.0) (MBp 5.0) exFeature1)

glyph2 :: Glyph Unit
glyph2 = glyphify 50.0 (featureToScreen (MBp 0.0) (MBp 5.0) exFeature2)

glyph3 :: Glyph Unit
glyph3 = glyphify 100.0 (featureToScreen (Bp 0.0) (Bp 5.0) exFeature3)

glyphify :: Number -> ScreenFeature Unit -> Glyph Unit
glyphify y (Feature _ xl xr _) = do
  stroke "#ff0000"
  fill "#555555"
  rect { x: xl, y: y } { x: xr, y: y + 40.0 }

checkGlyphPosInstances :: ∀ eff. Spec ( console :: CONSOLE
                                      , random :: RANDOM
                                      , exception :: EXCEPTION | eff) Unit
checkGlyphPosInstances = do
  let prxGlyph = Proxy :: Proxy GlyphPosition
  describe "GlyphPosition instances" do
    it "is a Semigroup" $ do
      liftEff $ Data.checkSemigroup prxGlyph
    it "is a Monoid" $ do
      liftEff $ Data.checkMonoid prxGlyph

cyJson :: Array Json
cyJson = unsafePartial $ fromJust $ case jsonParser "[{\"data\": { \"id\": \"a\" }},{\"data\": { \"id\": \"b\" }},{\"data\": { \"id\": \"ab\", \"source\": \"a\", \"target\": \"b\" }}]" of
  Left e     -> Nothing
  Right json -> toArray json

specCytoscape :: ∀ eff. Spec (cy :: CY | eff) Unit
specCytoscape = do
  describe "Cytoscape" do
    it "is not empty if created with elements" $ do
      cy <- liftEff $ Cy.cytoscape Nothing (Just cyJson)
      eles <- liftEff $ Cy.graphGetCollection cy
      eles `shouldNotEqual` emptyCollection cy

    it "collections can be filtered and recombined" $ do
      cy <- liftEff $ Cy.cytoscape Nothing (Just cyJson)
      eles <- liftEff $ Cy.graphGetCollection cy

      let edges = filter isEdge eles
          nodes = filter isNode eles
      when (not $ eles `contains` edges) (fail "Graph doesn't contain its edges")
      when (not $ eles `contains` nodes) (fail "Graph doesn't contain its nodes")

      -- union of parts is equal to sum
      (edges <> nodes) `shouldEqual` eles
      eles             `shouldEqual` (edges <> nodes)
      -- union is commutative
      (edges <> nodes) `shouldEqual` (nodes <> edges)

runBrowserTest :: ∀ eff. QC ( canvas :: CANVAS
                            , dom :: DOM
                            | eff
                            ) Unit
runBrowserTest = do
  canvas <- getCanvasElementById "canvas"
  case canvas of
    Nothing -> log "couldn't find canvas"
    Just c  -> do
      ctx <- getContext2D c
      _ <- translate {translateX: -200.0, translateY: 0.0} ctx
      log "rendering glyph to canvas"
      traverse_ (Canvas.renderGlyph ctx) [glyph1, glyph2, glyph3]

  log "rendering glyph to svg"
  traverse_ (\g -> SVG.renderGlyph g >>= addElementToDiv "svgDiv") [glyph1, glyph2, glyph3]
  pure unit

main :: QC _ Unit
main = do
  run [consoleReporter] do
    specCytoscape
    checkGlyphPosInstances
  setOnLoad runBrowserTest
  Units.main

module Test.Main where

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import DOM (DOM)
import DOM.Node.Types as DOM
import Data.Argonaut (Json, jsonParser, toArray)
import Data.Either (Either(..))
import Data.Foreign (Foreign)
import Data.Maybe (Maybe(..), fromJust)
import Data.Traversable (traverse_)
import Genetics.Browser.Cytoscape as Cy
import Genetics.Browser.Cytoscape.Collection (contains, emptyCollection, filter, isEdge, isNode, union)
import Genetics.Browser.Feature (Feature(..), ScreenFeature, featureToScreen)
import Genetics.Browser.Glyph (Glyph, circle, fill, rect, stroke)
import Genetics.Browser.GlyphF.Canvas as Canvas
import Genetics.Browser.GlyphF.SVG as SVG
import Genetics.Browser.GlyphPosition (GlyphPosition)
import Genetics.Browser.Units (Bp(..), MBp(..))
import Graphics.Canvas (getCanvasElementById, getContext2D, translate)
import Partial.Unsafe (unsafePartial)
import Prelude
import Test.QuickCheck.Laws (QC)
import Test.QuickCheck.Laws.Data as Data
import Test.Spec (describe, it)
import Test.Spec.Assertions (fail, shouldEqual, shouldNotEqual)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Spec.Runner (run)
import Test.Units as Units
import Type.Proxy (Proxy(..))

foreign import testGlyphPos :: Foreign -> String
foreign import showGlyphSVG :: Foreign -> Unit
foreign import addElementToDiv :: ∀ eff. String -> DOM.Element -> Eff ( dom :: DOM | eff ) Unit
foreign import setOnLoad :: ∀ eff. Eff eff Unit -> Eff eff Unit

exGlyph :: Glyph Unit
exGlyph = do
  stroke "#ff0000"
  fill "#333333"
  rect {x: 0.0, y: 0.0} {x: 20.0, y: 140.0}
  stroke "#00ff00"
  fill "#777777"
  circle {x: 48.0, y: 30.0} 5.356
  stroke "#0000ff"
  fill "#aaaaaa"
  rect {x: 0.0, y: 10.0} {x: 400.0, y: 15.0}

exFeature1 :: Feature MBp Unit
exFeature1 = Feature "1" (MBp (-5.0)) (MBp 5.0) unit
exFeature2 :: Feature MBp Unit
exFeature2 = Feature "1" (MBp 10.0) (MBp 20.0) unit
exFeature3 :: Feature Bp Unit
exFeature3 = Feature "1" (Bp 60000.0) (Bp 61000.0) unit

glyph1 :: Glyph Unit
glyph1 = glyphify 0.0 (featureToScreen (MBp 0.0) (MBp 5.0) exFeature1)

glyph2 :: Glyph Unit
glyph2 = glyphify 50.0 (featureToScreen (MBp 0.0) (MBp 5.0) exFeature2)

glyph3 :: Glyph Unit
glyph3 = glyphify 100.0 (featureToScreen (Bp 0.0) (Bp 5.0) exFeature3)

glyphify :: Number -> ScreenFeature Unit -> Glyph Unit
glyphify y (Feature _ xl xr _) = do
  stroke "#ff0000"
  fill "#555555"
  rect { x: xl, y: y } { x: xr, y: y + 40.0 }

checkGlyphPosInstances :: ∀ e. QC e Unit
checkGlyphPosInstances = do
  Data.checkSemigroup prxGlyph
  Data.checkMonoid prxGlyph
  where
    prxGlyph = Proxy :: Proxy GlyphPosition

cyJson :: Array Json
cyJson = unsafePartial $ fromJust $ case jsonParser "[{\"data\": { \"id\": \"a\" }},{\"data\": { \"id\": \"b\" }},{\"data\": { \"id\": \"ab\", \"source\": \"a\", \"target\": \"b\" }}]" of
  Left e     -> Nothing
  Right json -> toArray json

-- specCytoscape :: ∀ eff. Eff (SpecEffects (cy :: CY, process :: PROCESS)) Unit
specCytoscape :: Eff _ Unit
specCytoscape = run [consoleReporter] do
  describe "Cytoscape" do
    it "is not empty if created with elements" $ do
      cy <- liftEff $ Cy.cytoscape Nothing (Just cyJson)
      eles <- liftEff $ Cy.graphGetCollection cy
      eles `shouldNotEqual` emptyCollection cy

    it "collections can be filtered and recombined" $ do
      cy <- liftEff $ Cy.cytoscape Nothing (Just cyJson)
      eles <- liftEff $ Cy.graphGetCollection cy

      let edges = filter isEdge eles
          nodes = filter isNode eles
      when (not $ eles `contains` edges) (fail "Graph doesn't contain its edges")
      when (not $ eles `contains` nodes) (fail "Graph doesn't contain its nodes")

      -- union of parts is equal to sum
      (edges <> nodes) `shouldEqual` eles
      eles             `shouldEqual` (edges <> nodes)
      -- union is commutative
      (edges <> nodes) `shouldEqual` (nodes <> edges)

runBrowserTest :: QC _ Unit
runBrowserTest = do
  canvas <- getCanvasElementById "canvas"
  case canvas of
    Nothing -> log "couldn't find canvas"
    Just c  -> do
      ctx <- getContext2D c
      _ <- translate {translateX: -200.0, translateY: 0.0} ctx
      log "rendering glyph to canvas"
      traverse_ (Canvas.renderGlyph ctx) [glyph1, glyph2, glyph3]

  log "rendering glyph to svg"
  traverse_ (\g -> SVG.renderGlyph g >>= addElementToDiv "svgDiv") [glyph1, glyph2, glyph3]

  pure unit

main :: QC _ Unit
main = do
  checkGlyphPosInstances
  setOnLoad runBrowserTest
  specCytoscape
  Units.main


[CSE-68] Update `layout` view using `pux 10.x`

module Explorer.View.Layout where

import Prelude
import Data.Lens ((^.))

import Pux.DOM.HTML (Html) as P

import Text.Smolder.HTML (div, main)
import Text.Smolder.HTML.Attributes (className)

import Explorer.Lenses.State (gViewMobileMenuOpenend, globalViewState, route, viewStates)
import Explorer.Routes (Route(..))
import Explorer.Types.Actions (Action)
import Explorer.Types.State (State)
import Explorer.View.Address (addressView)
import Explorer.View.Block (blockView)
import Explorer.View.Blocks (blocksView)
import Explorer.View.CSS (route) as CSS
import Explorer.View.Calculator (calculatorView)
import Explorer.View.Dashboard.Dashboard (dashboardView)
import Explorer.View.Footer (footerView)
import Explorer.View.Header (headerView)
import Explorer.View.NotFound (notFoundView)
import Explorer.View.Playground (playgroundView)
import Explorer.View.Transaction (transactionView)

view :: State -> P.Html Action
view state =
    let mobileMenuClazz = if state ^. (viewStates <<< globalViewState <<< gViewMobileMenuOpenend)
                          then " mobile__menu--opened"
                          else ""
        routeClazz = CSS.route $ state ^. route
    in
    div ! className ("explorer-container" <> mobileMenuClazz <> " " <> routeClazz) $ do
        div ! className "explorer-bg__container" $ do
            div ! className "explorer-content__wrapper" $ do
                main ! className "explorer-content" $ do
                    case state ^. route of
                        Dashboard -> dashboardView state
                        (Tx id) -> transactionView state
                        (Address address) -> addressView state
                        (Epoch epoch) -> blocksView state
                        (EpochSlot epoch slot) -> blocksView state
                        Calculator -> calculatorView state
                        (Block hash) -> blockView state
                        Playground -> playgroundView state
                        NotFound -> notFoundView state
                    footerView state
            headerView state

module Explorer.View.Layout where

import Prelude
import Data.Lens ((^.))
import Explorer.Lenses.State (gViewMobileMenuOpenend, globalViewState, route, viewStates)
import Explorer.Routes (Route(..))
import Explorer.Types.Actions (Action)
import Explorer.Types.State (State)
import Explorer.View.Address (addressView)
import Explorer.View.Block (blockView)
import Explorer.View.Blocks (blocksView)
import Explorer.View.CSS (route) as CSS
import Explorer.View.Calculator (calculatorView)
import Explorer.View.Dashboard.Dashboard (dashboardView)
import Explorer.View.Footer (footerView)
import Explorer.View.Header (headerView)
import Explorer.View.NotFound (notFoundView)
import Explorer.View.Playground (playgroundView)
import Explorer.View.Transaction (transactionView)
import Pux.Html (Html, div, main) as P
import Pux.Html.Attributes (className) as P

view :: State -> P.Html Action
view state =
    let mobileMenuClazz = if state ^. (viewStates <<< globalViewState <<< gViewMobileMenuOpenend)
                          then " mobile__menu--opened"
                          else ""
        routeClazz = CSS.route $ state ^. route
    in
    P.div
      [ P.className $ "explorer-container" <> mobileMenuClazz <> " " <> routeClazz
      ]
      [ P.div
          [ P.className "explorer-bg__container" ]
          []
        , P.div
              [ P.className "explorer-content__wrapper"]
              [ P.main
                  [ P.className "explorer-content" ]
                  [ case state ^. route of
                      Dashboard -> dashboardView state
                      (Tx id) -> transactionView state
                      (Address address) -> addressView state
                      (Epoch epoch) -> blocksView state
                      (EpochSlot epoch slot) -> blocksView state
                      Calculator -> calculatorView state
                      (Block hash) -> blockView state
                      Playground -> playgroundView state
                      NotFound -> notFoundView state
                  ]
              , footerView state
              ]
        , headerView state
      ]