Move toward sensible coordinates w/ functorial coordsys

module Genetics.Browser.Types.Coordinates where

import Prelude

import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Filterable (class Filterable, filter)
import Data.Foldable (length, sum)
import Data.Int as Int
import Data.Lens (Lens', Traversal', Lens, foldMapOf, lens, previewOn, traversed, view, (%~))
import Data.Lens (filtered) as Lens
import Data.Lens.Record (prop) as Lens
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype, unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Ratio (Ratio, (%))
import Data.Ratio as Ratio
import Data.Symbol (SProxy(..))
import Data.Tuple (Tuple(Tuple), uncurry)
import Genetics.Browser.Types (Bp, Point)
import Genetics.Browser.View (Pixels)
import Graphics.Canvas as Canvas

-- The global coordinate system works by taking the sum of the chromosome sizes;
-- we represent it using a BigInt

-- Consider making it a wrapper on Ratio BigInt instead.
-- Would ensure exactness when moving between global & interval points...
-- ... while that shouldn't be a problem anyway, it would make things feel safer.
newtype BrowserPoint = BPoint BigInt

derive instance eqBrowserPoint :: Eq BrowserPoint
derive instance ordBrowserPoint :: Ord BrowserPoint
derive instance newtypeBrowserPoint :: Newtype BrowserPoint _

derive newtype instance ringBrowserPoint :: Ring BrowserPoint
derive newtype instance semiringBrowserPoint :: Semiring BrowserPoint
derive newtype instance commutativeringBrowserPoint :: CommutativeRing BrowserPoint
derive newtype instance euclideanringBrowserPoint :: EuclideanRing BrowserPoint

-- Subsets of the global coordinate system are defined by some interval,
--

-- data Interval c = Interval c c

type Interval = Pair

type RelPoint = Ratio BigInt
-- data IntervalPoint c = IntervalPoint (Interval c) RelPoint

relPointToNumber :: RelPoint -> Number
relPointToNumber p =
  let d = Ratio.denominator p
      n = Ratio.numerator p
      qt = BigInt.toNumber $ n / d
      -- rm = BigInt.toNumber $ case n `mod` d of
      --                          0 -> 1
      --                          x -> x
      -- TODO be safer by using Number.EPSILON etc.
      -- eps =  2.220446049250313e-16
      -- epsD =  BigInt.fromString "22204460492503130000000000000000"
  in qt -- + (rm / (BigInt.toNumber d))

intervalSize :: forall c.
                Ring c
             => Interval c
             -> c
intervalSize (Pair l r) = r - l

inInterval :: forall c.
               Ord c
            => c
            -> Interval c
            -> Boolean
inInterval p (Pair l r) = l <= p && p <= r

-- TODO test this
intervalsOverlap :: forall c.
                    Ord c
                 => Interval c
                 -> Interval c
                 -> Boolean
intervalsOverlap (Pair l1 r1) (Pair l2 r2) =
  let (Pair l1' r1') = Pair (min l1 l2) (min r1 r2)
      (Pair l2' r2') = Pair (max l1 l2) (max r1 r2)
  in r1' >= l2'

coveringIntervals :: forall f i c.
                     Ord c
                  => Filterable f
                  => Interval c
                  -> f (Interval c)
                  -> f (Interval c)
coveringIntervals iv = filter (intervalsOverlap iv)

type CoordInterval i c = { index :: i
                         , interval :: Interval c
                         , chrSize :: Bp }

_Index :: forall i c. Lens' (CoordInterval i c) i
_Index = Lens.prop (SProxy :: SProxy "index")

_Interval :: forall i a b.
             Lens
             (CoordInterval i a) (CoordInterval i b)
             (Interval a) (Interval b)
_Interval = Lens.prop (SProxy :: SProxy "interval")

_ChrSize :: forall i c. Lens' (CoordInterval i c) Bp
_ChrSize = Lens.prop (SProxy :: SProxy "chrSize")

type CoordSysRec i c =
  { size :: c
  , padding :: c
  , intervals :: Array (CoordInterval i c)
  }

newtype CoordSys i c =
  CoordSys (CoordSysRec i c)

instance functorCoordSys :: Functor (CoordSys i) where
  map :: forall a b. (a -> b) -> CoordSys i a -> CoordSys i b
  map f (CoordSys r) = CoordSys $ { size: f r.size
                                  , padding: f r.padding
                                  , intervals: map (_Interval %~ (map f)) r.intervals }

_CoordSys :: forall i c. Lens' (CoordSys i c) (CoordSysRec i c)
_CoordSys = lens (\(CoordSys x) -> x) (\(CoordSys _) x -> CoordSys x)

_BrowserIntervals :: forall i c. Lens' (CoordSys i c) (Array (CoordInterval i c))
_BrowserIntervals =   _CoordSys
                  <<< Lens.prop (SProxy :: SProxy "intervals")

_BrowserSize :: forall i c. Lens' (CoordSys i c) c
_BrowserSize =   _CoordSys
             <<< Lens.prop (SProxy :: SProxy "size")

_BrowserPadding :: forall i c. Lens' (CoordSys i c) c
_BrowserPadding =   _CoordSys
                <<< Lens.prop (SProxy :: SProxy "padding")

screenScaledIntervals :: forall i a r.
                         Ord i
                      => CoordSys i BrowserPoint
                      -> Pixels
                      -> BrowserPoint
                      -> Map i (Interval Pixels)
screenScaledIntervals cs canvasWidth viewWidth =
  let width :: Pixels
      width = BigInt.toNumber (unwrap viewWidth)
      scale :: BrowserPoint -> Pixels
      scale p = ((BigInt.toNumber $ unwrap p) * canvasWidth) / width
  in (map <<< map) scale $ (view _Interval <$> intervalsToMap cs)

intervalsToMap :: forall i c.
                  Ord i
               => CoordSys i c
               -> Map i (CoordInterval i c)
intervalsToMap (CoordSys {intervals}) = Map.fromFoldable $ map f intervals
  where f ci@{index} = Tuple index ci

lookupInterval :: forall i c.
                  Ord i
               => CoordSys i c
               -> i
               -> Maybe (CoordInterval i c)
lookupInterval cs i = Map.lookup i $ intervalsToMap cs

findIntervalFromGlobal :: forall f i c r.
                          Ord c
                       => c
                       -> Array { interval :: Interval c | r }
                       -> Maybe { interval :: Interval c | r }
findIntervalFromGlobal x = Array.find (inInterval x <<< _.interval)

findBrowserInterval :: forall i c.
                       Ord c
                    => CoordSys i c
                    -> c
                    -> Maybe (CoordInterval i c)
findBrowserInterval cs x = previewOn cs
                            (_BrowserIntervals
                             <<< traversed
                             <<< Lens.filtered
                             (inInterval x <<< view _Interval))

viewIntervals :: forall i c.
                 Ord c
              => CoordSys i c
              -> Interval c
              -> Array (CoordInterval i c)
viewIntervals cs vw = foldMapOf inView pure cs
  where inView = _BrowserIntervals
                 <<< traversed
                 <<< Lens.filtered
                 (intervalsOverlap vw <<< view _Interval)

globalToInterval :: forall c.
                    Newtype c BigInt
                 => Interval c
                 -> c
                 -> RelPoint
globalToInterval v x = globalToInterval' (map unwrap v) (unwrap x)

globalToInterval' :: forall c.
                     Ord c
                  => EuclideanRing c
                  => Interval c
                  -> c
                  -> Ratio c
globalToInterval' (Pair l r) x =
  let n = x - l
      d = max one (r - l)
  in n % d

-- Global <-> Interval are isomorphic for big enough intervals...
intervalToGlobal :: forall c.
                    Newtype c BigInt
                 => Interval c
                 -> RelPoint
                 -> c
intervalToGlobal v x = wrap $ intervalToGlobal' (map unwrap v) x

intervalToGlobal' :: forall c.
                     Ord c
                  => Show c
                  => EuclideanRing c
                  => Interval c
                  -> Ratio c
                  -> c
intervalToGlobal' iv@(Pair l r) p =
  let d1 = max one (r - l)
      d2 = Ratio.denominator p
      a = d1 / d2
      n = a * Ratio.numerator p
  in l + n

offsets :: BigInt -> Array BigInt -> Array (Pair BigInt)
offsets pad xs = ivals
  where os = Array.scanl (\x y -> pad + x + y) zero xs
        ivals = Array.zipWith Pair (zero `Array.cons` os) os

mkCoordSys :: forall i c.
           Array (Tuple i BigInt)
        -> BigInt
        -> CoordSys i BrowserPoint
mkCoordSys chrs pad = CoordSys { size
                               , intervals
                               , padding
                               }
  where (Tuple ids sizes) = Array.unzip chrs
        ivals = (map <<< map) wrap $ offsets pad sizes

        f :: i -> BigInt -> { index :: i, chrSize :: Bp }
        f index s = { index, chrSize: wrap $ BigInt.toNumber s }

        g :: Interval BrowserPoint -> { index :: i, chrSize :: _ } -> _
        g interval { index, chrSize } = { interval, index, chrSize }

        intervals :: Array (CoordInterval i _)
        intervals = Array.zipWith g ivals (uncurry f <$> chrs)

        size' = (sum sizes) + (length sizes * pad)
        size :: BrowserPoint
        size = wrap size'
        padding :: BrowserPoint
        padding = wrap pad

canvasToView :: forall r.
                { width :: Number | r }
             -> Number
             -> RelPoint
canvasToView {width} x = globalToInterval' (Pair zero w') x'
  where (Pair x' w') = BigInt.fromInt <<< Int.round <$> Pair x width

canvasToBrowserPoint :: forall r.
                        { width :: Number | r }
                     -> Interval BrowserPoint
                     -> Number
                     -> BrowserPoint
canvasToBrowserPoint cw v@(Pair vL vR) x =
  intervalToGlobal v $ (canvasToView cw x)

browserPointToCanvas :: forall r.
                        Canvas.Dimensions
                     -> Interval BrowserPoint
                     -> BrowserPoint
                     -> Number
browserPointToCanvas screenSize v@(Pair vL vR) p = relPointToNumber pixels'
  where viewSize :: BigInt
        viewSize = unwrap $ intervalSize v
        width' = BigInt.fromInt $ Int.round screenSize.width
        -- Pixels/BrowserPoint
        scale :: Ratio BigInt
        scale = width' % viewSize
        pixels' = (unwrap (p - vL) % one) * scale

intervalToScreen :: forall i c r.
                    Canvas.Dimensions
                 -> Interval BrowserPoint
                 -> Interval BrowserPoint
                 -> { width :: Number, offset :: Number }
intervalToScreen screen v interval = {width, offset}
  where (Pair l r) = browserPointToCanvas screen v <$> interval
        width = r - l
        offset = l

shiftIntervalBy :: forall c.
                   Newtype c BigInt
                => Interval c
                -> Ratio BigInt
                -> Interval c
shiftIntervalBy v rat = wrap <$> shiftIntervalBy' (unwrap <$> v) rat

shiftIntervalBy' :: forall c.
                    EuclideanRing c
                 => Interval c
                 -> Ratio c
                 -> Interval c
shiftIntervalBy' v@(Pair l r) rat =
  let diff = ((r - l) * (Ratio.numerator rat)) / (Ratio.denominator rat)
  in Pair (l + diff) (r + diff)

zoomIntervalBy :: forall c.
                  Newtype c BigInt
               => Interval c
               -> Ratio BigInt
               -> Interval c
zoomIntervalBy v r = wrap <$> zoomIntervalBy' (unwrap <$> v) r

zoomIntervalBy' :: forall c.
                   EuclideanRing c
                => Interval c
                -> Ratio c
                -> Interval c
