Refactored function for knowing whether mouse is on a square that could possibly be selected by the current player

module Checkers.Main where

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

import Checkers.Constants
import Checkers.Types

createPiece :: Player -> Piece
createPiece player =
  let color = if player == playerOne
              then colorPlayerOne
              else colorPlayerTwo
  in { player: player, color: color, king: false }

createGrid :: Tuple Number Number -> Int -> Int -> Int -> Grid
createGrid (Tuple ox oy) width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          isPieceSquare = ((even x) && (odd y)) || ((even y) && (odd x))
          color = if isPieceSquare then colorSquareOne else colorSquareTwo
          piece = if isPieceSquare && (y < layers)
                  then Just (createPiece playerOne)
                  else if isPieceSquare && (y >= height - layers)
                       then Just (createPiece playerTwo)
                       else Nothing
      return { ox: ox, oy: oy, x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

createState :: Tuple Number Number -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid:               createGrid offset width height layers,
    currentPlayer:      playerOne,
    selectedCoordinate: Nothing }

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

isValid :: Grid -> Coordinate -> Boolean
isValid grid (Tuple x y) = x >= 0 && x < grid.width && y >= 0 && y < grid.height

getCoordinateIndex :: Array Square -> Coordinate -> Maybe Int
getCoordinateIndex squares coordinate = findIndex (\e -> (Tuple e.x e.y) == coordinate) squares

hasPlayerPiece :: Array Square -> Coordinate -> Player -> Boolean
hasPlayerPiece squares coordinate player =
  case getCoordinateIndex squares coordinate of
    Nothing -> false
    Just index ->
      case (fromJust (squares !! index)).piece of
        Nothing -> false
        Just p -> p.player == player

hasPiece :: Array Square -> Coordinate -> Boolean
hasPiece squares coordinate =
  hasPlayerPiece squares coordinate playerOne ||
  hasPlayerPiece squares coordinate playerTwo

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

isOnSquare :: Square -> Number -> Number -> Boolean
isOnSquare square x y =
  let vx = square.rx + square.ox
      vy = square.ry + square.oy
  in vx < x && x < vx + renderSize && vy < y && y < vy + renderSize

isOnActiveSquare :: Grid -> Player -> Square -> Number -> Number -> Boolean
isOnActiveSquare grid player square ux uy =
  let moves = getMoves grid player (Tuple square.x square.y)
  in isOnSquare square ux uy && not (null moves)

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to = not hasPiece grid.squares to &&
  ((player == playerOne && snd to > snd from) ||
   (player == playerTwo && snd to < snd from))

getMoves :: Grid -> Player -> Coordinate -> Array Coordinate
getMoves grid player coordinate = do
  potential <- getDiagonalSquares coordinate
  guard $ (isValid grid potential && isValidMove grid player coordinate potential)
  return potential

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

renderSquare :: forall e.
                  Context2D ->
                  Maybe DOMEvent ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx event _ square = do
  setFillStyle square.color ctx
  fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  return unit

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

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle "black" ctx
  strokeRect ctx border
  return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Maybe DOMEvent ->
            Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
render ctx st event = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx event) unit state.grid.squares
  withContext ctx $ do
    foldM (renderPiece state ctx event) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  return unit

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

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

module Checkers.Main where

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

import Checkers.Constants
import Checkers.Types

createPiece :: Player -> Piece
createPiece player =
  let color = if player == playerOne
              then colorPlayerOne
              else colorPlayerTwo
  in { player: player, color: color, king: false }

createGrid :: Tuple Number Number -> Int -> Int -> Int -> Grid
createGrid (Tuple ox oy) width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          isPieceSquare = ((even x) && (odd y)) || ((even y) && (odd x))
          color = if isPieceSquare then colorSquareOne else colorSquareTwo
          piece = if isPieceSquare && (y < layers)
                  then Just (createPiece playerOne)
                  else if isPieceSquare && (y >= height - layers)
                       then Just (createPiece playerTwo)
                       else Nothing
      return { ox: ox, oy: oy, x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

createState :: Tuple Number Number -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid:               createGrid offset width height layers,
    currentPlayer:      playerOne,
    selectedCoordinate: Nothing }

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

isValid :: Grid -> Coordinate -> Boolean
isValid grid (Tuple x y) = x >= 0 && x < grid.width && y >= 0 && y < grid.height

getCoordinateIndex :: Array Square -> Coordinate -> Maybe Int
getCoordinateIndex squares coordinate = findIndex (\e -> (Tuple e.x e.y) == coordinate) squares

hasPlayerPiece :: Array Square -> Coordinate -> Player -> Boolean
hasPlayerPiece squares coordinate player =
  case getCoordinateIndex squares coordinate of
    Nothing -> false
    Just index ->
      case (fromJust (squares !! index)).piece of
        Nothing -> false
        Just p -> p.player == player

hasPiece :: Array Square -> Coordinate -> Boolean
hasPiece squares coordinate =
  hasPlayerPiece squares coordinate playerOne ||
  hasPlayerPiece squares coordinate playerTwo

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

isOnSquare :: Square -> Number -> Number -> Boolean
isOnSquare square x y =
  let vx = square.rx + square.ox
      vy = square.ry + square.oy
  in vx < x && x < vx + renderSize && vy < y && y < vy + renderSize

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to = not hasPiece grid.squares to &&
  ((player == playerOne && snd to > snd from) ||
   (player == playerTwo && snd to < snd from))

getMoves :: Grid -> Player -> Coordinate -> Array Coordinate
getMoves grid player coordinate = do
  potential <- getDiagonalSquares coordinate
  guard $ (isValid grid potential && isValidMove grid player coordinate potential)
  return potential

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

renderSquare :: forall e.
                  Context2D ->
                  Maybe DOMEvent ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx event _ square = do
  setFillStyle square.color ctx
  fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  return unit

renderPiece :: forall e.
                 State ->
                 Context2D ->
                 Maybe DOMEvent ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece state ctx event _ square =
  case square.piece of
    Just piece -> do
      setFillStyle piece.color ctx
      let arcPiece = { x: square.rx + 0.5 * renderSize,
                       y: square.ry + 0.5 * renderSize,
                       r: (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end: 2.0 * pi }
      fillPath ctx $ arc ctx arcPiece
      case event of
        Nothing -> return unit
        Just e -> do
          ux <- unsafeEventNumberProp "clientX" e
          uy <- unsafeEventNumberProp "clientY" e
          let moves = getMoves state.grid state.currentPlayer (Tuple square.x square.y)
          case isOnSquare square (toNumber ux) (toNumber uy) && not (null moves) of
            true -> do
              setLineWidth highlightWidth ctx
              strokePath ctx $ arc ctx arcPiece
              return unit
            false -> return unit
          return unit
      return unit
    _ -> return unit

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle "black" ctx
  strokeRect ctx border
  return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Maybe DOMEvent ->
            Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
render ctx st event = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx event) unit state.grid.squares
  withContext ctx $ do
    foldM (renderPiece state ctx event) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  return unit

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

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


