Remove references to `codePointToInt` (#135)

The `codePointToInt` function is no longer available but is still
referenced in a few documentation examples. Here we replace it with
`fromEnum`.

-- | These functions allow PureScript strings to be treated as if they were
-- | sequences of Unicode code points instead of their true underlying
-- | implementation (sequences of UTF-16 code units). For nearly all uses of
-- | strings, these functions should be preferred over the ones in
-- | `Data.String.CodeUnits`.
module Data.String.CodePoints
  ( module Exports
  , CodePoint
  , codePointFromChar
  , singleton
  , fromCodePointArray
  , toCodePointArray
  , codePointAt
  , uncons
  , length
  , countPrefix
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , take
  -- , takeRight
  , takeWhile
  , drop
  -- , dropRight
  , dropWhile
  -- , slice
  , splitAt
  ) where

import Prelude

import Data.Array as Array
import Data.Enum (class BoundedEnum, class Enum, Cardinality(..), defaultPred, defaultSucc, fromEnum, toEnum, toEnumWithDefaults)
import Data.Int (hexadecimal, toStringAs)
import Data.Maybe (Maybe(..))
import Data.String.CodeUnits (contains, stripPrefix, stripSuffix) as Exports
import Data.String.CodeUnits as CU
import Data.String.Common (toUpper)
import Data.String.Pattern (Pattern)
import Data.String.Unsafe as Unsafe
import Data.Tuple (Tuple(..))
import Data.Unfoldable (unfoldr)

-- | CodePoint is an Int bounded between 0 and 0x10FFFF, corresponding to
-- | Unicode code points.
newtype CodePoint = CodePoint Int

derive instance eqCodePoint :: Eq CodePoint
derive instance ordCodePoint :: Ord CodePoint

instance showCodePoint :: Show CodePoint where
  show (CodePoint i) = "(CodePoint 0x" <> toUpper (toStringAs hexadecimal i) <> ")"

instance boundedCodePoint :: Bounded CodePoint where
  bottom = CodePoint 0
  top = CodePoint 0x10FFFF

instance enumCodePoint :: Enum CodePoint where
  succ = defaultSucc toEnum fromEnum
  pred = defaultPred toEnum fromEnum

instance boundedEnumCodePoint :: BoundedEnum CodePoint where
  cardinality = Cardinality (0x10FFFF + 1)
  fromEnum (CodePoint n) = n
  toEnum n
    | n >= 0 && n <= 0x10FFFF = Just (CodePoint n)
    | otherwise = Nothing

-- | Creates a CodePoint from a given Char.
-- |
-- | ```purescript
-- | >>> codePointFromChar 'B'
-- | CodePoint 0x42 -- represents 'B'
-- | ```
-- |
codePointFromChar :: Char -> CodePoint
codePointFromChar = fromEnum >>> CodePoint

-- | Creates a string containing just the given code point. Operates in
-- | constant space and time.
-- |
-- | ```purescript
-- | >>> map singleton (toEnum 0x1D400)
-- | Just "𝐀"
-- | ```
-- |
singleton :: CodePoint -> String
singleton = _singleton singletonFallback

foreign import _singleton
  :: (CodePoint -> String)
  -> CodePoint
  -> String

singletonFallback :: CodePoint -> String
singletonFallback (CodePoint cp) | cp <= 0xFFFF = fromCharCode cp
singletonFallback (CodePoint cp) =
  let lead = ((cp - 0x10000) / 0x400) + 0xD800 in
  let trail = (cp - 0x10000) `mod` 0x400 + 0xDC00 in
  fromCharCode lead <> fromCharCode trail

-- | Creates a string from an array of code points. Operates in space and time
-- | linear to the length of the array.
-- |
-- | ```purescript
-- | >>> codePointArray = toCodePointArray "c 𝐀"
-- | >>> codePointArray
-- | [CodePoint 0x63, CodePoint 0x20, CodePoint 0x1D400]
-- | >>> fromCodePointArray codePointArray
-- | "c 𝐀"
-- | ```
-- |
fromCodePointArray :: Array CodePoint -> String
fromCodePointArray = _fromCodePointArray singletonFallback

foreign import _fromCodePointArray
  :: (CodePoint -> String)
  -> Array CodePoint
  -> String

-- | Creates an array of code points from a string. Operates in space and time
-- | linear to the length of the string.
-- |
-- | ```purescript
-- | >>> codePointArray = toCodePointArray "b 𝐀𝐀"
-- | >>> codePointArray
-- | [CodePoint 0x62, CodePoint 0x20, CodePoint 0x1D400, CodePoint 0x1D400]
-- | >>> map singleton codePointArray
-- | ["b", " ", "𝐀", "𝐀"]
-- | ```
-- |
toCodePointArray :: String -> Array CodePoint
toCodePointArray = _toCodePointArray toCodePointArrayFallback unsafeCodePointAt0

foreign import _toCodePointArray
  :: (String -> Array CodePoint)
  -> (String -> CodePoint)
  -> String
  -> Array CodePoint

toCodePointArrayFallback :: String -> Array CodePoint
toCodePointArrayFallback s = unfoldr unconsButWithTuple s

unconsButWithTuple :: String -> Maybe (Tuple CodePoint String)
unconsButWithTuple s = (\{ head, tail } -> Tuple head tail) <$> uncons s

-- | Returns the first code point of the string after dropping the given number
-- | of code points from the beginning, if there is such a code point. Operates
-- | in constant space and in time linear to the given index.
-- |
-- | ```purescript
-- | >>> codePointAt 1 "𝐀𝐀𝐀𝐀"
-- | Just (CodePoint 0x1D400) -- represents "𝐀"
-- | -- compare to Data.String:
-- | >>> charAt 1 "𝐀𝐀𝐀𝐀"
-- | Just '�'
-- | ```
-- |
codePointAt :: Int -> String -> Maybe CodePoint
codePointAt n _ | n < 0 = Nothing
codePointAt 0 "" = Nothing
codePointAt 0 s = Just (unsafeCodePointAt0 s)
codePointAt n s = _codePointAt codePointAtFallback Just Nothing unsafeCodePointAt0 n s

foreign import _codePointAt
  :: (Int -> String -> Maybe CodePoint)
  -> (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> (String -> CodePoint)
  -> Int
  -> String
  -> Maybe CodePoint

codePointAtFallback :: Int -> String -> Maybe CodePoint
codePointAtFallback n s = case uncons s of
  Just { head, tail } -> if n == 0 then Just head else codePointAtFallback (n - 1) tail
  _ -> Nothing

-- | Returns a record with the first code point and the remaining code points
-- | of the string. Returns Nothing if the string is empty. Operates in
-- | constant space and time.
-- |
-- | ```purescript
-- | >>> uncons "𝐀𝐀 c 𝐀"
-- | Just { head: CodePoint 0x1D400, tail: "𝐀 c 𝐀" }
-- | >>> uncons ""
-- | Nothing
-- | ```
-- |
uncons :: String -> Maybe { head :: CodePoint, tail :: String }
uncons s = case CU.length s of
  0 -> Nothing
  1 -> Just { head: CodePoint (fromEnum (Unsafe.charAt 0 s)), tail: "" }
  _ ->
    let
      cu0 = fromEnum (Unsafe.charAt 0 s)
      cu1 = fromEnum (Unsafe.charAt 1 s)
    in
      if isLead cu0 && isTrail cu1
        then Just { head: unsurrogate cu0 cu1, tail: CU.drop 2 s }
        else Just { head: CodePoint cu0, tail: CU.drop 1 s }

-- | Returns the number of code points in the string. Operates in constant
-- | space and in time linear to the length of the string.
-- |
-- | ```purescript
-- | >>> length "b 𝐀𝐀 c 𝐀"
-- | 8
-- | -- compare to Data.String:
-- | >>> length "b 𝐀𝐀 c 𝐀"
-- | 11
-- | ```
-- |
length :: String -> Int
length = Array.length <<< toCodePointArray

-- | Returns the number of code points in the leading sequence of code points
-- | which all match the given predicate. Operates in constant space and in
-- | time linear to the length of the string.
-- |
-- | ```purescript
-- | >>> countPrefix (\c -> fromEnum c == 0x1D400) "𝐀𝐀 b c 𝐀"
-- | 2
-- | ```
-- |
countPrefix :: (CodePoint -> Boolean) -> String -> Int
countPrefix = _countPrefix countFallback unsafeCodePointAt0

foreign import _countPrefix
  :: ((CodePoint -> Boolean) -> String -> Int)
  -> (String -> CodePoint)
  -> (CodePoint -> Boolean)
  -> String
  -> Int

countFallback :: (CodePoint -> Boolean) -> String -> Int
countFallback p s = countTail p s 0

countTail :: (CodePoint -> Boolean) -> String -> Int -> Int
countTail p s accum = case uncons s of
  Just { head, tail } -> if p head then countTail p tail (accum + 1) else accum
  _ -> accum

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Returns Nothing when no matches are found.
-- |
-- | ```purescript
-- | >>> indexOf (Pattern "𝐀") "b 𝐀𝐀 c 𝐀"
-- | Just 2
-- | >>> indexOf (Pattern "o") "b 𝐀𝐀 c 𝐀"
-- | Nothing
-- | ```
-- |
indexOf :: Pattern -> String -> Maybe Int
indexOf p s = (\i -> length (CU.take i s)) <$> CU.indexOf p s

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Pattern matches preceding the given index will be
-- | ignored. Returns Nothing when no matches are found.
-- |
-- | ```purescript
-- | >>> indexOf' (Pattern "𝐀") 4 "b 𝐀𝐀 c 𝐀"
-- | Just 7
-- | >>> indexOf' (Pattern "o") 4 "b 𝐀𝐀 c 𝐀"
-- | Nothing
-- | ```
-- |
indexOf' :: Pattern -> Int -> String -> Maybe Int
indexOf' p i s =
  let s' = drop i s in
  (\k -> i + length (CU.take k s')) <$> CU.indexOf p s'

-- | Returns the number of code points preceding the last match of the given
-- | pattern in the string. Returns Nothing when no matches are found.
-- |
-- | ```purescript
-- | >>> lastIndexOf (Pattern "𝐀") "b 𝐀𝐀 c 𝐀"
-- | Just 7
-- | >>> lastIndexOf (Pattern "o") "b 𝐀𝐀 c 𝐀"
-- | Nothing
-- | ```
-- |
lastIndexOf :: Pattern -> String -> Maybe Int
lastIndexOf p s = (\i -> length (CU.take i s)) <$> CU.lastIndexOf p s

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Pattern matches following the given index will be
-- | ignored. Returns Nothing when no matches are found.
-- |
-- | ```purescript
-- | >>> lastIndexOf' (Pattern "𝐀") 5 "b 𝐀𝐀 c 𝐀"
-- | Just 3
-- | >>> lastIndexOf' (Pattern "o") 5 "b 𝐀𝐀 c 𝐀"
-- | Nothing
-- | ```
-- |
lastIndexOf' :: Pattern -> Int -> String -> Maybe Int
lastIndexOf' p i s =
  let i' = CU.length (take i s) in
  (\k -> length (CU.take k s)) <$> CU.lastIndexOf' p i' s

-- | Returns a string containing the given number of code points from the
-- | beginning of the given string. If the string does not have that many code
-- | points, returns the empty string. Operates in constant space and in time
-- | linear to the given number.
-- |
-- | ```purescript
-- | >>> take 3 "b 𝐀𝐀 c 𝐀"
-- | "b 𝐀"
-- | -- compare to Data.String:
-- | >>> take 3 "b 𝐀𝐀 c 𝐀"
-- | "b �"
-- | ```
-- |
take :: Int -> String -> String
take = _take takeFallback

foreign import _take :: (Int -> String -> String) -> Int -> String -> String

takeFallback :: Int -> String -> String
takeFallback n _ | n < 1 = ""
takeFallback n s = case uncons s of
  Just { head, tail } -> singleton head <> takeFallback (n - 1) tail
  _ -> s

-- | Returns a string containing the leading sequence of code points which all
-- | match the given predicate from the string. Operates in constant space and
-- | in time linear to the length of the string.
-- |
-- | ```purescript
-- | >>> takeWhile (\c -> fromEnum c == 0x1D400) "𝐀𝐀 b c 𝐀"
-- | "𝐀𝐀"
-- | ```
-- |
takeWhile :: (CodePoint -> Boolean) -> String -> String
takeWhile p s = take (countPrefix p s) s

-- | Drops the given number of code points from the beginning of the string. If
-- | the string does not have that many code points, returns the empty string.
-- | Operates in constant space and in time linear to the given number.
-- |
-- | ```purescript
-- | >>> drop 5 "𝐀𝐀 b c"
-- | "c"
-- | -- compared to Data.String:
-- | >>> drop 5 "𝐀𝐀 b c"
-- | "b c" -- because "𝐀" occupies 2 code units
-- | ```
-- |
drop :: Int -> String -> String
drop n s = CU.drop (CU.length (take n s)) s

-- | Drops the leading sequence of code points which all match the given
-- | predicate from the string. Operates in constant space and in time linear
-- | to the length of the string.
-- |
-- | ```purescript
-- | >>> dropWhile (\c -> fromEnum c == 0x1D400) "𝐀𝐀 b c 𝐀"
-- | " b c 𝐀"
-- | ```
-- |
dropWhile :: (CodePoint -> Boolean) -> String -> String
dropWhile p s = drop (countPrefix p s) s

-- | Splits a string into two substrings, where `before` contains the code
-- | points up to (but not including) the given index, and `after` contains the
-- | rest of the string, from that index on.
-- |
-- | ```purescript
-- | >>> splitAt 3 "b 𝐀𝐀 c 𝐀"
-- | { before: "b 𝐀", after: "𝐀 c 𝐀" }
-- | ```
-- |
-- | Thus the length of `(splitAt i s).before` will equal either `i` or
-- | `length s`, if that is shorter. (Or if `i` is negative the length will be
-- | 0.)
-- |
-- | In code:
-- | ```purescript
-- | length (splitAt i s).before == min (max i 0) (length s)
-- | (splitAt i s).before <> (splitAt i s).after == s
-- | splitAt i s == {before: take i s, after: drop i s}
-- | ```
splitAt :: Int -> String -> { before :: String, after :: String }
splitAt i s =
  let before = take i s in
  { before
  -- inline drop i s to reuse the result of take i s
  , after: CU.drop (CU.length before) s
  }

unsurrogate :: Int -> Int -> CodePoint
unsurrogate lead trail = CodePoint ((lead - 0xD800) * 0x400 + (trail - 0xDC00) + 0x10000)

isLead :: Int -> Boolean
isLead cu = 0xD800 <= cu && cu <= 0xDBFF

isTrail :: Int -> Boolean
isTrail cu = 0xDC00 <= cu && cu <= 0xDFFF

fromCharCode :: Int -> String
fromCharCode = CU.singleton <<< toEnumWithDefaults bottom top

-- WARN: this function expects the String parameter to be non-empty
unsafeCodePointAt0 :: String -> CodePoint
unsafeCodePointAt0 = _unsafeCodePointAt0 unsafeCodePointAt0Fallback

foreign import _unsafeCodePointAt0
  :: (String -> CodePoint)
  -> String
  -> CodePoint

unsafeCodePointAt0Fallback :: String -> CodePoint
unsafeCodePointAt0Fallback s =
  let
    cu0 = fromEnum (Unsafe.charAt 0 s)
  in
    if isLead cu0 && CU.length s > 1
       then
         let cu1 = fromEnum (Unsafe.charAt 1 s) in
         if isTrail cu1 then unsurrogate cu0 cu1 else CodePoint cu0
       else
         CodePoint cu0

-- | These functions allow PureScript strings to be treated as if they were
-- | sequences of Unicode code points instead of their true underlying
-- | implementation (sequences of UTF-16 code units). For nearly all uses of
-- | strings, these functions should be preferred over the ones in
-- | `Data.String.CodeUnits`.
module Data.String.CodePoints
  ( module Exports
  , CodePoint
  , codePointFromChar
  , singleton
  , fromCodePointArray
  , toCodePointArray
  , codePointAt
  , uncons
  , length
  , countPrefix
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , take
  -- , takeRight
  , takeWhile
  , drop
  -- , dropRight
  , dropWhile
  -- , slice
  , splitAt
  ) where

import Prelude

import Data.Array as Array
import Data.Enum (class BoundedEnum, class Enum, Cardinality(..), defaultPred, defaultSucc, fromEnum, toEnum, toEnumWithDefaults)
import Data.Int (hexadecimal, toStringAs)
import Data.Maybe (Maybe(..))
import Data.String.CodeUnits (contains, stripPrefix, stripSuffix) as Exports
import Data.String.CodeUnits as CU
import Data.String.Common (toUpper)
import Data.String.Pattern (Pattern)
import Data.String.Unsafe as Unsafe
import Data.Tuple (Tuple(..))
import Data.Unfoldable (unfoldr)

-- | CodePoint is an Int bounded between 0 and 0x10FFFF, corresponding to
-- | Unicode code points.
newtype CodePoint = CodePoint Int

derive instance eqCodePoint :: Eq CodePoint
derive instance ordCodePoint :: Ord CodePoint

instance showCodePoint :: Show CodePoint where
  show (CodePoint i) = "(CodePoint 0x" <> toUpper (toStringAs hexadecimal i) <> ")"

instance boundedCodePoint :: Bounded CodePoint where
  bottom = CodePoint 0
  top = CodePoint 0x10FFFF

instance enumCodePoint :: Enum CodePoint where
  succ = defaultSucc toEnum fromEnum
  pred = defaultPred toEnum fromEnum

instance boundedEnumCodePoint :: BoundedEnum CodePoint where
  cardinality = Cardinality (0x10FFFF + 1)
  fromEnum (CodePoint n) = n
  toEnum n
    | n >= 0 && n <= 0x10FFFF = Just (CodePoint n)
    | otherwise = Nothing

-- | Creates a CodePoint from a given Char.
-- |
-- | ```purescript
-- | >>> codePointFromChar 'B'
-- | CodePoint 0x42 -- represents 'B'
-- | ```
-- |
codePointFromChar :: Char -> CodePoint
codePointFromChar = fromEnum >>> CodePoint

-- | Creates a string containing just the given code point. Operates in
-- | constant space and time.
-- |
-- | ```purescript
-- | >>> map singleton (toEnum 0x1D400)
-- | Just "𝐀"
-- | ```
-- |
singleton :: CodePoint -> String
singleton = _singleton singletonFallback

foreign import _singleton
  :: (CodePoint -> String)
  -> CodePoint
  -> String

singletonFallback :: CodePoint -> String
singletonFallback (CodePoint cp) | cp <= 0xFFFF = fromCharCode cp
singletonFallback (CodePoint cp) =
  let lead = ((cp - 0x10000) / 0x400) + 0xD800 in
  let trail = (cp - 0x10000) `mod` 0x400 + 0xDC00 in
  fromCharCode lead <> fromCharCode trail

-- | Creates a string from an array of code points. Operates in space and time
-- | linear to the length of the array.
-- |
-- | ```purescript
-- | >>> codePointArray = toCodePointArray "c 𝐀"
-- | >>> codePointArray
-- | [CodePoint 0x63, CodePoint 0x20, CodePoint 0x1D400]
-- | >>> fromCodePointArray codePointArray
-- | "c 𝐀"
-- | ```
-- |
fromCodePointArray :: Array CodePoint -> String
fromCodePointArray = _fromCodePointArray singletonFallback

foreign import _fromCodePointArray
  :: (CodePoint -> String)
  -> Array CodePoint
  -> String

-- | Creates an array of code points from a string. Operates in space and time
-- | linear to the length of the string.
-- |
-- | ```purescript
-- | >>> codePointArray = toCodePointArray "b 𝐀𝐀"
-- | >>> codePointArray
-- | [CodePoint 0x62, CodePoint 0x20, CodePoint 0x1D400, CodePoint 0x1D400]
-- | >>> map singleton codePointArray
-- | ["b", " ", "𝐀", "𝐀"]
-- | ```
-- |
toCodePointArray :: String -> Array CodePoint
toCodePointArray = _toCodePointArray toCodePointArrayFallback unsafeCodePointAt0

foreign import _toCodePointArray
  :: (String -> Array CodePoint)
  -> (String -> CodePoint)
  -> String
  -> Array CodePoint

toCodePointArrayFallback :: String -> Array CodePoint
toCodePointArrayFallback s = unfoldr unconsButWithTuple s

unconsButWithTuple :: String -> Maybe (Tuple CodePoint String)
unconsButWithTuple s = (\{ head, tail } -> Tuple head tail) <$> uncons s

-- | Returns the first code point of the string after dropping the given number
-- | of code points from the beginning, if there is such a code point. Operates
-- | in constant space and in time linear to the given index.
-- |
-- | ```purescript
-- | >>> codePointAt 1 "𝐀𝐀𝐀𝐀"
-- | Just (CodePoint 0x1D400) -- represents "𝐀"
-- | -- compare to Data.String:
-- | >>> charAt 1 "𝐀𝐀𝐀𝐀"
-- | Just '�'
-- | ```
-- |
codePointAt :: Int -> String -> Maybe CodePoint
codePointAt n _ | n < 0 = Nothing
codePointAt 0 "" = Nothing
codePointAt 0 s = Just (unsafeCodePointAt0 s)
codePointAt n s = _codePointAt codePointAtFallback Just Nothing unsafeCodePointAt0 n s

foreign import _codePointAt
  :: (Int -> String -> Maybe CodePoint)
  -> (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> (String -> CodePoint)
  -> Int
  -> String
  -> Maybe CodePoint

codePointAtFallback :: Int -> String -> Maybe CodePoint
codePointAtFallback n s = case uncons s of
  Just { head, tail } -> if n == 0 then Just head else codePointAtFallback (n - 1) tail
  _ -> Nothing

-- | Returns a record with the first code point and the remaining code points
-- | of the string. Returns Nothing if the string is empty. Operates in
-- | constant space and time.
-- |
-- | ```purescript
-- | >>> uncons "𝐀𝐀 c 𝐀"
-- | Just { head: CodePoint 0x1D400, tail: "𝐀 c 𝐀" }
-- | >>> uncons ""
-- | Nothing
-- | ```
-- |
uncons :: String -> Maybe { head :: CodePoint, tail :: String }
uncons s = case CU.length s of
  0 -> Nothing
  1 -> Just { head: CodePoint (fromEnum (Unsafe.charAt 0 s)), tail: "" }
  _ ->
    let
      cu0 = fromEnum (Unsafe.charAt 0 s)
      cu1 = fromEnum (Unsafe.charAt 1 s)
    in
      if isLead cu0 && isTrail cu1
        then Just { head: unsurrogate cu0 cu1, tail: CU.drop 2 s }
        else Just { head: CodePoint cu0, tail: CU.drop 1 s }

-- | Returns the number of code points in the string. Operates in constant
-- | space and in time linear to the length of the string.
-- |
-- | ```purescript
-- | >>> length "b 𝐀𝐀 c 𝐀"
-- | 8
-- | -- compare to Data.String:
-- | >>> length "b 𝐀𝐀 c 𝐀"
-- | 11
-- | ```
-- |
length :: String -> Int
length = Array.length <<< toCodePointArray

-- | Returns the number of code points in the leading sequence of code points
-- | which all match the given predicate. Operates in constant space and in
-- | time linear to the length of the string.
-- |
-- | ```purescript
-- | >>> countPrefix (\c -> codePointToInt c == 0x1D400) "𝐀𝐀 b c 𝐀"
-- | 2
-- | ```
-- |
countPrefix :: (CodePoint -> Boolean) -> String -> Int
countPrefix = _countPrefix countFallback unsafeCodePointAt0

foreign import _countPrefix
  :: ((CodePoint -> Boolean) -> String -> Int)
  -> (String -> CodePoint)
  -> (CodePoint -> Boolean)
  -> String
  -> Int

countFallback :: (CodePoint -> Boolean) -> String -> Int
countFallback p s = countTail p s 0

countTail :: (CodePoint -> Boolean) -> String -> Int -> Int
countTail p s accum = case uncons s of
  Just { head, tail } -> if p head then countTail p tail (accum + 1) else accum
  _ -> accum

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Returns Nothing when no matches are found.
-- |
-- | ```purescript
-- | >>> indexOf (Pattern "𝐀") "b 𝐀𝐀 c 𝐀"
-- | Just 2
-- | >>> indexOf (Pattern "o") "b 𝐀𝐀 c 𝐀"
-- | Nothing
-- | ```
-- |
indexOf :: Pattern -> String -> Maybe Int
indexOf p s = (\i -> length (CU.take i s)) <$> CU.indexOf p s

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Pattern matches preceding the given index will be
-- | ignored. Returns Nothing when no matches are found.
-- |
-- | ```purescript
-- | >>> indexOf' (Pattern "𝐀") 4 "b 𝐀𝐀 c 𝐀"
-- | Just 7
-- | >>> indexOf' (Pattern "o") 4 "b 𝐀𝐀 c 𝐀"
-- | Nothing
-- | ```
-- |
indexOf' :: Pattern -> Int -> String -> Maybe Int
indexOf' p i s =
  let s' = drop i s in
  (\k -> i + length (CU.take k s')) <$> CU.indexOf p s'

-- | Returns the number of code points preceding the last match of the given
-- | pattern in the string. Returns Nothing when no matches are found.
-- |
-- | ```purescript
-- | >>> lastIndexOf (Pattern "𝐀") "b 𝐀𝐀 c 𝐀"
-- | Just 7
-- | >>> lastIndexOf (Pattern "o") "b 𝐀𝐀 c 𝐀"
-- | Nothing
-- | ```
-- |
lastIndexOf :: Pattern -> String -> Maybe Int
lastIndexOf p s = (\i -> length (CU.take i s)) <$> CU.lastIndexOf p s

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Pattern matches following the given index will be
-- | ignored. Returns Nothing when no matches are found.
-- |
-- | ```purescript
-- | >>> lastIndexOf' (Pattern "𝐀") 5 "b 𝐀𝐀 c 𝐀"
-- | Just 3
-- | >>> lastIndexOf' (Pattern "o") 5 "b 𝐀𝐀 c 𝐀"
-- | Nothing
-- | ```
-- |
lastIndexOf' :: Pattern -> Int -> String -> Maybe Int
lastIndexOf' p i s =
  let i' = CU.length (take i s) in
  (\k -> length (CU.take k s)) <$> CU.lastIndexOf' p i' s

-- | Returns a string containing the given number of code points from the
-- | beginning of the given string. If the string does not have that many code
-- | points, returns the empty string. Operates in constant space and in time
-- | linear to the given number.
-- |
-- | ```purescript
-- | >>> take 3 "b 𝐀𝐀 c 𝐀"
-- | "b 𝐀"
-- | -- compare to Data.String:
-- | >>> take 3 "b 𝐀𝐀 c 𝐀"
-- | "b �"
-- | ```
-- |
take :: Int -> String -> String
take = _take takeFallback

foreign import _take :: (Int -> String -> String) -> Int -> String -> String

takeFallback :: Int -> String -> String
takeFallback n _ | n < 1 = ""
takeFallback n s = case uncons s of
  Just { head, tail } -> singleton head <> takeFallback (n - 1) tail
  _ -> s

-- | Returns a string containing the leading sequence of code points which all
-- | match the given predicate from the string. Operates in constant space and
-- | in time linear to the length of the string.
-- |
-- | ```purescript
-- | >>> takeWhile (\c -> codePointToInt c == 0x1D400) "𝐀𝐀 b c 𝐀"
-- | "𝐀𝐀"
-- | ```
-- |
takeWhile :: (CodePoint -> Boolean) -> String -> String
takeWhile p s = take (countPrefix p s) s

-- | Drops the given number of code points from the beginning of the string. If
-- | the string does not have that many code points, returns the empty string.
-- | Operates in constant space and in time linear to the given number.
-- |
-- | ```purescript
-- | >>> drop 5 "𝐀𝐀 b c"
-- | "c"
-- | -- compared to Data.String:
-- | >>> drop 5 "𝐀𝐀 b c"
-- | "b c" -- because "𝐀" occupies 2 code units
-- | ```
-- |
drop :: Int -> String -> String
drop n s = CU.drop (CU.length (take n s)) s

-- | Drops the leading sequence of code points which all match the given
-- | predicate from the string. Operates in constant space and in time linear
-- | to the length of the string.
-- |
-- | ```purescript
-- | >>> dropWhile (\c -> codePointToInt c == 0x1D400) "𝐀𝐀 b c 𝐀"
-- | " b c 𝐀"
-- | ```
-- |
dropWhile :: (CodePoint -> Boolean) -> String -> String
dropWhile p s = drop (countPrefix p s) s

-- | Splits a string into two substrings, where `before` contains the code
-- | points up to (but not including) the given index, and `after` contains the
-- | rest of the string, from that index on.
-- |
-- | ```purescript
-- | >>> splitAt 3 "b 𝐀𝐀 c 𝐀"
-- | { before: "b 𝐀", after: "𝐀 c 𝐀" }
-- | ```
-- |
-- | Thus the length of `(splitAt i s).before` will equal either `i` or
-- | `length s`, if that is shorter. (Or if `i` is negative the length will be
-- | 0.)
-- |
-- | In code:
-- | ```purescript
-- | length (splitAt i s).before == min (max i 0) (length s)
-- | (splitAt i s).before <> (splitAt i s).after == s
-- | splitAt i s == {before: take i s, after: drop i s}
-- | ```
splitAt :: Int -> String -> { before :: String, after :: String }
splitAt i s =
  let before = take i s in
  { before
  -- inline drop i s to reuse the result of take i s
  , after: CU.drop (CU.length before) s
  }

unsurrogate :: Int -> Int -> CodePoint
unsurrogate lead trail = CodePoint ((lead - 0xD800) * 0x400 + (trail - 0xDC00) + 0x10000)

isLead :: Int -> Boolean
isLead cu = 0xD800 <= cu && cu <= 0xDBFF

isTrail :: Int -> Boolean
isTrail cu = 0xDC00 <= cu && cu <= 0xDFFF

fromCharCode :: Int -> String
fromCharCode = CU.singleton <<< toEnumWithDefaults bottom top

-- WARN: this function expects the String parameter to be non-empty
unsafeCodePointAt0 :: String -> CodePoint
unsafeCodePointAt0 = _unsafeCodePointAt0 unsafeCodePointAt0Fallback

foreign import _unsafeCodePointAt0
  :: (String -> CodePoint)
  -> String
  -> CodePoint

unsafeCodePointAt0Fallback :: String -> CodePoint
unsafeCodePointAt0Fallback s =
  let
    cu0 = fromEnum (Unsafe.charAt 0 s)
  in
    if isLead cu0 && CU.length s > 1
       then
         let cu1 = fromEnum (Unsafe.charAt 1 s) in
         if isTrail cu1 then unsurrogate cu0 cu1 else CodePoint cu0
       else
         CodePoint cu0


Fix coding style

Fix coding style

module Database.PostgreSQL.PG
( module Row
, module Value
, module PostgreSQL
, PG
, command
, execute
, hoistPG
, query
, onIntegrityError
, scalar
, withConnection
, withTransaction
) where

import Prelude

import Control.Monad.Error.Class (catchError, throwError)
import Control.Monad.Except (ExceptT(..))
import Control.Monad.Except.Trans (ExceptT, runExceptT)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Database.PostgreSQL (Connection, PGError(..), Pool, Query)
import Database.PostgreSQL (class FromSQLRow, class FromSQLValue, class ToSQLRow, class ToSQLValue, Connection, Database, PGError(..), PGErrorDetail, Pool, PoolConfiguration, Query(..), Row0(..), Row1(..), Row10(..), Row11(..), Row12(..), Row13(..), Row14(..), Row15(..), Row16(..), Row17(..), Row18(..), Row19(..), Row2(..), Row3(..), Row4(..), Row5(..), Row6(..), Row7(..), Row8(..), Row9(..), defaultPoolConfiguration, fromSQLRow, fromSQLValue, instantFromString, instantToString, newPool, null, toSQLRow, toSQLValue, unsafeIsBuffer) as PostgreSQL
import Database.PostgreSQL (command, execute, query, scalar, withConnection, withTransaction) as P
import Database.PostgreSQL.Row (class FromSQLRow, class ToSQLRow, Row0(..), Row1(..), Row10(..), Row11(..), Row12(..), Row13(..), Row14(..), Row15(..), Row16(..), Row17(..), Row18(..), Row19(..), Row2(..), Row3(..), Row4(..), Row5(..), Row6(..), Row7(..), Row8(..), Row9(..), fromSQLRow, toSQLRow) as Row
import Database.PostgreSQL.Row (class FromSQLRow, class ToSQLRow, Row1)
import Database.PostgreSQL.Value (class FromSQLValue)
import Database.PostgreSQL.Value (class FromSQLValue, class ToSQLValue, fromSQLValue, instantFromString, instantToString, null, toSQLValue, unsafeIsBuffer) as Value
import Effect.Aff (Aff)
import Effect.Aff.Class (class MonadAff, liftAff)

type Database = String

-- | PostgreSQL computations run in the `PG` monad. It's just `Aff` stacked with
-- | `ExceptT` to provide error handling.
-- |
-- | Errors originating from database queries or connection to the database are
-- | modeled with the `PGError` type. Use `runExceptT` from
-- | `Control.Monad.Except.Trans` to turn a `PG a` action into `Aff (Either
-- | PGError a)`.
type PG a = ExceptT PGError Aff a

hoistPG :: forall m. MonadAff m => PG ~> ExceptT PGError m
hoistPG m = ExceptT $ liftAff $
  runExceptT m >>= case _ of
    Right a -> pure (Right a)
    Left pgError -> pure (Left pgError)

-- | Run an action with a connection. The connection is released to the pool
-- | when the action returns.
withConnection
    :: forall a
     . Pool
    -> (Connection -> PG a)
    -> PG a
withConnection p k = ExceptT $ P.withConnection p case _ of
  Right conn -> runExceptT $ k conn
  Left pgErr -> pure (Left pgErr)

-- | Run an action within a transaction. The transaction is committed if the
-- | action returns cleanly, and rolled back if the action throws (either a
-- | `PGError` or a JavaScript exception in PG context). If you want to
-- | change the transaction mode, issue a separate `SET TRANSACTION` statement
-- | within the transaction.
withTransaction
    :: forall a
     . Connection
    -> PG a
    -> PG a
withTransaction conn action =
  ExceptT $ join <$> P.withTransaction conn (runExceptT action)

-- | Execute a PostgreSQL query and discard its results.
execute
    :: forall i o
     . (ToSQLRow i)
    => Connection
    -> Query i o
    -> i
    -> PG Unit
execute conn sql values = ExceptT $ P.execute conn sql values >>= case _ of
  Just pgErr -> pure (Left pgErr)
  Nothing -> pure (Right unit)

-- | Execute a PostgreSQL query and return its results.
query
    :: forall i o
     . ToSQLRow i
    => FromSQLRow o
    => Connection
    -> Query i o
    -> i
    -> PG (Array o)
query conn sql = ExceptT <<< P.query conn sql

-- | Execute a PostgreSQL query and return the first field of the first row in
-- | the result.
scalar
    :: forall i o
     . ToSQLRow i
    => FromSQLValue o
    => Connection
    -> Query i (Row1 o)
    -> i
    -> PG (Maybe o)
scalar conn sql = ExceptT <<< P.scalar conn sql

-- | Execute a PostgreSQL query and return its command tag value
-- | (how many rows were affected by the query). This may be useful
-- | for example with `DELETE` or `UPDATE` queries.
command
    :: forall i
     . ToSQLRow i
    => Connection
    -> Query i Int
    -> i
    -> PG Int
command conn sql = ExceptT <<< P.command conn sql

onIntegrityError :: forall a. PG a -> PG a -> PG a
onIntegrityError errorResult db =
    catchError db handleError
    where
    handleError e =
        case e of
            IntegrityError _ -> errorResult
            _ -> throwError e

module Database.PostgreSQL.PG
( module Row
, module Value
, module PostgreSQL
, PG
, command
, execute
, query
, onIntegrityError
, scalar
, withConnection
, withTransaction
) where

import Prelude

import Control.Monad.Error.Class (catchError, throwError)
import Control.Monad.Except (ExceptT(..))
import Control.Monad.Except.Trans (ExceptT, runExceptT)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Database.PostgreSQL (Connection, PGError(..), Pool, Query)
import Database.PostgreSQL (class FromSQLRow, class FromSQLValue, class ToSQLRow, class ToSQLValue, Connection, Database, PGError(..), PGErrorDetail, Pool, PoolConfiguration, Query(..), Row0(..), Row1(..), Row10(..), Row11(..), Row12(..), Row13(..), Row14(..), Row15(..), Row16(..), Row17(..), Row18(..), Row19(..), Row2(..), Row3(..), Row4(..), Row5(..), Row6(..), Row7(..), Row8(..), Row9(..), defaultPoolConfiguration, fromSQLRow, fromSQLValue, instantFromString, instantToString, newPool, null, toSQLRow, toSQLValue, unsafeIsBuffer) as PostgreSQL
import Database.PostgreSQL (command, execute, query, scalar, withConnection, withTransaction) as P
import Database.PostgreSQL.Row (class FromSQLRow, class ToSQLRow, Row0(..), Row1(..), Row10(..), Row11(..), Row12(..), Row13(..), Row14(..), Row15(..), Row16(..), Row17(..), Row18(..), Row19(..), Row2(..), Row3(..), Row4(..), Row5(..), Row6(..), Row7(..), Row8(..), Row9(..), fromSQLRow, toSQLRow) as Row
import Database.PostgreSQL.Row (class FromSQLRow, class ToSQLRow, Row1)
import Database.PostgreSQL.Value (class FromSQLValue)
import Database.PostgreSQL.Value (class FromSQLValue, class ToSQLValue, fromSQLValue, instantFromString, instantToString, null, toSQLValue, unsafeIsBuffer) as Value
import Effect.Aff (Aff)
import Effect.Aff.Class (class MonadAff, liftAff)

type Database = String

-- | PostgreSQL computations run in the `PG` monad. It's just `Aff` stacked with
-- | `ExceptT` to provide error handling.
-- |
-- | Errors originating from database queries or connection to the database are
-- | modeled with the `PGError` type. Use `runExceptT` from
-- | `Control.Monad.Except.Trans` to turn a `PG a` action into `Aff (Either
-- | PGError a)`.
type PG a = ExceptT PGError Aff a

hoistPG ∷ ∀ m. MonadAff m ⇒ PG ~> ExceptT PGError m
hoistPG m = ExceptT $ liftAff $
  runExceptT m >>= case _ of
    Right a → pure (Right a)
    Left pgError → pure (Left pgError)

-- | Run an action with a connection. The connection is released to the pool
-- | when the action returns.
withConnection
    :: forall a
     . Pool
    -> (Connection -> PG a)
    -> PG a
withConnection p k = ExceptT $ P.withConnection p case _ of
  Right conn -> runExceptT $ k conn
  Left pgErr -> pure (Left pgErr)

-- | Run an action within a transaction. The transaction is committed if the
-- | action returns cleanly, and rolled back if the action throws (either a
-- | `PGError` or a JavaScript exception in PG context). If you want to
-- | change the transaction mode, issue a separate `SET TRANSACTION` statement
-- | within the transaction.
withTransaction
    :: forall a
     . Connection
    -> PG a
    -> PG a
withTransaction conn action =
  ExceptT $ join <$> P.withTransaction conn (runExceptT action)

-- | Execute a PostgreSQL query and discard its results.
execute
    :: forall i o
     . (ToSQLRow i)
    => Connection
    -> Query i o
    -> i
    -> PG Unit
execute conn sql values = ExceptT $ P.execute conn sql values >>= case _ of
  Just pgErr -> pure (Left pgErr)
  Nothing -> pure (Right unit)

-- | Execute a PostgreSQL query and return its results.
query
    :: forall i o
     . ToSQLRow i
    => FromSQLRow o
    => Connection
    -> Query i o
    -> i
    -> PG (Array o)
query conn sql = ExceptT <<< P.query conn sql

-- | Execute a PostgreSQL query and return the first field of the first row in
-- | the result.
scalar
    :: forall i o
     . ToSQLRow i
    => FromSQLValue o
    => Connection
    -> Query i (Row1 o)
    -> i
    -> PG (Maybe o)
scalar conn sql = ExceptT <<< P.scalar conn sql

-- | Execute a PostgreSQL query and return its command tag value
-- | (how many rows were affected by the query). This may be useful
-- | for example with `DELETE` or `UPDATE` queries.
command
    :: forall i
     . ToSQLRow i
    => Connection
    -> Query i Int
    -> i
    -> PG Int
command conn sql = ExceptT <<< P.command conn sql

onIntegrityError :: forall a. PG a -> PG a -> PG a
onIntegrityError errorResult db =
    catchError db handleError
    where
    handleError e =
        case e of
            IntegrityError _ -> errorResult
            _ -> throwError e


Minor reordering of arguments

Minor reordering of arguments

module Main (main) where

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

type Coordinate = Tuple Int Int

type Player = Int

type Piece = { color :: String, king :: Boolean }

type Square = { x :: Int, y :: Int, rx :: Number, ry :: Number, color :: String, piece :: Maybe Piece }

type Grid = { width :: Int, height :: Int, squares :: Array Square }

type State = { grid :: Grid, currentPlayer :: Player }

defaultWidth    = 8
defaultHeight   = 8
layerCount      = 3
renderSize      = 60.0
renderWidth     = (toNumber defaultWidth) * renderSize
renderHeight    = (toNumber defaultHeight) * renderSize
renderDimension = { width: renderWidth, height: renderHeight }

colorSquareOne  = "#d18b47"
colorSquareTwo  = "#ffce9e"
colorPlayerOne  = "red"
colorPlayerTwo  = "white"

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

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

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

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

isOnSquare :: Square -> Number -> Number -> Boolean
isOnSquare square x y =
  square.rx < x && x < square.rx + renderSize &&
  square.ry < y && y < square.ry + renderSize

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

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

render :: forall s e. Context2D -> STRef s State -> Maybe DOMEvent -> Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, 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
    setStrokeStyle "black" ctx
    strokeRect ctx { x: 0.5,
                     y: 0.5,
                     w: (toNumber state.grid.width) * renderSize - 0.5,
                     h: (toNumber state.grid.height) * renderSize - 0.5 }
  return unit

onMouseMoveListener :: forall s e. STRef s State -> DOMEvent -> Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
onMouseMoveListener st e = renderPage st (Just e)

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 = do
  st <- newSTRef (createState defaultWidth defaultHeight layerCount)
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      addMouseEventListener MouseMoveEvent (onMouseMoveListener st) canvas
      renderPage st Nothing
      return unit
    _ -> return unit

module Main (main) where

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

type Coordinate = Tuple Int Int

type Player = Int

type Piece = { color :: String, king :: Boolean }

type Square = { x :: Int, y :: Int, rx :: Number, ry :: Number, color :: String, piece :: Maybe Piece }

type Grid = { width :: Int, height :: Int, squares :: Array Square }

type State = { grid :: Grid, currentPlayer :: Player }

defaultWidth    = 8
defaultHeight   = 8
layerCount      = 3
renderSize      = 60.0
renderWidth     = (toNumber defaultWidth) * renderSize
renderHeight    = (toNumber defaultHeight) * renderSize
renderDimension = { width: renderWidth, height: renderHeight }

colorSquareOne  = "#d18b47"
colorSquareTwo  = "#ffce9e"
colorPlayerOne  = "red"
colorPlayerTwo  = "white"

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

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

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

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

isOnSquare :: Square -> Number -> Number -> Boolean
isOnSquare square x y =
  square.rx < x && x < square.rx + renderSize &&
  square.ry < y && y < square.ry + renderSize

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (findPiece from grid)
      toIndex = fromJust (findPiece to grid)
      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, console :: CONSOLE, dom :: DOM | e) Unit
renderSquare ctx event _ square = do
  withContext ctx $ do
    setFillStyle square.color ctx
    fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  case square.piece of
    Just piece -> do
      withContext ctx $ do
        setFillStyle piece.color ctx
        let arcPiece = { x: square.rx + 0.5 * renderSize,
                         y: square.ry + 0.5 * renderSize,
                         r: (renderSize / 2.0) * 0.8,
                         start: 0.0,
                         end: 2.0 * pi }
        fillPath ctx $ arc ctx arcPiece
        case event of
          Nothing -> return unit
          Just e -> do
            ux <- unsafeEventNumberProp "clientX" e
            uy <- unsafeEventNumberProp "clientY" e
            case isOnSquare square (toNumber ux) (toNumber uy) of
              true -> do
                strokePath ctx $ arc ctx arcPiece
                return unit
              false -> return unit
            return unit
        return unit
    _ -> return unit

render :: forall s e. Context2D -> STRef s State -> Maybe DOMEvent -> Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, 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
    setStrokeStyle "black" ctx
    strokeRect ctx { x: 0.5,
                     y: 0.5,
                     w: (toNumber state.grid.width) * renderSize - 0.5,
                     h: (toNumber state.grid.height) * renderSize - 0.5 }
  return unit

onMouseMoveListener :: forall s e. STRef s State -> DOMEvent -> Eff (st :: ST s, canvas :: Canvas, console :: CONSOLE, dom :: DOM | e) Unit
onMouseMoveListener st e = renderPage st (Just e)

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 = do
  st <- newSTRef (createState defaultWidth defaultHeight layerCount)
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      addMouseEventListener MouseMoveEvent (onMouseMoveListener st) canvas
      renderPage st Nothing
      return unit
    _ -> return unit


fix: always set viewport size

fix: always set viewport size

module Main (main,run) where

import Debug.Trace

import Control.Bind
import Control.Timer (timeout,clearTimeout)
import Control.Monad.Eff
import Control.Monad.Eff.Ref
import Data.Date
import Data.Time
import Data.Foldable (for_, foldl)

import Ace
import Ace.Types
import qualified Ace.Editor as Editor
import qualified Ace.EditSession as Session
import qualified Ace.Range as Range

import qualified Graphics.WebGL as GL
import qualified Control.Monad.JQuery as J

import WebSocket
import DefaultText
import Data.Either
import Sample

import Data.Function
import Data.Maybe
import Data.StrMap
import Data.Tuple
import Data.Array(filter,head)

import Backend
import IR
import Mesh
import Type
import Input

import MeshJsonDecode
import PipelineJsonDecode
import qualified Data.Argonaut as A
import qualified Data.Argonaut.Core as AC

import Data.Matrix (Mat(..))
import Data.Matrix4
import Data.Vector3

import qualified DOM as DOM

main = return unit

foreign import getJSON """
  function getJSON(uri) {
    return function(act) {
      return function() {
        $.getJSON(uri, function(data) {
          act(data)();
        });
      };
    };
  }
""" :: forall eff a. String -> (AC.Json -> Eff (dom :: DOM.DOM | eff) a) -> Eff (dom :: DOM.DOM | eff) Unit

{-
  control-b - compile/build
  control-n - new
-}
foreign import addCommand """
  function addCommand(editor) {
    return function(cmdName) {
      return function(winKey) {
        return function(macKey) {
          return function(cmd) {
            return function() {
              editor.commands.addCommand({
                name: cmdName,
                bindKey: {win: winKey,  mac: macKey},
                exec: function(editor) {
                  cmd(editor)();
                }
              });
            };
          };
        };
      };
    };
  }
""" :: forall eff . Editor -> String -> String -> String -> (Editor -> Eff (ace :: EAce | eff) Unit) -> Eff (ace :: EAce | eff) Unit

foreign import tokenTooltip """
  function tokenTooltip(editor) {
    return function(getTy) {
      return function() {
          editor.tokenTooltip = new myTokenTooltip(editor,getTy);
      };
    };
  }
""" :: forall eff . Editor -> (Int -> Int -> Eff (ace :: EAce | eff) TypeInfoRecord) -> Eff (ace :: EAce | eff) Unit

foreign import add
  """
  function add(ob1) {
    return function(ob) {
      return function () {
        return ob.add(ob1);
      };
    };
  }
  """ :: forall eff. J.JQuery -> J.JQuery -> Eff (dom :: DOM.DOM | eff) J.JQuery

foreign import addMarkerImpl
  "function addMarkerImpl(range, clazz, type, inFront, self) {\
  \  return function() {\
  \    return self.addMarker(range, clazz, type, inFront);\
  \  };\
  \}" :: forall eff. Fn5 Range String String Boolean EditSession (Eff (ace :: EAce | eff) Int)

addMarker :: forall eff. Range -> String -> String -> Boolean -> EditSession -> Eff (ace :: EAce | eff) Int
addMarker range clazz _type inFront self = runFn5 addMarkerImpl range clazz _type inFront self

run = GL.runWebGL "glcanvas" (\s -> trace s) $ \context -> do
  Milliseconds baseTime <- nowEpochMilliseconds
  -- setup pipeline input
  let inputSchema =
        { slots : fromList [ Tuple "stream"  {primitive: Triangles, attributes: fromList [Tuple "position"  TV3F, Tuple "normal" TV3F]}
                           , Tuple "stream4" {primitive: Triangles, attributes: fromList [Tuple "position4" TV4F, Tuple "vertexUV" TV2F]}
                           , Tuple "line"    {primitive: Triangles, attributes: fromList [Tuple "position" TV3F]}
                           , Tuple "grid"    {primitive: Triangles, attributes: fromList [Tuple "position" TV3F]}
                           , Tuple "quad"    {primitive: Triangles, attributes: fromList [Tuple "position" TV4F]}
                           , Tuple "grid3d"  {primitive: Points,    attributes: fromList [Tuple "position" TV3F]}
                           ]
        , uniforms : fromList [Tuple "MVP" M44F, Tuple "MVP2" M44F, Tuple "Time" Float]
        }
  pplInput <- mkWebGLPipelineInput inputSchema
  let toLCMat4 :: Mat4 -> M44F
      toLCMat4 (Mat [x11, x21, x31, x41, x12, x22, x32, x42, x13, x23, x33, x43, x14, x24, x34, x44]) = let
          v1 = V4 x11 x21 x31 x41
          v2 = V4 x12 x22 x32 x42
          v3 = V4 x13 x23 x33 x43
          v4 = V4 x14 x24 x34 x44
        in V4 v1 v2 v3 v4

      updateInput t = do
        w <- GL.getCanvasWidth context
        h <- GL.getCanvasHeight context
        setScreenSize pplInput (V2 w h)
        let pi = 3.141592653589793
            angle = pi / 24 * t
            cm = makeLookAt (vec3 3 1.3 0.3) (vec3 0 0 0) (vec3 0 1 0)
            mm = makeRotate angle (vec3 0 1 0)
            pm = makePerspective 45 (w/h) 0.1 100
            mvp = pm `mul` cm `mul` mm
            cm' = makeLookAt (vec3 4 0.5 (-0.6)) (vec3 0 0 0) (vec3 0 1 0)
            mvp2 = pm `mul` cm' `mul` mm

        uniformFloat "Time" pplInput.uniformSetter t
        uniformM44F "MVP" pplInput.uniformSetter $ toLCMat4 mvp
        uniformM44F "MVP2" pplInput.uniformSetter $ toLCMat4 mvp2

  gpuCube <- compileMesh myCube
  addMesh pplInput "stream4" gpuCube []

  let addRemoteModel sname uri = getJSON uri $ \m -> do
        case A.decodeJson m of
          Left e -> trace $ "decode error: " ++ e
          Right (MeshData mesh) -> do
            gpuMesh <- compileMesh mesh
            addMesh pplInput sname gpuMesh []
            sortSlotObjects pplInput
            return unit

  --addRemoteModel "grid3d" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/grid3d.mesh.json"
  --addRemoteModel "stream" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/logo2.mesh.json"
  --addRemoteModel "stream" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/logo3.mesh.json"
  addRemoteModel "quad"   "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/quad.mesh.json"
  addRemoteModel "grid"   "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/grid.mesh.json"
  addRemoteModel "line"   "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/line.mesh.json"
  addRemoteModel "stream" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/ico.mesh.json"

  -- setup ace editor
  editor <- Ace.edit "editor" ace
  session <- Editor.getSession editor
  Editor.setTheme "ace/theme/terminal" editor
  Session.setMode "ace/mode/haskell" session
  Session.setValue defaultSrc session
  typeInfoRef <- newRef []
  markerRef <- newRef []
  let lessEqPos l c l' c' = l < l' || l == l' && c <= c'
  let lessPos l c l' c' = l < l' || l == l' && c < c'
  let getTypeInfo l c = do
        x <- readRef typeInfoRef
        let ps = flip filter x $ \(TypeInfo i) -> lessEqPos i.startLine i.startColumn l c && lessPos l c i.endLine i.endColumn
        let f Nothing (TypeInfo i) = Just i
            f (Just d) (TypeInfo i)
                | lessPos d.startLine d.startColumn i.startLine i.startColumn = Just i
                | otherwise = Just d
        return $ case foldl f Nothing ps of
          Nothing ->
              { startLine   : 0
              , startColumn : 0
              , endLine     : 0
              , endColumn   : 0
              , text        : ""
              }
          Just a -> a
  tokenTooltip editor getTypeInfo

  b <- J.body
  messagepanel <- J.find "#messagepanel" b
  statuspanel <- J.find "#statuspanel" b
  btnCompile <- J.find "#compilebutton" b
  exerciseselect <- J.find "#exerciseselect" b

  pipelineRef <- newRef Nothing
  let compile s = do
        trace "compile"
        J.setText "Compiling..." statuspanel
        src <- Session.getValue session
        send s src

      render ir = do
        old <- readRef pipelineRef
        writeRef pipelineRef Nothing
        case old of
          Nothing -> return unit
          Just p -> do
            trace "dispose old pipeline"
            disposePipeline p
        trace "allocate new pipeline"
        ppl <- allocPipeline ir -- gfx03Pipeline -- samplePipeline
        trace "attach pipeline input"
        setPipelineInput ppl (Just pplInput)
        trace "generate object commands"
        sortSlotObjects pplInput
        writeRef pipelineRef $ Just ppl

  socket1 <- webSocket "ws://localhost:8000/exerciselist" $
    { onOpen    : \s -> do
        send s "query"
        trace "socket1 is ready"
        return unit
    , onMessage : \s m -> case A.jsonParser m >>= A.decodeJson of
          Left e -> trace $ "decode error: " ++ e
          Right es -> do
            for_ (es :: [String]) $ \e -> do
                op <- J.create "<option></option>"
                J.setText e op
                J.append op exerciseselect
            return unit
    , onError   : \s m -> trace m
    , onClose   : trace "socket1 is closed"
    }

  socket <- webSocket "ws://localhost:8000/compile" $
    { onOpen    : \s -> do
        trace "socket is ready"
        compile s
        timerRef <- newRef Nothing
        Session.onChange session $ do
          t <- readRef timerRef
          case t of
            Nothing -> return unit
            Just a -> clearTimeout a
          writeRef timerRef =<< Just <$> timeout 1000 (compile s)

    , onClose   : trace "socket is closed"
    , onMessage : \s m -> do
        trace "got response"
        case A.jsonParser m >>= A.decodeJson of
          Left e -> trace $ "decode error: " ++ e
          Right (MyLeft (TypeInfo e) infos) -> do
            J.setText "Error" statuspanel
            J.setText e.text messagepanel
            range <- Range.create (e.startLine - 1) (e.startColumn - 1) (e.endLine - 1) (e.endColumn - 1)
            rs <- readRef markerRef
            for_ rs $ \mkr -> Session.removeMarker mkr session
            mkr <- addMarker range "lc_error" "text" false session
            writeRef markerRef [mkr]
            writeRef typeInfoRef infos
            return unit
          Right (MyRight p infos) -> do
            J.setText "Compiled" statuspanel
            J.setText "No errors." messagepanel
            writeRef typeInfoRef infos
            rs <- readRef markerRef
            for_ rs $ \mkr -> Session.removeMarker mkr session
            writeRef markerRef []
            render p
    , onError   : \s m -> trace $ "error: " ++ m
    }
  case socket of
    Left m -> trace $ "error: " ++ m
    Right ws -> do

      socket2 <- webSocket "ws://localhost:8000/getexercise" $
        { onOpen    : \s -> do
            trace "socket2 is ready"
            flip (J.on "change") exerciseselect $ \_ _ -> do
                sel <- J.find ":selected" exerciseselect
                txt <- J.getText sel
                send s txt
            return unit
        , onMessage : \s m -> case A.jsonParser m >>= A.decodeJson of
              Left e -> trace $ "decode error: " ++ e
              Right src -> do
                Session.setValue src session
                compile ws
                return unit
        , onError   : \s m -> trace m
        , onClose   : trace "socket2 is closed"
        }

      flip (J.on "click") btnCompile $ \_ _ -> do
        compile ws
        trace "clicked compile"
      addCommand editor "Compile" "Ctrl-B" "Command-B" (\_ -> compile ws)
      let renderLoop = do
            Milliseconds t <- nowEpochMilliseconds
            updateInput ((t - baseTime) / 1000)
            mppl <- readRef pipelineRef
            case mppl of
              Nothing -> return unit
              Just ppl -> renderPipeline ppl
            timeout (1000/25) renderLoop
      -- render loop
      renderLoop
      return unit

module Main (main,run) where

import Debug.Trace

import Control.Bind
import Control.Timer (timeout,clearTimeout)
import Control.Monad.Eff
import Control.Monad.Eff.Ref
import Data.Date
import Data.Time
import Data.Foldable (for_, foldl)

import Ace
import Ace.Types
import qualified Ace.Editor as Editor
import qualified Ace.EditSession as Session
import qualified Ace.Range as Range

import qualified Graphics.WebGL as GL
import qualified Control.Monad.JQuery as J

import WebSocket
import DefaultText
import Data.Either
import Sample

import Data.Function
import Data.Maybe
import Data.StrMap
import Data.Tuple
import Data.Array(filter,head)

import Backend
import IR
import Mesh
import Type
import Input

import MeshJsonDecode
import PipelineJsonDecode
import qualified Data.Argonaut as A
import qualified Data.Argonaut.Core as AC

import Data.Matrix (Mat(..))
import Data.Matrix4
import Data.Vector3

import qualified DOM as DOM

main = return unit

foreign import getJSON """
  function getJSON(uri) {
    return function(act) {
      return function() {
        $.getJSON(uri, function(data) {
          act(data)();
        });
      };
    };
  }
""" :: forall eff a. String -> (AC.Json -> Eff (dom :: DOM.DOM | eff) a) -> Eff (dom :: DOM.DOM | eff) Unit

{-
  control-b - compile/build
  control-n - new
-}
foreign import addCommand """
  function addCommand(editor) {
    return function(cmdName) {
      return function(winKey) {
        return function(macKey) {
          return function(cmd) {
            return function() {
              editor.commands.addCommand({
                name: cmdName,
                bindKey: {win: winKey,  mac: macKey},
                exec: function(editor) {
                  cmd(editor)();
                }
              });
            };
          };
        };
      };
    };
  }
""" :: forall eff . Editor -> String -> String -> String -> (Editor -> Eff (ace :: EAce | eff) Unit) -> Eff (ace :: EAce | eff) Unit

foreign import tokenTooltip """
  function tokenTooltip(editor) {
    return function(getTy) {
      return function() {
          editor.tokenTooltip = new myTokenTooltip(editor,getTy);
      };
    };
  }
""" :: forall eff . Editor -> (Int -> Int -> Eff (ace :: EAce | eff) TypeInfoRecord) -> Eff (ace :: EAce | eff) Unit

foreign import add
  """
  function add(ob1) {
    return function(ob) {
      return function () {
        return ob.add(ob1);
      };
    };
  }
  """ :: forall eff. J.JQuery -> J.JQuery -> Eff (dom :: DOM.DOM | eff) J.JQuery

foreign import addMarkerImpl
  "function addMarkerImpl(range, clazz, type, inFront, self) {\
  \  return function() {\
  \    return self.addMarker(range, clazz, type, inFront);\
  \  };\
  \}" :: forall eff. Fn5 Range String String Boolean EditSession (Eff (ace :: EAce | eff) Int)

addMarker :: forall eff. Range -> String -> String -> Boolean -> EditSession -> Eff (ace :: EAce | eff) Int
addMarker range clazz _type inFront self = runFn5 addMarkerImpl range clazz _type inFront self

run = GL.runWebGL "glcanvas" (\s -> trace s) $ \context -> do
  Milliseconds baseTime <- nowEpochMilliseconds
  -- setup pipeline input
  let inputSchema =
        { slots : fromList [ Tuple "stream"  {primitive: Triangles, attributes: fromList [Tuple "position"  TV3F, Tuple "normal" TV3F]}
                           , Tuple "stream4" {primitive: Triangles, attributes: fromList [Tuple "position4" TV4F, Tuple "vertexUV" TV2F]}
                           , Tuple "line"    {primitive: Triangles, attributes: fromList [Tuple "position" TV3F]}
                           , Tuple "grid"    {primitive: Triangles, attributes: fromList [Tuple "position" TV3F]}
                           , Tuple "quad"    {primitive: Triangles, attributes: fromList [Tuple "position" TV4F]}
                           , Tuple "grid3d"  {primitive: Points,    attributes: fromList [Tuple "position" TV3F]}
                           ]
        , uniforms : fromList [Tuple "MVP" M44F, Tuple "MVP2" M44F, Tuple "Time" Float]
        }
  pplInput <- mkWebGLPipelineInput inputSchema
  let toLCMat4 :: Mat4 -> M44F
      toLCMat4 (Mat [x11, x21, x31, x41, x12, x22, x32, x42, x13, x23, x33, x43, x14, x24, x34, x44]) = let
          v1 = V4 x11 x21 x31 x41
          v2 = V4 x12 x22 x32 x42
          v3 = V4 x13 x23 x33 x43
          v4 = V4 x14 x24 x34 x44
        in V4 v1 v2 v3 v4

      updateInput t = do
        w <- GL.getCanvasWidth context
        h <- GL.getCanvasHeight context
        let pi = 3.141592653589793
            angle = pi / 24 * t
            cm = makeLookAt (vec3 3 1.3 0.3) (vec3 0 0 0) (vec3 0 1 0)
            mm = makeRotate angle (vec3 0 1 0)
            pm = makePerspective 45 (w/h) 0.1 100
            mvp = pm `mul` cm `mul` mm
            cm' = makeLookAt (vec3 4 0.5 (-0.6)) (vec3 0 0 0) (vec3 0 1 0)
            mvp2 = pm `mul` cm' `mul` mm

        uniformFloat "Time" pplInput.uniformSetter t
        uniformM44F "MVP" pplInput.uniformSetter $ toLCMat4 mvp
        uniformM44F "MVP2" pplInput.uniformSetter $ toLCMat4 mvp2

  gpuCube <- compileMesh myCube
  addMesh pplInput "stream4" gpuCube []

  let addRemoteModel sname uri = getJSON uri $ \m -> do
        case A.decodeJson m of
          Left e -> trace $ "decode error: " ++ e
          Right (MeshData mesh) -> do
            gpuMesh <- compileMesh mesh
            addMesh pplInput sname gpuMesh []
            sortSlotObjects pplInput
            return unit

  --addRemoteModel "grid3d" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/grid3d.mesh.json"
  --addRemoteModel "stream" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/logo2.mesh.json"
  --addRemoteModel "stream" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/logo3.mesh.json"
  addRemoteModel "quad"   "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/quad.mesh.json"
  addRemoteModel "grid"   "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/grid.mesh.json"
  addRemoteModel "line"   "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/line.mesh.json"
  addRemoteModel "stream" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/ico.mesh.json"

  -- setup ace editor
  editor <- Ace.edit "editor" ace
  session <- Editor.getSession editor
  Editor.setTheme "ace/theme/terminal" editor
  Session.setMode "ace/mode/haskell" session
  Session.setValue defaultSrc session
  typeInfoRef <- newRef []
  markerRef <- newRef []
  let lessEqPos l c l' c' = l < l' || l == l' && c <= c'
  let lessPos l c l' c' = l < l' || l == l' && c < c'
  let getTypeInfo l c = do
        x <- readRef typeInfoRef
        let ps = flip filter x $ \(TypeInfo i) -> lessEqPos i.startLine i.startColumn l c && lessPos l c i.endLine i.endColumn
        let f Nothing (TypeInfo i) = Just i
            f (Just d) (TypeInfo i)
                | lessPos d.startLine d.startColumn i.startLine i.startColumn = Just i
                | otherwise = Just d
        return $ case foldl f Nothing ps of
          Nothing ->
              { startLine   : 0
              , startColumn : 0
              , endLine     : 0
              , endColumn   : 0
              , text        : ""
              }
          Just a -> a
  tokenTooltip editor getTypeInfo

  b <- J.body
  messagepanel <- J.find "#messagepanel" b
  statuspanel <- J.find "#statuspanel" b
  btnCompile <- J.find "#compilebutton" b
  exerciseselect <- J.find "#exerciseselect" b

  pipelineRef <- newRef Nothing
  let compile s = do
        trace "compile"
        J.setText "Compiling..." statuspanel
        src <- Session.getValue session
        send s src

      render ir = do
        old <- readRef pipelineRef
        writeRef pipelineRef Nothing
        case old of
          Nothing -> return unit
          Just p -> do
            trace "dispose old pipeline"
            disposePipeline p
        trace "allocate new pipeline"
        ppl <- allocPipeline ir -- gfx03Pipeline -- samplePipeline
        trace "attach pipeline input"
        setPipelineInput ppl (Just pplInput)
        trace "generate object commands"
        sortSlotObjects pplInput
        writeRef pipelineRef $ Just ppl

  socket1 <- webSocket "ws://localhost:8000/exerciselist" $
    { onOpen    : \s -> do
        send s "query"
        trace "socket1 is ready"
        return unit
    , onMessage : \s m -> case A.jsonParser m >>= A.decodeJson of
          Left e -> trace $ "decode error: " ++ e
          Right es -> do
            for_ (es :: [String]) $ \e -> do
                op <- J.create "<option></option>"
                J.setText e op
                J.append op exerciseselect
            return unit
    , onError   : \s m -> trace m
    , onClose   : trace "socket1 is closed"
    }

  socket <- webSocket "ws://localhost:8000/compile" $
    { onOpen    : \s -> do
        trace "socket is ready"
        compile s
        timerRef <- newRef Nothing
        Session.onChange session $ do
          t <- readRef timerRef
          case t of
            Nothing -> return unit
            Just a -> clearTimeout a
          writeRef timerRef =<< Just <$> timeout 1000 (compile s)

    , onClose   : trace "socket is closed"
    , onMessage : \s m -> do
        trace "got response"
        case A.jsonParser m >>= A.decodeJson of
          Left e -> trace $ "decode error: " ++ e
          Right (MyLeft (TypeInfo e) infos) -> do
            J.setText "Error" statuspanel
            J.setText e.text messagepanel
            range <- Range.create (e.startLine - 1) (e.startColumn - 1) (e.endLine - 1) (e.endColumn - 1)
            rs <- readRef markerRef
            for_ rs $ \mkr -> Session.removeMarker mkr session
            mkr <- addMarker range "lc_error" "text" false session
            writeRef markerRef [mkr]
            writeRef typeInfoRef infos
            return unit
          Right (MyRight p infos) -> do
            J.setText "Compiled" statuspanel
            J.setText "No errors." messagepanel
            writeRef typeInfoRef infos
            rs <- readRef markerRef
            for_ rs $ \mkr -> Session.removeMarker mkr session
            writeRef markerRef []
            render p
    , onError   : \s m -> trace $ "error: " ++ m
    }
  case socket of
    Left m -> trace $ "error: " ++ m
    Right ws -> do

      socket2 <- webSocket "ws://localhost:8000/getexercise" $
        { onOpen    : \s -> do
            trace "socket2 is ready"
            flip (J.on "change") exerciseselect $ \_ _ -> do
                sel <- J.find ":selected" exerciseselect
                txt <- J.getText sel
                send s txt
            return unit
        , onMessage : \s m -> case A.jsonParser m >>= A.decodeJson of
              Left e -> trace $ "decode error: " ++ e
              Right src -> do
                Session.setValue src session
                compile ws
                return unit
        , onError   : \s m -> trace m
        , onClose   : trace "socket2 is closed"
        }

      flip (J.on "click") btnCompile $ \_ _ -> do
        compile ws
        trace "clicked compile"
      addCommand editor "Compile" "Ctrl-B" "Command-B" (\_ -> compile ws)
      let renderLoop = do
            Milliseconds t <- nowEpochMilliseconds
            updateInput ((t - baseTime) / 1000)
            mppl <- readRef pipelineRef
            case mppl of
              Nothing -> return unit
              Just ppl -> renderPipeline ppl
            timeout (1000/25) renderLoop
      -- render loop
      renderLoop
      return unit


Fixed compiler errors in Free WebGL.

Fixed compiler errors in Free WebGL.

module Graphics.WebGL.Free (
	WebGL(),
	WebGLF()
	) where

import Prelude
import Control.Monad.Eff
import Control.Monad.Free
import Graphics.Canvas (Canvas())
import qualified Graphics.WebGL.Raw as R
import Graphics.WebGL.Raw.Types

data WebGLF a
	= Clear GLbitfield a
	| ClearColor GLclampf GLclampf GLclampf GLclampf a
	| DepthFunc GLenum a
	| Enable GLenum a
	| Viewport GLint GLint GLsizei GLsizei a

instance functorWebGLF :: Functor WebGLF where
	map f (Clear mask x) = Clear mask (f x)
	map f (ClearColor r g b a x) = ClearColor r g b a (f x)
	map f (DepthFunc func x) = DepthFunc func (f x)
	map f (Enable cap x) = Enable cap (f x)
	map f (Viewport x y w h a) = Viewport x y w h (f a)

type WebGL = Free WebGLF

clear :: GLbitfield -> WebGL Unit
clear mask = liftF $ Clear mask unit

clearColor :: GLclampf -> GLclampf -> GLclampf -> GLclampf -> WebGL Unit
clearColor r g b a = liftF $ ClearColor r g b a unit

depthFunc :: GLenum -> WebGL Unit
depthFunc func = liftF $ DepthFunc func unit

enable :: GLenum -> WebGL Unit
enable cap = liftF $ Enable cap unit

viewport :: GLint -> GLint -> GLsizei -> GLsizei -> WebGL Unit
viewport x y w h = liftF $ Viewport x y w h unit

runWebGL :: forall a eff. WebGLContext -> WebGL a -> Eff (canvas :: Canvas | eff) a
runWebGL gl = runFreeM interpret
	where
	interpret :: forall a. WebGLF (WebGL a) -> Eff (canvas :: Canvas | eff) (WebGL a)
	interpret (Clear mask rest) = do
		R.clear gl mask
		return rest
	interpret (ClearColor r g b a rest) = do
		R.clearColor gl r g b a
		return rest
	interpret (DepthFunc func rest) = do
		R.depthFunc gl func
		return rest
	interpret (Enable cap rest) = do
		R.enable gl cap
		return rest
	interpret (Viewport x y w h rest) = do
		R.viewport gl x y w h
		return rest

module Graphics.WebGL.Free (
	WebGL(),
	WebGLF()
	) where

import Prelude
import Control.Monad.Eff
import Control.Monad.Free
import Graphics.Canvas (Canvas())
import qualified Graphics.WebGL.Raw as R
import Graphics.WebGL.Raw.Types

data WebGLF a
	= Clear GLbitfield a
	| ClearColor GLclampf GLclampf GLclampf GLclampf a
	| DepthFunc GLenum a
	| Enable GLenum a
	| Viewport GLint GLint GLsizei GLsizei a

instance functorWebGLF :: Functor WebGLF where
	map f (Clear mask x) = Clear mask (f x)
	map f (ClearColor r g b a x) = ClearColor r g b a (f x)
	map f (DepthFunc func x) = DepthFunc func (f x)
	map f (Enable cap x) = Enable cap (f x)
	map f (Viewport x y w h a) = Viewport x y w h (f a)

type WebGL = Free WebGLF

clear :: GLbitfield -> WebGL Unit
clear mask = liftF $ Clear mask unit

clearColor :: GLclampf -> GLclampf -> GLclampf -> GLclampf -> WebGL Unit
clearColor r g b a = liftF $ ClearColor r g b a unit

depthFunc :: GLenum -> WebGL Unit
depthFunc func = liftF $ DepthFunc func unit

enable :: GLenum -> WebGL Unit
enable cap = liftF $ Enable cap unit

viewport :: GLint -> GLint -> GLsizei -> GLsizei -> WebGL Unit
viewport x y w h = liftF $ Viewport x y w h unit

runWebGL :: forall a eff. R.WebGLContext -> WebGL a -> Eff (canvas :: Canvas | eff) a
runWebGL gl = runFreeM interpret
	where
	interpret :: WebGLF (WebGL a) -> Eff (canvas :: Canvas | eff) a
	interpret (Clear mask rest) = do
		R.clear gl mask
		return rest
	interpret (ClearColor r g b a rest) = do
		R.clearColor gl r g b a
		return rest
	interpret (DepthFunc func rest) = do
		R.depthFunc gl func
		return rest
	interpret (Enable cap) = do
		R.enable gl cap
		return rest
	interpret (Viewport x y w h rest) = do
		R.viewport gl x y w h
		return rest


tweaked upgrade costs

tweaked upgrade costs

module Upgrades
  ( upgradeCost
  , upgradeName
  , nextUpgrade
  , canBuyUpgrade
  , upgradeDescription
  , buyUpgrade
  , isInflectionUpgrade
  , inflectionUpgradeMessage
  , cpsFromUpgrades
  , burstFromUpgrades
  ) where

import Prelude
import Data.Foldable (elem, sum, foldl)
import Data.Array (concat)
import Data.Int (toNumber)
import Data.Lens (LensP(), (^.), (+~), (-~), (.~), view)

import Types
import Lenses
import Util

upgradeCost :: Upgrade -> Clicks
upgradeCost (Misc1 n)    = Clicks (upgradeCostPolynomial 10.0 n)
upgradeCost (Misc2 n)    = Clicks (upgradeCostPolynomial 500.0 n)
upgradeCost (Tech1 n)    = Clicks (upgradeCostPolynomial 7500.0 n)
upgradeCost (Tech2 n)    = Clicks (upgradeCostPolynomial 950000.0 n)
upgradeCost (Phil1 n)    = Clicks (upgradeCostPolynomial 8250000.0 n)
upgradeCost (Phil2 n)    = Clicks (upgradeCostPolynomial 52000000.0 n)
upgradeCost (Poli1 n)    = Clicks (upgradeCostPolynomial 800000000.0 n)
upgradeCost (Poli2 n)    = Clicks (upgradeCostPolynomial 6050000000.0 n)
upgradeCost (Science1 n) = Clicks (upgradeCostPolynomial 600500004000.0 n)
upgradeCost (Science2 n) = Clicks (upgradeCostPolynomial 6500007000080.0 n)

upgradeCostPolynomial :: Number -> Int -> Number
upgradeCostPolynomial coeff level = upgradeCostModifier level * coeff * 1.2 ^ (toNumber level)

upgradeCostModifier :: Int -> Number
upgradeCostModifier n
  | n <= 10 = 1.5
  | n <= 25 = 1.0
  | n <= 50 = 0.75
  | n <= 75 = 0.5
  | n <= 100 = 0.25
  | otherwise = 0.125

upgradeName :: Upgrade -> Age -> String
upgradeName (Misc1 _) Stone = "language"
upgradeName (Misc2 _) Stone = "spear tips"
upgradeName (Tech1 _) Stone = "fire!"
upgradeName (Tech2 _) Stone = "stone tools"
upgradeName (Phil1 _) Stone = "funeral rites"
upgradeName (Phil2 _) Stone = "cave paintings"
upgradeName (Poli1 _) Stone = "basic fishing"
upgradeName (Poli2 _) Stone = "rudimentary farming"
upgradeName (Science1 _) Stone = "dog domestication"
upgradeName (Science2 _) Stone = "abstract numbers"

upgradeDescription :: Upgrade -> Age -> String
upgradeDescription (Misc1 _) Stone = "No more grunt-and-point for you!"
upgradeDescription (Misc2 _) Stone = "Tip: a well-balanced spear is crucial for hunting."
upgradeDescription (Tech1 _) Stone = "We DID start the fire."
upgradeDescription (Tech2 _) Stone = "Never leave the Stone Age without 'em."
upgradeDescription (Phil1 _) Stone = "Funerals are a basic human rite."
upgradeDescription (Phil2 _) Stone = "You're no Picasso, but your paintings will last longer."
upgradeDescription (Poli1 _) Stone = "Fishing for landsharks?"
upgradeDescription (Poli2 _) Stone = "Can I interest you in some delicious BEETS?"
upgradeDescription (Science1 _) Stone = "A Clickonian's best friend."
upgradeDescription (Science2 _) Stone = "You've discovered that two clicks and two dogs both share 'twoness.' You also almost discovered the ultrafilter lemma, but you couldn't write it down fast enough. Because you haven't discovered writing yet."

nextUpgrade :: Upgrade -> Upgrade
nextUpgrade (Misc1 n) = Misc1 (n + 1)
nextUpgrade (Misc2 n) = Misc2 (n + 1)
nextUpgrade (Tech1 n) = Tech1 (n + 1)
nextUpgrade (Tech2 n) = Tech2 (n + 1)
nextUpgrade (Phil1 n) = Phil1 (n + 1)
nextUpgrade (Phil2 n) = Phil2 (n + 1)
nextUpgrade (Poli1 n) = Poli1 (n + 1)
nextUpgrade (Poli2 n) = Poli2 (n + 1)
nextUpgrade (Science1 n) = Science1 (n + 1)
nextUpgrade (Science2 n) = Science2 (n + 1)

canBuyUpgrade :: State -> LensP Upgrades Upgrade -> Boolean
canBuyUpgrade state optic =
  let currClicks = state ^. currentClicks
      currUpgrade = state ^. upgrades <<< optic
      next = nextUpgrade currUpgrade
      nextCost = upgradeCost next
   in currClicks >= nextCost

upgradeBoost :: Upgrade -> Number
upgradeBoost (Misc1 n)    = 0.5 * upgradeBoostModifier n
upgradeBoost (Misc2 n)    = 4.0 * upgradeBoostModifier n
upgradeBoost (Tech1 n)    = 30.0 * upgradeBoostModifier n
upgradeBoost (Tech2 n)    = 400.0 * upgradeBoostModifier n
upgradeBoost (Phil1 n)    = 6000.0 * upgradeBoostModifier n
upgradeBoost (Phil2 n)    = 12220.5 * upgradeBoostModifier n
upgradeBoost (Poli1 n)    = 214592.6 * upgradeBoostModifier n
upgradeBoost (Poli2 n)    = 1712818.2 * upgradeBoostModifier n
upgradeBoost (Science1 n) = 49000000.0 * upgradeBoostModifier n
upgradeBoost (Science2 n) = 100000000.0 * upgradeBoostModifier n

upgradeBoostModifier :: Int -> Number
upgradeBoostModifier n
  | n <= 10 = 1.0
  | n <= 25 = 4.0
  | n <= 50 = 16.0
  | n <= 75 = 64.0
  | n <= 100 = 256.0
  | otherwise = 1024.0

buyUpgrade :: Upgrade -> State -> State
buyUpgrade up@(Misc1 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up misc1
buyUpgrade up@(Misc2 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up misc2
buyUpgrade up@(Tech1 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up tech1
buyUpgrade up@(Tech2 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up tech2
buyUpgrade up@(Phil1 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up phil1
buyUpgrade up@(Phil2 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up phil2
buyUpgrade up@(Poli1 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up poli1
buyUpgrade up@(Poli2 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up poli2
buyUpgrade up@(Science1 _) = installUpgrade up cpsNumber 0.75
                         <<< installUpgrade up burstNumber 0.3
                         <<< recordPurchase up science1
buyUpgrade up@(Science2 _) = installUpgrade up cpsNumber 0.75
                         <<< installUpgrade up burstNumber 0.3
                         <<< recordPurchase up science2

recordPurchase :: Upgrade -> LensP Upgrades Upgrade -> State -> State
recordPurchase up optic = (currentClicks -~ upgradeCost up)
                      <<< (upgrades <<< optic .~ up)

installUpgrade :: Upgrade -> LensP State Number -> Number -> State -> State
installUpgrade up optic coeff = optic +~ coeff * upgradeBoost up

isInflectionUpgrade :: Upgrade -> Boolean
isInflectionUpgrade up = (up ^. viewLevel) `elem` [10, 25, 50, 75, 100]

inflectionUpgradeMessage :: Upgrade -> Age -> String
inflectionUpgradeMessage up age = upgradeName up age ++ " cost down, boost up"

makeUpgradedState :: Upgrades -> State
makeUpgradedState u = foldl (flip buyUpgrade) initialState upArray
  where
    upArray = concat [ misc1arr, misc2arr, tech1arr, tech2arr, phil1arr
                     , phil2arr, poli1arr, poli2arr, science1arr, science2arr ]
    misc1arr    = Misc1 <$> 1 ... u ^. misc1 <<< viewLevel
    misc2arr    = Misc2 <$> 1 ... u ^. misc2 <<< viewLevel
    tech1arr    = Tech1 <$> 1 ... u ^. tech1 <<< viewLevel
    tech2arr    = Tech2 <$> 1 ... u ^. tech2 <<< viewLevel
    phil1arr    = Phil1 <$> 1 ... u ^. phil1 <<< viewLevel
    phil2arr    = Phil2 <$> 1 ... u ^. phil2 <<< viewLevel
    poli1arr    = Poli1 <$> 1 ... u ^. poli1 <<< viewLevel
    poli2arr    = Poli2 <$> 1 ... u ^. poli2 <<< viewLevel
    science1arr = Science1 <$> 1 ... u ^. science1 <<< viewLevel
    science2arr = Science2 <$> 1 ... u ^. science2 <<< viewLevel

cpsFromUpgrades :: Upgrades -> ClicksPerSecond
cpsFromUpgrades = view cps <<< makeUpgradedState

burstFromUpgrades :: Upgrades -> Clicks
burstFromUpgrades = view burst <<< makeUpgradedState

module Upgrades
  ( upgradeCost
  , upgradeName
  , nextUpgrade
  , canBuyUpgrade
  , upgradeDescription
  , buyUpgrade
  , isInflectionUpgrade
  , inflectionUpgradeMessage
  , cpsFromUpgrades
  , burstFromUpgrades
  ) where

import Prelude
import Data.Foldable (elem, sum, foldl)
import Data.Array (concat)
import Data.Int (toNumber)
import Data.Lens (LensP(), (^.), (+~), (-~), (.~), view)

import Types
import Lenses
import Util

upgradeCost :: Upgrade -> Clicks
upgradeCost (Misc1 n)    = Clicks (upgradeCostPolynomial 10.0 n)
upgradeCost (Misc2 n)    = Clicks (upgradeCostPolynomial 500.0 n)
upgradeCost (Tech1 n)    = Clicks (upgradeCostPolynomial 7500.0 n)
upgradeCost (Tech2 n)    = Clicks (upgradeCostPolynomial 950000.0 n)
upgradeCost (Phil1 n)    = Clicks (upgradeCostPolynomial 8250000.0 n)
upgradeCost (Phil2 n)    = Clicks (upgradeCostPolynomial 52000000.0 n)
upgradeCost (Poli1 n)    = Clicks (upgradeCostPolynomial 800000000.0 n)
upgradeCost (Poli2 n)    = Clicks (upgradeCostPolynomial 80500000000.0 n)
upgradeCost (Science1 n) = Clicks (upgradeCostPolynomial 8005000000000.0 n)
upgradeCost (Science2 n) = Clicks (upgradeCostPolynomial 750000000000000.0 n)

upgradeCostPolynomial :: Number -> Int -> Number
upgradeCostPolynomial coeff level = upgradeCostModifier level * coeff * 1.2 ^ (toNumber level)

upgradeCostModifier :: Int -> Number
upgradeCostModifier n
  | n <= 10 = 1.5
  | n <= 25 = 1.0
  | n <= 50 = 0.75
  | n <= 75 = 0.5
  | n <= 100 = 0.25
  | otherwise = 0.125

upgradeName :: Upgrade -> Age -> String
upgradeName (Misc1 _) Stone = "language"
upgradeName (Misc2 _) Stone = "spear tips"
upgradeName (Tech1 _) Stone = "fire!"
upgradeName (Tech2 _) Stone = "stone tools"
upgradeName (Phil1 _) Stone = "funeral rites"
upgradeName (Phil2 _) Stone = "cave paintings"
upgradeName (Poli1 _) Stone = "basic fishing"
upgradeName (Poli2 _) Stone = "rudimentary farming"
upgradeName (Science1 _) Stone = "dog domestication"
upgradeName (Science2 _) Stone = "abstract numbers"

upgradeDescription :: Upgrade -> Age -> String
upgradeDescription (Misc1 _) Stone = "No more grunt-and-point for you!"
upgradeDescription (Misc2 _) Stone = "Tip: a well-balanced spear is crucial for hunting."
upgradeDescription (Tech1 _) Stone = "We DID start the fire."
upgradeDescription (Tech2 _) Stone = "Never leave the Stone Age without 'em."
upgradeDescription (Phil1 _) Stone = "Funerals are a basic human rite."
upgradeDescription (Phil2 _) Stone = "You're no Picasso, but your paintings will last longer."
upgradeDescription (Poli1 _) Stone = "Fishing for landsharks?"
upgradeDescription (Poli2 _) Stone = "Can I interest you in some delicious BEETS?"
upgradeDescription (Science1 _) Stone = "A Clickonian's best friend."
upgradeDescription (Science2 _) Stone = "You've discovered that two clicks and two dogs both share 'twoness.' You also almost discovered the ultrafilter lemma, but you couldn't write it down fast enough."

nextUpgrade :: Upgrade -> Upgrade
nextUpgrade (Misc1 n) = Misc1 (n + 1)
nextUpgrade (Misc2 n) = Misc2 (n + 1)
nextUpgrade (Tech1 n) = Tech1 (n + 1)
nextUpgrade (Tech2 n) = Tech2 (n + 1)
nextUpgrade (Phil1 n) = Phil1 (n + 1)
nextUpgrade (Phil2 n) = Phil2 (n + 1)
nextUpgrade (Poli1 n) = Poli1 (n + 1)
nextUpgrade (Poli2 n) = Poli2 (n + 1)
nextUpgrade (Science1 n) = Science1 (n + 1)
nextUpgrade (Science2 n) = Science2 (n + 1)

canBuyUpgrade :: State -> LensP Upgrades Upgrade -> Boolean
canBuyUpgrade state optic =
  let currClicks = state ^. currentClicks
      currUpgrade = state ^. upgrades <<< optic
      next = nextUpgrade currUpgrade
      nextCost = upgradeCost next
   in currClicks >= nextCost

upgradeBoost :: Upgrade -> Number
upgradeBoost (Misc1 n)    = 0.5 * upgradeBoostModifier n
upgradeBoost (Misc2 n)    = 4.0 * upgradeBoostModifier n
upgradeBoost (Tech1 n)    = 30.0 * upgradeBoostModifier n
upgradeBoost (Tech2 n)    = 400.0 * upgradeBoostModifier n
upgradeBoost (Phil1 n)    = 6000.0 * upgradeBoostModifier n
upgradeBoost (Phil2 n)    = 12220.5 * upgradeBoostModifier n
upgradeBoost (Poli1 n)    = 214592.6 * upgradeBoostModifier n
upgradeBoost (Poli2 n)    = 1712818.2 * upgradeBoostModifier n
upgradeBoost (Science1 n) = 49000000.0 * upgradeBoostModifier n
upgradeBoost (Science2 n) = 100000000.0 * upgradeBoostModifier n

upgradeBoostModifier :: Int -> Number
upgradeBoostModifier n
  | n <= 10 = 1.0
  | n <= 25 = 4.0
  | n <= 50 = 16.0
  | n <= 75 = 64.0
  | n <= 100 = 256.0
  | otherwise = 1024.0

buyUpgrade :: Upgrade -> State -> State
buyUpgrade up@(Misc1 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up misc1
buyUpgrade up@(Misc2 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up misc2
buyUpgrade up@(Tech1 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up tech1
buyUpgrade up@(Tech2 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up tech2
buyUpgrade up@(Phil1 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up phil1
buyUpgrade up@(Phil2 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up phil2
buyUpgrade up@(Poli1 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up poli1
buyUpgrade up@(Poli2 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up poli2
buyUpgrade up@(Science1 _) = installUpgrade up cpsNumber 0.75
                         <<< installUpgrade up burstNumber 0.3
                         <<< recordPurchase up science1
buyUpgrade up@(Science2 _) = installUpgrade up cpsNumber 0.75
                         <<< installUpgrade up burstNumber 0.3
                         <<< recordPurchase up science2

recordPurchase :: Upgrade -> LensP Upgrades Upgrade -> State -> State
recordPurchase up optic = (currentClicks -~ upgradeCost up)
                      <<< (upgrades <<< optic .~ up)

installUpgrade :: Upgrade -> LensP State Number -> Number -> State -> State
installUpgrade up optic coeff = optic +~ coeff * upgradeBoost up

isInflectionUpgrade :: Upgrade -> Boolean
isInflectionUpgrade up = (up ^. viewLevel) `elem` [10, 25, 50, 75, 100]

inflectionUpgradeMessage :: Upgrade -> Age -> String
inflectionUpgradeMessage up age = upgradeName up age ++ " cost down, boost up"

makeUpgradedState :: Upgrades -> State
makeUpgradedState u = foldl (flip buyUpgrade) initialState upArray
  where
    upArray = concat [ misc1arr, misc2arr, tech1arr, tech2arr, phil1arr
                     , phil2arr, poli1arr, poli2arr, science1arr, science2arr ]
    misc1arr    = Misc1 <$> 1 ... u ^. misc1 <<< viewLevel
    misc2arr    = Misc2 <$> 1 ... u ^. misc2 <<< viewLevel
    tech1arr    = Tech1 <$> 1 ... u ^. tech1 <<< viewLevel
    tech2arr    = Tech2 <$> 1 ... u ^. tech2 <<< viewLevel
    phil1arr    = Phil1 <$> 1 ... u ^. phil1 <<< viewLevel
    phil2arr    = Phil2 <$> 1 ... u ^. phil2 <<< viewLevel
    poli1arr    = Poli1 <$> 1 ... u ^. poli1 <<< viewLevel
    poli2arr    = Poli2 <$> 1 ... u ^. poli2 <<< viewLevel
    science1arr = Science1 <$> 1 ... u ^. science1 <<< viewLevel
    science2arr = Science2 <$> 1 ... u ^. science2 <<< viewLevel

cpsFromUpgrades :: Upgrades -> ClicksPerSecond
cpsFromUpgrades = view cps <<< makeUpgradedState

burstFromUpgrades :: Upgrades -> Clicks
burstFromUpgrades = view burst <<< makeUpgradedState


incorrect font size in funnel

incorrect font size in funnel

module SlamData.Workspace.Card.BuildChart.Funnel.Eval
  ( eval
  , module SlamData.Workspace.Card.BuildChart.Funnel.Model
  ) where

import SlamData.Prelude

import Data.Argonaut (JArray, Json, cursorGet, toString)
import Data.Array as A
import Data.Lens ((^?))
import Data.Map as M
import Data.Set as Set

import ECharts.Monad (DSL)
import ECharts.Commands as E
import ECharts.Types as ET
import ECharts.Types.Phantom (OptionI)
import ECharts.Types.Phantom as ETP

import Quasar.Types (FilePath)

import SlamData.Common.Sort (Sort(..))
import SlamData.Common.Align (Align(..))
import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.Error as QE
import SlamData.Workspace.Card.BuildChart.Common.Eval (type (>>))
import SlamData.Workspace.Card.BuildChart.Common.Eval as BCE
import SlamData.Workspace.Card.BuildChart.Funnel.Model (Model, FunnelR)
import SlamData.Workspace.Card.CardType.ChartType (ChartType(Funnel))
import SlamData.Workspace.Card.BuildChart.Aggregation as Ag
import SlamData.Workspace.Card.BuildChart.ColorScheme (colors)
import SlamData.Workspace.Card.BuildChart.Semantics (analyzeJson, semanticsToNumber)
import SlamData.Workspace.Card.Eval.CardEvalT as CET
import SlamData.Workspace.Card.Port as Port

eval
  ∷ ∀ m
  . (Monad m, QuasarDSL m)
  ⇒ Model
  → FilePath
  → CET.CardEvalT m Port.Port
eval Nothing _ =
  QE.throw "Please select axis to aggregate"
eval (Just conf) resource = do
  records ← BCE.records resource
  pure $ Port.ChartInstructions (buildFunnel conf records) Funnel

type FunnelSeries =
  { name ∷ Maybe String
  , items ∷ String >> Number
  , x ∷ Maybe Number
  , y ∷ Maybe Number
  , w ∷ Maybe Number
  , h ∷ Maybe Number
  }

buildFunnelData ∷ FunnelR → JArray → Array FunnelSeries
buildFunnelData r records = series
  where
  -- | maybe series >> category >> values
  dataMap ∷ Maybe String >> String >> Array Number
  dataMap =
    foldl dataMapFoldFn M.empty records

  dataMapFoldFn
    ∷ Maybe String >> String >> Array Number
    → Json
    → Maybe String >> String >> Array Number
  dataMapFoldFn acc js =
    case toString =<< cursorGet r.category js of
      Nothing → acc
      Just categoryKey →
        let
          mbSeries = toString =<< flip cursorGet js =<< r.series
          values =
            foldMap A.singleton
              $ semanticsToNumber =<< analyzeJson =<< cursorGet r.value js

          alterSeriesFn
            ∷ Maybe (String >> Array Number)
            → Maybe (String >> Array Number)
          alterSeriesFn Nothing =
            Just $ M.singleton categoryKey values
          alterSeriesFn (Just sers) =
            Just $ M.alter alterCategoryFn categoryKey sers

          alterCategoryFn
            ∷ Maybe (Array Number)
            → Maybe (Array Number)
          alterCategoryFn Nothing = Just values
          alterCategoryFn (Just arr) = Just $ arr ⊕ values
        in
          M.alter alterSeriesFn mbSeries acc

  rawSeries ∷ Array FunnelSeries
  rawSeries =
    foldMap mkOneSeries $ M.toList dataMap

  mkOneSeries
    ∷ Maybe String × (String >> Array Number)
    → Array FunnelSeries
  mkOneSeries (name × ss) =
    [{ name
     , x: Nothing
     , y: Nothing
     , w: Nothing
     , h: Nothing
     , items: map (Ag.runAggregation r.valueAggregation) ss
     }]

  series ∷ Array FunnelSeries
  series = adjustPosition rawSeries

  adjustPosition ∷ Array FunnelSeries → Array FunnelSeries
  adjustPosition = id

buildFunnel ∷ FunnelR → JArray → DSL OptionI
buildFunnel r records = do
  E.tooltip do
    E.triggerItem
    E.textStyle do
      E.fontFamily "Ubuntu, sans"
      E.fontSize 12

  E.legend do
    E.items $ map ET.strItem legendNames
    E.topBottom
    E.textStyle do
      E.fontFamily "Ubuntu, sans"

  E.colors colors

  E.titles
    $ traverse_ E.title titles

  E.series series

  where
  funnelData ∷ Array FunnelSeries
  funnelData = buildFunnelData r records

  legendNames ∷ Array String
  legendNames =
    A.fromFoldable
      $ foldMap (_.name ⋙ foldMap Set.singleton) funnelData

  titles ∷ Array (DSL ETP.TitleI)
  titles = funnelData <#> \{name, x, y} → do
    for_ name E.text
    E.textStyle do
      E.fontFamily "Ubunut, sans"
      E.fontSize 12
    traverse_ (E.top ∘ ET.Percent) y
    traverse_ (E.left ∘ ET.Percent) x
    E.textCenter
    E.textBottom

  series ∷ ∀ i. DSL (funnel ∷ ETP.I|i)
  series = for_ funnelData \{x, y, w, h, items, name} → E.funnel do
    traverse_ E.widthPct w
    traverse_ E.heightPct h
    for_ name E.name
    case r.order of
      Asc → E.ascending
      Desc → E.descending
    case r.align of
      LeftAlign → E.funnelLeft
      RightAlign → E.funnelRight
      CenterAlign → E.funnelCenter
    E.label $ E.normal $ E.textStyle $ E.fontFamily "Ubuntu, sans"
    E.buildItems $ for_ (M.toList items) \(name × value) → E.addItem do
      E.name name
      E.value value
    traverse_ (E.top ∘ ET.Percent) y
    traverse_ (E.left ∘ ET.Percent) x

module SlamData.Workspace.Card.BuildChart.Funnel.Eval
  ( eval
  , module SlamData.Workspace.Card.BuildChart.Funnel.Model
  ) where

import SlamData.Prelude

import Data.Argonaut (JArray, Json, cursorGet, toString)
import Data.Array as A
import Data.Lens ((^?))
import Data.Map as M
import Data.Set as Set

import ECharts.Monad (DSL)
import ECharts.Commands as E
import ECharts.Types as ET
import ECharts.Types.Phantom (OptionI)
import ECharts.Types.Phantom as ETP

import Quasar.Types (FilePath)

import SlamData.Common.Sort (Sort(..))
import SlamData.Common.Align (Align(..))
import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.Error as QE
import SlamData.Workspace.Card.BuildChart.Common.Eval (type (>>))
import SlamData.Workspace.Card.BuildChart.Common.Eval as BCE
import SlamData.Workspace.Card.BuildChart.Funnel.Model (Model, FunnelR)
import SlamData.Workspace.Card.CardType.ChartType (ChartType(Funnel))
import SlamData.Workspace.Card.BuildChart.Aggregation as Ag
import SlamData.Workspace.Card.BuildChart.ColorScheme (colors)
import SlamData.Workspace.Card.BuildChart.Semantics (analyzeJson, semanticsToNumber)
import SlamData.Workspace.Card.Eval.CardEvalT as CET
import SlamData.Workspace.Card.Port as Port

eval
  ∷ ∀ m
  . (Monad m, QuasarDSL m)
  ⇒ Model
  → FilePath
  → CET.CardEvalT m Port.Port
eval Nothing _ =
  QE.throw "Please select axis to aggregate"
eval (Just conf) resource = do
  records ← BCE.records resource
  pure $ Port.ChartInstructions (buildFunnel conf records) Funnel

type FunnelSeries =
  { name ∷ Maybe String
  , items ∷ String >> Number
  , x ∷ Maybe Number
  , y ∷ Maybe Number
  , w ∷ Maybe Number
  , h ∷ Maybe Number
  }

buildFunnelData ∷ FunnelR → JArray → Array FunnelSeries
buildFunnelData r records = series
  where
  -- | maybe series >> category >> values
  dataMap ∷ Maybe String >> String >> Array Number
  dataMap =
    foldl dataMapFoldFn M.empty records

  dataMapFoldFn
    ∷ Maybe String >> String >> Array Number
    → Json
    → Maybe String >> String >> Array Number
  dataMapFoldFn acc js =
    case toString =<< cursorGet r.category js of
      Nothing → acc
      Just categoryKey →
        let
          mbSeries = toString =<< flip cursorGet js =<< r.series
          values =
            foldMap A.singleton
              $ semanticsToNumber =<< analyzeJson =<< cursorGet r.value js

          alterSeriesFn
            ∷ Maybe (String >> Array Number)
            → Maybe (String >> Array Number)
          alterSeriesFn Nothing =
            Just $ M.singleton categoryKey values
          alterSeriesFn (Just sers) =
            Just $ M.alter alterCategoryFn categoryKey sers

          alterCategoryFn
            ∷ Maybe (Array Number)
            → Maybe (Array Number)
          alterCategoryFn Nothing = Just values
          alterCategoryFn (Just arr) = Just $ arr ⊕ values
        in
          M.alter alterSeriesFn mbSeries acc

  rawSeries ∷ Array FunnelSeries
  rawSeries =
    foldMap mkOneSeries $ M.toList dataMap

  mkOneSeries
    ∷ Maybe String × (String >> Array Number)
    → Array FunnelSeries
  mkOneSeries (name × ss) =
    [{ name
     , x: Nothing
     , y: Nothing
     , w: Nothing
     , h: Nothing
     , items: map (Ag.runAggregation r.valueAggregation) ss
     }]

  series ∷ Array FunnelSeries
  series = adjustPosition rawSeries

  adjustPosition ∷ Array FunnelSeries → Array FunnelSeries
  adjustPosition = id

buildFunnel ∷ FunnelR → JArray → DSL OptionI
buildFunnel r records = do
  E.tooltip do
    E.triggerItem
    E.textStyle do
      E.fontFamily "Ubuntu, sans"
      E.fontSize 122

  E.legend do
    E.items $ map ET.strItem legendNames
    E.topBottom
    E.textStyle do
      E.fontFamily "Ubuntu, sans"

  E.colors colors

  E.titles
    $ traverse_ E.title titles

  E.series series

  where
  funnelData ∷ Array FunnelSeries
  funnelData = buildFunnelData r records

  legendNames ∷ Array String
  legendNames =
    A.fromFoldable
      $ foldMap (_.name ⋙ foldMap Set.singleton) funnelData

  titles ∷ Array (DSL ETP.TitleI)
  titles = funnelData <#> \{name, x, y} → do
    for_ name E.text
    E.textStyle do
      E.fontFamily "Ubunut, sans"
      E.fontSize 12
    traverse_ (E.top ∘ ET.Percent) y
    traverse_ (E.left ∘ ET.Percent) x
    E.textCenter
    E.textBottom

  series ∷ ∀ i. DSL (funnel ∷ ETP.I|i)
  series = for_ funnelData \{x, y, w, h, items, name} → E.funnel do
    traverse_ E.widthPct w
    traverse_ E.heightPct h
    for_ name E.name
    case r.order of
      Asc → E.ascending
      Desc → E.descending
    case r.align of
      LeftAlign → E.funnelLeft
      RightAlign → E.funnelRight
      CenterAlign → E.funnelCenter
    E.label $ E.normal $ E.textStyle $ E.fontFamily "Ubuntu, sans"
    E.buildItems $ for_ (M.toList items) \(name × value) → E.addItem do
      E.name name
      E.value value
    traverse_ (E.top ∘ ET.Percent) y
    traverse_ (E.left ∘ ET.Percent) x