zoomIntervalBy' v@(Pair l r) rat =
  let diff = ((r - l) * (Ratio.numerator rat)) / (Ratio.denominator rat)
  in Pair (l - diff) (r + diff)

newtype Normalized a = Normalized a

derive instance newtypeNormalized :: Newtype (Normalized a) _

normalizePoint :: { width :: Number
                  , height :: Number }
               -> Point
               -> Normalized Point
normalizePoint {width, height} {x, y} = Normalized { x: x', y: y' }
  where x' = x / width
        y' = y / height

normPoint :: Point -> Maybe (Normalized Point)
normPoint p@{x, y}
  | x < 0.0 || x > 1.0 = Nothing
  | y < 0.0 || y > 1.0 = Nothing
  | otherwise = Just $ Normalized p

nPointToFrame :: Pixels -> Pixels -> Normalized Point -> Point
nPointToFrame w h (Normalized p) = {x: p.x * w, y: p.y * h}

module Genetics.Browser.Types.Coordinates where

import Prelude

import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Filterable (class Filterable, filter)
import Data.Foldable (length, sum)
import Data.Int as Int
import Data.Lens (Lens', Traversal', foldMapOf, lens, previewOn, traversed, view)
import Data.Lens (filtered) as Lens
import Data.Lens.Record (prop) as Lens
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype, unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Ratio (Ratio, (%))
import Data.Ratio as Ratio
import Data.Symbol (SProxy(..))
import Data.Tuple (Tuple(Tuple), uncurry)
import Genetics.Browser.Types (Bp, Point)
import Genetics.Browser.View (Pixels)
import Graphics.Canvas as Canvas

-- The global coordinate system works by taking the sum of the chromosome sizes;
-- we represent it using a BigInt

-- Consider making it a wrapper on Ratio BigInt instead.
-- Would ensure exactness when moving between global & interval points...
-- ... while that shouldn't be a problem anyway, it would make things feel safer.
newtype BrowserPoint = BPoint BigInt

derive instance eqBrowserPoint :: Eq BrowserPoint
derive instance ordBrowserPoint :: Ord BrowserPoint
derive instance newtypeBrowserPoint :: Newtype BrowserPoint _

derive newtype instance ringBrowserPoint :: Ring BrowserPoint
derive newtype instance semiringBrowserPoint :: Semiring BrowserPoint
derive newtype instance commutativeringBrowserPoint :: CommutativeRing BrowserPoint
derive newtype instance euclideanringBrowserPoint :: EuclideanRing BrowserPoint

-- Subsets of the global coordinate system are defined by some interval,
--

-- data Interval c = Interval c c

type Interval = Pair

type RelPoint = Ratio BigInt
-- data IntervalPoint c = IntervalPoint (Interval c) RelPoint

relPointToNumber :: RelPoint -> Number
relPointToNumber p =
  let d = Ratio.denominator p
      n = Ratio.numerator p
      qt = BigInt.toNumber $ n / d
      -- rm = BigInt.toNumber $ case n `mod` d of
      --                          0 -> 1
      --                          x -> x
      -- TODO be safer by using Number.EPSILON etc.
      -- eps =  2.220446049250313e-16
      -- epsD =  BigInt.fromString "22204460492503130000000000000000"
  in qt -- + (rm / (BigInt.toNumber d))

intervalSize :: forall c.
                Ring c
             => Interval c
             -> c
intervalSize (Pair l r) = r - l

inInterval :: forall c.
               Ord c
            => c
            -> Interval c
            -> Boolean
inInterval p (Pair l r) = l <= p && p <= r

-- TODO test this
intervalsOverlap :: forall c.
                    Ord c
                 => Interval c
                 -> Interval c
                 -> Boolean
intervalsOverlap (Pair l1 r1) (Pair l2 r2) =
  let (Pair l1' r1') = Pair (min l1 l2) (min r1 r2)
      (Pair l2' r2') = Pair (max l1 l2) (max r1 r2)
  in r1' >= l2'

p0 = Pair 0 0
p1 = Pair 0 2
p2 = Pair 2 4
p3 = Pair 3 4
p4 = Pair (-2) (-1)

coveringIntervals :: forall f i c.
                     Ord c
                  => Filterable f
                  => Interval c
                  -> f (Interval c)
                  -> f (Interval c)
coveringIntervals iv = filter (intervalsOverlap iv)

-- type ChrInterval c = { interval :: Interval c, chrSize :: Number }

type CoordInterval i c = { index :: i
                         , interval :: Interval c
                         , chrSize :: Bp }

_Index :: forall i c. Lens' (CoordInterval i c) i
_Index = Lens.prop (SProxy :: SProxy "index")

_Interval :: forall i c. Lens' (CoordInterval i c) (Interval c)
_Interval = Lens.prop (SProxy :: SProxy "interval")

_ChrSize :: forall i c. Lens' (CoordInterval i c) Bp
_ChrSize = Lens.prop (SProxy :: SProxy "chrSize")

type CoordSysRec i c =
  { size :: c
  , padding :: c
  , intervals :: Array (CoordInterval i c)
  }

newtype CoordSys i c =
  CoordSys (CoordSysRec i c)

-- traversed :: forall t a b. Traversable t => Traversal (t a) (t b) a b
_CoordSys :: forall i c. Lens' (CoordSys i c) (CoordSysRec i c)
_CoordSys = lens (\(CoordSys x) -> x) (\(CoordSys _) x -> CoordSys x)

_BrowserIntervals :: forall i c. Lens' (CoordSys i c) (Array (CoordInterval i c))
_BrowserIntervals =   _CoordSys
                  <<< Lens.prop (SProxy :: SProxy "intervals")

_BrowserSize :: forall i c. Lens' (CoordSys i c) c
_BrowserSize =   _CoordSys
             <<< Lens.prop (SProxy :: SProxy "size")

_BrowserPadding :: forall i c. Lens' (CoordSys i c) c
_BrowserPadding =   _CoordSys
                <<< Lens.prop (SProxy :: SProxy "padding")

intervalsToMap :: forall i c.
                  Ord i
               => CoordSys i c
               -> Map i (CoordInterval i c)
intervalsToMap (CoordSys {intervals}) = Map.fromFoldable $ map f intervals
  where f ci@{index} = Tuple index ci

lookupInterval :: forall i c.
                  Ord i
               => CoordSys i c
               -> i
               -> Maybe (CoordInterval i c)
lookupInterval cs i = Map.lookup i $ intervalsToMap cs

findIntervalFromGlobal :: forall f i c r.
                          Ord c
                       => c
                       -> Array { interval :: Interval c | r }
                       -> Maybe { interval :: Interval c | r }
findIntervalFromGlobal x = Array.find (inInterval x <<< _.interval)

findBrowserInterval :: forall i c.
                       Ord c
                    => CoordSys i c
                    -> c
                    -> Maybe (CoordInterval i c)
findBrowserInterval cs x = previewOn cs
                            (_BrowserIntervals
                             <<< traversed
                             <<< Lens.filtered
                             (inInterval x <<< view _Interval))

viewIntervals :: forall i c.
                 Ord c
              => CoordSys i c
              -> Interval c
              -> Array (CoordInterval i c)
viewIntervals cs vw = foldMapOf inView pure cs
  where inView = _BrowserIntervals
                 <<< traversed
                 <<< Lens.filtered
                 (intervalsOverlap vw <<< view _Interval)

globalToInterval :: forall c.
                    Newtype c BigInt
                 => Interval c
                 -> c
                 -> RelPoint
globalToInterval v x = globalToInterval' (map unwrap v) (unwrap x)

globalToInterval' :: forall c.
                     Ord c
                  => EuclideanRing c
                  => Interval c
                  -> c
                  -> Ratio c
globalToInterval' (Pair l r) x =
  let n = x - l
      d = max one (r - l)
  in n % d

-- Global <-> Interval are isomorphic for big enough intervals...
intervalToGlobal :: forall c.
                    Newtype c BigInt
                 => Interval c
                 -> RelPoint
                 -> c
intervalToGlobal v x = wrap $ intervalToGlobal' (map unwrap v) x

intervalToGlobal' :: forall c.
                     Ord c
                  => Show c
                  => EuclideanRing c
                  => Interval c
                  -> Ratio c
                  -> c
intervalToGlobal' iv@(Pair l r) p =
  let d1 = max one (r - l)
      d2 = Ratio.denominator p
      a = d1 / d2
      n = a * Ratio.numerator p
  in l + n

offsets :: BigInt -> Array BigInt -> Array (Pair BigInt)
offsets pad xs = ivals
  where os = Array.scanl (\x y -> pad + x + y) zero xs
        ivals = Array.zipWith Pair (zero `Array.cons` os) os

mkCoordSys :: forall i c.
           Array (Tuple i BigInt)
        -> BigInt
        -> CoordSys i BrowserPoint
mkCoordSys chrs pad = CoordSys { size
                               , intervals
                               , padding
                               }
  where (Tuple ids sizes) = Array.unzip chrs
        ivals = (map <<< map) wrap $ offsets pad sizes

        f :: i -> BigInt -> { index :: i, chrSize :: Bp }
        f index s = { index, chrSize: wrap $ BigInt.toNumber s }

        g :: Interval BrowserPoint -> { index :: i, chrSize :: _ } -> _
        g interval { index, chrSize } = { interval, index, chrSize }

        intervals :: Array (CoordInterval i _)
        intervals = Array.zipWith g ivals (uncurry f <$> chrs)

        size' = (sum sizes) + (length sizes * pad)
        size :: BrowserPoint
        size = wrap size'
        padding :: BrowserPoint
        padding = wrap pad

canvasToView :: forall r.
                { width :: Number | r }
             -> Number
             -> RelPoint
canvasToView {width} x = globalToInterval' (Pair zero w') x'
  where (Pair x' w') = BigInt.fromInt <<< Int.round <$> Pair x width

canvasToBrowserPoint :: forall r.
                        { width :: Number | r }
                     -> Interval BrowserPoint
                     -> Number
                     -> BrowserPoint
canvasToBrowserPoint cw v@(Pair vL vR) x =
  intervalToGlobal v $ (canvasToView cw x)

browserPointToCanvas :: forall r.
                        Canvas.Dimensions
                     -> Interval BrowserPoint
                     -> BrowserPoint
                     -> Number
browserPointToCanvas screenSize v@(Pair vL vR) p = relPointToNumber pixels'
  where viewSize :: BigInt
        viewSize = unwrap $ intervalSize v
        width' = BigInt.fromInt $ Int.round screenSize.width
        -- Pixels/BrowserPoint
        scale :: Ratio BigInt
        scale = width' % viewSize
        pixels' = (unwrap (p - vL) % one) * scale

intervalToScreen :: forall i c r.
                    Canvas.Dimensions
                 -> Interval BrowserPoint
                 -> Interval BrowserPoint
                 -> { width :: Number, offset :: Number }
intervalToScreen screen v interval = {width, offset}
  where (Pair l r) = browserPointToCanvas screen v <$> interval
        width = r - l
        offset = l

shiftIntervalBy :: forall c.
                   Newtype c BigInt
                => Interval c
                -> Ratio BigInt
                -> Interval c
shiftIntervalBy v rat = wrap <$> shiftIntervalBy' (unwrap <$> v) rat

shiftIntervalBy' :: forall c.
                    EuclideanRing c
                 => Interval c
                 -> Ratio c
                 -> Interval c
shiftIntervalBy' v@(Pair l r) rat =
  let diff = ((r - l) * (Ratio.numerator rat)) / (Ratio.denominator rat)
  in Pair (l + diff) (r + diff)

zoomIntervalBy :: forall c.
                  Newtype c BigInt
               => Interval c
               -> Ratio BigInt
               -> Interval c