Correctly unesape escaped doublequote and escaped backslash

Original commit 3a8986b6f815a1185b7b229adf095106f0da68b1

module Data.JSON.AST
    ( parse
    , Node(..)
    , Property(..)
    , Literal(..)
    ) where

import Core

import Data.Argonaut.Core (Json, isBoolean, isNull, isNumber, isString)
import Data.Argonaut.Decode (class DecodeJson, decodeJson, (.?))
import Data.Foldable (foldl)
import Data.String as S
import Data.String.Util as S
import Data.Tuple (Tuple(..))

type MkEither a b =
    { success :: b -> Either a b
    , fail :: a -> Either a b
    }

mkEither :: forall a b. MkEither a b
mkEither = { success: Right, fail: Left }

foreign import _parse :: MkEither String Json -> String -> Either String Json

parse :: String -> Either String Node
parse s = do
    obj <- _parse mkEither s
    decodeJson obj

data Property = Property { label :: String, node :: Node }

data Key = Key String

data Literal
    = String String
    | Boolean Boolean
    | Null
    | Number Number String

data Node
    = Literal Literal
    | Object (Array Property)
    | Array (Array Node)

instance decodeLiteral:: DecodeJson Literal where
    decodeJson j = do
        obj <- decodeJson j
        val <- obj .? "value"
        raw <- obj .? "rawValue"
        case val of
            _ | isString val ->
                String <$> decodeJson val
            _ | isBoolean val ->
                Boolean <$> decodeJson val
            _ | isNull val ->
                pure Null
            _ | isNumber val -> do
                n <- decodeJson val
                pure $ Number n raw
            _ -> Left $ "Could not decode literal: " <> raw

instance decodeKey :: DecodeJson Key where
    decodeJson j = do
        obj <- decodeJson j
        label <- obj .? "value"
        pure $ Key (unescape label)
        where
            -- https://github.com/vtrushin/json-to-ast/issues/17
            replace s (Tuple this that) = S.replaceAll (S.Pattern this) (S.Replacement that) s
            unescape s = foldl replace s [
                Tuple "\\\"" "\"",
                Tuple "\\\\" "\\"
            ]

instance decodeProperty :: DecodeJson Property where
    decodeJson :: Json -> Either String Property
    decodeJson j = do
        obj <- decodeJson j
        Key label <- obj .? "key"
        node <- obj .? "value"
        pure $ Property { label, node }

instance decodeNode :: DecodeJson Node where
    decodeJson j = do
        obj <- decodeJson j
        typ <- obj .? "type"
        case typ of
            "object" -> do
                props <- obj .? "children"
                pure $ Object props
            "literal" -> do
                literal <- decodeJson j
                pure $ Literal literal
            "array" -> do
                children <- obj .? "children"
                pure $ Array children
            _ -> Left "Unsupported JSON value"

module Data.JSON.AST
    ( parse
    , Node(..)
    , Property(..)
    , Literal(..)
    ) where

import Core

import Data.Argonaut.Core (Json, isBoolean, isNull, isNumber, isString)
import Data.Argonaut.Decode (class DecodeJson, decodeJson, (.?))
import Data.String as S
import Data.String.Util as S

type MkEither a b =
    { success :: b -> Either a b
    , fail :: a -> Either a b
    }

mkEither :: forall a b. MkEither a b
mkEither = { success: Right, fail: Left }

foreign import _parse :: MkEither String Json -> String -> Either String Json

parse :: String -> Either String Node
parse s = do
    obj <- _parse mkEither s
    decodeJson obj

data Property = Property { label :: String, node :: Node }

data Key = Key String

data Literal
    = String String
    | Boolean Boolean
    | Null
    | Number Number String

data Node
    = Literal Literal
    | Object (Array Property)
    | Array (Array Node)

instance decodeLiteral:: DecodeJson Literal where
    decodeJson j = do
        obj <- decodeJson j
        val <- obj .? "value"
        raw <- obj .? "rawValue"
        case val of
            _ | isString val ->
                String <$> decodeJson val
            _ | isBoolean val ->
                Boolean <$> decodeJson val
            _ | isNull val ->
                pure Null
            _ | isNumber val -> do
                n <- decodeJson val
                pure $ Number n raw
            _ -> Left $ "Could not decode literal: " <> raw

instance decodeKey :: DecodeJson Key where
    decodeJson j = do
        obj <- decodeJson j
        -- https://github.com/vtrushin/json-to-ast/issues/17
        let deslash = S.replaceAll (S.Pattern "\\") (S.Replacement "")
        label <- deslash <$> obj .? "value"
        pure $ Key label

instance decodeProperty :: DecodeJson Property where
    decodeJson :: Json -> Either String Property
    decodeJson j = do
        obj <- decodeJson j
        Key label <- obj .? "key"
        node <- obj .? "value"
        pure $ Property { label, node }

instance decodeNode :: DecodeJson Node where
    decodeJson j = do
        obj <- decodeJson j
        typ <- obj .? "type"
        case typ of
            "object" -> do
                props <- obj .? "children"
                pure $ Object props
            "literal" -> do
                literal <- decodeJson j
                pure $ Literal literal
            "array" -> do
                children <- obj .? "children"
                pure $ Array children
            _ -> Left "Unsupported JSON value"


Don't use non-ASCII in JSON Schema refs

Don't use non-ASCII in JSON Schema refs

Original commit afe27002521b58c7fd746ff1b5a5def1b14ce95c

module JsonSchema where

import Doc
import IRGraph
import Prelude
import Utils

import Data.Argonaut.Core (Json, fromArray, fromBoolean, fromObject, fromString, stringifyWithSpace)
import Data.Array as A
import Data.Char as Char
import Data.Foldable (intercalate)
import Data.List (List)
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.StrMap (StrMap)
import Data.StrMap as SM
import Data.String as String
import Data.String.Util (camelCase, capitalize)
import Data.Tuple (Tuple(..))

forbiddenNames :: Array String
forbiddenNames = []

renderer :: Renderer
renderer =
    { name: "JSON Schema"
    , aceMode: "json"
    , extension: "json"
    , doc: jsonSchemaDoc
    , transforms:
        { nameForClass
        , unionName: Nothing
        , unionPredicate: Nothing
        , nextName: \s -> "Other" <> s
        , forbiddenNames
        }
    }

legalize :: String -> String
legalize s =
    String.fromCharArray $ map (\c -> if isLegal c then c else '_') (String.toCharArray s)
    where
        isLegal c =
            let cc = Char.toCharCode c
            in cc >= 32 && cc < 128

jsonNameStyle :: String -> String
jsonNameStyle =
    camelCase >>> capitalize >>> legalize

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = jsonNameStyle $ combineNames names

unionName :: List String -> String
unionName s =
    L.sort s
    <#> jsonNameStyle
    # intercalate "Or"

typeStrMap :: String -> Doc (StrMap Json)
typeStrMap s = pure $ SM.insert "type" (fromString s) SM.empty