zoomIntervalBy v r = wrap <$> zoomIntervalBy' (unwrap <$> v) r

zoomIntervalBy' :: forall c.
                   EuclideanRing c
                => Interval c
                -> Ratio c
                -> Interval c
zoomIntervalBy' v@(Pair l r) rat =
  let diff = ((r - l) * (Ratio.numerator rat)) / (Ratio.denominator rat)
  in Pair (l - diff) (r + diff)

newtype Normalized a = Normalized a

derive instance newtypeNormalized :: Newtype (Normalized a) _

normalizePoint :: { width :: Number
                  , height :: Number }
               -> Point
               -> Normalized Point
normalizePoint {width, height} {x, y} = Normalized { x: x', y: y' }
  where x' = x / width
        y' = y / height

normPoint :: Point -> Maybe (Normalized Point)
normPoint p@{x, y}
  | x < 0.0 || x > 1.0 = Nothing
  | y < 0.0 || y > 1.0 = Nothing
  | otherwise = Just $ Normalized p

nPointToFrame :: Pixels -> Pixels -> Normalized Point -> Point
nPointToFrame w h (Normalized p) = {x: p.x * w, y: p.y * h}


Update doc string.

Update doc string.

module React.Redox
  ( ConnectState(..)
  , DispatchFn
  , RedoxContext
  , RedoxSpec
  , withStore
  , connect'
  , connect
  , withDispatch
  , dispatch
  , asReactClass
  , overRedoxSpec
  , unsafeShallowEqual
  , unsafeStrictEqual
  ) where

import Prelude

import Control.Monad.Aff (Fiber)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Uncurried (EffFn1, EffFn2, runEffFn1, runEffFn2)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Free (Free)
import Data.Function.Uncurried (Fn2, Fn3, mkFn2, runFn2, runFn3)
import Data.Lens (Getter', view)
import Data.Maybe (Maybe(Just, Nothing))
import Data.Newtype (class Newtype, over)
import React (ReactClass, ReactElement, ReactSpec, ReactThis, childrenToArray, createClass, createElement, forceUpdate, getProps, readState, writeState)
import React as R
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox as Redox
import Redox.Store (ReadRedox, RedoxStore, Store, SubscribeRedox, SubscriptionId)
import Type.Proxy (Proxy(..))
import Unsafe.Coerce (unsafeCoerce)

type DispatchFn state dsl reff eff = Free dsl (state -> state) -> Eff (redox :: RedoxStore reff | eff) (Fiber (redox :: RedoxStore reff | eff) Unit)

-- | Shallowly compare two objects.  If the first argument is true it skips
-- | comparing the `key` property which should not be accessed on a property
-- | object.
foreign import unsafeShallowEqual :: forall a. Fn3 Boolean a a Boolean

-- | Compare two objects using strict equality `===`
foreign import unsafeStrictEqual :: forall a. Fn2 a a Boolean

foreign import writeIsMountedImpl
  :: forall props state e
   . EffFn2 e (ReactThis props state) Boolean Unit

writeIsMounted :: forall props state e. ReactThis props state -> Boolean -> Eff e Unit
writeIsMounted this isMounted = runEffFn2 writeIsMountedImpl this isMounted

foreign import readIsMountedImpl
  :: forall props state e
   . EffFn1 e (ReactThis props state) Boolean

readIsMounted :: forall props state e. ReactThis props state -> Eff e Boolean
readIsMounted this = runEffFn1 readIsMountedImpl this

createClassStatelessWithContext
  :: forall props ctx
   . (props -> ctx -> ReactElement)
  -> ReactClass props
createClassStatelessWithContext fn = unsafeCoerce f
  where
    f :: Fn2 props { ctx :: ctx } ReactElement
    f = mkFn2 (\a { ctx } -> fn a ctx)

newtype RedoxContext state dsl reff eff = RedoxContext
  { store :: Store state
  , dispatch :: DispatchFn state dsl reff eff
  }

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function available through React context.
-- | Then you can connect a component with `connect` (or `connect'`) and get
-- | access to the store and the dispatch function.
withStore
  :: forall state props dsl reff eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> DispatchFn state dsl reff eff)
  -> ReactClass props
  -> Eff eff (ReactClass props)
withStore store dispatch_ cls =
  pure $ withContext cls { redox: RedoxContext { store, dispatch: dispatch_ store } }

newtype ConnectState state = ConnectState { state :: state, sid :: Maybe SubscriptionId }

derive instance newtypeConnectState :: Newtype (ConnectState state) _

_connect
  :: forall state state' dsl props props' reff eff
   . (ReactThis props' (ConnectState state')
      -> Eff
        (context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff)
        (RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff)
     )
  -> Getter' state state'
  -> ((DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff) -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state')
      ( context :: CONTEXT
      , redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff)
      | eff
      )