strMapForType :: IRType -> Doc (StrMap Json)
strMapForType t =
    case t of
    IRNothing -> pure SM.empty
    IRNull -> typeStrMap "null"
    IRInteger -> typeStrMap "integer"
    IRDouble -> typeStrMap "number"
    IRBool -> typeStrMap "boolean"
    IRString -> typeStrMap "string"
    IRArray a -> do
        itemType <- strMapForType a
        sm <- typeStrMap "array"
        pure $ SM.insert "items" (fromObject itemType) sm
    IRClass i -> do
        name <- lookupClassName i
        pure $ SM.insert "$ref" (fromString $ "#/definitions/" <> name) SM.empty
    IRMap m -> do
        propertyType <- strMapForType m
        sm <- typeStrMap "object"
        pure $ SM.insert "additionalProperties" (fromObject propertyType) sm
    IRUnion ur -> do
        types <- mapM strMapForType $ L.fromFoldable $ unionToSet ur
        let typesJson = fromArray $ A.fromFoldable $ map fromObject types
        pure $ SM.insert "oneOf" typesJson SM.empty

definitionForClass :: Tuple Int IRClassData -> Doc (Tuple String Json)
definitionForClass (Tuple i (IRClassData { properties })) = do
    className <- lookupClassName i
    let sm = SM.insert "additionalProperties" (fromBoolean false) $ SM.insert "type" (fromString "object") SM.empty
    propsMap <- mapMapM (\_ -> strMapForType) properties
    let requiredProps = A.fromFoldable $ map fromString $ M.keys $ M.filter (\t -> not $ canBeNull t) properties
    let propsSM = SM.fromFoldable $ (M.toUnfoldable (map fromObject propsMap) :: List _)
    pure $ Tuple className (fromObject $ SM.insert "required" (fromArray requiredProps) $ SM.insert "properties" (fromObject propsSM) sm)

irToJson :: Doc Json
irToJson = do
    classes <- getClasses
    definitions <- fromObject <$> SM.fromFoldable <$> mapM definitionForClass classes
    topLevel <- strMapForType =<< getTopLevel
    let sm = SM.insert "definitions" definitions topLevel
    pure $ fromObject sm

jsonSchemaDoc :: Doc Unit
jsonSchemaDoc = do
    json <- irToJson
    line $ stringifyWithSpace "    " json

module JsonSchema where

import Doc
import IRGraph
import Prelude
import Utils

import Data.Argonaut.Core (Json, fromArray, fromBoolean, fromObject, fromString, stringifyWithSpace)
import Data.Array as A
import Data.Foldable (intercalate)
import Data.List (List)
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.StrMap (StrMap)
import Data.StrMap as SM
import Data.String.Util (camelCase, capitalize)
import Data.Tuple (Tuple(..))

forbiddenNames :: Array String
forbiddenNames = []

renderer :: Renderer
renderer =
    { name: "JSON Schema"
    , aceMode: "json"
    , extension: "json"
    , doc: jsonSchemaDoc
    , transforms:
        { nameForClass
        , unionName: Nothing
        , unionPredicate: Nothing
        , nextName: \s -> "Other" <> s
        , forbiddenNames
        }
    }

jsonNameStyle :: String -> String
jsonNameStyle =
    camelCase >>> capitalize

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = jsonNameStyle $ combineNames names

unionName :: List String -> String
unionName s =
    L.sort s
    <#> jsonNameStyle
    # intercalate "Or"

typeStrMap :: String -> Doc (StrMap Json)
typeStrMap s = pure $ SM.insert "type" (fromString s) SM.empty

strMapForType :: IRType -> Doc (StrMap Json)
strMapForType t =
    case t of
    IRNothing -> pure SM.empty
    IRNull -> typeStrMap "null"
    IRInteger -> typeStrMap "integer"
    IRDouble -> typeStrMap "number"
    IRBool -> typeStrMap "boolean"
    IRString -> typeStrMap "string"
    IRArray a -> do
        itemType <- strMapForType a
        sm <- typeStrMap "array"
        pure $ SM.insert "items" (fromObject itemType) sm
    IRClass i -> do
        name <- lookupClassName i
        pure $ SM.insert "$ref" (fromString $ "#/definitions/" <> name) SM.empty
    IRMap m -> do
        propertyType <- strMapForType m
        sm <- typeStrMap "object"
        pure $ SM.insert "additionalProperties" (fromObject propertyType) sm
    IRUnion ur -> do
        types <- mapM strMapForType $ L.fromFoldable $ unionToSet ur
        let typesJson = fromArray $ A.fromFoldable $ map fromObject types
        pure $ SM.insert "oneOf" typesJson SM.empty

definitionForClass :: Tuple Int IRClassData -> Doc (Tuple String Json)
definitionForClass (Tuple i (IRClassData { properties })) = do
    className <- lookupClassName i
    let sm = SM.insert "additionalProperties" (fromBoolean false) $ SM.insert "type" (fromString "object") SM.empty
    propsMap <- mapMapM (\_ -> strMapForType) properties
    let requiredProps = A.fromFoldable $ map fromString $ M.keys $ M.filter (\t -> not $ canBeNull t) properties
    let propsSM = SM.fromFoldable $ (M.toUnfoldable (map fromObject propsMap) :: List _)
    pure $ Tuple className (fromObject $ SM.insert "required" (fromArray requiredProps) $ SM.insert "properties" (fromObject propsSM) sm)

irToJson :: Doc Json
irToJson = do
    classes <- getClasses
    definitions <- fromObject <$> SM.fromFoldable <$> mapM definitionForClass classes
    topLevel <- strMapForType =<< getTopLevel
    let sm = SM.insert "definitions" definitions topLevel
    pure $ fromObject sm

jsonSchemaDoc :: Doc Unit
jsonSchemaDoc = do
    json <- irToJson
    line $ stringifyWithSpace "    " json


Comment

Comment

Original commit ad7d9910a4207844bb8ea101917950c33cb7f8a3

module TypeScript
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory, isLetter)
import Data.Foldable (for_, intercalate, maximum)

import Data.List as L

import Data.Map as M
import Data.Maybe (Maybe(Nothing, Just), maybe)
import Data.Set (Set)
import Data.Set as S

import Data.String as Str
import Data.String.Util as Str

import Data.String.Regex as Rx
import Data.String.Regex.Flags as RxFlags
import Data.String.Util (camelCase, capitalize)

import Data.Tuple (Tuple(..), fst)
import Partial.Unsafe (unsafePartial)
import Utils (mapM)
import Data.Either as Either

renderer :: Renderer
renderer =
    { name: "TypeScript"
    , aceMode: "typescript"
    , extension: "ts"
    , doc: typeScriptDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , unionName: Nothing
        , unionPredicate: Just unionPredicate
        , nextName: \s -> s <> "_"
        , forbiddenNames: []
        , topLevelNameFromGiven: id
        , forbiddenFromTopLevelNameGiven: const []
        }
    }

unionPredicate :: IRType -> Maybe (Set IRType)
unionPredicate = case _ of
    IRUnion ur ->
        let s = unionToSet ur
        in case nullableFromSet s of
            Nothing -> Just s
            _ -> Nothing
    _ -> Nothing

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = interfaceNamify $ combineNames names

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

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || (generalCategory c == Just LetterNumber)

isStartCharacter :: Char -> Boolean
isStartCharacter c =
    isLetterCharacter c || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Nothing -> false
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isLetterCharacter c

legalizeIdentifier :: String -> String
legalizeIdentifier str =
    case Str.charAt 0 str of
    Nothing -> "Empty"
    Just s ->
        if isStartCharacter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier ("_" <> str)

renderUnion :: Set IRType -> Doc String
renderUnion s =
    case nullableFromSet s of
    Just x -> renderType x
    Nothing -> do
        types <- mapM renderType $ L.fromFoldable s
        pure $ intercalate " | " types

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "any" -- we can have arrays of nothing
    IRNull -> pure "any"
    IRInteger -> pure "number"
    IRDouble -> pure "number"
    IRBool -> pure "boolean"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderType a
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "{ [key: string]: " <> rendered <> " }"
    IRUnion types -> renderUnion $ unionToSet types

interfaceNamify :: String -> String
interfaceNamify = Str.camelCase >>> Str.capitalize >>> legalizeIdentifier

propertyNamify :: String -> String
propertyNamify s
    | Rx.test hasInternalSeparator s = "\"" <> s <> "\""
    | otherwise =
        case Str.charAt 0 s of
            Nothing -> "Empty"
            Just c | isStartCharacter c -> s
                   | otherwise -> "\"" <> s <> "\""

hasInternalSeparator :: Rx.Regex
hasInternalSeparator = unsafePartial $ Either.fromRight $ Rx.regex "[-. ]" RxFlags.noFlags

typeScriptDoc :: Doc Unit
typeScriptDoc = do
    top <- getTopLevel >>= renderType
    line $ """// To parse this JSON data:
//
//     import * as """ <> top <> """ from "./""" <> top <> """;
//     let value = """ <> top <> """.Convert.fromJson(json);
//
"""
    classes <- getClasses
    for_ classes \(Tuple i cd) -> do
        interface <- lookupClassName i
        renderInterface cd interface
        blank
    converter

renderInterface :: IRClassData -> String -> Doc Unit
renderInterface (IRClassData { names, properties }) className = do
    let propertyNames = transformNames (simpleNamer propertyNamify) (_ <> "_") (S.singleton className) $ map (\n -> Tuple n n) $ M.keys properties

    let resolver name typ = markNullable (lookupName name propertyNames) typ
    let resolvePropertyNameWithType (Tuple name typ) = Tuple (resolver name typ) typ

    line $ "export interface " <> className <> " {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let resolved = resolvePropertyNameWithType <$> props
        let maxWidth = resolved <#> fst <#> Str.length # maximum
        for_ resolved \(Tuple pname ptype) -> do
            let indent = maybe 1 (\w -> w - Str.length pname + 1) maxWidth
            rendered <- renderType ptype
            line $ pname <> ":" <> Str.times " " indent <> rendered <> ";"
    line "}"

-- If this is a nullable, add a '?'
markNullable :: String -> IRType -> String
markNullable name (IRUnion unionRep) =
    case nullableFromSet $ unionToSet unionRep of
        Just _ -> name <> "?"
        _ -> name
markNullable name _ = name

renderTypeMapType :: IRType -> Doc String
renderTypeMapType = case _ of
    IRNothing -> pure "'undefined'" -- we can have arrays of nothing
    IRNull -> pure "'undefined'"
    IRInteger -> pure "'number'"
    IRDouble -> pure "'number'"
    IRBool -> pure "'boolean'"
    IRString -> pure "'string'"
    IRArray a -> do
        rendered <- renderTypeMapType a
        pure $ "array(" <> rendered <> ")"
    IRClass i -> do
        name <- lookupClassName i
        pure $ "object('" <> name <> "')"
    IRMap t -> do
        rendered <- renderTypeMapType t
        pure $ "map(" <> rendered <> ")"
    IRUnion types -> do
        renderedTyps <- mapM renderTypeMapType $ L.fromFoldable $ unionToSet types
        pure $ "union(" <> intercalate ", " renderedTyps <> ")"

renderTypeMapClass :: IRClassData -> String -> Doc Unit
renderTypeMapClass (IRClassData { names, properties }) className = do
    let propertyNames = transformNames (simpleNamer propertyNamify) (_ <> "_") (S.singleton className) $ map (\n -> Tuple n n) $ M.keys properties

    let resolver name typ = lookupName name propertyNames
    let resolvePropertyNameWithType (Tuple name typ) = Tuple (resolver name typ) typ

    line $ className <> ": {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let resolved = resolvePropertyNameWithType <$> props
        for_ resolved \(Tuple pname ptype) -> do
            rendered <- renderTypeMapType ptype
            line $ pname <> ": " <> rendered <> ","
    line "},"

typemap :: Doc Unit
typemap = do
    line "// The typeMap is used to assert that objects from"
    line "// JSON.parse conform to the types we expect them to."
    line $ "const typeMap = {"
    indent do
        classes <- getClasses
        for_ classes \(Tuple i cd) -> do
            className <- lookupClassName i
            renderTypeMapClass cd className
    line $ "};"

converter :: Doc Unit
converter = do
    top <- getTopLevel >>= renderType
    line """export module Convert {
    let path = [];

    export function fromJson(json: string): TopLevel {
        return cast(JSON.parse(json), "TopLevel");
    }

    export function toJson(value: TopLevel): string {
        return JSON.stringify(value);
    }

    function cast<T>(obj: any, className: string): T {
        path = [];
        if (!isValid(object(className), obj)) {
            throw `Invalid value: obj${path.join("")}`
        }
        return obj;
    }

    function isValid(typ: any, val: any): boolean {
        if      (typ.isUnion)  return isValidUnion(typ.typs, val);
        else if (typ.isArray)  return isValidArray(typ.typ, val);
        else if (typ.isMap)    return isValidMap(typ.typ, val);
        else if (typ.isObject) return isValidObject(typ.cls, val);
        else    /*primitive*/  return isValidPrimitive(typ, val);
    }

    function isValidPrimitive(typ: string, val: any) {
        if (typ == 'undefined') return !val;
        return typ === typeof val;
    }

    function isValidUnion(typs: any[], val: any): boolean {
        // val must validate against one typ in typs
        return typs.find(typ => isValid(typ, val)) !== undefined;
    }

    function isValidArray(typ: any, val: any): boolean {
        // val must be an array with no invalid elements
        return Array.isArray(val) && !val.find((val, i) => {
            path.push(`[${i}]`);
            if (isValid(typ, val)) {
                path.pop();
            } else {
                return true;
            }
        });
    }

    function isValidMap(typ: any, val: any): boolean {
        // all values in the map must be typ
        for (let prop in val) {
            path.push(`['${prop}']`);
            if (!isValid(typ, val[prop]))
                return false;
            path.pop();
        }
        return true;
    }

    function isValidObject(className: string, val: any): boolean {
        let typeRep = typeMap[className];

        for (let prop in typeRep) {
            path.push(`.${prop}`);
            if (!isValid(typeRep[prop], val[prop]))
                return false;
            path.pop();
        }

        return true;
    }

    function array(typ: any) {
        return { typ, isArray: true };
    }

    function union(...typs: any[]) {
        return { typs, isUnion: true };
    }

    function map(typ: any) {
        return { typ, isMap: true };
    }

    function object(className: string) {
        return { cls: className, isObject: true };
    }
"""
    indent typemap
    line """
}
"""