_connect ctxEff _lns _iso cls = (R.spec' getInitialState renderFn)
    { displayName = getDisplayName cls <> "Connect"
    , componentDidMount = componentDidMount
    , componentWillUnmount = componentWillUnmount
    , shouldComponentUpdate = shouldComponentUpdate
    }
  where

    -- Connect the child component to the context, this is required for the
    -- `dispatch` function.
    cls_ :: ReactClass props
    cls_ = accessContext cls

    update this state = do
      st <- readState this
      isMounted <- readIsMounted this
      when isMounted do
        void $ writeState this $ over ConnectState (_ { state = view _lns state }) st

    getInitialState this = do
      -- unsafeCoerceEff is used to add react effects to ctxEff
      RedoxContext ctx <- unsafeCoerceEff $ ctxEff this
      state <- Redox.getState ctx.store
      pure (ConnectState { state: view _lns state, sid: Nothing })

    -- | Subscription to redox store happens in `componentDidMount`, rather than
    -- | on `componentWillMount`.  This is because `componentWillUnmount` and
    -- | `componentDidMount` do not fire in SSR. Otherwise we'd have a memory
    -- | leak.
    componentDidMount this = do
      writeIsMounted this true
      RedoxContext { store } <- unsafeCoerceEff $ ctxEff this
      st@ConnectState { state } <- readState this
      sid <- Redox.subscribe store $ update this
      _ <- writeState this (over ConnectState (_ { sid = Just sid }) st)
      state' <- view _lns <$> Redox.getState store
      when
        (runFn2 unsafeStrictEqual state state')
        (forceUpdate this)

    componentWillUnmount this = do
      writeIsMounted this false
      RedoxContext ctx <- unsafeCoerceEff $ ctxEff this
      ConnectState { sid: msid } <- R.readState this
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe ctx.store sid

    shouldComponentUpdate this nPr (ConnectState nSt) = do
      pr <- getProps this
      ConnectState st <- readState this
      -- Take care only of `st.state` changes, `st.sid` is not used for
      -- rendering.
      let stateChanged = not $ runFn2 unsafeStrictEqual st.state nSt.state
          propsChanged = not $ runFn3 unsafeShallowEqual true pr nPr
      pure $ stateChanged || propsChanged

    renderFn this = do
      props' <- R.getProps this
      children <- R.getChildren this
      RedoxContext ctx <- unsafeCoerceEff $ ctxEff this
      ConnectState { state } <- R.readState this
      pure $ R.createElement cls_ (_iso ctx.dispatch state props') children

-- | Newtype wrapper around `ReactSpec`.  Use  `overRedoxSpec` to change the
-- | underlying spec and `asReactClass` to create a react class.
newtype RedoxSpec props state eff = RedoxSpec (ReactSpec props state eff)

overRedoxSpec
  :: forall props state eff
   . (ReactSpec props state eff ->  ReactSpec props state eff)
  -> RedoxSpec props state eff
  -> RedoxSpec props state eff
overRedoxSpec f (RedoxSpec spec) = RedoxSpec <<< f $ spec

asReactClass :: forall props state eff. RedoxSpec props state eff -> ReactClass props
asReactClass (RedoxSpec spec) = accessContext <<< createClass $ spec

-- | This function makes the redox store and dispatch function available
-- | through context.  The first argument is a lens that identifies the part
-- | of redox store's state that you want to subscribe for.  The view on this
-- | lens will be checked for changes, so if you want to optimise your code,
-- | return as 'tight' lens as possible.
-- |
-- | Use `asReactClass` function to create react class from `RedoxSpec` that
-- | this function returns and `overRedoxSpec` to possibly change the spec, for
-- | example by changing the `shouldComponentUpdate` react life cycle method.
-- |
-- | The second argument let you combine state and additional properties
-- | `props'` to get props of the class that you are connecting to the store.
-- | You can read the context with:
-- | ```purescript
-- | ReactHocs.readContext this >>= pure <<< _.redox :: Eff eff (RedoxContext state (Free dsl (state -> state))  eff)
-- | ```
connect'
  :: forall state state' dsl props props' reff eff
   . Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> RedoxSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connect' _ _lns _iso cls = RedoxSpec $ _connect ctxEff _lns _iso cls
  where
    proxy :: Proxy ({ redox :: RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff })
    proxy = Proxy

    ctxEff this = _.redox <$> readContext proxy this

-- | Like `connect'` but for `ReactClass`-es.
connect
  :: forall state state' dsl props props' reff eff'
   . Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect p _lns _iso cls = asReactClass $ connect' p _lns _iso cls

-- | If you just want to wrap your actions with a dispatch function use this
-- | function.  Unlike `connect'` (and `connect`) it does not wrap your
-- | component inside another component.
withDispatch
  :: forall state props props' dsl reff eff'
   . (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
withDispatch fn cls = accessContext $ createClassStatelessWithContext
  \props' { redox: RedoxContext { dispatch: disp }}
  -- todo: childrenToArray
  -> createElement cls (fn disp props') (childrenToArray (unsafeCoerce props').children)

-- | Light weight version of `connect`.  It does not require wrapping a parent
-- | with `withStore` since it is not using react context to access the store.
-- | You just need to provide the store with your first argument.
-- |
-- | Note: it is not safe to do server side rendering and keep the store as
-- | a global reference.  However, you can safely use this method if you are
-- | passing the store explicitly through props.
connectStore
  :: forall state state' dsl props props' reff eff
   . Store state
  -> DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connectStore store dispatch_ _lns _iso cls = _connect (const $ pure (RedoxContext {store, dispatch: dispatch_})) _lns _iso cls

-- | The component must be wrapped with `accessContext` to use this function.
-- | `connect` and `asReactClass` do that for you.
dispatch
  :: forall dsl rProps rState state reff eff
   . ReactThis rProps rState
  -> Free dsl (state -> state)
  -> Eff (context :: CONTEXT, redox :: RedoxStore reff | eff) (Fiber (context :: CONTEXT, redox :: RedoxStore reff | eff) Unit)
dispatch this dsl =
  let proxy :: Proxy ({ redox :: RedoxContext state dsl reff (context :: CONTEXT | eff) })
      proxy = Proxy
  in do
    { redox: RedoxContext { dispatch: disp } } <- readContext proxy this
    disp dsl

module React.Redox
  ( ConnectState(..)
  , DispatchFn
  , RedoxContext
  , RedoxSpec
  , withStore
  , connect'
  , connect
  , withDispatch
  , dispatch
  , asReactClass
  , overRedoxSpec
  , unsafeShallowEqual
  , unsafeStrictEqual
  ) where

import Prelude

import Control.Monad.Aff (Fiber)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Uncurried (EffFn1, EffFn2, runEffFn1, runEffFn2)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Free (Free)
import Data.Function.Uncurried (Fn2, Fn3, mkFn2, runFn2, runFn3)
import Data.Lens (Getter', view)
import Data.Maybe (Maybe(Just, Nothing))
import Data.Newtype (class Newtype, over)
import React (ReactClass, ReactElement, ReactSpec, ReactThis, childrenToArray, createClass, createElement, forceUpdate, getProps, readState, writeState)
import React as R
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox as Redox
import Redox.Store (ReadRedox, RedoxStore, Store, SubscribeRedox, SubscriptionId)
import Type.Proxy (Proxy(..))
import Unsafe.Coerce (unsafeCoerce)

type DispatchFn state dsl reff eff = Free dsl (state -> state) -> Eff (redox :: RedoxStore reff | eff) (Fiber (redox :: RedoxStore reff | eff) Unit)

-- | Shallowly compare two objects.  If the first argument is true it skips
-- | comparing the `key` property which should not be accessed on a property
-- | object.
foreign import unsafeShallowEqual :: forall a. Fn3 Boolean a a Boolean

-- | Compare two objects using strict equality `===`
foreign import unsafeStrictEqual :: forall a. Fn2 a a Boolean

foreign import writeIsMountedImpl
  :: forall props state e
   . EffFn2 e (ReactThis props state) Boolean Unit

writeIsMounted :: forall props state e. ReactThis props state -> Boolean -> Eff e Unit
writeIsMounted this isMounted = runEffFn2 writeIsMountedImpl this isMounted

foreign import readIsMountedImpl
  :: forall props state e
   . EffFn1 e (ReactThis props state) Boolean

readIsMounted :: forall props state e. ReactThis props state -> Eff e Boolean
readIsMounted this = runEffFn1 readIsMountedImpl this

createClassStatelessWithContext
  :: forall props ctx
   . (props -> ctx -> ReactElement)
  -> ReactClass props
createClassStatelessWithContext fn = unsafeCoerce f
  where
    f :: Fn2 props { ctx :: ctx } ReactElement
    f = mkFn2 (\a { ctx } -> fn a ctx)

newtype RedoxContext state dsl reff eff = RedoxContext
  { store :: Store state
  , dispatch :: DispatchFn state dsl reff eff
  }

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function available through React context.
-- | Then you can connect a component with `connect` (or `connect'`) and get
-- | access to the store and the dispatch function.
withStore
  :: forall state props dsl reff eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> DispatchFn state dsl reff eff)
  -> ReactClass props
  -> Eff eff (ReactClass props)
withStore store dispatch_ cls =
  pure $ withContext cls { redox: RedoxContext { store, dispatch: dispatch_ store } }

newtype ConnectState state = ConnectState { state :: state, sid :: Maybe SubscriptionId }

derive instance newtypeConnectState :: Newtype (ConnectState state) _

_connect
  :: forall state state' dsl props props' reff eff
   . (ReactThis props' (ConnectState state')
      -> Eff
        (context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff)
        (RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff)
     )
  -> Getter' state state'
  -> ((DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff) -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state')
      ( context :: CONTEXT
      , redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff)
      | eff
      )
_connect ctxEff _lns _iso cls = (R.spec' getInitialState renderFn)
    { displayName = getDisplayName cls <> "Connect"
    , componentDidMount = componentDidMount
    , componentWillUnmount = componentWillUnmount
    , shouldComponentUpdate = shouldComponentUpdate
    }
  where

    -- Connect the child component to the context, this is required for the
    -- `dispatch` function.
    cls_ :: ReactClass props
    cls_ = accessContext cls

    update this state = do
      st <- readState this
      isMounted <- readIsMounted this
      when isMounted do
        void $ writeState this $ over ConnectState (_ { state = view _lns state }) st

    getInitialState this = do
      -- unsafeCoerceEff is used to add react effects to ctxEff
      RedoxContext ctx <- unsafeCoerceEff $ ctxEff this
      state <- Redox.getState ctx.store
      pure (ConnectState { state: view _lns state, sid: Nothing })

    -- | Subscription to redox store happens in `componentDidMount`, rather than
    -- | on `componentWillMount`.  This is because `componentWillUnmount` and
    -- | `componentDidMount` do not fire in SSR. Otherwise we'd have a memory
    -- | leak.
    componentDidMount this = do
      writeIsMounted this true
      RedoxContext { store } <- unsafeCoerceEff $ ctxEff this
      st@ConnectState { state } <- readState this
      sid <- Redox.subscribe store $ update this
      _ <- writeState this (over ConnectState (_ { sid = Just sid }) st)
      state' <- view _lns <$> Redox.getState store
      when
        (runFn2 unsafeStrictEqual state state')
        (forceUpdate this)

    componentWillUnmount this = do
      writeIsMounted this false
      RedoxContext ctx <- unsafeCoerceEff $ ctxEff this
      ConnectState { sid: msid } <- R.readState this
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe ctx.store sid

    shouldComponentUpdate this nPr (ConnectState nSt) = do
      pr <- getProps this
      ConnectState st <- readState this
      -- Take care only of `st.state` changes, `st.sid` is not used for
      -- rendering.
      let stateChanged = not $ runFn2 unsafeStrictEqual st.state nSt.state
          propsChanged = not $ runFn3 unsafeShallowEqual true pr nPr
      pure $ stateChanged || propsChanged

    renderFn this = do
      props' <- R.getProps this
      children <- R.getChildren this
      RedoxContext ctx <- unsafeCoerceEff $ ctxEff this
      ConnectState { state } <- R.readState this
      pure $ R.createElement cls_ (_iso ctx.dispatch state props') children

-- | Newtype wrapper around `ReactSpec`.  Use  `overRedoxSpec` to change the
-- | underlying spec and `asReactClass` to create a react class.
newtype RedoxSpec props state eff = RedoxSpec (ReactSpec props state eff)

overRedoxSpec
  :: forall props state eff
   . (ReactSpec props state eff ->  ReactSpec props state eff)
  -> RedoxSpec props state eff
  -> RedoxSpec props state eff
overRedoxSpec f (RedoxSpec spec) = RedoxSpec <<< f $ spec

asReactClass :: forall props state eff. RedoxSpec props state eff -> ReactClass props
asReactClass (RedoxSpec spec) = accessContext <<< createClass $ spec

-- | This function makes the redox store and dispatch function available
-- | through context.  The first argument is a lens that identifies the part
-- | of redox store's state that you want to subscribe for.  The view on this
-- | lens will be checked for changes, so if you want to optimise your code,
-- | return as 'tight' lens as possible.
-- |
-- | Use `asReactClass` function to create react class from `RedoxSpec` that
-- | this function returns and `overRedoxSpec` to possibly change the spec, for
-- | example by changing the `shouldComponentUpdate` react life cycle method.
-- |
-- | The second argument let you combine state and additional properties
-- | `props'` to get props of the class that you are connecting to the store.
-- | You can read the context with:
-- | ```purescript
-- | ReactHocs.readContext this >>= pure <<< _.redox :: Eff eff (RedoxContext state (Free dsl (state -> state))  eff)
-- | ```
connect'
  :: forall state state' dsl props props' reff eff
   . Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> RedoxSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connect' _ _lns _iso cls = RedoxSpec $ _connect ctxEff _lns _iso cls
  where
    proxy :: Proxy ({ redox :: RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff })
    proxy = Proxy

    ctxEff this = _.redox <$> readContext proxy this

-- | Like `connect'` but for `ReactClass`-es.
connect
  :: forall state state' dsl props props' reff eff'
   . Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect p _lns _iso cls = asReactClass $ connect' p _lns _iso cls

-- | If you just want to wrap your actions with a dispatch function use this
-- | function.  Unlike `connect'` (and `connect`) it does not wrap your
-- | component inside another component.
withDispatch
  :: forall state props props' dsl reff eff'
   . (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
withDispatch fn cls = accessContext $ createClassStatelessWithContext
  \props' { redox: RedoxContext { dispatch: disp }}
  -- todo: childrenToArray
  -> createElement cls (fn disp props') (childrenToArray (unsafeCoerce props').children)

-- | Light weight version of `connect`.  It does not require wrapping a parent
-- | with `withStore` since it is not using react context to access the store.
-- | You just need to provide the store with your first argument.
-- |
-- | Note: it is not safe to do server side rendering and keep the store as
-- | a global reference.  However, you can safely use this method if you are
-- | passing the store explicitly through props.
connectStore
  :: forall state state' dsl props props' reff eff
   . Store state
  -> DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connectStore store dispatch_ _lns _iso cls = _connect (const $ pure (RedoxContext {store, dispatch: dispatch_})) _lns _iso cls

-- | If you wrapped your component with `connect` or `connect'` you can use
-- | this `dispatch` function to run your actions.
dispatch
  :: forall dsl rProps rState state reff eff
   . ReactThis rProps rState
  -> Free dsl (state -> state)
  -> Eff (context :: CONTEXT, redox :: RedoxStore reff | eff) (Fiber (context :: CONTEXT, redox :: RedoxStore reff | eff) Unit)
dispatch this dsl =
  let proxy :: Proxy ({ redox :: RedoxContext state dsl reff (context :: CONTEXT | eff) })
      proxy = Proxy
  in do
    { redox: RedoxContext { dispatch: disp } } <- readContext proxy this
    disp dsl


Fix line endings and formatting to match project (#132)

module Data.String.Regex.Unsafe
  ( unsafeRegex
  ) where

import Control.Category (identity)
import Data.Either (either)
import Data.String.Regex (Regex, regex)
import Data.String.Regex.Flags (RegexFlags)
import Partial.Unsafe (unsafeCrashWith)

-- | Constructs a `Regex` from a pattern string and flags. Fails with
-- | an exception if the pattern contains a syntax error.
unsafeRegex :: String -> RegexFlags -> Regex
unsafeRegex s f = either unsafeCrashWith identity (regex s f)


should be the right type now

should be the right type now

module Views.Input
	( inputView
	) where

import Control.Alternative

import Data.Either
import Data.Foreign.Class

import Halogen
import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Events as A
import qualified Halogen.HTML.Events.Forms as A
import qualified Halogen.HTML.Events.Handler as E
import qualified Halogen.HTML.Events.Monad as E

import qualified Halogen.Themes.Bootstrap3 as B

import Models.Action
import Models.Message

import Control.Alt
import Control.Monad.Eff
import Control.Monad.Eff.Class
import Control.Monad.Aff

import Network.HTTP.Affjax

inputView :: forall m eff. (Alternative m) => H.HTML (E.Event (HalogenEffects (ajax :: AJAX | eff)) Action)
inputView =
	H.div
		[ A.class_ $ A.className "input-view" ]
		[ H.input
			[ A.classes [ B.formControl ]
			, A.placeholder "Message"
			, A.onValueChanged (A.input $ \text -> SendMessage $ TextMessage { text: text })
			]
			[]
		, H.button
			[ A.onClick  (\_ -> pure (handler "1+2"))
			]
			[]
		]

handler :: forall eff. String -> E.Event (HalogenEffects (ajax :: AJAX | eff)) Action
handler code = E.yield DoNothing `E.andThen` \_ -> E.async compileAff
	where
	compileAff :: Aff (HalogenEffects (ajax :: AJAX | eff)) Action
	compileAff = do
		result <- post "http://try.purescript.org/compile/text" code
		let response = result.response
		return case readProp "js" response <|> readProp "error" response of
			Right js -> SendMessage $ TextMessage { text: js }
			Left _ -> DoNothing

module Views.Input
	( inputView
	) where

import Control.Alternative

import Data.Either
import Data.Foreign.Class

import Halogen
import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Events as A
import qualified Halogen.HTML.Events.Forms as A
import qualified Halogen.HTML.Events.Handler as E
import qualified Halogen.HTML.Events.Monad as E

import qualified Halogen.Themes.Bootstrap3 as B

import Models.Action
import Models.Message

import Control.Alt
import Control.Monad.Eff
import Control.Monad.Eff.Class
import Control.Monad.Aff

import Network.HTTP.Affjax

inputView :: forall m. (Alternative m) => H.HTML (m _)
inputView =
	H.div
		[ A.class_ $ A.className "input-view" ]
		[ H.input
			[ A.classes [ B.formControl ]
			, A.placeholder "Message"
			, A.onValueChanged (A.input $ \text -> SendMessage $ TextMessage { text: text })
			]
			[]
		, H.button
			[ A.onClick  (\_ -> pure (handler "1+2"))
			]
			[]
		]

handler :: forall eff. String -> E.Event (HalogenEffects (ajax :: AJAX | eff)) Action
handler code = E.yield (SendMessage $ TextMessage { text: "" }) `E.andThen` \_ -> E.async compileAff
	where
	compileAff :: Aff (HalogenEffects (ajax :: AJAX | eff)) Action
	compileAff = do
		result <- post "http://try.purescript.org/compile/text" code
		let response = result.response
		return case readProp "js" response <|> readProp "error" response of
			Right js -> SendMessage $ TextMessage { text: js }
			Left _ -> DoNothing


Commandant Teste

Commandant Teste

module KanColle.Expedition.New.CostModel
  ( calcFleetMaxCost
  , calcActualCost
  , calcFleetActualCost
  , normalCostModel
  ) where

import Prelude
import KanColle.Expedition.New.Types
import Data.Map as M
import Data.Maybe
import Control.MonadPlus
import Data.Unfoldable
import Data.Tuple
import Data.Traversable
import Data.Int

calcFleetMaxCost :: CostModel -> FleetCompo -> Maybe FleetMaxCost
calcFleetMaxCost cm fcAr = fold <$> sequence compos
  where
    fc :: M.Map SType Int
    fc = M.fromFoldableWith (+) (map (\x -> Tuple x 1) fcAr)
    compos = map (\(Tuple sty cnt) -> cm sty cnt) (M.toList fc)

calcActualCost :: MaxCost -> Info -> ActualCost
calcActualCost (MCost mc) info = ACost
    { fuel: floor (info.fuelCostPercent * toNumber mc.fuel)
    , ammo: floor (info.ammoCostPercent * toNumber mc.ammo)
    }

calcFleetActualCost :: FleetMaxCost -> Info -> FleetActualCost
calcFleetActualCost fmc info = FACost (foldl merge z fmc)
  where
    z = {fuel: 0, ammo: 0}
    merge acc mc = case calcActualCost mc info of
      (ACost actual) ->
        {fuel: acc.fuel+actual.fuel, ammo: acc.ammo+actual.ammo}

-- | a normal cost model assumes all ships are remodelled to
-- | their final forms. (the exceptions are like Taigei, Chitose-A and Chiyoda-A
-- | as their further remodels also change ship type.)
normalCostModel :: CostModel
normalCostModel stype = case stype of
    DD -> ddCost
    CL -> clCost
    CVLike -> cvlLikeCost
    SSLike -> ssLikeCost
    CA -> caCost
    BBV -> bbvCost
    AS -> asCost
    CT -> ctCost
    AV -> avCost
  where
    ddCost n =
      -- use Mutsuki class destroyers
      Just (replicate n (mkMC 15 15))
    clCost n
      | n <= 2 =
        -- use 2 Tenryuu class ships,
        Just (replicate n (mkMC 25 25))
      | n <= 6 = do
        -- if we need more, fill the rest with some Nagara class ships
        c <- clCost 2
        Just (c <> replicate (n-2) (mkMC 25 30))
      | otherwise = Nothing
    avCost n
      | n <= 2 =
        -- Chitose-A and Chiyoda-A
        Just (replicate n (mkMC 35 45))
      | n <= 3 = do
        -- and Mizuho Kai
        c <- avCost 2
        Just (c <> [mkMC 40 45])
      | n <= 4 = do
        -- and Commandant Teste Kai
        c <- avCost 3
        Just (c <> [mkMC 40 50])
      | n <= 5 = do
        -- and Akitsushima Kai
        c <- avCost 4
        Just (c <> [mkMC 60 15])
      | otherwise = Nothing
    -- Taigei
    asCost n = do
        guard (n <= 1)
        Just (replicate n (mkMC 35 10))
    -- Katori class
    ctCost n = do
        guard (n <= 2)
        Just (replicate n (mkMC 35 20))
    caCost n
      | n <= 1 =
        -- Aoba Kai
        Just (replicate n (mkMC 35 55))
      | n <= 4 = do
        -- Furutaka Kai Ni, Kako Kai Ni, Kinugasa Kai Ni
        c <- caCost 1
        Just (c <> replicate (n-1) (mkMC 35 65))
      | n <= 6 = do
        -- Takao Kai, Atago Kai
        c <- caCost 4
        Just (c <> replicate (n-4) (mkMC 40 70))
      | otherwise = Nothing
    bbvCost n
      | n <= 2 =
        -- Ise class
        Just (replicate n (mkMC 95 105))
      | n <= 4 = do
        -- Fusou class
        c <- bbvCost 2
        Just (c <> replicate (n-2) (mkMC 105 140))
      | otherwise = Nothing
    ssLikeCost n
      | n <= 1 =
        -- Maruyu Kai
        Just (replicate n (mkMC 10 10))
      | n <= 6 = do
        -- no need for SSV if we just consider:
        -- I-168, I-58, I-19, I-8 and Ro-500
        c <- ssLikeCost 1
        Just (replicate (n-1) (mkMC 10 20))
      | otherwise = Nothing
    cvlLikeCost n
      | n <= 1 =
        -- Houshou Kai
        Just (replicate n (mkMC 30 30))
      | n <= 2 = do
        -- Ryuuhou Kai
        c <- cvlLikeCost 1
        Just (c <> replicate (n-1) (mkMC 35 40))
      | n <= 4 = do
        -- Chitose-A, Chiyoda-A
        c <- cvlLikeCost 2
        Just (c <> replicate (n-2) (mkMC 35 45))
      | n <= 6 = do
        -- Shouhou Kai, Zuihou Kai
        c <- cvlLikeCost 4
        Just (c <> replicate (n-4) (mkMC 40 40))
      | otherwise = Nothing

module KanColle.Expedition.New.CostModel
  ( calcFleetMaxCost
  , calcActualCost
  , calcFleetActualCost
  , normalCostModel
  ) where

import Prelude
import KanColle.Expedition.New.Types
import Data.Map as M
import Data.Maybe
import Control.MonadPlus
import Data.Unfoldable
import Data.Tuple
import Data.Traversable
import Data.Int

calcFleetMaxCost :: CostModel -> FleetCompo -> Maybe FleetMaxCost
calcFleetMaxCost cm fcAr = fold <$> sequence compos
  where
    fc :: M.Map SType Int
    fc = M.fromFoldableWith (+) (map (\x -> Tuple x 1) fcAr)
    compos = map (\(Tuple sty cnt) -> cm sty cnt) (M.toList fc)

calcActualCost :: MaxCost -> Info -> ActualCost
calcActualCost (MCost mc) info = ACost
    { fuel: floor (info.fuelCostPercent * toNumber mc.fuel)
    , ammo: floor (info.ammoCostPercent * toNumber mc.ammo)
    }

calcFleetActualCost :: FleetMaxCost -> Info -> FleetActualCost
calcFleetActualCost fmc info = FACost (foldl merge z fmc)
  where
    z = {fuel: 0, ammo: 0}
    merge acc mc = case calcActualCost mc info of
      (ACost actual) ->
        {fuel: acc.fuel+actual.fuel, ammo: acc.ammo+actual.ammo}

-- | a normal cost model assumes all ships are remodelled to
-- | their final forms. (the exceptions are like Taigei, Chitose-A and Chiyoda-A
-- | as their further remodels also change ship type.)
normalCostModel :: CostModel
normalCostModel stype = case stype of
    DD -> ddCost
    CL -> clCost
    CVLike -> cvlLikeCost
    SSLike -> ssLikeCost
    CA -> caCost
    BBV -> bbvCost
    AS -> asCost
    CT -> ctCost
    AV -> avCost
  where
    ddCost n =
      -- use Mutsuki class destroyers
      Just (replicate n (mkMC 15 15))
    clCost n
      | n <= 2 =
        -- use 2 Tenryuu class ships,
        Just (replicate n (mkMC 25 25))
      | n <= 6 = do
        -- if we need more, fill the rest with some Nagara class ships
        c <- clCost 2
        Just (c <> replicate (n-2) (mkMC 25 30))
      | otherwise = Nothing
    avCost n
      | n <= 2 =
        -- Chitose-A and Chiyoda-A
        Just (replicate n (mkMC 35 45))
      | n <= 3 = do
        -- and Mizuho Kai
        c <- avCost 2
        Just (c <> [mkMC 40 45])
      | n <= 4 = do
        -- and Akitsushima Kai
        c <- avCost 3
        Just (c <> [mkMC 60 15])
      | otherwise = Nothing
    -- Taigei
    asCost n = do
        guard (n <= 1)
        Just (replicate n (mkMC 35 10))
    -- Katori class
    ctCost n = do
        guard (n <= 2)
        Just (replicate n (mkMC 35 20))
    caCost n
      | n <= 1 =
        -- Aoba Kai
        Just (replicate n (mkMC 35 55))
      | n <= 4 = do
        -- Furutaka Kai Ni, Kako Kai Ni, Kinugasa Kai Ni
        c <- caCost 1
        Just (c <> replicate (n-1) (mkMC 35 65))
      | n <= 6 = do
        -- Takao Kai, Atago Kai
        c <- caCost 4
        Just (c <> replicate (n-4) (mkMC 40 70))
      | otherwise = Nothing
    bbvCost n
      | n <= 2 =
        -- Ise class
        Just (replicate n (mkMC 95 105))
      | n <= 4 = do
        -- Fusou class
        c <- bbvCost 2
        Just (c <> replicate (n-2) (mkMC 105 140))
      | otherwise = Nothing
    ssLikeCost n
      | n <= 1 =
        -- Maruyu Kai
        Just (replicate n (mkMC 10 10))
      | n <= 6 = do
        -- no need for SSV if we just consider:
        -- I-168, I-58, I-19, I-8 and Ro-500
        c <- ssLikeCost 1
        Just (replicate (n-1) (mkMC 10 20))
      | otherwise = Nothing
    cvlLikeCost n
      | n <= 1 =
        -- Houshou Kai
        Just (replicate n (mkMC 30 30))
      | n <= 2 = do
        -- Ryuuhou Kai
        c <- cvlLikeCost 1
        Just (c <> replicate (n-1) (mkMC 35 40))
      | n <= 4 = do
        -- Chitose-A, Chiyoda-A
        c <- cvlLikeCost 2
        Just (c <> replicate (n-2) (mkMC 35 45))
      | n <= 6 = do
        -- Shouhou Kai, Zuihou Kai
        c <- cvlLikeCost 4
        Just (c <> replicate (n-4) (mkMC 40 40))
      | otherwise = Nothing


Fixes for no overlapping instances

Fixes for no overlapping instances

module Control.Applicative where

import Prelude

infixl 4 <*
infixl 4 *>

(<*) :: forall a b f. (Functor f, Applicative f) => f a -> f b -> f a
(<*) x y = const <$> x <*> y

(*>) :: forall a b f. (Functor f, Applicative f) => f a -> f b -> f b
(*>) x y = const id <$> x <*> y

lift2 :: forall a b c f. (Functor f, Applicative f) => (a -> b -> c) -> f a -> f b -> f c
lift2 f x y = f <$> x <*> y

lift3 :: forall a b c d f. (Functor f, Applicative f) => (a -> b -> c -> d) -> f a -> f b -> f c -> f d
lift3 f x y z = f <$> x <*> y <*> z

module Control.Applicative where

import Prelude

infixl 4 <*
infixl 4 *>

(<*) :: forall a b f. (Applicative f) => f a -> f b -> f a
(<*) x y = const <$> x <*> y

(*>) :: forall a b f. (Applicative f) => f a -> f b -> f b
(*>) x y = const id <$> x <*> y

lift2 :: forall a b c f. (Applicative f) => (a -> b -> c) -> f a -> f b -> f c
lift2 f x y = f <$> x <*> y

lift3 :: forall a b c d f. (Applicative f) => (a -> b -> c -> d) -> f a -> f b -> f c -> f d
lift3 f x y z = f <$> x <*> y <*> z


Styling and such

Styling and such

Now <eu> is a diphthong. Clean up some whitespace on paste.

module Scansion where

import Prelude
import UIHelpers
import CSS as CSS
import CSS.Overflow as CSS.Overflow
import CSS.TextAlign as CSS.TextAlign
import DOM.Event.Event as Event
import DOM.HTML.HTMLInputElement as HInput
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import ArrayState (evalArrayState, evalReversedArrayState, sequence, sequenceReversed)
import CSS (CSS, StyleM, ex, fromHexString, nil)
import CSS.Common (auto)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.State (State)
import Control.Monad.State.Trans (get, put)
import Control.Plus (empty)
import DOM (DOM)
import DOM.Event.Types (Event)
import DOM.HTML.Types (HTMLInputElement)
import Data.Array (filter, mapWithIndex) as Array
import Data.Generic (class Generic, gCompare, gEq, gShow)
import Data.Int (odd)
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.String (Pattern(..), indexOf, joinWith, trim)
import Data.String (split) as String
import Data.String.Regex (Regex, replace, split, test)
import Data.String.Regex.Flags (global, ignoreCase, noFlags)
import Data.String.Regex.Unsafe (unsafeRegex)
import Halogen.Aff (HalogenEffects)
import Halogen.Aff.Util (awaitBody, runHalogenAff)
import Halogen.HTML.CSS (style)
import Halogen.VDom.Driver (runUI)
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

newtype Line =
    Line (Array Res)

instance showLine :: Show Line where
    show (Line line) = joinWith "" do
        res <- line
        pure case res of
            Punct s -> s
            Verb { syllables } ->
                joinWith "" do
                    Syllable { value, stype } <- syllables
                    --pure (value <> show stype)
                    pure value

class HalogenDisplay displayable where
    display :: forall a b. displayable -> HH.HTML a b

instance displayLine :: HalogenDisplay Line where
    display line_@(Line line) =
        HH.div_ [ scanned, raw ]
        where
            raw = HH.span [ style $ zindex 1 ] [ HH.text $ show line_ ]
            scanned = HH.div [ divstyle ] $ evalArrayState (map mapper line) 0.0
            divstyle = style do
                CSS.height (1.2#ex)
                zindex (-1)
                no_pointer_events
            mapper (Punct "\n") = pure HH.br_
            mapper (Punct s) = pure (spacer $ HH.text s)
            mapper (Verb { syllables, gloss }) =
                map HH.span_ $ sequence $ map displaySyllableColored syllables

y_mark :: forall a b. CSS -> HP.IProp ( style :: String | a ) b
y_mark extra =
    style do
        CSS.color (unsafePartial $ fromJust $ fromHexString "#F50057")
        CSS.Overflow.overflow CSS.Overflow.visible
        CSS.height (ex 1.0)
        scale 2.0 1.4
        no_user_select
        CSS.margin auto auto auto auto
        CSS.TextAlign.textAlign CSS.TextAlign.center
        extra

instance displaySyllable :: HalogenDisplay Syllable where
    display = displaySyllableStyled (CSS.height nil)

displaySyllableStyled :: forall a b. CSS -> Syllable -> HH.HTML a b
displaySyllableStyled extraStyle (Syllable { value, stype }) =
    HH.div
        [ style do
            CSS.display CSS.inlineBlock
        ]
        [ HH.div [ y_mark extraStyle ] [ HH.text $ show stype ]
        , spacer $ HH.text value
        ]

displaySyllableColored :: forall a b. Syllable -> State Number (HH.HTML a b)
displaySyllableColored syllable@(Syllable { value, stype }) = do
    position <- get
    let incr = case stype of
            Elided ->
                0.0

            Long ->
                1.0

            Ambiguous (Just a) | a ->
                1.0

            _ ->
                0.5
    put (position + incr)
    let clr =
            CSS.color $ fromMaybe (CSS.gray) $ CSS.fromHexString $
                case position of
                    0.0 ->
                        "#F50057"

                    2.0 ->
                        "#D500F9"

                    4.0 ->
                        "#651FFF"

                    6.0 ->
                        "#00E5FF"

                    8.0 ->
                        "#1DE9B6"

                    10.0 ->
                        "#00E676"

                    11.0 ->
                        "#2E7D32"

                    10.5 ->
                        "#FF3D00"

                    11.5 ->
                        "#FF3D00"

                    12.0 ->
                        "#FF3D00"

                    _ ->
                        ""
    pure $ displaySyllableStyled (clr) syllable

data Res
    = Punct String
    | Verb Word

type Word =
    { syllables :: Array Syllable
    , gloss :: String
    }

newtype Syllable = Syllable
    { value :: String
    , stype :: SyllableType
    }

data SyllableType
    = Long
    | Ambiguous (Maybe Boolean)
    | Short
    | Elided

instance showSyllableType :: Show SyllableType where
    show s =
        case s of
            Short ->
                "˘"

            Long ->
                "¯"

            Elided ->
                "˙"

            Ambiguous Nothing ->
                "˟"

            Ambiguous (Just b)
                | b -> "˜"
                | otherwise -> "ˇ"

startsWith :: Pattern -> String -> Boolean
startsWith p s = case indexOf p s of
    Just 0 -> true
    _ -> false

weight :: String -> ScanBias
weight syllable =
    if startsWith (Pattern "x") syllable || startsWith (Pattern "z") syllable then
        IntoDoubleConsonant
    else if test r_cx syllable then
        IntoConsonant
    else
        IntoVowel

data ScanBias = Elidable | IntoVowel | IntoConsonant | IntoDoubleConsonant | LineEnd
derive instance genericScanBias :: Generic ScanBias

instance showScanBias :: Show ScanBias where
  show = gShow

instance eqScanBias :: Eq ScanBias where
  eq = gEq

instance ordScanBias :: Ord ScanBias where
  compare = gCompare

reform :: Syllable -> ScanBias -> SyllableType
reform _ IntoDoubleConsonant = Long
reform (Syllable {stype: Ambiguous _}) LineEnd = Long
reform (Syllable {stype: Short}) LineEnd = Ambiguous Nothing
reform (Syllable {value}) Elidable
    | test r_elision value = Elided
reform (Syllable {stype: Ambiguous Nothing}) IntoVowel = Ambiguous (Just false)
reform (Syllable {stype: Ambiguous Nothing}) Elidable = Ambiguous (Just false)
reform (Syllable {stype: Ambiguous Nothing}) IntoConsonant = Ambiguous (Just true)
reform (Syllable {stype}) _ = stype

resimplify :: Boolean -> SyllableType -> SyllableType
resimplify true (Ambiguous (Just false)) = Short
resimplify true (Ambiguous (Just true)) = Long
resimplify _ stype = stype

inner :: Boolean -> Syllable -> State ScanBias Syllable
inner simplify syllable@(Syllable {value}) = do
    bias <- get
    put (weight value)
    let stype = resimplify simplify $ reform syllable bias
    pure (Syllable { value, stype })

middle :: Boolean -> Array Syllable -> State ScanBias (Array Syllable)
middle simplify syllables = sequenceReversed $ map (inner simplify) syllables

outer :: Boolean -> Res -> State ScanBias Res
outer simplify (Verb w) = do
    bias <- get
    case bias of
        IntoVowel -> put Elidable
        -- double consonants do not affect preceding word in scansion
        IntoDoubleConsonant -> put IntoConsonant
        _ -> pure unit
    syllables <- middle simplify w.syllables
    pure $ Verb { syllables, gloss: w.gloss }
outer _ (res@Punct "\n") = do
    put LineEnd
    pure res
outer _ res = pure res

rescan :: Boolean -> Line -> Line
rescan simplify (Line line) = Line rescanned
    where
        rescanned = evalReversedArrayState statecomputation LineEnd
        statecomputation = map (outer simplify) line

v :: String
v =
    "(?:[aeiouy]͡[aeiouyāēīōūȳ]̄?|(?:a[eu]|oe|eu)(?![̄̈])|[aeiouyāēīōūȳ]̄?|[aeiouy]̄|[äëïöüÿ])"

c :: String
c =
    "(?:[qg]u(?=" <> v <> ")|[ck]h|[bcdfghjklmnprstvwxz]|\\bi(?=" <> v <> "))"

l :: String
l =
    "(?:" <> c <> "|" <> v <> ")"

r_word :: Regex
r_word =
    unsafeRegex ("((?:" <> c <> "|" <> v <> ")+)") (ignoreCase <> global)

r_syllable :: Regex
r_syllable =
    unsafeRegex (c <> "*" <> v <> "(" <> c <> "*$|(?![dbpckgt][rl])" <> c <> "((?=" <> c <> "+" <> v <> "?))" <> ")?") (ignoreCase <> global)

r_short :: Regex
r_short =
    unsafeRegex ("(\\bi?|[^aeiouy]|[qg]u)[aeiouy]$") ignoreCase

r_long :: Regex
r_long =
    unsafeRegex ("[aeiouy]̄|[āēīōūȳ]|a[eu]|oe|eu|(x|z|" <> c <> c <> ")$") ignoreCase

r_cx :: Regex
r_cx =
    unsafeRegex ("^((?!h)" <> c <> "|[ij]" <> v <> "|[aeiouy]̄|[äëïöüÿ])") ignoreCase

r_elision :: Regex
r_elision =
    unsafeRegex (v <> "m?$") ignoreCase

r_wordbreak :: Regex
r_wordbreak =
    unsafeRegex ("(?:(?:^|" <> l <> ")" <> l <> "*(?=))") ignoreCase

foreign import _findall :: Regex -> String -> Array String

mksyllables :: String -> Array Syllable
mksyllables content =
    content # _findall r_syllable # map mksyllable
    --content # Regex.find Regex.All r_syllable # map (_.match >>> syllable)
    --content # Regex.match r_syllable # fromMaybe [] # map (_.match >>> syllable)

mksyllable :: String -> Syllable
mksyllable s = Syllable
    { value: s
    , stype:
        if test r_short s then
            Short
        else if test r_long s then
            Long
        else
            Ambiguous Nothing
    }

mkline :: Boolean -> String -> Line
mkline simplify content =
    content # mkwords # Array.filter nonempty # Line # rescan simplify
    where
        nonempty (Punct "") = false
        nonempty (Verb { syllables: [] }) = false
        nonempty _ = true

mklines :: Boolean -> String -> Array Line
mklines simplify content =
    trim content # String.split (Pattern "\n") # map (trim >>> mkline simplify)

processtext :: (String -> Res) -> (String -> Res) -> String -> Array Res
processtext mkverb mkpunct =
    let
        mapper i
            | odd i = mkverb
            | otherwise = mkpunct
    in
        Array.mapWithIndex mapper <<< split r_word

mkwords :: String -> Array Res
mkwords content =
    --content # split r_word # map (\s -> Verb { syllables: mksyllables s, gloss: s})
    processtext (\s -> Verb $ { syllables: mksyllables s, gloss: s }) Punct content

data Query a
    = ToggleState a
    | UserInput Event a

type UIState =
    { simplify :: Boolean
    , text :: String
    }

initialState :: UIState
initialState =
    { simplify: true
    , text: """arma virumque canō, Trōiae quī prīmus ab ōrīs
Ītaliam fātō profugus Lāvīni͡aque vēnit"""
    }

legend :: forall a b. Boolean -> HH.HTML a b
legend true =
    HH.div_/>"¯ a long (heavy) syllable, ˘ a short syllable"
legend false =
    HH.div_/>"¯ a long (heavy) syllable, ˜ a syllable long by position, ˇ a syllable short by position, ˘ a short syllable"

ui :: forall eff. H.Component HH.HTML Query Unit Void (Aff (dom :: DOM | eff))
ui = H.component { render, eval, initialState: const initialState, receiver: const Nothing }
  where

  render :: UIState -> H.ComponentHTML Query
  render state =
    HH.div_
        [ HH.h2_/>"Pantheum: Scansion"
        , HH.div_ $ map display $ mklines state.simplify state.text
        , HH.br_
        , legend state.simplify
        , checkbox (HE.input_ ToggleState) [] "Simplify scansion marks" state.simplify
        , textarea (HE.input UserInput) [] "Text to scan" 5 state.text
        , HH.br_
        ]

  eval :: Query ~> H.ComponentDSL UIState Query Void (Aff (dom :: DOM | eff))
  eval (ToggleState next) = do
    H.modify (\state -> { simplify: not state.simplify, text: state.text })
    pure next
  eval (UserInput e next) = do
    let node = unsafeCoerce Event.target e :: HTMLInputElement
    s <- H.liftEff (HInput.value node :: Eff (dom :: DOM | eff) String)
    let text = s
            # replace (unsafeRegex "[\\s\\n]+\\n\\s*|\\s*\\n[\\s\\n]+" global) "\n"
            # replace (unsafeRegex "\\d+" global) ""
            # replace (unsafeRegex "'([^']+)'" global) "‘$1’"
            # replace (unsafeRegex "\"([^\"]+)\"" global) "“$1”"
    H.modify (\state -> { simplify: state.simplify, text })
    pure next

main :: Eff (HalogenEffects ()) Unit
main = runHalogenAff do
  body <- awaitBody
  runUI ui unit body

module Scansion where

import Prelude
import UIHelpers
import CSS as CSS
import CSS.Overflow as CSS.Overflow
import CSS.TextAlign as CSS.TextAlign
import DOM.Event.Event as Event
import DOM.HTML.HTMLInputElement as HInput
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import ArrayState (evalReversedArrayState, sequenceReversed)
import CSS (ex, fromHexString, nil)
import CSS.Common (auto)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.State (State)
import Control.Monad.State.Trans (get, put)
import DOM (DOM)
import DOM.Event.Types (Event)
import DOM.HTML.Types (HTMLInputElement)
import Data.Array (filter, mapWithIndex) as Array
import Data.Generic (class Generic, gCompare, gEq, gShow)
import Data.Int (odd)
import Data.Maybe (Maybe(..), fromJust)
import Data.String (Pattern(..), indexOf, joinWith, trim)
import Data.String (split) as String
import Data.String.Regex (Regex, test, split)
import Data.String.Regex.Flags (global, ignoreCase)
import Data.String.Regex.Unsafe (unsafeRegex)
import Halogen.Aff (HalogenEffects)
import Halogen.Aff.Util (awaitBody, runHalogenAff)
import Halogen.HTML.CSS (style)
import Halogen.VDom.Driver (runUI)
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

newtype Line =
    Line (Array Res)

instance showLine :: Show Line where
    show (Line line) = joinWith "" do
        res <- line
        pure case res of
            Punct s -> s
            Verb { syllables } ->
                joinWith "" do
                    Syllable { value, stype } <- syllables
                    --pure (value <> show stype)
                    pure value

class HalogenDisplay displayable where
    display :: forall a b. displayable -> HH.HTML a b

instance displayLine :: HalogenDisplay Line where
    display line_@(Line line) =
        HH.div_ [ scanned, raw ]
        where
            raw = HH.span [ style $ zindex 1 ] [ HH.text $ show line_ ]
            scanned = HH.div [ divstyle ] $ map mapper line
            divstyle = style do
                CSS.height (1.0#ex)
                zindex (-1)
                no_pointer_events
            mapper (Punct "\n") = HH.br_
            mapper (Punct s) = spacer $ HH.text s
            mapper (Verb { syllables, gloss }) =
                HH.span_ $ map display syllables

y_mark :: forall a b. HP.IProp ( style :: String | a ) b
y_mark =
    style do
        CSS.color (unsafePartial $ fromJust $ fromHexString "#F50057")
        CSS.Overflow.overflow CSS.Overflow.visible
        CSS.height (ex 1.0)
        scale 2.0 1.4
        no_user_select
        CSS.margin auto auto auto auto
        CSS.TextAlign.textAlign CSS.TextAlign.center

instance displaySyllable :: HalogenDisplay Syllable where
    display (Syllable { value, stype }) =
        HH.div
            [ style do
                CSS.display CSS.inlineBlock
                CSS.height nil
            ]
            [ HH.div [ y_mark ] [ HH.text $ show stype ]
            , spacer $ HH.text value
            ]

data Res
    = Punct String
    | Verb Word

type Word =
    { syllables :: Array Syllable
    , gloss :: String
    }

newtype Syllable = Syllable
    { value :: String
    , stype :: SyllableType
    }

data SyllableType
    = Long
    | Ambiguous (Maybe Boolean)
    | Short
    | Elided

instance showSyllableType :: Show SyllableType where
    show s =
        case s of
            Short ->
                "˘"

            Long ->
                "¯"

            Elided ->
                "˙"

            Ambiguous Nothing ->
                "˟"

            Ambiguous (Just b)
                | b -> "˜"
                | otherwise -> "ˇ"

startsWith :: Pattern -> String -> Boolean
startsWith p s = case indexOf p s of
    Just 0 -> true
    _ -> false

weight :: String -> ScanBias
weight syllable =
    if startsWith (Pattern "x") syllable || startsWith (Pattern "z") syllable then
        IntoDoubleConsonant
    else if test r_cx syllable then
        IntoConsonant
    else
        IntoVowel

data ScanBias = Elidable | IntoVowel | IntoConsonant | IntoDoubleConsonant | LineEnd
derive instance genericScanBias :: Generic ScanBias

instance showScanBias :: Show ScanBias where
  show = gShow

instance eqScanBias :: Eq ScanBias where
  eq = gEq

instance ordScanBias :: Ord ScanBias where
  compare = gCompare

reform :: Syllable -> ScanBias -> SyllableType
reform _ IntoDoubleConsonant = Long
reform (Syllable {stype: Ambiguous _}) LineEnd = Long
reform (Syllable {stype: Short}) LineEnd = Ambiguous Nothing
reform (Syllable {value}) Elidable
    | test r_elision value = Elided
reform (Syllable {stype: Ambiguous Nothing}) IntoVowel = Ambiguous (Just false)
reform (Syllable {stype: Ambiguous Nothing}) Elidable = Ambiguous (Just false)
reform (Syllable {stype: Ambiguous Nothing}) IntoConsonant = Ambiguous (Just true)
reform (Syllable {stype}) _ = stype

resimplify :: Boolean -> SyllableType -> SyllableType
resimplify true (Ambiguous (Just false)) = Short
resimplify true (Ambiguous (Just true)) = Long
resimplify _ stype = stype

inner :: Boolean -> Syllable -> State ScanBias Syllable
inner simplify syllable@(Syllable {value}) = do
    bias <- get
    put (weight value)
    let stype = resimplify simplify $ reform syllable bias
    pure (Syllable { value, stype })

middle :: Boolean -> Array Syllable -> State ScanBias (Array Syllable)
middle simplify syllables = sequenceReversed $ map (inner simplify) syllables

outer :: Boolean -> Res -> State ScanBias Res
outer simplify (Verb w) = do
    bias <- get
    case bias of
        IntoVowel -> put Elidable
        -- double consonants do not affect preceding word in scansion
        IntoDoubleConsonant -> put IntoConsonant
        _ -> pure unit
    syllables <- middle simplify w.syllables
    pure $ Verb { syllables, gloss: w.gloss }
outer _ (res@Punct "\n") = do
    put LineEnd
    pure res
outer _ res = pure res

rescan :: Boolean -> Line -> Line
rescan simplify (Line line) = Line rescanned
    where
        rescanned = evalReversedArrayState statecomputation LineEnd
        statecomputation = map (outer simplify) line

v :: String
v =
    "(?:[aeiouy]͡[aeiouyāēīōūȳ]̄?|(?:a[eu]|oe)(?![̄̈])|[aeiouyāēīōūȳ]̄?|[aeiouy]̄|[äëïöüÿ])"

c :: String
c =
    "(?:[qg]u(?=" <> v <> ")|[ck]h|[bcdfghjklmnprstvwxz]|\\bi(?=" <> v <> "))"

l :: String
l =
    "(?:" <> c <> "|" <> v <> ")"

r_word :: Regex
r_word =
    unsafeRegex ("((?:" <> c <> "|" <> v <> ")+)") (ignoreCase <> global)

r_syllable :: Regex
r_syllable =
    unsafeRegex (c <> "*" <> v <> "(" <> c <> "*$|(?![dbpckgt][rl])" <> c <> "((?=" <> c <> "+" <> v <> "?))" <> ")?") (ignoreCase <> global)

r_short :: Regex
r_short =
    unsafeRegex ("(\\bi?|[^aeiouy]|[qg]u)[aeiouy]$") ignoreCase

r_long :: Regex
r_long =
    unsafeRegex ("[aeiouy]̄|[āēīōūȳ]|a[eu]|oe|(x|z|" <> c <> c <> ")$") ignoreCase

r_cx :: Regex
r_cx =
    unsafeRegex ("^((?!h)" <> c <> "|[ij]" <> v <> "|[aeiouy]̄|[äëïöüÿ])") ignoreCase

r_elision :: Regex
r_elision =
    unsafeRegex (v <> "m?$") ignoreCase

r_wordbreak :: Regex
r_wordbreak =
    unsafeRegex ("(?:(?:^|" <> l <> ")" <> l <> "*(?=))") ignoreCase

foreign import _findall :: Regex -> String -> Array String

mksyllables :: String -> Array Syllable
mksyllables content =
    content # _findall r_syllable # map mksyllable
    --content # Regex.find Regex.All r_syllable # map (_.match >>> syllable)
    --content # Regex.match r_syllable # fromMaybe [] # map (_.match >>> syllable)

mksyllable :: String -> Syllable
mksyllable s = Syllable
    { value: s
    , stype:
        if test r_short s then
            Short
        else if test r_long s then
            Long
        else
            Ambiguous Nothing
    }

mkline :: Boolean -> String -> Line
mkline simplify content =
    content # mkwords # Array.filter nonempty # Line # rescan simplify
    where
        nonempty (Punct "") = false
        nonempty (Verb { syllables: [] }) = false
        nonempty _ = true

mklines :: Boolean -> String -> Array Line
mklines simplify content =
    trim content # String.split (Pattern "\n") # map (trim >>> mkline simplify)

processtext :: (String -> Res) -> (String -> Res) -> String -> Array Res
processtext mkverb mkpunct =
    let
        mapper i
            | odd i = mkverb
            | otherwise = mkpunct
    in
        Array.mapWithIndex mapper <<< split r_word

mkwords :: String -> Array Res
mkwords content =
    --content # split r_word # map (\s -> Verb { syllables: mksyllables s, gloss: s})
    processtext (\s -> Verb $ { syllables: mksyllables s, gloss: s }) Punct content

data Query a
    = ToggleState a
    | UserInput Event a

type UIState =
    { simplify :: Boolean
    , text :: String
    }

initialState :: UIState
initialState =
    { simplify: true
    , text: """arma virumque canō, Trōiae quī prīmus ab ōrīs
Ītaliam fātō profugus Lāvīni͡aque vēnit"""
    }

ui :: forall eff. H.Component HH.HTML Query Unit Void (Aff (dom :: DOM | eff))
ui = H.component { render, eval, initialState: const initialState, receiver: const Nothing }
  where

  render :: UIState -> H.ComponentHTML Query
  render state =
    HH.div_
        ([ HH.h2_/>"Pantheum"
        , checkbox (HE.input_ ToggleState) [] "Simplify scansion marks" state.simplify
        , textarea (HE.input UserInput) [] "Text to scan" 5 state.text
        , HH.br_
        ] <> map display (mklines state.simplify state.text))

  eval :: Query ~> H.ComponentDSL UIState Query Void (Aff (dom :: DOM | eff))
  eval (ToggleState next) = do
    H.modify (\state -> { simplify: not state.simplify, text: state.text })
    pure next
  eval (UserInput e next) = do
    let node = unsafeCoerce Event.target e :: HTMLInputElement
    s <- H.liftEff (HInput.value node :: Eff (dom :: DOM | eff) String)
    H.modify (\state -> { simplify: state.simplify, text: s })
    pure next

main :: Eff (HalogenEffects ()) Unit
main = runHalogenAff do
  body <- awaitBody
  runUI ui unit body


takeOrFail

takeOrFail

module KanColle.Expedition.New.CostModel
  ( calcFleetMaxCost
  , calcActualCost
  , calcFleetActualCost
  , normalCostModel
  ) where

import Prelude
import KanColle.Expedition.New.Types
import Data.Map as M
import Data.Array as A
import Data.Maybe
import Control.MonadPlus
import Data.Unfoldable
import Data.Tuple
import Data.Traversable
import Data.Int

calcFleetMaxCost :: CostModel -> FleetCompo -> Maybe FleetMaxCost
calcFleetMaxCost cm fcAr = fold <$> sequence compos
  where
    fc :: M.Map SType Int
    fc = M.fromFoldableWith (+) (map (\x -> Tuple x 1) fcAr)
    compos = map (\(Tuple sty cnt) -> cm sty cnt) (M.toList fc)

calcActualCost :: MaxCost -> Info -> ActualCost
calcActualCost (MCost mc) info = ACost
    { fuel: floor (info.fuelCostPercent * toNumber mc.fuel)
    , ammo: floor (info.ammoCostPercent * toNumber mc.ammo)
    }

calcFleetActualCost :: FleetMaxCost -> Info -> FleetActualCost
calcFleetActualCost fmc info = FACost (foldl merge z fmc)
  where
    z = {fuel: 0, ammo: 0}
    merge acc mc = case calcActualCost mc info of
      (ACost actual) ->
        {fuel: acc.fuel+actual.fuel, ammo: acc.ammo+actual.ammo}

-- | take some elements from a list, fail if the array does not have sufficient elements
takeOrFail :: forall a. Int -> Array a -> Maybe (Array a)
takeOrFail n xs
  | n <= A.length xs = Just (A.take n xs)
  | otherwise = Nothing

-- | a normal cost model assumes all ships are remodelled to
-- | their final forms. (the exceptions are like Taigei, Chitose-A and Chiyoda-A
-- | as their further remodels also change ship type.)
normalCostModel :: CostModel
normalCostModel stype = case stype of
    DD -> ddCost
    CL -> clCost
    CVLike -> cvlLikeCost
    SSLike -> ssLikeCost
    CA -> caCost
    BBV -> bbvCost
    AS -> asCost
    CT -> ctCost
    AV -> avCost
  where
    ddCost n =
      -- use Mutsuki class destroyers
      Just (replicate n (mkMC 15 15))
    clCost n
      | n <= 2 =
        -- use 2 Tenryuu class ships,
        Just (replicate n (mkMC 25 25))
      | n <= 6 = do
        -- if we need more, fill the rest with some Nagara class ships
        c <- clCost 2
        Just (c <> replicate (n-2) (mkMC 25 30))
      | otherwise = Nothing
    avCost n
      | n <= 2 =
        -- Chitose-A and Chiyoda-A
        Just (replicate n (mkMC 35 45))
      | n <= 3 = do
        -- and Mizuho Kai
        c <- avCost 2
        Just (c <> [mkMC 40 45])
      | n <= 4 = do
        -- and Commandant Teste Kai
        c <- avCost 3
        Just (c <> [mkMC 40 50])
      | n <= 5 = do
        -- and Akitsushima Kai
        c <- avCost 4
        Just (c <> [mkMC 60 15])
      | otherwise = Nothing
    -- Taigei
    asCost n = do
        guard (n <= 1)
        Just (replicate n (mkMC 35 10))
    -- Katori class
    ctCost n = do
        guard (n <= 2)
        Just (replicate n (mkMC 35 20))
    caCost n
      | n <= 1 =
        -- Aoba Kai
        Just (replicate n (mkMC 35 55))
      | n <= 4 = do
        -- Furutaka Kai Ni, Kako Kai Ni, Kinugasa Kai Ni
        c <- caCost 1
        Just (c <> replicate (n-1) (mkMC 35 65))
      | n <= 6 = do
        -- Takao Kai, Atago Kai
        c <- caCost 4
        Just (c <> replicate (n-4) (mkMC 40 70))
      | otherwise = Nothing
    bbvCost n
      | n <= 2 =
        -- Ise class
        Just (replicate n (mkMC 95 105))
      | n <= 4 = do
        -- Fusou class
        c <- bbvCost 2
        Just (c <> replicate (n-2) (mkMC 105 140))
      | otherwise = Nothing
    ssLikeCost n
      | n <= 1 =
        -- Maruyu Kai
        Just (replicate n (mkMC 10 10))
      | n <= 6 = do
        -- no need for SSV if we just consider:
        -- I-168, I-58, I-19, I-8 and Ro-500
        c <- ssLikeCost 1
        Just (c <> replicate (n-1) (mkMC 10 20))
      | otherwise = Nothing
    cvlLikeCost n
      | n <= 1 =
        -- Houshou Kai
        Just (replicate n (mkMC 30 30))
      | n <= 2 = do
        -- Ryuuhou Kai
        c <- cvlLikeCost 1
        Just (c <> replicate (n-1) (mkMC 35 40))
      | n <= 4 = do
        -- Chitose-A, Chiyoda-A
        c <- cvlLikeCost 2
        Just (c <> replicate (n-2) (mkMC 35 45))
      | n <= 6 = do
        -- Shouhou Kai, Zuihou Kai
        c <- cvlLikeCost 4
        Just (c <> replicate (n-4) (mkMC 40 40))
      | otherwise = Nothing

module KanColle.Expedition.New.CostModel
  ( calcFleetMaxCost
  , calcActualCost
  , calcFleetActualCost
  , normalCostModel
  ) where

import Prelude
import KanColle.Expedition.New.Types
import Data.Map as M
import Data.Maybe
import Control.MonadPlus
import Data.Unfoldable
import Data.Tuple
import Data.Traversable
import Data.Int

calcFleetMaxCost :: CostModel -> FleetCompo -> Maybe FleetMaxCost
calcFleetMaxCost cm fcAr = fold <$> sequence compos
  where
    fc :: M.Map SType Int
    fc = M.fromFoldableWith (+) (map (\x -> Tuple x 1) fcAr)
    compos = map (\(Tuple sty cnt) -> cm sty cnt) (M.toList fc)

calcActualCost :: MaxCost -> Info -> ActualCost
calcActualCost (MCost mc) info = ACost
    { fuel: floor (info.fuelCostPercent * toNumber mc.fuel)
    , ammo: floor (info.ammoCostPercent * toNumber mc.ammo)
    }

calcFleetActualCost :: FleetMaxCost -> Info -> FleetActualCost
calcFleetActualCost fmc info = FACost (foldl merge z fmc)
  where
    z = {fuel: 0, ammo: 0}
    merge acc mc = case calcActualCost mc info of
      (ACost actual) ->
        {fuel: acc.fuel+actual.fuel, ammo: acc.ammo+actual.ammo}

-- | a normal cost model assumes all ships are remodelled to
-- | their final forms. (the exceptions are like Taigei, Chitose-A and Chiyoda-A
-- | as their further remodels also change ship type.)
normalCostModel :: CostModel
normalCostModel stype = case stype of
    DD -> ddCost
    CL -> clCost
    CVLike -> cvlLikeCost
    SSLike -> ssLikeCost
    CA -> caCost
    BBV -> bbvCost
    AS -> asCost
    CT -> ctCost
    AV -> avCost
  where
    ddCost n =
      -- use Mutsuki class destroyers
      Just (replicate n (mkMC 15 15))
    clCost n
      | n <= 2 =
        -- use 2 Tenryuu class ships,
        Just (replicate n (mkMC 25 25))
      | n <= 6 = do
        -- if we need more, fill the rest with some Nagara class ships
        c <- clCost 2
        Just (c <> replicate (n-2) (mkMC 25 30))
      | otherwise = Nothing
    avCost n
      | n <= 2 =
        -- Chitose-A and Chiyoda-A
        Just (replicate n (mkMC 35 45))
      | n <= 3 = do
        -- and Mizuho Kai
        c <- avCost 2
        Just (c <> [mkMC 40 45])
      | n <= 4 = do
        -- and Commandant Teste Kai
        c <- avCost 3
        Just (c <> [mkMC 40 50])
      | n <= 5 = do
        -- and Akitsushima Kai
        c <- avCost 4
        Just (c <> [mkMC 60 15])
      | otherwise = Nothing
    -- Taigei
    asCost n = do
        guard (n <= 1)
        Just (replicate n (mkMC 35 10))
    -- Katori class
    ctCost n = do
        guard (n <= 2)
        Just (replicate n (mkMC 35 20))
    caCost n
      | n <= 1 =
        -- Aoba Kai
        Just (replicate n (mkMC 35 55))
      | n <= 4 = do
        -- Furutaka Kai Ni, Kako Kai Ni, Kinugasa Kai Ni
        c <- caCost 1
        Just (c <> replicate (n-1) (mkMC 35 65))
      | n <= 6 = do
        -- Takao Kai, Atago Kai
        c <- caCost 4
        Just (c <> replicate (n-4) (mkMC 40 70))
      | otherwise = Nothing
    bbvCost n
      | n <= 2 =
        -- Ise class
        Just (replicate n (mkMC 95 105))
      | n <= 4 = do
        -- Fusou class
        c <- bbvCost 2
        Just (c <> replicate (n-2) (mkMC 105 140))
      | otherwise = Nothing
    ssLikeCost n
      | n <= 1 =
        -- Maruyu Kai
        Just (replicate n (mkMC 10 10))
      | n <= 6 = do
        -- no need for SSV if we just consider:
        -- I-168, I-58, I-19, I-8 and Ro-500
        c <- ssLikeCost 1
        Just (c <> replicate (n-1) (mkMC 10 20))
      | otherwise = Nothing
    cvlLikeCost n
      | n <= 1 =
        -- Houshou Kai
        Just (replicate n (mkMC 30 30))
      | n <= 2 = do
        -- Ryuuhou Kai
        c <- cvlLikeCost 1
        Just (c <> replicate (n-1) (mkMC 35 40))
      | n <= 4 = do
        -- Chitose-A, Chiyoda-A
        c <- cvlLikeCost 2
        Just (c <> replicate (n-2) (mkMC 35 45))
      | n <= 6 = do
        -- Shouhou Kai, Zuihou Kai
        c <- cvlLikeCost 4
        Just (c <> replicate (n-4) (mkMC 40 40))
      | otherwise = Nothing