module TypeScript
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory, isLetter)
import Data.Foldable (for_, intercalate, maximum)

import Data.List as L

import Data.Map as M
import Data.Maybe (Maybe(Nothing, Just), maybe)
import Data.Set (Set)
import Data.Set as S

import Data.String as Str
import Data.String.Util as Str

import Data.String.Regex as Rx
import Data.String.Regex.Flags as RxFlags
import Data.String.Util (camelCase, capitalize)

import Data.Tuple (Tuple(..), fst)
import Partial.Unsafe (unsafePartial)
import Utils (mapM)
import Data.Either as Either

renderer :: Renderer
renderer =
    { name: "TypeScript"
    , aceMode: "typescript"
    , extension: "ts"
    , doc: typeScriptDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , unionName: Nothing
        , unionPredicate: Just unionPredicate
        , nextName: \s -> s <> "_"
        , forbiddenNames: []
        , topLevelNameFromGiven: id
        , forbiddenFromTopLevelNameGiven: const []
        }
    }

unionPredicate :: IRType -> Maybe (Set IRType)
unionPredicate = case _ of
    IRUnion ur ->
        let s = unionToSet ur
        in case nullableFromSet s of
            Nothing -> Just s
            _ -> Nothing
    _ -> Nothing

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = interfaceNamify $ combineNames names

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

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || (generalCategory c == Just LetterNumber)

isStartCharacter :: Char -> Boolean
isStartCharacter c =
    isLetterCharacter c || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Nothing -> false
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isLetterCharacter c

legalizeIdentifier :: String -> String
legalizeIdentifier str =
    case Str.charAt 0 str of
    Nothing -> "Empty"
    Just s ->
        if isStartCharacter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier ("_" <> str)

renderUnion :: Set IRType -> Doc String
renderUnion s =
    case nullableFromSet s of
    Just x -> renderType x
    Nothing -> do
        types <- mapM renderType $ L.fromFoldable s
        pure $ intercalate " | " types

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "any" -- we can have arrays of nothing
    IRNull -> pure "any"
    IRInteger -> pure "number"
    IRDouble -> pure "number"
    IRBool -> pure "boolean"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderType a
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "{ [key: string]: " <> rendered <> " }"
    IRUnion types -> renderUnion $ unionToSet types

interfaceNamify :: String -> String
interfaceNamify = Str.camelCase >>> Str.capitalize >>> legalizeIdentifier

propertyNamify :: String -> String
propertyNamify s
    | Rx.test hasInternalSeparator s = "\"" <> s <> "\""
    | otherwise =
        case Str.charAt 0 s of
            Nothing -> "Empty"
            Just c | isStartCharacter c -> s
                   | otherwise -> "\"" <> s <> "\""

hasInternalSeparator :: Rx.Regex
hasInternalSeparator = unsafePartial $ Either.fromRight $ Rx.regex "[-. ]" RxFlags.noFlags

typeScriptDoc :: Doc Unit
typeScriptDoc = do
    top <- getTopLevel >>= renderType
    line $ """// To parse this JSON data:
//
//     import * as """ <> top <> """ from "./""" <> top <> """;
//     let value = """ <> top <> """.Convert.fromJson(json);
//
"""
    classes <- getClasses
    for_ classes \(Tuple i cd) -> do
        interface <- lookupClassName i
        renderInterface cd interface
        blank
    converter

renderInterface :: IRClassData -> String -> Doc Unit
renderInterface (IRClassData { names, properties }) className = do
    let propertyNames = transformNames (simpleNamer propertyNamify) (_ <> "_") (S.singleton className) $ map (\n -> Tuple n n) $ M.keys properties

    let resolver name typ = markNullable (lookupName name propertyNames) typ
    let resolvePropertyNameWithType (Tuple name typ) = Tuple (resolver name typ) typ

    line $ "export interface " <> className <> " {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let resolved = resolvePropertyNameWithType <$> props
        let maxWidth = resolved <#> fst <#> Str.length # maximum
        for_ resolved \(Tuple pname ptype) -> do
            let indent = maybe 1 (\w -> w - Str.length pname + 1) maxWidth
            rendered <- renderType ptype
            line $ pname <> ":" <> Str.times " " indent <> rendered <> ";"
    line "}"

-- If this is a nullable, add a '?'
markNullable :: String -> IRType -> String
markNullable name (IRUnion unionRep) =
    case nullableFromSet $ unionToSet unionRep of
        Just _ -> name <> "?"
        _ -> name
markNullable name _ = name

renderTypeMapType :: IRType -> Doc String
renderTypeMapType = case _ of
    IRNothing -> pure "'undefined'" -- we can have arrays of nothing
    IRNull -> pure "'undefined'"
    IRInteger -> pure "'number'"
    IRDouble -> pure "'number'"
    IRBool -> pure "'boolean'"
    IRString -> pure "'string'"
    IRArray a -> do
        rendered <- renderTypeMapType a
        pure $ "array(" <> rendered <> ")"
    IRClass i -> do
        name <- lookupClassName i
        pure $ "object('" <> name <> "')"
    IRMap t -> do
        rendered <- renderTypeMapType t
        pure $ "map(" <> rendered <> ")"
    IRUnion types -> do
        renderedTyps <- mapM renderTypeMapType $ L.fromFoldable $ unionToSet types
        pure $ "union(" <> intercalate ", " renderedTyps <> ")"

renderTypeMapClass :: IRClassData -> String -> Doc Unit
renderTypeMapClass (IRClassData { names, properties }) className = do
    let propertyNames = transformNames (simpleNamer propertyNamify) (_ <> "_") (S.singleton className) $ map (\n -> Tuple n n) $ M.keys properties

    let resolver name typ = lookupName name propertyNames
    let resolvePropertyNameWithType (Tuple name typ) = Tuple (resolver name typ) typ

    line $ className <> ": {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let resolved = resolvePropertyNameWithType <$> props
        for_ resolved \(Tuple pname ptype) -> do
            rendered <- renderTypeMapType ptype
            line $ pname <> ": " <> rendered <> ","
    line "},"

typemap :: Doc Unit
typemap = do
    line $ "const typeMap = {"
    indent do
        classes <- getClasses
        for_ classes \(Tuple i cd) -> do
            className <- lookupClassName i
            renderTypeMapClass cd className
    line $ "};"

converter :: Doc Unit
converter = do
    top <- getTopLevel >>= renderType
    line """export module Convert {
    let path = [];

    export function fromJson(json: string): TopLevel {
        return cast(JSON.parse(json), "TopLevel");
    }

    export function toJson(value: TopLevel): string {
        return JSON.stringify(value);
    }

    function cast<T>(obj: any, className: string): T {
        path = [];
        if (!isValid(object(className), obj)) {
            throw `Invalid value: obj${path.join("")}`
        }
        return obj;
    }

    function isValid(typ: any, val: any): boolean {
        if      (typ.isUnion)  return isValidUnion(typ.typs, val);
        else if (typ.isArray)  return isValidArray(typ.typ, val);
        else if (typ.isMap)    return isValidMap(typ.typ, val);
        else if (typ.isObject) return isValidObject(typ.cls, val);
        else    /*primitive*/  return isValidPrimitive(typ, val);
    }

    function isValidPrimitive(typ: string, val: any) {
        if (typ == 'undefined') return !val;
        return typ === typeof val;
    }

    function isValidUnion(typs: any[], val: any): boolean {
        // val must validate against one typ in typs
        return typs.find(typ => isValid(typ, val)) !== undefined;
    }

    function isValidArray(typ: any, val: any): boolean {
        // val must be an array with no invalid elements
        return Array.isArray(val) && !val.find((val, i) => {
            path.push(`[${i}]`);
            if (isValid(typ, val)) {
                path.pop();
            } else {
                return true;
            }
        });
    }

    function isValidMap(typ: any, val: any): boolean {
        // all values in the map must be typ
        for (let prop in val) {
            path.push(`['${prop}']`);
            if (!isValid(typ, val[prop]))
                return false;
            path.pop();
        }
        return true;
    }

    function isValidObject(className: string, val: any): boolean {
        let typeRep = typeMap[className];

        for (let prop in typeRep) {
            path.push(`.${prop}`);
            if (!isValid(typeRep[prop], val[prop]))
                return false;
            path.pop();
        }

        return true;
    }

    function array(typ: any) {
        return { typ, isArray: true };
    }

    function union(...typs: any[]) {
        return { typs, isUnion: true };
    }

    function map(typ: any) {
        return { typ, isMap: true };
    }

    function object(className: string) {
        return { cls: className, isObject: true };
    }
"""
    indent typemap
    line """
}
"""


Updates for 0.7

Updates for 0.7

module Test.Main where

import Prelude

import Console (log)
import Control.Monad.Eff

foreign import throwError
  """
  function throwError(msg) {
    throw new Error(msg)
  }
  """ :: forall e. String -> Eff e Unit

check :: forall e a. (Show a, Ord a) => Ordering -> a -> a -> Eff e Unit
check expected a b =
  let actual = compare a b
  in if actual == expected
    then return unit
    else throwError (show a <> " `compare` " <> show b <> ": " <>
                      "expected " <> show expected <> ", got " <> show actual)

main = do
  check EQ [] ([] :: Array Number)
  check LT [] [0]
  check GT [0] []
  check EQ [1,2,3] [1,2,3]
  check LT [1,1,3] [1,2,3]
  check GT [1,3,3] [1,2,3]

  log "All good!"

module Test.Main where

import Console (log)
import Control.Monad.Eff

foreign import throwError
  """
  function throwError(msg) {
    throw new Error(msg)
  }
  """ :: forall e. String -> Eff e Unit

check :: forall e a. (Show a, Ord a) => Ordering -> a -> a -> Eff e Unit
check expected a b =
  let actual = compare a b
  in if actual == expected
    then return unit
    else throwError (show a <> " `compare` " <> show b <> ": " <>
                      "expected " <> show expected <> ", got " <> show actual)

main = do
  check EQ [] ([] :: Array Number)
  check LT [] [0]
  check GT [0] []
  check EQ [1,2,3] [1,2,3]
  check LT [1,1,3] [1,2,3]
  check GT [1,3,3] [1,2,3]

  log "All good!"


Make Mario physics better (fixes #1)

Make Mario physics better (fixes #1)

module Mario where

import Math (abs, max, min)
import Signal ((~>), foldp, runSignal, sampleOn)
import Signal.DOM (animationFrame, keyPressed)

import Mario.DOM

initialState :: GameState
initialState = jump true {
    x: -40, y: 0,
    dx: maxMoveSpeed, dy: 0,
    dir: Right
  }

data Direction = Left | Right
instance showDirection :: Show Direction where
  show Left = "left"
  show Right = "right"

data Verb = Jumping | Walking | Standing
instance showVerb :: Show Verb where
  show Jumping = "jump"
  show Walking = "walk"
  show Standing = "stand"

type GameState = { x :: Number, y :: Number, dx :: Number, dy :: Number, dir :: Direction }
type Inputs = { right :: Boolean, left :: Boolean, jump :: Boolean }

jumpKeyCode = 38 -- up arrow
rightKeyCode = 39 -- right arrow
leftKeyCode = 37 -- left arrow

groundHeight = 40 -- px

gravity = 0.2 -- px / frame^2

jumpCoefficient = 0.4
minJumpHeight = 3 -- px / frame
maxMoveSpeed = 2.5 -- px / frame

groundAccel = 0.06 -- px / frame^2
airAccel = 0.04 -- px / frame^2

groundFriction = 0.1 -- px / frame^2
airFriction = 0.02 -- px / frame^2

marioSpriteUrl :: Verb -> Direction -> String
marioSpriteUrl verb dir = "http://elm-lang.org/imgs/mario/" ++ show verb ++ "/" ++ show dir ++ ".gif"

offsetGround :: Number -> Coordinate -> Coordinate
offsetGround amount pos = pos { y = pos.y + amount - 4 } -- 4 pixels for image offset

mkInputs :: Boolean -> Boolean -> Boolean -> Inputs
mkInputs l r j = { left: l, right: r, jump: j }

isAirborne :: GameState -> Boolean
isAirborne s = s.y > 0

currentActivity :: GameState -> Verb
currentActivity s | isAirborne s = Jumping
currentActivity s | s.dx /= 0 = Walking
currentActivity s = Standing

accel :: GameState -> Number
accel s = if isAirborne s then airAccel else groundAccel

friction :: GameState -> Number
friction s = if isAirborne s then airFriction else groundFriction

velocity :: GameState -> GameState
velocity s = s { x = s.x + s.dx, y = s.y + s.dy }

applyGravity :: GameState -> GameState
applyGravity s =
  if s.y <= -s.dy
  then s { y = 0, dy = 0 }
  else s { y = s.y + s.dy, dy = s.dy - gravity }

jumpSpeed :: Number -> Number
jumpSpeed dx = minJumpHeight + jumpCoefficient * abs dx

jump :: Boolean -> GameState -> GameState
jump true s | not (isAirborne s) = s { dy = jumpSpeed s.dx }
jump _ s = s

walk :: Boolean -> Boolean -> GameState -> GameState
walk true false s =
  let s' = if s.dx > 0 then applyFriction s else s in
  s' { dx = max (-maxMoveSpeed) (s'.dx - accel s'), dir = Left }
walk false true s =
  let s' = if s.dx < 0 then applyFriction s else s in
  s' { dx = min maxMoveSpeed (s'.dx + accel s'), dir = Right }
walk x y s = applyFriction s

applyFriction :: GameState -> GameState
applyFriction s | s.dx == 0 = s
applyFriction s | abs s.dx <= friction s = s { dx = 0 }
applyFriction s | s.dx > 0 = s { dx = s.dx - friction s }
applyFriction s | s.dx < 0 = s { dx = s.dx + friction s }

marioLogic :: Inputs -> GameState -> GameState
marioLogic inputs = velocity <<< applyGravity
  <<< jump inputs.jump
  <<< walk inputs.left inputs.right

main = onDOMContentLoaded do
  marioElement <- getMario
  jumpKey <- keyPressed jumpKeyCode
  rightKey <- keyPressed rightKeyCode
  leftKey <- keyPressed leftKeyCode
  let inputs = mkInputs <$> leftKey <*> rightKey <*> jumpKey
  frames <- animationFrame
  runSignal $ foldp marioLogic initialState (sampleOn frames inputs) ~> \gameState -> do
    updateSprite marioElement $ marioSpriteUrl (currentActivity gameState) gameState.dir
    updatePosition marioElement (offsetGround groundHeight {x: gameState.x, y: gameState.y})

module Mario where

import Math (abs, max, min)
import Signal ((~>), foldp, runSignal, sampleOn)
import Signal.DOM (animationFrame, keyPressed)

import Mario.DOM

initialState :: GameState
initialState = jump true {
    x: -40, y: 0,
    dx: maxMoveSpeed, dy: 0,
    dir: Right
  }

data Direction = Left | Right
instance showDirection :: Show Direction where
  show Left = "left"
  show Right = "right"

data Verb = Jumping | Walking | Standing
instance showVerb :: Show Verb where
  show Jumping = "jump"
  show Walking = "walk"
  show Standing = "stand"

type GameState = { x :: Number, y :: Number, dx :: Number, dy :: Number, dir :: Direction }
type Inputs = { right :: Boolean, left :: Boolean, jump :: Boolean }

jumpKeyCode = 38 -- up arrow
rightKeyCode = 39 -- right arrow
leftKeyCode = 37 -- left arrow

groundHeight = 40 -- px

gravity = 0.3 -- px / frame^2

jumpCoefficient = 0.4
minJumpHeight = 4 -- px / frame
maxMoveSpeed = 4 -- px / frame

groundAccel = 0.06 -- px / frame^2
airAccel = 0.04 -- px / frame^2

groundFriction = 0.15 -- px / frame^2
airFriction = 0.02 -- px / frame^2

marioSpriteUrl :: Verb -> Direction -> String
marioSpriteUrl verb dir = "http://elm-lang.org/imgs/mario/" ++ show verb ++ "/" ++ show dir ++ ".gif"

offsetGround :: Number -> Coordinate -> Coordinate
offsetGround amount pos = pos { y = pos.y + amount - 4 } -- 4 pixels for image offset

mkInputs :: Boolean -> Boolean -> Boolean -> Inputs
mkInputs l r j = { left: l, right: r, jump: j }

isAirborne :: GameState -> Boolean
isAirborne s = s.y > 0

currentActivity :: GameState -> Verb
currentActivity s | isAirborne s = Jumping
currentActivity s | s.dx /= 0 = Walking
currentActivity s = Standing

accel :: GameState -> Number
accel s = if isAirborne s then airAccel else groundAccel

friction :: GameState -> Number
friction s = if isAirborne s then airFriction else groundFriction

velocity :: GameState -> GameState
velocity s = s { x = s.x + s.dx, y = s.y + s.dy }

applyGravity :: GameState -> GameState
applyGravity s =
  if s.y <= -s.dy
  then s { y = 0, dy = 0 }
  else s { y = s.y + s.dy, dy = s.dy - gravity }

jumpSpeed :: Number -> Number
jumpSpeed dx = minJumpHeight + jumpCoefficient * abs dx

jump :: Boolean -> GameState -> GameState
jump true s | not (isAirborne s) = s { dy = jumpSpeed s.dx }
jump _ s = s

walk :: Boolean -> Boolean -> GameState -> GameState
walk true false s =
  let s' = if s.dx > 0 then applyFriction s else s in
  s' { dx = max (-maxMoveSpeed) (s'.dx - accel s'), dir = Left }
walk false true s =
  let s' = if s.dx < 0 then applyFriction s else s in
  s' { dx = min maxMoveSpeed (s'.dx + accel s'), dir = Right }
walk x y s = applyFriction s

applyFriction :: GameState -> GameState
applyFriction s | s.dx == 0 = s
applyFriction s | abs s.dx <= friction s = s { dx = 0 }
applyFriction s | s.dx > 0 = s { dx = s.dx - friction s }
applyFriction s | s.dx < 0 = s { dx = s.dx + friction s }

marioLogic :: Inputs -> GameState -> GameState
marioLogic inputs = velocity <<< applyGravity
  <<< jump inputs.jump
  <<< walk inputs.left inputs.right

main = onDOMContentLoaded do
  marioElement <- getMario
  jumpKey <- keyPressed jumpKeyCode
  rightKey <- keyPressed rightKeyCode
  leftKey <- keyPressed leftKeyCode
  let inputs = mkInputs <$> leftKey <*> rightKey <*> jumpKey
  frames <- animationFrame
  runSignal $ foldp marioLogic initialState (sampleOn frames inputs) ~> \gameState -> do
    updateSprite marioElement $ marioSpriteUrl (currentActivity gameState) gameState.dir
    updatePosition marioElement (offsetGround groundHeight {x: gameState.x, y: gameState.y})


Puts disconnected functions in right order

module CodeSnippet where

import Data.Array as A
import Control.Monad.Aff (Aff, attempt)
import Data.Either (either, Either(..))
import Data.Eq (class Eq)
import Data.Functor (map)
import Data.List (List(..))
import Data.Map (Map, fromFoldableWith)
-- import Data.Maybe (Maybe(..))
import Data.Show (class Show)
import Data.String (fromCharArray)
import Data.Tuple (Tuple(..))
import Network.HTTP.Affjax (get, AJAX)
import Prelude (bind, pure, (<>), (<<<), show, ($), (*>), (<*), const, id, (<$>), unit)
import Text.Parsing.StringParser (Parser, runParser)
import Text.Parsing.StringParser.Combinators (sepEndBy, manyTill, many, choice, lookAhead)
import Text.Parsing.StringParser.String (string, anyChar, noneOf, eof)

data Language = Purescript
              | Elm
              | Haskell
              | Idris
              | Clojure
              | Scheme
              | Elixir
              | Scala

derive instance eqLanguage :: Eq Language

comment :: Language -> String
comment Purescript = "--"
comment Elm = "--"
comment Haskell = "--"
comment Idris = "--"
comment Clojure = ";"
comment Scheme = ";"
comment Elixir = "#"
comment Scala = "//"

suffix :: Language -> String
suffix Purescript = "purs"
suffix Elm = "elm"
suffix Haskell = "hs"
suffix Idris = "idr"
suffix Clojure = "clj"
suffix Scheme = "scm"
suffix Elixir = "ex"
suffix Scala = "scala"

data SourceCode = SourceCode { getSourceCode :: String
                             , language :: Language
                             }
data FunctionBlock = FunctionBlock { name :: String
                                   , body :: String
                                   }

instance showSourceCode :: Show SourceCode where
  show (SourceCode sc) = sc.getSourceCode

instance showFunctionBlock :: Show FunctionBlock where
  show (FunctionBlock f) = f.name <> ": " <> f.body

getFile :: forall eff. String -> Language -> Aff (ajax :: AJAX | eff) (Either String SourceCode)
getFile fname lang = do
  let fullname = "/src/Structures/" <> fname <> "." <> suffix lang
  res <- attempt $ get fullname
  pure $ either (Left <<< show) (\r -> Right $ SourceCode { getSourceCode : r.response
                                                          , language : lang
                                                          }) res

docComment :: Language -> Parser String
docComment lang = string (comment lang <> " | *")

fromCharList :: List Char -> String
fromCharList = fromCharArray <<< A.fromFoldable

functionTag :: Language -> Parser String
functionTag lang = fromCharList <$> (docComment lang *> many (noneOf ['\n']))

endComment :: Language -> Parser String
endComment lang = string (comment lang <> " .end")

functionBody :: Language -> Parser FunctionBlock
functionBody lang = do
  name <- functionTag lang
  body <- manyTill anyChar $ endComment lang
  pure $ FunctionBlock { name : name
                       , body : fromCharList body
                       }

functions :: Language -> Parser (List FunctionBlock)
functions lang = sepEndBy (functionBody lang) (nextFunction lang)

nextFunction :: Language -> Parser (List Char)
nextFunction lang = manyTill anyChar (choice [eof, (const unit <$> lookAhead (functionTag lang))])

parseFunctions :: SourceCode -> Map String String
parseFunctions (SourceCode code) =
  let
    res = runParser (nextFunction code.language *> functions code.language) code.getSourceCode
    fns = either (const Nil) id res
  in
   fromFoldableWith (\a b -> b <> a) (map (\ (FunctionBlock f) -> Tuple f.name f.body) fns)

testString :: String
testString = """
-- | *DataStructure Stack
data Stack a = Nil
             | Cons a (Stack a)
-- .end

-- | *empty
empty :: forall a. Stack a
empty = Nil
-- .end

-- | *head
head :: forall a. Stack a -> Maybe a
head Nil = Nothing
head (Cons x _) = Just x
-- .end

-- | *tail
tail :: forall a. Stack a -> Maybe (Stack a)
tail Nil = Nothing
tail (Cons _ xs) = Just xs
-- .end
"""

testSC :: SourceCode
testSC = SourceCode { getSourceCode: testString
                    , language: Purescript
                    }

module CodeSnippet where

import Data.Array as A
import Control.Monad.Aff (Aff, attempt)
import Data.Either (either, Either(..))
import Data.Eq (class Eq)
import Data.Functor (map)
import Data.List (List(..))
import Data.Map (Map, fromFoldableWith)
-- import Data.Maybe (Maybe(..))
import Data.Show (class Show)
import Data.String (fromCharArray)
import Data.Tuple (Tuple(..))
import Network.HTTP.Affjax (get, AJAX)
import Prelude (bind, pure, (<>), (<<<), show, ($), (*>), (<*), const, id, (<$>), unit)
import Text.Parsing.StringParser (Parser, runParser)
import Text.Parsing.StringParser.Combinators (sepEndBy, manyTill, many, choice, lookAhead)
import Text.Parsing.StringParser.String (string, anyChar, noneOf, eof)

data Language = Purescript
              | Elm
              | Haskell
              | Idris
              | Clojure
              | Scheme
              | Elixir
              | Scala

derive instance eqLanguage :: Eq Language

comment :: Language -> String
comment Purescript = "--"
comment Elm = "--"
comment Haskell = "--"
comment Idris = "--"
comment Clojure = ";"
comment Scheme = ";"
comment Elixir = "#"
comment Scala = "//"

suffix :: Language -> String
suffix Purescript = "purs"
suffix Elm = "elm"
suffix Haskell = "hs"
suffix Idris = "idr"
suffix Clojure = "clj"
suffix Scheme = "scm"
suffix Elixir = "ex"
suffix Scala = "scala"

data SourceCode = SourceCode { getSourceCode :: String
                             , language :: Language
                             }
data FunctionBlock = FunctionBlock { name :: String
                                   , body :: String
                                   }

instance showSourceCode :: Show SourceCode where
  show (SourceCode sc) = sc.getSourceCode

instance showFunctionBlock :: Show FunctionBlock where
  show (FunctionBlock f) = f.name <> ": " <> f.body

getFile :: forall eff. String -> Language -> Aff (ajax :: AJAX | eff) (Either String SourceCode)
getFile fname lang = do
  let fullname = "/src/Structures/" <> fname <> "." <> suffix lang
  res <- attempt $ get fullname
  pure $ either (Left <<< show) (\r -> Right $ SourceCode { getSourceCode : r.response
                                                          , language : lang
                                                          }) res

docComment :: Language -> Parser String
docComment lang = string (comment lang <> " | *")

fromCharList :: List Char -> String
fromCharList = fromCharArray <<< A.fromFoldable

functionTag :: Language -> Parser String
functionTag lang = fromCharList <$> (docComment lang *> many (noneOf ['\n']))

endComment :: Language -> Parser String
endComment lang = string (comment lang <> " .end")

functionBody :: Language -> Parser FunctionBlock
functionBody lang = do
  name <- functionTag lang
  body <- manyTill anyChar $ endComment lang
  pure $ FunctionBlock { name : name
                       , body : fromCharList body
                       }

functions :: Language -> Parser (List FunctionBlock)
functions lang = sepEndBy (functionBody lang) (nextFunction lang)

nextFunction :: Language -> Parser (List Char)
nextFunction lang = manyTill anyChar (choice [eof, (const unit <$> lookAhead (functionTag lang))])

parseFunctions :: SourceCode -> Map String String
parseFunctions (SourceCode code) =
  let
    res = runParser (nextFunction code.language *> functions code.language) code.getSourceCode
    fns = either (const Nil) id res
  in
   fromFoldableWith (<>) (map (\ (FunctionBlock f) -> Tuple f.name f.body) fns)

testString :: String
testString = """
-- | *DataStructure Stack
data Stack a = Nil
             | Cons a (Stack a)
-- .end

-- | *empty
empty :: forall a. Stack a
empty = Nil
-- .end

-- | *head
head :: forall a. Stack a -> Maybe a
head Nil = Nothing
head (Cons x _) = Just x
-- .end

-- | *tail
tail :: forall a. Stack a -> Maybe (Stack a)
tail Nil = Nothing
tail (Cons _ xs) = Just xs
-- .end
"""

testSC :: SourceCode
testSC = SourceCode { getSourceCode: testString
                    , language: Purescript
                    }