Zipper for Compose

Zipper for Compose

module Zippers where

import Prelude

import Control.Apply (lift2)
import Control.Comonad (class Comonad)
import Control.Comonad.Cofree (Cofree)
import Control.Comonad.Env (EnvT(..))
import Control.Extend (class Extend)
import Data.Bifunctor (bimap, lmap)
import Data.Const (Const(..))
import Data.Either (Either(..), either)
import Data.Function (on)
import Data.Functor.Compose (Compose(..))
import Data.Functor.Coproduct (Coproduct, left, right)
import Data.Functor.Product (Product(..), product)
import Data.Functor.Variant (VariantF)
import Data.Functor.Variant as VF
import Data.Identity (Identity)
import Data.Lazy (Lazy, defer, force)
import Data.Lens (Lens', lens, (^.))
import Data.List.Lazy (List, nil, uncons, (:))
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid.Additive (Additive)
import Data.Newtype (unwrap, wrap)
import Data.Pair (Pair(..))
import Data.StrMap (StrMap)
import Data.StrMap as StrMap
import Data.Symbol (class IsSymbol, SProxy(..))
import Data.Tuple (Tuple(..), fst)
import Data.Variant.Internal (FProxy(..), RLProxy(..))
import Matryoshka (class Corecursive, class Recursive, Algebra, cata, embed, project)
import Recursion (Alg)
import Test.QuickCheck (class Arbitrary, class Coarbitrary, arbitrary, coarbitrary)
import Type.Row (class ListToRow, class RowToList, Cons, Nil, kind RowList)
import Types (ATypeV, ATypeVF, Ident, Proper, Qualified, _app, _function, _name, _var)
import Unsafe.Coerce (unsafeCoerce)

type Tag = Tuple (Additive Int) (Additive Int)
type ATypeVC = Cofree ATypeVF Tag

class (Functor f, Functor f') <= Diff1 f f' | f -> f' where
  upF   :: forall x. ZF f x  ->       f x
  downF :: forall x.    f x  -> f (ZF f x)

downFTrivial ::
  forall f x.
    Functor f =>
    Diff1 f (Const Unit) =>
  f x -> f (ZF f x)
downFTrivial = map (pure (toDF (Const unit)) :<-: _)
upFTrivial ::
  forall f x.
    Applicative f =>
    Diff1 f (Const Unit) =>
  ZF f x -> f x
upFTrivial = (_ ^. _focusF) >>> pure

aroundF :: forall f f' f'' x. Diff1 f f' => Diff1 f' f'' => ZF f x  -> ZF f (ZF f x)
aroundF z@(c :<-: f) =
  (_ :<-: z) $ defer \_ ->toDF $
    downF (fromDF (force c)) <#> upZ
  where
    upZ :: ZF f' x -> ZF f x
    upZ z'@(_ :<-: x) = pure (toDF (upF z')) :<-: x

instance derivativeEnvT :: (Functor f, Diff1 f f') => Diff1 (EnvT e f) (EnvT e f') where
  downF (EnvT (Tuple e f)) = EnvT $ Tuple e $ downF f <#>
    injZF (EnvT <<< Tuple e)
  upF (dex :<-: x) =
    case fromDF (force dex) of
      EnvT (Tuple e dfx) ->
        EnvT $ Tuple e $ upF (pure (toDF' (FProxy :: FProxy f) dfx) :<-: x)

foreign import data DF :: (Type -> Type) -> Type -> Type
toDF' :: forall f f' x. Diff1 f f' => FProxy f -> f' x -> DF f x
toDF' _ = toDF
toDF :: forall f f' x. Diff1 f f' => f' x -> DF f x
toDF = unsafeCoerce
fromDF :: forall f f' x. Diff1 f f' => DF f x -> f' x
fromDF = unsafeCoerce
reDF :: forall f g f' x. Diff1 f f' => Diff1 g f' => DF f x -> DF g x
reDF = fromDF >>> toDF
reDF' :: forall f g f' x. Diff1 f f' => Diff1 g f' => FProxy g -> DF f x -> DF g x
reDF' p = fromDF >>> toDF' p
injDF :: forall f f' g x. Diff1 f f' => Diff1 (g f) (g f') =>
  (forall x. x ~> g x) -> DF f x -> DF (g f) x
injDF g = fromDF >>> g >>> toDF
liftDF :: forall f f' g g' x. Diff1 f f' => Diff1 g g' => (f' x -> g' x) -> DF f x -> DF g x
liftDF fg = fromDF >>> fg >>> toDF

instance functorDF :: Diff1 f f' => Functor (DF f) where
  map f = fromDF >>> map f >>> toDF

instance arbitraryDF :: ( Diff1 f f', Arbitrary (f' x), Arbitrary x ) => Arbitrary (DF f x) where
  arbitrary = toDF <$> arbitrary
instance coarbitraryDF :: ( Diff1 f f', Coarbitrary (f' x), Coarbitrary x ) => Coarbitrary (DF f x) where
  coarbitrary = fromDF >>> coarbitrary
instance eqDF :: ( Diff1 f f', Eq (f' x), Eq x ) => Eq (DF f x) where
  eq = eq `on` fromDF

data ZF f x = ZF (Lazy (DF f x)) x
infix 1 ZF as :<-:
cxF :: forall f x. ZF f x -> Lazy (DF f x)
cxF = (_ ^. _contextF)
toZF :: forall f f' x. Diff1 f f' => Tuple (f' x) x -> ZF f x
toZF (Tuple f'x x) = pure (toDF f'x) :<-: x
fromZF :: forall f f' x. Diff1 f f' => ZF f x -> Tuple (f' x) x
fromZF (f'x :<-: x) = Tuple (fromDF (force f'x)) x
reZF :: forall f g f' x. Diff1 f f' => Diff1 g f' => ZF f x -> ZF g x
reZF (f'x :<-: x) = reDF <$> f'x :<-: x
reZF' :: forall f g f' x. Diff1 f f' => Diff1 g f' => FProxy g -> ZF f x -> ZF g x
reZF' p (f'x :<-: x) = reDF' p <$> f'x :<-: x
injZF :: forall f f' g x. Diff1 f f' => Diff1 (g f) (g f') =>
  (forall x. x ~> g x) -> ZF f x -> ZF (g f) x
injZF g (f'x :<-: x) = injDF g <$> f'x :<-: x
injZF2 :: forall f f' g x. Diff1 f f' => Diff1 (g f) (g f') =>
  (forall x. x ~> g x) -> ZF f (ZF f x) -> ZF (g f) (ZF (g f) x)
injZF2 g (f'x :<-: x) = f'x <#> (injDF g >>> map (injZF g)) :<-: injZF g x
liftZF :: forall f f' g g' x. Diff1 f f' => Diff1 g g' => (f' x -> g' x) -> ZF f x -> ZF g x
liftZF fg (f'x :<-: x) = liftDF fg <$> f'x :<-: x

_contextF :: forall f x. Lens' (ZF f x) (Lazy (DF f x))
_contextF = lens (\(c :<-: _) -> c)
  \(_ :<-: f) c -> c :<-: f

_focusF :: forall f x. Lens' (ZF f x) x
_focusF = lens (\(_ :<-: f) -> f)
  \(c :<-: _) f -> c :<-: f

instance functorZF :: Diff1 f f' => Functor (ZF f) where
  map f (f'x :<-: x) = map f <$> f'x :<-: f x
instance extendZF :: (Diff1 f f', Diff1 f' f'') => Extend (ZF f) where
  extend f = map f <<< aroundF
instance comonadZF :: (Diff1 f f', Diff1 f' f'') => Comonad (ZF f) where
  extract (_ :<-: x) = x

instance arbitraryZF :: ( Diff1 f f', Arbitrary (f' x), Arbitrary x ) => Arbitrary (ZF f x) where
  arbitrary = lift2 ZF arbitrary arbitrary
instance coarbitraryZF :: ( Diff1 f f', Coarbitrary (f' x), Coarbitrary x ) => Coarbitrary (ZF f x) where
  coarbitrary (c :<-: f) = coarbitrary c <<< coarbitrary f
instance eqZF :: ( Diff1 f f', Eq (f' x), Eq x ) => Eq (ZF f x) where
  eq (c1 :<-: f1) (c2 :<-: f2) = eq c1 c2 && eq f1 f2

ixPair :: forall a b. (Boolean -> a -> b) -> Pair a -> Pair b
ixPair f (Pair l r) = Pair (f false l) (f true r)

ixDPair :: forall a. DPair a -> Boolean
ixDPair = fst

instance derivativeofTuple_keepsA :: Diff1 (Tuple a) (Const a) where
  downF (Tuple a b) = Tuple a $ pure (toDF (Const a)) :<-: b
  upF (a :<-: b) = Tuple (unwrap $ fromDF $ force a) b

type DPair = Tuple Boolean
instance derivativeofPair_isDPair :: Diff1 Pair (Tuple Boolean) where
  downF (Pair l r) = Pair
    (pure (toDF (Tuple false r)) :<-: l)
    (pure (toDF (Tuple true  l)) :<-: r)
  upF (c :<-: x) = case fromDF (force c), x of
    Tuple false r, l -> Pair l r
    Tuple true  l, r -> Pair l r

type DStrMap = Compose (Tuple String) StrMap
instance derivativeofStrMap_isDStrMap :: Diff1 StrMap (Compose (Tuple String) StrMap) where
  downF sm = sm # StrMap.mapWithKey \k v -> (_ :<-: v) $ defer \_ ->
    toDF (Compose (Tuple k (StrMap.delete k sm)))
  upF (c :<-: v) = case fromDF $ force c of
    Compose (Tuple k sm) ->
      StrMap.insert k v sm

instance derivativeofConst_isVoid :: Diff1 (Const a) (Const Void) where
  downF (Const a) = Const a
  upF (c :<-: _) = absurd $ unwrap $ fromDF $ force c

instance derivativeofIdentity_isUnit :: Diff1 Identity (Const Unit) where
  downF f = downFTrivial f
  upF z = upFTrivial z
instance derivativeofMaybe_isUnit :: Diff1 Maybe (Const Unit) where
  downF f = downFTrivial f
  upF z = upFTrivial z
instance derivativeofEither_isUnit :: Diff1 (Either e) (Const Unit) where
  downF f = downFTrivial f
  upF z = upFTrivial z

instance chainRule :: ( Functor f, Diff1 f f', Functor g, Diff1 g g' ) =>
  Diff1 (Compose f g) (Product (Compose f' g) g') where
  downF (Compose fg) = Compose $ downF fg <#> \(f'g :<-: g) ->
    downF g <#> liftZF \x ->
      product (Compose (fromDF (force f'g))) x
  upF (c :<-: x) = case lmap unwrap (unwrap (fromDF (force c))) of
    Tuple f'g g' -> Compose $ upF $ pure (toDF f'g) :<-:
      upF (pure (toDF g') :<-: x)

instance derivativeofCoproduct :: ( Functor f, Diff1 f f', Functor g, Diff1 g g' ) =>
  Diff1 (Coproduct f g) (Coproduct f' g') where
  downF = unwrap >>> bimap
    (downF >>> map (liftZF \f' -> left f'))
    (downF >>> map (liftZF \g' -> right g')) >>> wrap
  upF (c :<-: x) = case unwrap (fromDF (force c)) of
    Left  f' -> left  (upF (pure (toDF f') :<-: x))
    Right g' -> right (upF (pure (toDF g') :<-: x))

instance derivativeofProduct :: ( Functor f, Diff1 f f', Functor g, Diff1 g g' ) =>
  Diff1 (Product f g) (Coproduct (Product f' g) (Product f g')) where
  upF (c :<-: x) = case bimap unwrap unwrap (unwrap (fromDF (force c))) of
    Left (Tuple f' g) -> product
      (upF (pure (toDF f') :<-: x))
      (g)
    Right (Tuple f g') -> product
      (f)
      (upF (pure (toDF g') :<-: x))
  downF (Product (Tuple f g)) = product
    (downF f <#> liftZF \f' -> left  (product f' g))
    (downF g <#> liftZF \g' -> right (product f g'))

instance deriveofVariant_isVariantOfDerivatives ::
  ( RowToList r rl
  , DiffVariantF r r' rl rl'
  , ListToRow rl' r'
  ) => Diff1 (VariantF r) (VariantF r') where
  downF = unsafeCoerce (downV (RLProxy :: RLProxy rl))
  upF = unsafeCoerce (upV (RLProxy :: RLProxy rl))

type VF r' a = Tuple (Lazy (VariantF r' a)) a

class DiffVariantF (r :: # Type) (r' :: # Type) (rl :: RowList) (rl' :: RowList) | rl -> r r' rl' where
  upV :: forall a. RLProxy rl -> VF r' a -> VariantF r a
  downV :: forall a. RLProxy rl -> VariantF r a -> VariantF r (VF r' a)

instance diffVNil :: DiffVariantF () () Nil Nil where
  upV _ = fst >>> force >>> VF.case_
  downV _ = VF.case_

instance diffVCons ::
  ( IsSymbol sym
  , Functor f
  , Diff1 f f'
  , RowCons sym (FProxy f) n r
  , ListToRow rl n
  , DiffVariantF n n' rl rl'
  , RowToList n' rl'
  , RowCons sym (FProxy f') n' r'
  , Union n m r
  , Union n' m' r'
  ) => DiffVariantF r r' (Cons sym (FProxy f) rl) (Cons sym (FProxy f') rl') where
    upV _ (Tuple v x) = handleThis handleOther $ force v
      where
        sym = SProxy :: SProxy sym
        handleOther v' = VF.expand $
          upV (RLProxy :: RLProxy rl) (Tuple (pure v') x)
        handleThis = VF.on sym \f' ->
          VF.inj sym $ upF $
            pure (toDF' (FProxy :: FProxy f) f') :<-: x
    downV _ = handleThis handleOther
      where
        sym = SProxy :: SProxy sym
        handleOther v' = VF.expand $ lmap (map VF.expand) <$>
          downV (RLProxy :: RLProxy rl) v'
        handleThis = VF.on sym \f -> VF.inj sym $
          ((\(c :<-: f) -> Tuple (defer \_ -> VF.inj sym (fromDF (force c))) f) <$> downF f)

type ParentCtx t = DF (Alg t) t
type ParentCtxs t = List (ParentCtx t)
data ZRec t = ZRec (ParentCtxs t) t
infix 1 ZRec as :<<~:

toParentCtx ::
  forall t f f'.
    Recursive t f =>
    Corecursive t f =>
    Diff1 f f' =>
  DF f ~> DF (Alg t)
toParentCtx = unsafeCoerce

fromParentCtx ::
  forall t f f'.
    Recursive t f =>
    Corecursive t f =>
    Diff1 f f' =>
  DF (Alg t) ~> DF f
fromParentCtx = unsafeCoerce

downRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  ZRec t -> f (ZRec t)
downRec (context :<<~: focus) = downF (project focus) <#>
  case _ of
    cx :<-: fc ->
      toParentCtx (force cx) : context :<<~: fc

upRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  ZRec t -> Either t (ZRec t)
upRec (cxs :<<~: focus) =
  case uncons cxs of
    Nothing -> Left focus
    Just { head: cx, tail: context } -> Right $
      context :<<~: embed (upF (pure (fromParentCtx cx) :<-: focus))

tipRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  t -> ZRec t
tipRec = ZRec nil

topRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  ZRec t -> t
topRec z = upRec z # either id topRec

downIntoRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  (f ~> Maybe) -> ZRec t -> ZRec t
downIntoRec f z = maybe z id (f (downRec z))

_contextRec :: forall t. Lens' (ZRec t) (List (DF (Alg t) t))
_contextRec = lens (\(c :<<~: _) -> c)
  \(_ :<<~: f) c -> c :<<~: f

_focusRec :: forall t. Lens' (ZRec t) t
_focusRec = lens (\(_ :<<~: f) -> f)
  \(c :<<~: _) f -> c :<<~: f

type ZipperVRec = ZRec ATypeVC

handleATypeVFByTypes :: forall a r.
  { "Const" :: forall b. Const b a -> r
  , "Pair" :: Pair a -> r } ->
  ATypeVF a -> r
handleATypeVFByTypes methods = handleATypeVF
  { name: methods."Const"
  , var: methods."Const"
  , function: methods."Pair"
  , app: methods."Pair"
  }

handleATypeVFPairs :: forall a r.
  { name :: Const (Qualified Proper) a -> r
  , var :: Const Ident a -> r
  , "Pair" :: Pair a -> r } ->
  ATypeVF a -> r
handleATypeVFPairs methods = handleATypeVF
  { name: methods.name
  , var: methods.var
  , function: methods."Pair"
  , app: methods."Pair"
  }

handleATypeVFConsts :: forall a r.
  { "Const" :: forall b. Const b a -> r
  , function :: Pair a -> r
  , app :: Pair a -> r } ->
  ATypeVF a -> r
handleATypeVFConsts methods = handleATypeVF
  { name: methods."Const"
  , var: methods."Const"
  , function: methods.function
  , app: methods.app
  }

handleATypeVF :: forall a r.
  { name :: Const (Qualified Proper) a -> r
  , var :: Const Ident a -> r
  , function :: Pair a -> r
  , app :: Pair a -> r } ->
  ATypeVF a -> r
handleATypeVF methods = VF.case_
  # VF.on _name methods.name
  # VF.on _var methods.var
  # VF.on _function methods.function
  # VF.on _app methods.app

handleATypeVFReinjector :: forall a r.
  { "Const" :: forall b.
      (Const b ~> ATypeVF) ->
      (DF (Const b) ~> DF ATypeVF) ->
      Const b a -> r
  , "Pair" ::
      (Pair ~> ATypeVF) ->
      (DF Pair ~> DF ATypeVF) ->
      Pair a -> r
  } -> ATypeVF a -> r
handleATypeVFReinjector methods = VF.case_
  # VF.on _name (methods."Const" (VF.inj _name) (fromDF >>> unwrap >>> absurd))
  # VF.on _var (methods."Const" (VF.inj _var) (fromDF >>> unwrap >>> absurd))
  # VF.on _function (methods."Pair" (VF.inj _function) (fromDF >>> VF.inj _function >>> toDF))
  # VF.on _app (methods."Pair" (VF.inj _app) (fromDF >>> VF.inj _app >>> toDF))

simpleShowZRec :: ZRec ATypeV -> String
simpleShowZRec (context :<<~: focus) = go context cx
  where
    show1 :: Algebra ATypeVF String
    show1 = VF.match
      { name: unwrap >>> show
      , var: unwrap >>> show
      , function: \(Pair l r) ->
          "(" <> l <> ") -> (" <> r <> ")"
      , app: \(Pair l r) ->
          "(" <> l <> ") (" <> r <> ")"
      }
    showAll = cata show1
    cx = showAll focus
    go ls s = case uncons ls of
      Nothing -> s
      Just { head: h, tail: r } -> go r $ VF.match
        { function: showBranch " -> " s
        , app: showBranch " " s
        , name: unwrap >>> absurd
        , var: unwrap >>> absurd
        } $ fromDF $ fromParentCtx h
    showBranch :: String -> String -> DPair ATypeV -> String
    showBranch sep s (Tuple false a) = "{" <> s <> "}" <> sep <> showAll a
    showBranch sep s (Tuple true a) = showAll a <> sep <> "{" <> s <> "}"

module Zippers where

import Prelude

import Control.Apply (lift2)
import Control.Comonad (class Comonad)
import Control.Comonad.Cofree (Cofree)
import Control.Comonad.Env (EnvT(..))
import Control.Extend (class Extend)
import Data.Bifunctor (bimap, lmap)
import Data.Const (Const(..))
import Data.Either (Either(..), either)
import Data.Function (on)
import Data.Functor.Compose (Compose(..))
import Data.Functor.Coproduct (Coproduct, left, right)
import Data.Functor.Product (Product(..), product)
import Data.Functor.Variant (VariantF)
import Data.Functor.Variant as VF
import Data.Identity (Identity(..))
import Data.Lazy (Lazy, defer, force)
import Data.Lens (Lens', lens, (^.))
import Data.List.Lazy (List, nil, uncons, (:))
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid.Additive (Additive)
import Data.Newtype (unwrap, wrap)
import Data.Pair (Pair(..))
import Data.StrMap (StrMap)
import Data.StrMap as StrMap
import Data.Symbol (class IsSymbol, SProxy(..))
import Data.Tuple (Tuple(..), fst)
import Data.Variant.Internal (FProxy(..), RLProxy(..))
import Matryoshka (class Corecursive, class Recursive, Algebra, cata, embed, project)
import Recursion (Alg)
import Test.QuickCheck (class Arbitrary, class Coarbitrary, arbitrary, coarbitrary)
import Type.Row (class ListToRow, class RowToList, Cons, Nil, kind RowList)
import Types (ATypeV, ATypeVF, Ident, Proper, Qualified, _app, _function, _name, _var)
import Unsafe.Coerce (unsafeCoerce)

type Tag = Tuple (Additive Int) (Additive Int)
type ATypeVC = Cofree ATypeVF Tag

class (Functor f, Functor f') <= Diff1 f f' | f -> f' where
  upF   :: forall x. ZF f x  ->       f x
  downF :: forall x.    f x  -> f (ZF f x)

aroundF :: forall f f' f'' x. Diff1 f f' => Diff1 f' f'' => ZF f x  -> ZF f (ZF f x)
aroundF z@(c :<-: f) =
  (_ :<-: z) $ defer \_ ->toDF $
    downF (fromDF (force c)) <#> upZ
  where
    upZ :: ZF f' x -> ZF f x
    upZ z'@(_ :<-: x) = pure (toDF (upF z')) :<-: x

instance derivativeEnvT :: (Functor f, Diff1 f f') => Diff1 (EnvT e f) (EnvT e f') where
  downF (EnvT (Tuple e f)) = EnvT $ Tuple e $ downF f <#>
    injZF (EnvT <<< Tuple e)
  upF (dex :<-: x) =
    case fromDF (force dex) of
      EnvT (Tuple e dfx) ->
        EnvT $ Tuple e $ upF (pure (toDF' (FProxy :: FProxy f) dfx) :<-: x)

foreign import data DF :: (Type -> Type) -> Type -> Type
toDF' :: forall f f' x. Diff1 f f' => FProxy f -> f' x -> DF f x
toDF' _ = toDF
toDF :: forall f f' x. Diff1 f f' => f' x -> DF f x
toDF = unsafeCoerce
fromDF :: forall f f' x. Diff1 f f' => DF f x -> f' x
fromDF = unsafeCoerce
reDF :: forall f g f' x. Diff1 f f' => Diff1 g f' => DF f x -> DF g x
reDF = fromDF >>> toDF
reDF' :: forall f g f' x. Diff1 f f' => Diff1 g f' => FProxy g -> DF f x -> DF g x
reDF' p = fromDF >>> toDF' p
injDF :: forall f f' g x. Diff1 f f' => Diff1 (g f) (g f') =>
  (forall x. x ~> g x) -> DF f x -> DF (g f) x
injDF g = fromDF >>> g >>> toDF
liftDF :: forall f f' g g' x. Diff1 f f' => Diff1 g g' => (f' x -> g' x) -> DF f x -> DF g x
liftDF fg = fromDF >>> fg >>> toDF

instance functorDF :: Diff1 f f' => Functor (DF f) where
  map f = fromDF >>> map f >>> toDF

instance arbitraryDF :: ( Diff1 f f', Arbitrary (f' x), Arbitrary x ) => Arbitrary (DF f x) where
  arbitrary = toDF <$> arbitrary
instance coarbitraryDF :: ( Diff1 f f', Coarbitrary (f' x), Coarbitrary x ) => Coarbitrary (DF f x) where
  coarbitrary = fromDF >>> coarbitrary
instance eqDF :: ( Diff1 f f', Eq (f' x), Eq x ) => Eq (DF f x) where
  eq = eq `on` fromDF

data ZF f x = ZF (Lazy (DF f x)) x
infix 1 ZF as :<-:
cxF :: forall f x. ZF f x -> Lazy (DF f x)
cxF = (_ ^. _contextF)
toZF :: forall f f' x. Diff1 f f' => Tuple (f' x) x -> ZF f x
toZF (Tuple f'x x) = pure (toDF f'x) :<-: x
fromZF :: forall f f' x. Diff1 f f' => ZF f x -> Tuple (f' x) x
fromZF (f'x :<-: x) = Tuple (fromDF (force f'x)) x
reZF :: forall f g f' x. Diff1 f f' => Diff1 g f' => ZF f x -> ZF g x
reZF (f'x :<-: x) = reDF <$> f'x :<-: x
reZF' :: forall f g f' x. Diff1 f f' => Diff1 g f' => FProxy g -> ZF f x -> ZF g x
reZF' p (f'x :<-: x) = reDF' p <$> f'x :<-: x
injZF :: forall f f' g x. Diff1 f f' => Diff1 (g f) (g f') =>
  (forall x. x ~> g x) -> ZF f x -> ZF (g f) x
injZF g (f'x :<-: x) = injDF g <$> f'x :<-: x
injZF2 :: forall f f' g x. Diff1 f f' => Diff1 (g f) (g f') =>
  (forall x. x ~> g x) -> ZF f (ZF f x) -> ZF (g f) (ZF (g f) x)
injZF2 g (f'x :<-: x) = f'x <#> (injDF g >>> map (injZF g)) :<-: injZF g x
liftZF :: forall f f' g g' x. Diff1 f f' => Diff1 g g' => (f' x -> g' x) -> ZF f x -> ZF g x
liftZF fg (f'x :<-: x) = liftDF fg <$> f'x :<-: x

_contextF :: forall f x. Lens' (ZF f x) (Lazy (DF f x))
_contextF = lens (\(c :<-: _) -> c)
  \(_ :<-: f) c -> c :<-: f

_focusF :: forall f x. Lens' (ZF f x) x
_focusF = lens (\(_ :<-: f) -> f)
  \(c :<-: _) f -> c :<-: f

instance functorZF :: Diff1 f f' => Functor (ZF f) where
  map f (f'x :<-: x) = map f <$> f'x :<-: f x
instance extendZF :: (Diff1 f f', Diff1 f' f'') => Extend (ZF f) where
  extend f = map f <<< aroundF
instance comonadZF :: (Diff1 f f', Diff1 f' f'') => Comonad (ZF f) where
  extract (_ :<-: x) = x

instance arbitraryZF :: ( Diff1 f f', Arbitrary (f' x), Arbitrary x ) => Arbitrary (ZF f x) where
  arbitrary = lift2 ZF arbitrary arbitrary
instance coarbitraryZF :: ( Diff1 f f', Coarbitrary (f' x), Coarbitrary x ) => Coarbitrary (ZF f x) where
  coarbitrary (c :<-: f) = coarbitrary c <<< coarbitrary f
instance eqZF :: ( Diff1 f f', Eq (f' x), Eq x ) => Eq (ZF f x) where
  eq (c1 :<-: f1) (c2 :<-: f2) = eq c1 c2 && eq f1 f2

ixPair :: forall a b. (Boolean -> a -> b) -> Pair a -> Pair b
ixPair f (Pair l r) = Pair (f false l) (f true r)

ixDPair :: forall a. DPair a -> Boolean
ixDPair = fst

instance derivativeofTuple_keepsA :: Diff1 (Tuple a) (Const a) where
  downF (Tuple a b) = Tuple a $ pure (toDF (Const a)) :<-: b
  upF (a :<-: b) = Tuple (unwrap $ fromDF $ force a) b

type DPair = Tuple Boolean
instance derivativeofPair_isDPair :: Diff1 Pair (Tuple Boolean) where
  downF (Pair l r) = Pair
    (pure (toDF (Tuple false r)) :<-: l)
    (pure (toDF (Tuple true  l)) :<-: r)
  upF (c :<-: x) = case fromDF (force c), x of
    Tuple false r, l -> Pair l r
    Tuple true  l, r -> Pair l r

type DStrMap = Compose (Tuple String) StrMap
instance derivativeofStrMap_isDStrMap :: Diff1 StrMap (Compose (Tuple String) StrMap) where
  downF sm = sm # StrMap.mapWithKey \k v -> (_ :<-: v) $ defer \_ ->
    toDF (Compose (Tuple k (StrMap.delete k sm)))
  upF (c :<-: v) = case fromDF $ force c of
    Compose (Tuple k sm) ->
      StrMap.insert k v sm

instance derivativeofConst_isVoid :: Diff1 (Const a) (Const Void) where
  downF (Const a) = Const a
  upF (c :<-: _) = absurd $ unwrap $ fromDF $ force c

instance derivativeofIdentity_isUnit :: Diff1 Identity (Const Unit) where
  downF = map \x -> pure (toDF (Const unit)) :<-: x
  upF (_ :<-: x) = Identity x

instance derivativeofMaybe_isUnit :: Diff1 Maybe (Const Unit) where
  downF = map \x -> pure (toDF (Const unit)) :<-: x
  upF (_ :<-: x) = pure x

instance derivativeofEither_isUnit :: Diff1 (Either e) (Const Unit) where
  downF = map \x -> pure (toDF (Const unit)) :<-: x
  upF (_ :<-: x) = pure x

instance derivativeofCoproduct :: ( Functor f, Diff1 f f', Functor g, Diff1 g g' ) =>
  Diff1 (Coproduct f g) (Coproduct f' g') where
  downF = unwrap >>> bimap
    (downF >>> map (liftZF \f' -> left f'))
    (downF >>> map (liftZF \g' -> right g')) >>> wrap
  upF (c :<-: x) = case unwrap (fromDF (force c)) of
    Left  f' -> left  (upF (pure (toDF f') :<-: x))
    Right g' -> right (upF (pure (toDF g') :<-: x))

instance derivativeofProduct :: ( Functor f, Diff1 f f', Functor g, Diff1 g g' ) =>
  Diff1 (Product f g) (Coproduct (Product f' g) (Product f g')) where
  upF (c :<-: x) = case bimap unwrap unwrap (unwrap (fromDF (force c))) of
    Left (Tuple f' g) -> product
      (upF (pure (toDF f') :<-: x))
      (g)
    Right (Tuple f g') -> product
      (f)
      (upF (pure (toDF g') :<-: x))
  downF (Product (Tuple f g)) = product
    (downF f <#> liftZF \f' -> left  (product f' g))
    (downF g <#> liftZF \g' -> right (product f g'))

instance deriveofVariant_isVariantOfDerivatives ::
  ( RowToList r rl
  , DiffVariantF r r' rl rl'
  , ListToRow rl' r'
  ) => Diff1 (VariantF r) (VariantF r') where
  downF = unsafeCoerce (downV (RLProxy :: RLProxy rl))
  upF = unsafeCoerce (upV (RLProxy :: RLProxy rl))

type VF r' a = Tuple (Lazy (VariantF r' a)) a

class DiffVariantF (r :: # Type) (r' :: # Type) (rl :: RowList) (rl' :: RowList) | rl -> r r' rl' where
  upV :: forall a. RLProxy rl -> VF r' a -> VariantF r a
  downV :: forall a. RLProxy rl -> VariantF r a -> VariantF r (VF r' a)

instance diffVNil :: DiffVariantF () () Nil Nil where
  upV _ = fst >>> force >>> VF.case_
  downV _ = VF.case_

instance diffVCons ::
  ( IsSymbol sym
  , Functor f
  , Diff1 f f'
  , RowCons sym (FProxy f) n r
  , ListToRow rl n
  , DiffVariantF n n' rl rl'
  , RowToList n' rl'
  , RowCons sym (FProxy f') n' r'
  , Union n m r
  , Union n' m' r'
  ) => DiffVariantF r r' (Cons sym (FProxy f) rl) (Cons sym (FProxy f') rl') where
    upV _ (Tuple v x) = handleThis handleOther $ force v
      where
        sym = SProxy :: SProxy sym
        handleOther v' = VF.expand $
          upV (RLProxy :: RLProxy rl) (Tuple (pure v') x)
        handleThis = VF.on sym \f' ->
          VF.inj sym $ upF $
            pure (toDF' (FProxy :: FProxy f) f') :<-: x
    downV _ = handleThis handleOther
      where
        sym = SProxy :: SProxy sym
        handleOther v' = VF.expand $ lmap (map VF.expand) <$>
          downV (RLProxy :: RLProxy rl) v'
        handleThis = VF.on sym \f -> VF.inj sym $
          ((\(c :<-: f) -> Tuple (defer \_ -> VF.inj sym (fromDF (force c))) f) <$> downF f)

type ParentCtx t = DF (Alg t) t
type ParentCtxs t = List (ParentCtx t)
data ZRec t = ZRec (ParentCtxs t) t
infix 1 ZRec as :<<~:

toParentCtx ::
  forall t f f'.
    Recursive t f =>
    Corecursive t f =>
    Diff1 f f' =>
  DF f ~> DF (Alg t)
toParentCtx = unsafeCoerce

fromParentCtx ::
  forall t f f'.
    Recursive t f =>
    Corecursive t f =>
    Diff1 f f' =>
  DF (Alg t) ~> DF f
fromParentCtx = unsafeCoerce

downRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  ZRec t -> f (ZRec t)
downRec (context :<<~: focus) = downF (project focus) <#>
  case _ of
    cx :<-: fc ->
      toParentCtx (force cx) : context :<<~: fc

upRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  ZRec t -> Either t (ZRec t)
upRec (cxs :<<~: focus) =
  case uncons cxs of
    Nothing -> Left focus
    Just { head: cx, tail: context } -> Right $
      context :<<~: embed (upF (pure (fromParentCtx cx) :<-: focus))

tipRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  t -> ZRec t
tipRec = ZRec nil

topRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  ZRec t -> t
topRec z = upRec z # either id topRec

downIntoRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  (f ~> Maybe) -> ZRec t -> ZRec t
downIntoRec f z = maybe z id (f (downRec z))

_contextRec :: forall t. Lens' (ZRec t) (List (DF (Alg t) t))
_contextRec = lens (\(c :<<~: _) -> c)
  \(_ :<<~: f) c -> c :<<~: f

_focusRec :: forall t. Lens' (ZRec t) t
_focusRec = lens (\(_ :<<~: f) -> f)
  \(c :<<~: _) f -> c :<<~: f

type ZipperVRec = ZRec ATypeVC

handleATypeVFByTypes :: forall a r.
  { "Const" :: forall b. Const b a -> r
  , "Pair" :: Pair a -> r } ->
  ATypeVF a -> r
handleATypeVFByTypes methods = handleATypeVF
  { name: methods."Const"
  , var: methods."Const"
  , function: methods."Pair"
  , app: methods."Pair"
  }

handleATypeVFPairs :: forall a r.
  { name :: Const (Qualified Proper) a -> r
  , var :: Const Ident a -> r
  , "Pair" :: Pair a -> r } ->
  ATypeVF a -> r
handleATypeVFPairs methods = handleATypeVF
  { name: methods.name
  , var: methods.var
  , function: methods."Pair"
  , app: methods."Pair"
  }

handleATypeVFConsts :: forall a r.
  { "Const" :: forall b. Const b a -> r
  , function :: Pair a -> r
  , app :: Pair a -> r } ->
  ATypeVF a -> r
handleATypeVFConsts methods = handleATypeVF
  { name: methods."Const"
  , var: methods."Const"
  , function: methods.function
  , app: methods.app
  }

handleATypeVF :: forall a r.
  { name :: Const (Qualified Proper) a -> r
  , var :: Const Ident a -> r
  , function :: Pair a -> r
  , app :: Pair a -> r } ->
  ATypeVF a -> r
handleATypeVF methods = VF.case_
  # VF.on _name methods.name
  # VF.on _var methods.var
  # VF.on _function methods.function
  # VF.on _app methods.app

handleATypeVFReinjector :: forall a r.
  { "Const" :: forall b.
      (Const b ~> ATypeVF) ->
      (DF (Const b) ~> DF ATypeVF) ->
      Const b a -> r
  , "Pair" ::
      (Pair ~> ATypeVF) ->
      (DF Pair ~> DF ATypeVF) ->
      Pair a -> r
  } -> ATypeVF a -> r
handleATypeVFReinjector methods = VF.case_
  # VF.on _name (methods."Const" (VF.inj _name) (fromDF >>> unwrap >>> absurd))
  # VF.on _var (methods."Const" (VF.inj _var) (fromDF >>> unwrap >>> absurd))
  # VF.on _function (methods."Pair" (VF.inj _function) (fromDF >>> VF.inj _function >>> toDF))
  # VF.on _app (methods."Pair" (VF.inj _app) (fromDF >>> VF.inj _app >>> toDF))

simpleShowZRec :: ZRec ATypeV -> String
simpleShowZRec (context :<<~: focus) = go context cx
  where
    show1 :: Algebra ATypeVF String
    show1 = VF.match
      { name: unwrap >>> show
      , var: unwrap >>> show
      , function: \(Pair l r) ->
          "(" <> l <> ") -> (" <> r <> ")"
      , app: \(Pair l r) ->
          "(" <> l <> ") (" <> r <> ")"
      }
    showAll = cata show1
    cx = showAll focus
    go ls s = case uncons ls of
      Nothing -> s
      Just { head: h, tail: r } -> go r $ VF.match
        { function: showBranch " -> " s
        , app: showBranch " " s
        , name: unwrap >>> absurd
        , var: unwrap >>> absurd
        } $ fromDF $ fromParentCtx h
    showBranch :: String -> String -> DPair ATypeV -> String
    showBranch sep s (Tuple false a) = "{" <> s <> "}" <> sep <> showAll a
    showBranch sep s (Tuple true a) = showAll a <> sep <> "{" <> s <> "}"


fix incorrect cond

fix incorrect cond

module KanColle.Expedition
  ( Fleet(..)
  , FleetRequirement(..)
  , RawShip(..)
  , Ship(..)
  , ShipRequirement(..)
  , checkExpedition
  , validExpeditionId
  , unsatisfiedRequirements
  , explainShipRequirement
  , explainFleetRequirement
  , explainRequirements
  , getAvailableExpeditions
  , fromRawShip
  , fromRawFleet
  ) where

import Prelude
import Data.Array
import Data.Foldable
import Data.Maybe
import Data.Monoid
import qualified Data.String as Str

import KanColle.SType

data ShipRequirement
  = ShipLevel Int
  | ShipTypeOneOf (Array SType)
  | ShipDrum Int

data FleetRequirement
  = Flagship ShipRequirement
  | FleetLevel Int
  | FleetDrum Int
  | FleetShipWithDrum Int
  | FleetSTypeCount Int (Array SType)
  | FleetShipCount Int

type ExpeditionRequirement = Array FleetRequirement

explainShipRequirement :: ShipRequirement -> String
explainShipRequirement v = case v of
    ShipLevel lvl -> "ship level should be at least " <> show lvl
    ShipTypeOneOf stypes ->
      "ship should have one of the following type: " <> Str.joinWith "," (map showSType stypes)
    ShipDrum n -> "ship should have at least " <> show n <> " drum(s)"

explainFleetRequirement :: FleetRequirement -> String
explainFleetRequirement v = case v of
    Flagship fs -> "flagship: " <> explainShipRequirement fs
    FleetLevel lvl -> "fleet level sum should be at least " <> show lvl
    FleetDrum drum -> "fleet should have at least " <> show drum <> " drum(s)"
    FleetShipWithDrum n -> "at least " <> show n <> " ship(s) should have drum(s)"
    FleetSTypeCount n stypes -> "require at least "
      <> show n <> " ship(s) of the following type: " <> Str.joinWith "," (map showSType stypes)
    FleetShipCount n -> "fleet should have at least " <> show n <> " ship(s)"

type Ship a =
  { ammo :: Int
  , morale :: Int
  , stype :: SType
  , level :: Int
  , drumCount :: Int
  | a}

type RawShip a =
  { ammo :: Int
  , morale :: Int
  , stype :: String
  , level :: Int
  , drumCount :: Int
  | a}

type Fleet a = Array (Ship a)

fromRawShip :: forall a. RawShip a -> Ship a
fromRawShip s = s {stype = readSType s.stype}

fromRawFleet :: forall a. Array (RawShip a) -> Fleet a
fromRawFleet = map fromRawShip

checkShip :: forall a. ShipRequirement -> Ship a -> Boolean
checkShip req s = case req of
  ShipLevel n -> s.level >= n
  ShipTypeOneOf stype -> any ((==) s.stype) stype
  ShipDrum n -> s.drumCount >= n

checkFleet :: forall a. FleetRequirement -> Fleet a -> Boolean
checkFleet req fleet = case uncons fleet of
    Just { head: hd, tail: tl } -> case req of
        Flagship req -> checkShip req hd
        FleetLevel n -> sum (map (\x -> x.level) fleet) >= n
        FleetDrum n -> sum (map (\x -> x.drumCount) fleet) >= n
        FleetShipWithDrum n -> count (\x -> x.drumCount > 0) fleet >= n
        FleetSTypeCount n stypes -> count (checkShip (ShipTypeOneOf stypes)) fleet >= n
        FleetShipCount n -> length fleet >= n
    Nothing -> false
  where
    count pred = length <<< filter pred

getExpeditionRequirement :: Int -> ExpeditionRequirement
getExpeditionRequirement v = case v of
    1 -> fslAndSc 1 2
    2 -> fslAndSc 2 4
    3 -> fslAndSc 3 3
    4 -> fslAndSc 3 3 <> sty 1 CL <> sty 2 DD
    5 -> fslAndSc 3 4 <> sty 1 CL <> sty 2 DD
    6 -> fslAndSc 4 4
    7 -> fslAndSc 5 6
    8 -> fslAndSc 6 6

    9 -> fslAndSc 3 4 <> sty 1 CL <> sty 2 DD
    10 -> fslAndSc 3 3 <> sty 2 CL
    11 -> fslAndSc 6 4 <> sty 2 DD
    12 -> fslAndSc 4 4 <> sty 2 DD
    13 -> fslAndSc 5 6 <> sty 1 CL <> sty 4 DD
    14 -> fslAndSc 6 6 <> sty 1 CL <> sty 3 DD
    15 -> fslAndSc 9 6 <> carrier 2 <> sty 2 DD
    16 -> fslAndSc 11 6 <> sty 1 CL <> sty 2 DD

    17 -> fslAndSc 20 6 <> sty 1 CL <> sty 3 DD
    18 -> fslAndSc 15 6 <> carrier 3 <> sty 2 DD
    19 -> fslAndSc 20 6 <> sty 2 BBV <> sty 2 DD
    20 -> fslAndSc 1 2 <> submarine 1 <> sty 1 CL
    21 -> fslAndSc 15 5 <> lvlCnt 30 <> sty 1 CL <> sty 4 DD
       <> [FleetShipWithDrum 3]
    22 -> fslAndSc 30 6 <> lvlCnt 45 <> sty 1 CA <> sty 1 CL <> sty 2 DD
    23 -> fslAndSc 50 6 <> lvlCnt 200 <> sty 2 BBV <> sty 2 DD
    24 -> fslAndSc 50 6 <> lvlCnt 200 <> sty 1 CL <> sty 4 DD
       <> [Flagship (ShipTypeOneOf [CL])]

    25 -> fslAndSc 25 4 <> sty 2 CA <> sty 2 DD
    26 -> fslAndSc 30 4 <> carrier 1 <> sty 1 CL <> sty 2 DD
    27 -> fslAndSc 1 2 <> submarine 2
    28 -> fslAndSc 30 3 <> submarine 3
    29 -> fslAndSc 50 3 <> submarine 3
    30 -> fslAndSc 55 4 <> submarine 4
    31 -> fslAndSc 60 4 <> lvlCnt 200 <> submarine 4
    32 -> fslAndSc 5 4 <> sty 1 CT <> sty 2 DD
       <> [Flagship (ShipTypeOneOf [CT])]

    35 -> fslAndSc 40 6 <> carrier 2 <> sty 1 CA <> sty 1 DD
    36 -> fslAndSc 30 6 <> sty 2 AV <> sty 1 CL <> sty 1 DD
    37 -> fslAndSc 50 6 <> lvlCnt 200 <> sty 1 CL <> sty 5 DD
       <> [FleetShipWithDrum 4]
    38 -> fslAndSc 65 6 <> lvlCnt 240 <> sty 5 DD
       <> [FleetShipWithDrum 4, FleetDrum 8]
    39 -> fslAndSc 3 5 <> lvlCnt 180 <> sty 1 AS <> submarine 4
    40 -> fslAndSc 25 6 <> lvlCnt 150 <> sty 1 CL <> sty 2 AV <> sty 2 DD
       <> [Flagship (ShipTypeOneOf [CL])]
    _ -> []
  where
    lvlCnt n = [FleetLevel n]
    carrier n = [FleetSTypeCount n [CV,CVL,AV]]
    submarine n = [FleetSTypeCount n [SS,SSV]]
    sty n stype = [FleetSTypeCount n [stype]]
    fslAndSc fsl sc =
      [Flagship (ShipLevel fsl), FleetShipCount sc]

unsatisfiedRequirements :: forall a. Int -> Fleet a -> Array FleetRequirement
unsatisfiedRequirements eId fleet =
    filter (\fr -> not (checkFleet fr fleet)) fleetReqs
  where
    fleetReqs = getExpeditionRequirement eId

explainRequirements :: Array FleetRequirement -> Array String
explainRequirements = map explainFleetRequirement

checkExpedition :: forall a. Int -> Fleet a -> Boolean
checkExpedition eId fleet = validExpeditionId eId
                         && null (unsatisfiedRequirements eId fleet)

validExpeditionId :: Int -> Boolean
validExpeditionId = getExpeditionRequirement >>> null >>> not

expeditionIds :: Array Int
expeditionIds = (1..32) <> (35..40)

getAvailableExpeditions :: forall a. Fleet a -> Array Int
getAvailableExpeditions fleet =
  filter (\eId -> checkExpedition eId fleet) expeditionIds

module KanColle.Expedition
  ( Fleet(..)
  , FleetRequirement(..)
  , RawShip(..)
  , Ship(..)
  , ShipRequirement(..)
  , checkExpedition
  , validExpeditionId
  , unsatisfiedRequirements
  , explainShipRequirement
  , explainFleetRequirement
  , explainRequirements
  , getAvailableExpeditions
  , fromRawShip
  , fromRawFleet
  ) where

import Prelude
import Data.Array
import Data.Foldable
import Data.Maybe
import Data.Monoid
import qualified Data.String as Str

import KanColle.SType

data ShipRequirement
  = ShipLevel Int
  | ShipTypeOneOf (Array SType)
  | ShipDrum Int

data FleetRequirement
  = Flagship ShipRequirement
  | FleetLevel Int
  | FleetDrum Int
  | FleetShipWithDrum Int
  | FleetSTypeCount Int (Array SType)
  | FleetShipCount Int

type ExpeditionRequirement = Array FleetRequirement

explainShipRequirement :: ShipRequirement -> String
explainShipRequirement v = case v of
    ShipLevel lvl -> "ship level should be at least " <> show lvl
    ShipTypeOneOf stypes ->
      "ship should have one of the following type: " <> Str.joinWith "," (map showSType stypes)
    ShipDrum n -> "ship should have at least " <> show n <> " drum(s)"

explainFleetRequirement :: FleetRequirement -> String
explainFleetRequirement v = case v of
    Flagship fs -> "flagship: " <> explainShipRequirement fs
    FleetLevel lvl -> "fleet level sum should be at least " <> show lvl
    FleetDrum drum -> "fleet should have at least " <> show drum <> " drum(s)"
    FleetShipWithDrum n -> "at least " <> show n <> " ship(s) should have drum(s)"
    FleetSTypeCount n stypes -> "require at least "
      <> show n <> " ship(s) of the following type: " <> Str.joinWith "," (map showSType stypes)
    FleetShipCount n -> "fleet should have at least " <> show n <> " ship(s)"

type Ship a =
  { ammo :: Int
  , morale :: Int
  , stype :: SType
  , level :: Int
  , drumCount :: Int
  | a}

type RawShip a =
  { ammo :: Int
  , morale :: Int
  , stype :: String
  , level :: Int
  , drumCount :: Int
  | a}

type Fleet a = Array (Ship a)

fromRawShip :: forall a. RawShip a -> Ship a
fromRawShip s = s {stype = readSType s.stype}

fromRawFleet :: forall a. Array (RawShip a) -> Fleet a
fromRawFleet = map fromRawShip

checkShip :: forall a. ShipRequirement -> Ship a -> Boolean
checkShip req s = case req of
  ShipLevel n -> s.level >= n
  ShipTypeOneOf stype -> any ((==) s.stype) stype
  ShipDrum n -> s.drumCount >= n

checkFleet :: forall a. FleetRequirement -> Fleet a -> Boolean
checkFleet req fleet = case uncons fleet of
    Just { head: hd, tail: tl } -> case req of
        Flagship req -> checkShip req hd
        FleetLevel n -> sum (map (\x -> x.level) fleet) >= n
        FleetDrum n -> sum (map (\x -> x.drumCount) fleet) >= n
        FleetShipWithDrum n -> count (\x -> x.drumCount > 0) fleet >= n
        FleetSTypeCount n stypes -> count (checkShip (ShipTypeOneOf stypes)) fleet >= n
        FleetShipCount n -> length fleet >= n
    Nothing -> false
  where
    count pred = length <<< filter pred

getExpeditionRequirement :: Int -> ExpeditionRequirement
getExpeditionRequirement v = case v of
    1 -> fslAndSc 1 2
    2 -> fslAndSc 2 4
    3 -> fslAndSc 3 3
    4 -> fslAndSc 3 3 <> sty 1 CL <> sty 2 DD
    5 -> fslAndSc 3 4 <> sty 1 CL <> sty 2 DD
    6 -> fslAndSc 4 4
    7 -> fslAndSc 5 6
    8 -> fslAndSc 6 6

    9 -> fslAndSc 3 4 <> sty 1 CL <> sty 2 DD
    10 -> fslAndSc 3 3 <> sty 2 CL
    11 -> fslAndSc 6 4 <> sty 2 DD
    12 -> fslAndSc 4 4 <> sty 2 DD
    13 -> fslAndSc 5 6 <> sty 1 CL <> sty 4 DD
    14 -> fslAndSc 6 6 <> sty 1 CL <> sty 3 DD
    15 -> fslAndSc 9 6 <> carrier 2 <> sty 2 DD
    16 -> fslAndSc 11 6 <> sty 1 CL <> sty 2 DD

    17 -> fslAndSc 20 6 <> sty 1 CL <> sty 3 DD
    18 -> fslAndSc 15 6 <> carrier 3 <> sty 2 DD
    19 -> fslAndSc 20 6 <> sty 2 BBV <> sty 2 DD
    20 -> fslAndSc 1 2 <> submarine 1 <> sty 1 CL
    21 -> fslAndSc 15 5 <> lvlCnt 30 <> sty 1 CL <> sty 4 DD
       <> [FleetShipWithDrum 3]
    22 -> fslAndSc 30 6 <> lvlCnt 45 <> sty 1 CA <> sty 1 CL <> sty 2 DD
    23 -> fslAndSc 50 6 <> lvlCnt 200 <> sty 2 BBV <> sty 2 DD
    24 -> fslAndSc 50 6 <> lvlCnt 200 <> sty 1 CL <> sty 4 DD
       <> [Flagship (ShipTypeOneOf [CL])]

    25 -> fslAndSc 25 4 <> sty 2 CA <> sty 2 DD
    26 -> fslAndSc 30 4 <> carrier 1 <> sty 1 CL <> sty 2 DD
    27 -> fslAndSc 1 2 <> submarine 2
    28 -> fslAndSc 30 3 <> submarine 3
    29 -> fslAndSc 50 3 <> submarine 3
    30 -> fslAndSc 55 4 <> submarine 4
    31 -> fslAndSc 60 4 <> lvlCnt 200 <> submarine 4
    32 -> fslAndSc 5 4 <> sty 1 CT <> sty 2 DD
       <> [Flagship (ShipTypeOneOf [CT])]

    35 -> fslAndSc 40 6 <> carrier 2 <> sty 1 CA <> sty 1 CL
    36 -> fslAndSc 30 6 <> sty 2 AV <> sty 1 CL <> sty 1 DD
    37 -> fslAndSc 50 6 <> lvlCnt 200 <> sty 1 CL <> sty 5 DD
       <> [FleetShipWithDrum 4]
    38 -> fslAndSc 65 6 <> lvlCnt 240 <> sty 5 DD
       <> [FleetShipWithDrum 4, FleetDrum 8]
    39 -> fslAndSc 3 5 <> lvlCnt 180 <> sty 1 AS <> submarine 4
    40 -> fslAndSc 25 6 <> lvlCnt 150 <> sty 1 CL <> sty 2 AV <> sty 2 DD
       <> [Flagship (ShipTypeOneOf [CL])]
    _ -> []
  where
    lvlCnt n = [FleetLevel n]
    carrier n = [FleetSTypeCount n [CV,CVL,AV]]
    submarine n = [FleetSTypeCount n [SS,SSV]]
    sty n stype = [FleetSTypeCount n [stype]]
    fslAndSc fsl sc =
      [Flagship (ShipLevel fsl), FleetShipCount sc]

unsatisfiedRequirements :: forall a. Int -> Fleet a -> Array FleetRequirement
unsatisfiedRequirements eId fleet =
    filter (\fr -> not (checkFleet fr fleet)) fleetReqs
  where
    fleetReqs = getExpeditionRequirement eId

explainRequirements :: Array FleetRequirement -> Array String
explainRequirements = map explainFleetRequirement

checkExpedition :: forall a. Int -> Fleet a -> Boolean
checkExpedition eId fleet = validExpeditionId eId
                         && null (unsatisfiedRequirements eId fleet)

validExpeditionId :: Int -> Boolean
validExpeditionId = getExpeditionRequirement >>> null >>> not

expeditionIds :: Array Int
expeditionIds = (1..32) <> (35..40)

getAvailableExpeditions :: forall a. Fleet a -> Array Int
getAvailableExpeditions fleet =
  filter (\eId -> checkExpedition eId fleet) expeditionIds


JS interface

JS interface

module KanColle.RepairTime where

import Prelude
import Math hiding (round,floor,ceil)
import Data.Int
import KanColle.SType
import Data.Maybe
import Data.Function

dockingInSec :: SType -> Int -> Int -> Int -> Int
dockingInSec s lvl curHp maxHp = fromMaybe 0 (fromNumber repairTime) + baseTime
  where
    lostHp = maxHp - curHp
    a = floor (sqrt (toNumber (lvl - 11))) * 10 + 50
    baseTime = 30
    repairTime :: Number
    repairTime = if lvl <= 11
        then toNumber (lvl * 10) * stypeFactor s * toNumber lostHp
        else toNumber (lvl * 5 + a) * stypeFactor s * toNumber lostHp

dockingInSecJS :: Fn4 String Int Int Int Int
dockingInSecJS = mkFn4 (\s -> dockingInSec (readSType s))

facilityInSec :: SType -> Int -> Int -> Int -> Int
facilityInSec s lvl curHp maxHp = if facilitySlowestTime <= roundDockingTime
    then facilitySlowestTime
    else roundDockingTime
  where
    m20 = 20*60
    dockingTime = dockingInSec s lvl curHp maxHp
    roundDockingTime :: Int
    roundDockingTime = ceil (toNumber dockingTime / toNumber m20) * m20
    facilitySlowestTime = m20 * (maxHp - curHp)

facilityInSecJS :: Fn4 String Int Int Int Int
facilityInSecJS = mkFn4 (\s -> facilityInSec (readSType s))

stypeFactor :: SType -> Number
stypeFactor SS = 0.5

stypeFactor DD = 1.0
stypeFactor CL = 1.0
stypeFactor CLT = 1.0
stypeFactor CT = 1.0
stypeFactor AV = 1.0
stypeFactor SSV = 1.0
stypeFactor LHA = 1.0

stypeFactor CA = 1.5
stypeFactor CAV = 1.5
stypeFactor FBB = 1.5
stypeFactor CVL = 1.5
stypeFactor AS = 1.5

stypeFactor BB = 2.0
stypeFactor BBV = 2.0
stypeFactor CV = 2.0
stypeFactor CVB = 2.0
stypeFactor AR = 2.0

-- the following 3 types are still unconfirmed
-- so I'll just guess.
stypeFactor DDE = 1.0
stypeFactor XBB = 2.0
stypeFactor AP = 2.0

module KanColle.RepairTime where

import Prelude
import Math hiding (round,floor,ceil)
import Data.Int
import KanColle.SType
import Data.Maybe

dockingInSec :: SType -> Int -> Int -> Int -> Int
dockingInSec s lvl curHp maxHp = fromMaybe 0 (fromNumber repairTime) + baseTime
  where
    lostHp = maxHp - curHp
    a = floor (sqrt (toNumber (lvl - 11))) * 10 + 50
    baseTime = 30
    repairTime :: Number
    repairTime = if lvl <= 11
        then toNumber (lvl * 10) * stypeFactor s * toNumber lostHp
        else toNumber (lvl * 5 + a) * stypeFactor s * toNumber lostHp

facilityInSec :: SType -> Int -> Int -> Int -> Int
facilityInSec s lvl curHp maxHp = if facilitySlowestTime <= roundDockingTime
    then facilitySlowestTime
    else roundDockingTime
  where
    m20 = 20*60
    dockingTime = dockingInSec s lvl curHp maxHp
    roundDockingTime :: Int
    roundDockingTime = ceil (toNumber dockingTime / toNumber m20) * m20
    facilitySlowestTime = m20 * (maxHp - curHp)

stypeFactor :: SType -> Number
stypeFactor SS = 0.5

stypeFactor DD = 1.0
stypeFactor CL = 1.0
stypeFactor CLT = 1.0
stypeFactor CT = 1.0
stypeFactor AV = 1.0
stypeFactor SSV = 1.0
stypeFactor LHA = 1.0

stypeFactor CA = 1.5
stypeFactor CAV = 1.5
stypeFactor FBB = 1.5
stypeFactor CVL = 1.5
stypeFactor AS = 1.5

stypeFactor BB = 2.0
stypeFactor BBV = 2.0
stypeFactor CV = 2.0
stypeFactor CVB = 2.0
stypeFactor AR = 2.0

-- the following 3 types are still unconfirmed
-- so I'll just guess.
stypeFactor DDE = 1.0
stypeFactor XBB = 2.0
stypeFactor AP = 2.0


remove spaces from show'd lists

remove spaces from show'd lists

module Data.Array.NonEmpty
  (
    NonEmpty(..)
    ,(:|)
    ,(!!)
    ,toArray
    ,length
    ,head
    ,tail
    ,last
    ,push
    ,pop
    ,(<|)
    ,take
    ,drop
    ,map
    ,filter
    ,singleton
    ,nub
    ,nubBy
    ,concatMap
    ,append
    ,reverse
    ,reducer
    ,reducel
  ) where

import qualified Data.Array (append, drop, take, map, filter, nub, nubBy, concatMap, (!!), length, reverse) as A
import qualified Data.Array.Unsafe (last) as AU
import Data.Foldable (Foldable, foldr, foldl, foldMap)
import qualified Data.Traversable (Traversable, traverse, sequence) as T
import Data.Maybe (Maybe(..))

data NonEmpty a = NonEmpty a [a]

instance showNonEmpty :: (Show a) => Show (NonEmpty a) where
    show (NonEmpty a as) = "[" ++ (show a) ++ ":|" ++ (show as) ++ "]"

instance eqNonEmpty :: (Eq a) => Eq (NonEmpty a) where
  (==) (NonEmpty l ls) (NonEmpty r rs) = l == r && ls == rs
  (/=) l r = not (l == r)

instance functorNonEmpty :: Functor NonEmpty where
  (<$>) = map

instance applyNonEmpty :: Apply NonEmpty where
  (<*>) x y = fromArray_ $ (toArray x) <*> (toArray y)

instance applicativeNonEmpty :: Applicative NonEmpty where
  pure = singleton

instance bindNonEmpty :: Bind NonEmpty where
  (>>=) = flip concatMap

instance monadNonEmpty :: Monad NonEmpty

instance semigroupNonEmpty :: Semigroup (NonEmpty a) where
  (<>) = append

instance foldableNonEmpty :: Foldable NonEmpty where
  foldr f b as = foldr f b (toArray as)
  foldl f b as = foldl f b (toArray as)
  foldMap f as = foldMap f (toArray as)

instance traversableNonEmpty :: T.Traversable NonEmpty where
  traverse = traverse_
  sequence = traverse_ id

traverse_ :: forall a b m. (Applicative m) => (a -> m b) -> NonEmpty a -> m (NonEmpty b)
traverse_ f (NonEmpty a []) = singleton <$> f a
traverse_ f (NonEmpty a as) = (<|) <$> (f a) <*> traverse_ f (fromArray_ as)

infix 5 :|
(:|) :: forall a. a -> [a] -> NonEmpty a
(:|) a as = NonEmpty a as

toArray :: forall a. NonEmpty a -> [a]
toArray (NonEmpty a as) = a:as

length :: forall a. NonEmpty a -> Number
length (NonEmpty _ as) = 1 + A.length as

head :: forall a. NonEmpty a -> a
head (NonEmpty a _) = a

tail :: forall a. NonEmpty a -> [a]
tail (NonEmpty _ as) = as

last :: forall a. NonEmpty a -> a
last (NonEmpty a []) = a
last (NonEmpty _ as) = AU.last as

push :: forall a. a -> NonEmpty a -> NonEmpty a
push x (NonEmpty a as) = NonEmpty x (a:as)

pop :: forall a. NonEmpty a -> [a]
pop (NonEmpty a []) = []
pop (NonEmpty a as) = a : (pop_ as)

(<|) :: forall a. a -> NonEmpty a -> NonEmpty a
(<|) a as = a :| toArray as

take :: forall a. Number -> NonEmpty a -> [a]
take 0 _ = []
take 1 (NonEmpty a _) = [a]
take n (NonEmpty a as) = a:(A.take (n - 1) as)

drop :: forall a. Number -> NonEmpty a -> [a]
drop 0 nel = toArray nel
drop 1 (NonEmpty _ as) = as
drop n (NonEmpty _ as) = A.drop (n-1) as

map :: forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
map f (NonEmpty a as) = f a :| (A.map f as)

filter :: forall a. (a -> Boolean) -> NonEmpty a -> [a]
filter p as = A.filter p (toArray as)

singleton :: forall a. a -> NonEmpty a
singleton a = NonEmpty a []

nub :: forall a. (Eq a) => NonEmpty a -> NonEmpty a
nub = apply A.nub

nubBy :: forall a. (a -> a -> Boolean) -> NonEmpty a -> NonEmpty a
nubBy f = apply (A.nubBy f)

apply :: forall a b. ([a] -> [b]) -> NonEmpty a -> NonEmpty b
apply f as = fromArray_ $ f (toArray as)

concatMap :: forall a b. (a -> NonEmpty b) -> NonEmpty a -> NonEmpty b
concatMap f as = fromArray_ $ A.concatMap g (toArray as)
  where g a = toArray $ f a

infixl 8 !!
(!!) :: forall a. NonEmpty a -> Number -> Maybe a
(!!) (NonEmpty a _) 0 = Just a
(!!) (NonEmpty _ as) n = A.(!!) as (n-1)

append :: forall a. NonEmpty a -> NonEmpty a -> NonEmpty a
append (NonEmpty a as) ys = a :| A.append as (toArray ys)

reverse :: forall a. NonEmpty a -> NonEmpty a
reverse as = fromArray_ $ A.reverse $ toArray as

reducer :: forall a. (a -> a -> a) -> NonEmpty a -> a
reducer f (NonEmpty a as) = foldr f a as

reducel :: forall a. (a -> a -> a) -> NonEmpty a -> a
reducel f (NonEmpty a as) = foldl f a as

fromArray_ (a:as) = a :| as

foreign import pop_
  """
  function pop_(l) {
    if(l.length == 0) return l;
    var l1 = l.slice();
    l1.pop();
    return l1;
  }
  """ :: forall a. [a] -> [a]

module Data.Array.NonEmpty
  (
    NonEmpty(..)
    ,(:|)
    ,(!!)
    ,toArray
    ,length
    ,head
    ,tail
    ,last
    ,push
    ,pop
    ,(<|)
    ,take
    ,drop
    ,map
    ,filter
    ,singleton
    ,nub
    ,nubBy
    ,concatMap
    ,append
    ,reverse
    ,reducer
    ,reducel
  ) where

import qualified Data.Array (append, drop, take, map, filter, nub, nubBy, concatMap, (!!), length, reverse) as A
import qualified Data.Array.Unsafe (last) as AU
import Data.Foldable (Foldable, foldr, foldl, foldMap)
import qualified Data.Traversable (Traversable, traverse, sequence) as T
import Data.Maybe (Maybe(..))

data NonEmpty a = NonEmpty a [a]

instance showNonEmpty :: (Show a) => Show (NonEmpty a) where
    show (NonEmpty a as) = (show a) ++ " :| " ++ (show as)

instance eqNonEmpty :: (Eq a) => Eq (NonEmpty a) where
  (==) (NonEmpty l ls) (NonEmpty r rs) = l == r && ls == rs
  (/=) l r = not (l == r)

instance functorNonEmpty :: Functor NonEmpty where
  (<$>) = map

instance applyNonEmpty :: Apply NonEmpty where
  (<*>) x y = fromArray_ $ (toArray x) <*> (toArray y)

instance applicativeNonEmpty :: Applicative NonEmpty where
  pure = singleton

instance bindNonEmpty :: Bind NonEmpty where
  (>>=) = flip concatMap

instance monadNonEmpty :: Monad NonEmpty

instance semigroupNonEmpty :: Semigroup (NonEmpty a) where
  (<>) = append

instance foldableNonEmpty :: Foldable NonEmpty where
  foldr f b as = foldr f b (toArray as)
  foldl f b as = foldl f b (toArray as)
  foldMap f as = foldMap f (toArray as)

instance traversableNonEmpty :: T.Traversable NonEmpty where
  traverse = traverse_
  sequence = traverse_ id

traverse_ :: forall a b m. (Applicative m) => (a -> m b) -> NonEmpty a -> m (NonEmpty b)
traverse_ f (NonEmpty a []) = singleton <$> f a
traverse_ f (NonEmpty a as) = (<|) <$> (f a) <*> traverse_ f (fromArray_ as)

infix 5 :|
(:|) :: forall a. a -> [a] -> NonEmpty a
(:|) a as = NonEmpty a as

toArray :: forall a. NonEmpty a -> [a]
toArray (NonEmpty a as) = a:as

length :: forall a. NonEmpty a -> Number
length (NonEmpty _ as) = 1 + A.length as

head :: forall a. NonEmpty a -> a
head (NonEmpty a _) = a

tail :: forall a. NonEmpty a -> [a]
tail (NonEmpty _ as) = as

last :: forall a. NonEmpty a -> a
last (NonEmpty a []) = a
last (NonEmpty _ as) = AU.last as

push :: forall a. a -> NonEmpty a -> NonEmpty a
push x (NonEmpty a as) = NonEmpty x (a:as)

pop :: forall a. NonEmpty a -> [a]
pop (NonEmpty a []) = []
pop (NonEmpty a as) = a : (pop_ as)

(<|) :: forall a. a -> NonEmpty a -> NonEmpty a
(<|) a as = a :| toArray as

take :: forall a. Number -> NonEmpty a -> [a]
take 0 _ = []
take 1 (NonEmpty a _) = [a]
take n (NonEmpty a as) = a:(A.take (n - 1) as)

drop :: forall a. Number -> NonEmpty a -> [a]
drop 0 nel = toArray nel
drop 1 (NonEmpty _ as) = as
drop n (NonEmpty _ as) = A.drop (n-1) as

map :: forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
map f (NonEmpty a as) = f a :| (A.map f as)

filter :: forall a. (a -> Boolean) -> NonEmpty a -> [a]
filter p as = A.filter p (toArray as)

singleton :: forall a. a -> NonEmpty a
singleton a = NonEmpty a []

nub :: forall a. (Eq a) => NonEmpty a -> NonEmpty a
nub = apply A.nub

nubBy :: forall a. (a -> a -> Boolean) -> NonEmpty a -> NonEmpty a
nubBy f = apply (A.nubBy f)

apply :: forall a b. ([a] -> [b]) -> NonEmpty a -> NonEmpty b
apply f as = fromArray_ $ f (toArray as)

concatMap :: forall a b. (a -> NonEmpty b) -> NonEmpty a -> NonEmpty b
concatMap f as = fromArray_ $ A.concatMap g (toArray as)
  where g a = toArray $ f a

infixl 8 !!
(!!) :: forall a. NonEmpty a -> Number -> Maybe a
(!!) (NonEmpty a _) 0 = Just a
(!!) (NonEmpty _ as) n = A.(!!) as (n-1)

append :: forall a. NonEmpty a -> NonEmpty a -> NonEmpty a
append (NonEmpty a as) ys = a :| A.append as (toArray ys)

reverse :: forall a. NonEmpty a -> NonEmpty a
reverse as = fromArray_ $ A.reverse $ toArray as

reducer :: forall a. (a -> a -> a) -> NonEmpty a -> a
reducer f (NonEmpty a as) = foldr f a as

reducel :: forall a. (a -> a -> a) -> NonEmpty a -> a
reducel f (NonEmpty a as) = foldl f a as

fromArray_ (a:as) = a :| as

foreign import pop_
  """
  function pop_(l) {
    if(l.length == 0) return l;
    var l1 = l.slice();
    l1.pop();
    return l1;
  }
  """ :: forall a. [a] -> [a]


Make C# code a little nicer

Make C# code a little nicer

Original commit 6e87ca45643708b558857d3b23ea488371ab80cf

module CSharp
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory, isLetter)
import Data.Foldable (find, for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..), maybe, isJust, isNothing)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Util (capitalize, camelCase, stringEscape)
import Data.Tuple (Tuple(..), fst)
import Partial.Unsafe (unsafePartial)
import Utils (removeElement)

forbiddenNames :: Array String
forbiddenNames = ["Converter", "JsonConverter", "Type"]

renderer :: Renderer
renderer =
    { name: "C#"
    , aceMode: "csharp"
    , extension: "cs"
    , doc: csharpDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , unionName: Just $ simpleNamer unionName
        , unionPredicate: Just unionPredicate
        , nextName: \s -> "Other" <> s
        , forbiddenNames
        , topLevelNameFromGiven: id
        , forbiddenFromTopLevelNameGiven: const []
        }
    }

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

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

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

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

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

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

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

legalizeIdentifier :: String -> String
legalizeIdentifier str =
    case Str.charAt 0 str of
    -- FIXME: use the type to infer a name?
    Nothing -> "Empty"
    Just s ->
        if isStartCharacter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier ("_" <> str)

renderUnionToCSharp :: Set IRType -> Doc String
renderUnionToCSharp s =
    case nullableFromSet s of
    Just x -> do
        rendered <- renderTypeToCSharp x
        pure if isValueType x then rendered <> "?" else rendered
    Nothing -> lookupUnionName s

renderTypeToCSharp :: IRType -> Doc String
renderTypeToCSharp = case _ of
    IRNothing -> pure "object" -- we can have arrays of nothing
    IRNull -> pure "object"
    IRInteger -> pure "long"
    IRDouble -> pure "double"
    IRBool -> pure "bool"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderTypeToCSharp a
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderTypeToCSharp t
        pure $ "Dictionary<string, " <> rendered <> ">"
    IRUnion types -> renderUnionToCSharp $ unionToSet types

csNameStyle :: String -> String
csNameStyle = camelCase >>> capitalize >>> legalizeIdentifier

getDecoderHelperPrefix :: String -> Doc String
getDecoderHelperPrefix topLevelNameGiven = getForSingleOrMultipleTopLevels "" (csNameStyle topLevelNameGiven)

csharpDoc :: Doc Unit
csharpDoc = do
    oneOfThese <- getForSingleOrMultipleTopLevels "" " one of these"
    line $ "// To parse this JSON data, add NuGet 'Newtonsoft.Json' then do" <> oneOfThese <> ":"
    forTopLevel_ \topLevelNameGiven topLevelType -> do
        prefix <- getDecoderHelperPrefix topLevelNameGiven
        line "//"
        line $ "//    var data = QuickType.Converter." <> prefix <> "FromJson(jsonString);"
    line "//"
    nameSpace <- getModuleName csNameStyle
    line $ "namespace " <> nameSpace
    line "{"
    blank
    indent do
        line """using System;
using System.Net;
using System.Collections.Generic;

using Newtonsoft.Json;"""
        blank
        renderJsonConverter
        blank
        classes <- getClasses
        for_ classes \(Tuple i cd) -> do
            className <- lookupClassName i
            renderCSharpClass cd className
            blank
        unions <- getUnions
        for_ unions \types -> do
            renderCSharpUnion types
            blank
    line "}"

stringIfTrue :: Boolean -> String -> String
stringIfTrue true s = s
stringIfTrue false _ = ""

renderJsonConverter :: Doc Unit
renderJsonConverter = do
    unionNames <- getUnionNames
    let haveUnions = not $ M.isEmpty unionNames
    let names = M.values unionNames
    line $ "public class Converter" <> stringIfTrue haveUnions " : JsonConverter"
    line "{"
    indent do
        line "// Serialize/deserialize helpers"
        forTopLevel_ \topLevelNameGiven topLevelType -> do
            blank
            topLevelTypeRendered <- renderTypeToCSharp topLevelType
            fromJsonPrefix <- getDecoderHelperPrefix topLevelNameGiven
            line
                $ "public static "
                <> topLevelTypeRendered
                <> " "
                <> fromJsonPrefix
                <> "FromJson(string json) => JsonConvert.DeserializeObject<"
                <> topLevelTypeRendered
                <> ">(json, Settings);"
            line
                $ "public static string ToJson("
                <> topLevelTypeRendered
                <> " o) => JsonConvert.SerializeObject(o, Settings);"

        blank
        line "// JsonConverter stuff"

        when haveUnions do
            blank
            line "public override bool CanConvert(Type t)"
            line "{"
            indent $ line $ "return " <> intercalate " || " (map (\n -> "t == typeof(" <> n <> ")") names) <> ";"
            line "}"
            blank
            line "public override object ReadJson(JsonReader reader, Type t, object existingValue, JsonSerializer serializer)"
            line "{"
            indent do
                -- FIXME: call the constructor via reflection?
                for_ names \name -> do
                    line $ "if (t == typeof(" <> name <> "))"
                    indent $ line $ "return new " <> name <> "(reader, serializer);"
                line "throw new Exception(\"Unknown type\");"
            line "}"
            blank
            line "public override void WriteJson(JsonWriter writer, object value, JsonSerializer serializer)"
            line "{"
            indent do
                line "var t = value.GetType();"
                for_ names \name -> do
                    line $ "if (t == typeof(" <> name <> ")) {"
                    indent do
                        line $ "((" <> name <> ")value).WriteJson(writer, serializer);"
                        line "return;"
                    line "}"
                line "throw new Exception(\"Unknown type\");"
            line "}"

        blank
        line "static JsonSerializerSettings Settings = new JsonSerializerSettings"
        line "{"
        indent do
            line "MetadataPropertyHandling = MetadataPropertyHandling.Ignore,"
            line "DateParseHandling = DateParseHandling.None,"
            when haveUnions do
                line "Converters = { new Converter() },"
        line "};"
    line "}"

tokenCase :: String -> Doc Unit
tokenCase tokenType =
    line $ "case JsonToken." <> tokenType <> ":"

renderNullDeserializer :: Set IRType -> Doc Unit
renderNullDeserializer types =
    when (S.member IRNull types) do
        tokenCase "Null"
        indent do
            line "break;"

unionFieldName :: IRType -> Doc String
unionFieldName t = csNameStyle <$> getTypeNameForUnion t

deserialize :: String -> String -> Doc Unit
deserialize fieldName typeName = do
    line $ fieldName <> " = serializer.Deserialize<" <> typeName <> ">(reader);"
    line "break;"

deserializeType :: IRType -> Doc Unit
deserializeType t = do
    fieldName <- unionFieldName t
    renderedType <- renderTypeToCSharp t
    deserialize fieldName renderedType

renderPrimitiveDeserializer :: List String -> IRType -> Set IRType -> Doc Unit
renderPrimitiveDeserializer tokenTypes t types =
    when (S.member t types) do
        for_ tokenTypes \tokenType -> do
            tokenCase tokenType
        indent do
            deserializeType t

renderDoubleDeserializer :: Set IRType -> Doc Unit
renderDoubleDeserializer types =
    when (S.member IRDouble types) do
        unless (S.member IRInteger types) do
            tokenCase "Integer"
        tokenCase "Float"
        indent do
            deserializeType IRDouble

renderGenericDeserializer :: (IRType -> Boolean) -> String -> Set IRType -> Doc Unit
renderGenericDeserializer predicate tokenType types = unsafePartial $
    case find predicate types of
    Nothing -> pure unit
    Just t -> do
        tokenCase tokenType
        indent do
            deserializeType t

renderCSharpUnion :: Set IRType -> Doc Unit
renderCSharpUnion allTypes = do
    name <- lookupUnionName allTypes
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) allTypes
    line $ "public struct " <> name
    line "{"
    indent do
        for_ nonNullTypes \t -> do
            typeString <- renderUnionToCSharp $ S.union (S.singleton t) (S.singleton IRNull)
            field <- unionFieldName t
            line $ "public " <> typeString <> " " <> field <> ";"
        blank
        line $ "public " <> name <> "(JsonReader reader, JsonSerializer serializer)"
        line "{"
        indent do
            for_ (L.fromFoldable nonNullTypes) \field -> do
                fieldName <- unionFieldName field
                line $ fieldName <> " = null;"
            blank
            line "switch (reader.TokenType)"
            line "{"
            indent do
                renderNullDeserializer allTypes
                renderPrimitiveDeserializer (L.singleton "Integer") IRInteger allTypes
                renderDoubleDeserializer allTypes
                renderPrimitiveDeserializer (L.singleton "Boolean") IRBool allTypes
                renderPrimitiveDeserializer ("String" : "Date" : L.Nil) IRString allTypes
                renderGenericDeserializer isArray "StartArray" allTypes
                renderGenericDeserializer isClass "StartObject" allTypes
                renderGenericDeserializer isMap "StartObject" allTypes
                line $ "default: throw new Exception(\"Cannot convert " <> name <> "\");"
            line "}"
        line "}"
        blank
        line $ "public void WriteJson(JsonWriter writer, JsonSerializer serializer)"
        line "{"
        indent do
            for_ (L.fromFoldable nonNullTypes) \field -> do
                fieldName <- unionFieldName field
                line $ "if (" <> fieldName <> " != null) {"
                indent do
                    line $ "serializer.Serialize(writer, " <> fieldName <> ");"
                    line "return;"
                line "}"
            when (isJust emptyOrNull) do
                line "writer.WriteNull();"
            when (isNothing emptyOrNull) do
                line "throw new Exception(\"Union must not be null\");"
        line "}"
    line "}"

renderCSharpClass :: IRClassData -> String -> Doc Unit
renderCSharpClass (IRClassData { names, properties }) className = do
    let propertyNames = transformNames (simpleNamer csNameStyle) ("Other" <> _) (S.singleton className) $ map (\n -> Tuple n n) $ M.keys properties
    line $ "public class " <> className
    line "{"
    indent do
        for_ (M.toUnfoldable properties :: Array _) \(Tuple pname ptype) -> do
            line $ "[JsonProperty(\"" <> stringEscape pname <> "\")]"
            rendered <- renderTypeToCSharp ptype
            let csPropName = lookupName pname propertyNames
            line $ "public " <> rendered <> " " <> csPropName <> " { get; set; }"
            blank
    line "}"

module CSharp
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory, isLetter)
import Data.Foldable (find, for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..), maybe, isJust, isNothing)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Util (capitalize, camelCase, stringEscape)
import Data.Tuple (Tuple(..), fst)
import Partial.Unsafe (unsafePartial)
import Utils (removeElement)

forbiddenNames :: Array String
forbiddenNames = ["Converter", "JsonConverter", "Type"]

renderer :: Renderer
renderer =
    { name: "C#"
    , aceMode: "csharp"
    , extension: "cs"
    , doc: csharpDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , unionName: Just $ simpleNamer unionName
        , unionPredicate: Just unionPredicate
        , nextName: \s -> "Other" <> s
        , forbiddenNames
        , topLevelNameFromGiven: id
        , forbiddenFromTopLevelNameGiven: const []
        }
    }

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

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

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

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

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

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

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

legalizeIdentifier :: String -> String
legalizeIdentifier str =
    case Str.charAt 0 str of
    -- FIXME: use the type to infer a name?
    Nothing -> "Empty"
    Just s ->
        if isStartCharacter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier ("_" <> str)

renderUnionToCSharp :: Set IRType -> Doc String
renderUnionToCSharp s =
    case nullableFromSet s of
    Just x -> do
        rendered <- renderTypeToCSharp x
        pure if isValueType x then rendered <> "?" else rendered
    Nothing -> lookupUnionName s

renderTypeToCSharp :: IRType -> Doc String
renderTypeToCSharp = case _ of
    IRNothing -> pure "object" -- we can have arrays of nothing
    IRNull -> pure "object"
    IRInteger -> pure "long"
    IRDouble -> pure "double"
    IRBool -> pure "bool"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderTypeToCSharp a
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderTypeToCSharp t
        pure $ "Dictionary<string, " <> rendered <> ">"
    IRUnion types -> renderUnionToCSharp $ unionToSet types

csNameStyle :: String -> String
csNameStyle = camelCase >>> capitalize >>> legalizeIdentifier

getDecoderHelperPrefix :: String -> Doc String
getDecoderHelperPrefix topLevelNameGiven = getForSingleOrMultipleTopLevels "" (csNameStyle topLevelNameGiven)

csharpDoc :: Doc Unit
csharpDoc = do
    oneOfThese <- getForSingleOrMultipleTopLevels "" " one of these"
    line $ "// To parse this JSON data, add NuGet 'Newtonsoft.Json' then do" <> oneOfThese <> ":"
    forTopLevel_ \topLevelNameGiven topLevelType -> do
        prefix <- getDecoderHelperPrefix topLevelNameGiven
        line "//"
        line $ "//    var data = QuickType.Converter." <> prefix <> "FromJson(jsonString);"
    line "//"
    nameSpace <- getModuleName csNameStyle
    line $ "namespace " <> nameSpace
    line "{"
    blank
    indent do
        line """using System;
using System.Net;
using System.Collections.Generic;

using Newtonsoft.Json;"""
        blank
        renderJsonConverter
        blank
        classes <- getClasses
        for_ classes \(Tuple i cd) -> do
            className <- lookupClassName i
            renderCSharpClass cd className
            blank
        unions <- getUnions
        for_ unions \types -> do
            renderCSharpUnion types
            blank
    line "}"

stringIfTrue :: Boolean -> String -> String
stringIfTrue true s = s
stringIfTrue false _ = ""

renderJsonConverter :: Doc Unit
renderJsonConverter = do
    unionNames <- getUnionNames
    let haveUnions = not $ M.isEmpty unionNames
    let names = M.values unionNames
    line $ "public class Converter" <> stringIfTrue haveUnions " : JsonConverter"
    line "{"
    indent do
        line "static JsonSerializerSettings Settings = new JsonSerializerSettings"
        line "{"
        indent do
            line "MetadataPropertyHandling = MetadataPropertyHandling.Ignore,"
            line "DateParseHandling = DateParseHandling.None,"
            when haveUnions do
                line "Converters = { new Converter() },"
        line "};"
        blank
        line "// Serialize/deserialize helpers"
        forTopLevel_ \topLevelNameGiven topLevelType -> do
            blank
            topLevelTypeRendered <- renderTypeToCSharp topLevelType
            fromJsonPrefix <- getDecoderHelperPrefix topLevelNameGiven
            line
                $ "public static "
                <> topLevelTypeRendered
                <> " "
                <> fromJsonPrefix
                <> "FromJson(string json) => JsonConvert.DeserializeObject<"
                <> topLevelTypeRendered
                <> ">(json, Settings);"
            line
                $ "public static string ToJson("
                <> topLevelTypeRendered
                <> " o) => JsonConvert.SerializeObject(o, Settings);"

        when haveUnions do
            blank
            line "public override bool CanConvert(Type t)"
            line "{"
            indent $ line $ "return " <> intercalate " || " (map (\n -> "t == typeof(" <> n <> ")") names) <> ";"
            line "}"
            blank
            line "public override object ReadJson(JsonReader reader, Type t, object existingValue, JsonSerializer serializer)"
            line "{"
            indent do
                -- FIXME: call the constructor via reflection?
                for_ names \name -> do
                    line $ "if (t == typeof(" <> name <> "))"
                    indent $ line $ "return new " <> name <> "(reader, serializer);"
                line "throw new Exception(\"Unknown type\");"
            line "}"
            blank
            line "public override void WriteJson(JsonWriter writer, object value, JsonSerializer serializer)"
            line "{"
            indent do
                line "var t = value.GetType();"
                for_ names \name -> do
                    line $ "if (t == typeof(" <> name <> ")) {"
                    indent do
                        line $ "((" <> name <> ")value).WriteJson(writer, serializer);"
                        line "return;"
                    line "}"
                line "throw new Exception(\"Unknown type\");"
            line "}"
    line "}"

tokenCase :: String -> Doc Unit
tokenCase tokenType =
    line $ "case JsonToken." <> tokenType <> ":"

renderNullDeserializer :: Set IRType -> Doc Unit
renderNullDeserializer types =
    when (S.member IRNull types) do
        tokenCase "Null"
        indent do
            line "break;"

unionFieldName :: IRType -> Doc String
unionFieldName t = csNameStyle <$> getTypeNameForUnion t

deserialize :: String -> String -> Doc Unit
deserialize fieldName typeName = do
    line $ fieldName <> " = serializer.Deserialize<" <> typeName <> ">(reader);"
    line "break;"

deserializeType :: IRType -> Doc Unit
deserializeType t = do
    fieldName <- unionFieldName t
    renderedType <- renderTypeToCSharp t
    deserialize fieldName renderedType

renderPrimitiveDeserializer :: List String -> IRType -> Set IRType -> Doc Unit
renderPrimitiveDeserializer tokenTypes t types =
    when (S.member t types) do
        for_ tokenTypes \tokenType -> do
            tokenCase tokenType
        indent do
            deserializeType t

renderDoubleDeserializer :: Set IRType -> Doc Unit
renderDoubleDeserializer types =
    when (S.member IRDouble types) do
        unless (S.member IRInteger types) do
            tokenCase "Integer"
        tokenCase "Float"
        indent do
            deserializeType IRDouble

renderGenericDeserializer :: (IRType -> Boolean) -> String -> Set IRType -> Doc Unit
renderGenericDeserializer predicate tokenType types = unsafePartial $
    case find predicate types of
    Nothing -> pure unit
    Just t -> do
        tokenCase tokenType
        indent do
            deserializeType t

renderCSharpUnion :: Set IRType -> Doc Unit
renderCSharpUnion allTypes = do
    name <- lookupUnionName allTypes
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) allTypes
    line $ "public struct " <> name
    line "{"
    indent do
        for_ nonNullTypes \t -> do
            typeString <- renderUnionToCSharp $ S.union (S.singleton t) (S.singleton IRNull)
            field <- unionFieldName t
            line $ "public " <> typeString <> " " <> field <> ";"
        blank
        line $ "public " <> name <> "(JsonReader reader, JsonSerializer serializer)"
        line "{"
        indent do
            for_ (L.fromFoldable nonNullTypes) \field -> do
                fieldName <- unionFieldName field
                line $ fieldName <> " = null;"
            blank
            line "switch (reader.TokenType)"
            line "{"
            indent do
                renderNullDeserializer allTypes
                renderPrimitiveDeserializer (L.singleton "Integer") IRInteger allTypes
                renderDoubleDeserializer allTypes
                renderPrimitiveDeserializer (L.singleton "Boolean") IRBool allTypes
                renderPrimitiveDeserializer ("String" : "Date" : L.Nil) IRString allTypes
                renderGenericDeserializer isArray "StartArray" allTypes
                renderGenericDeserializer isClass "StartObject" allTypes
                renderGenericDeserializer isMap "StartObject" allTypes
                line $ "default: throw new Exception(\"Cannot convert " <> name <> "\");"
            line "}"
        line "}"
        blank
        line $ "public void WriteJson(JsonWriter writer, JsonSerializer serializer)"
        line "{"
        indent do
            for_ (L.fromFoldable nonNullTypes) \field -> do
                fieldName <- unionFieldName field
                line $ "if (" <> fieldName <> " != null) {"
                indent do
                    line $ "serializer.Serialize(writer, " <> fieldName <> ");"
                    line "return;"
                line "}"
            when (isJust emptyOrNull) do
                line "writer.WriteNull();"
            when (isNothing emptyOrNull) do
                line "throw new Exception(\"Union must not be null\");"
        line "}"
    line "}"

renderCSharpClass :: IRClassData -> String -> Doc Unit
renderCSharpClass (IRClassData { names, properties }) className = do
    let propertyNames = transformNames (simpleNamer csNameStyle) ("Other" <> _) (S.singleton className) $ map (\n -> Tuple n n) $ M.keys properties
    line $ "public class " <> className
    line "{"
    indent do
        for_ (M.toUnfoldable properties :: Array _) \(Tuple pname ptype) -> do
            line $ "[JsonProperty(\"" <> stringEscape pname <> "\")]"
            rendered <- renderTypeToCSharp ptype
            let csPropName = lookupName pname propertyNames
            line $ "public " <> rendered <> " " <> csPropName <> " { get; set; }"
            blank
    line "}"


removed previous example file

removed previous example file

module Starter.Kit.Example where

import Data.Array
import Data.Maybe

-- This module defines a single function diffs, which
-- returns the differences for an increasing array.
--
-- If the input is not increasing, it returns Nothing.
--
-- This contrived example was chosen to demonstrate the use
-- of the Data.Array and Data.Maybe standard libraries.

import Data.Tuple

inOrder :: forall a. (Ord a) => a -> a -> Tuple a a
inOrder a1 a2 | a1 < a2 = Tuple a1 a2
inOrder a1 a2 = Tuple a2 a1

diffs :: [Number] -> Maybe [Number]
diffs [] = return []
diffs [_] = return []
diffs (x : tail@(x' : xs)) | x <= x' = do
  tailDiffs <- diffs tail
  return (x' - x : tailDiffs)
diffs _ = Nothing


Fix FFI example

Fix FFI example

module Main where

import Control.Monad.Eff

foreign import data Random :: !

foreign import random
  "function random() { \
  \  return Math.random(); \
  \}" :: Eff (random :: Random) Number

main = Debug.Trace.print <$> random

module Main where

import Control.Monad.Eff

foreign import data Random :: !

foreign import random
  "function random() { \
  \  return function() { \
  \    return Math.random(); \
  \  }; \
  \}" :: Eff (random :: Random) Number

main = Debug.Trace.print <$> random


First step towards using less code to express hasPlayerPiece

module Checkers.Main where

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

import Checkers.Constants
import Checkers.Types

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

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

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

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

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

getCoordinateIndex :: Array Square -> Coordinate -> Maybe Int
getCoordinateIndex squares coordinate = findIndex (\s -> s.coordinate == coordinate) squares

getSquare :: Array Square -> Coordinate -> Maybe Square
getSquare squares coordinate =
  case getCoordinateIndex squares coordinate of
    Nothing -> Nothing
    Just index -> squares !! index

hasPlayerPiece :: Array Square -> Coordinate -> Player -> Boolean
hasPlayerPiece squares coordinate player =
  case getSquare squares coordinate of
    Nothing -> false
    Just square -> fromMaybe false ((\p -> p.player == player) <$> square.piece)

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

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

isOnSquare :: Square -> Pixel -> Boolean
isOnSquare square (Tuple x y) =
  let vx = fst square.render + fst square.offset
      vy = snd square.render + snd square.offset
  in vx < x && x < vx + renderSize && vy < y && y < vy + renderSize

isOnActiveSquare :: Grid -> Player -> Pixel -> Square -> Boolean
isOnActiveSquare grid player pixel square =
  let moves = getMoves grid player square.coordinate
  in isOnSquare square pixel && not (null moves)

getActiveCoordinate :: Grid -> Player -> Pixel -> Maybe Coordinate
getActiveCoordinate grid player pixel =
  case findIndex (isOnActiveSquare grid player pixel) grid.squares of
    Just index -> (\s -> s.coordinate) <$> grid.squares !! index
    Nothing    -> Nothing

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

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

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

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

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

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

highlightPiece :: forall e. Context2D -> Square -> Eff (canvas :: Canvas | e) Unit
highlightPiece ctx square = do
  let arcPiece = { x: fst square.render + 0.5 * renderSize,
                   y: snd square.render + 0.5 * renderSize,
                   r: (renderSize / 2.0) * 0.8,
                   start: 0.0,
                   end: 2.0 * pi }
  setLineWidth highlightWidth ctx
  strokePath ctx $ arc ctx arcPiece
  return unit

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

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

clickListener :: forall s e.
                   STRef s State ->
                   DOMEvent ->
                   Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
clickListener st e = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      state <- readSTRef st
      ux <- unsafeEventNumberProp "clientX" e
      uy <- unsafeEventNumberProp "clientY" e
      let pixel = Tuple (toNumber ux) (toNumber uy)
          activeCoordinate = getActiveCoordinate state.grid state.currentPlayer pixel
      writeSTRef st $ state { selectedCoordinate = activeCoordinate }
      renderPage st (Just e)
      return unit
    _ -> return unit
  return unit

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

module Checkers.Main where

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

import Checkers.Constants
import Checkers.Types

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

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

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

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

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

getCoordinateIndex :: Array Square -> Coordinate -> Maybe Int
getCoordinateIndex squares coordinate = findIndex (\s -> s.coordinate == coordinate) squares

getSquare :: Array Square -> Coordinate -> Maybe Square
getSquare squares coordinate =
  case getCoordinateIndex squares coordinate of
    Nothing -> Nothing
    Just index -> squares !! index

hasPlayerPiece :: Array Square -> Coordinate -> Player -> Boolean
hasPlayerPiece squares coordinate player =
  case getSquare squares coordinate of
    Nothing -> false
    Just square ->
      case square.piece of
        Nothing -> false
        Just p -> p.player == player

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

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

isOnSquare :: Square -> Pixel -> Boolean
isOnSquare square (Tuple x y) =
  let vx = fst square.render + fst square.offset
      vy = snd square.render + snd square.offset
  in vx < x && x < vx + renderSize && vy < y && y < vy + renderSize

isOnActiveSquare :: Grid -> Player -> Pixel -> Square -> Boolean
isOnActiveSquare grid player pixel square =
  let moves = getMoves grid player square.coordinate
  in isOnSquare square pixel && not (null moves)

getActiveCoordinate :: Grid -> Player -> Pixel -> Maybe Coordinate
getActiveCoordinate grid player pixel =
  case findIndex (isOnActiveSquare grid player pixel) grid.squares of
    Just index -> (\s -> s.coordinate) <$> grid.squares !! index
    Nothing    -> Nothing

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

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

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

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

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

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

highlightPiece :: forall e. Context2D -> Square -> Eff (canvas :: Canvas | e) Unit
highlightPiece ctx square = do
  let arcPiece = { x: fst square.render + 0.5 * renderSize,
                   y: snd square.render + 0.5 * renderSize,
                   r: (renderSize / 2.0) * 0.8,
                   start: 0.0,
                   end: 2.0 * pi }
  setLineWidth highlightWidth ctx
  strokePath ctx $ arc ctx arcPiece
  return unit

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

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

clickListener :: forall s e.
                   STRef s State ->
                   DOMEvent ->
                   Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
clickListener st e = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      state <- readSTRef st
      ux <- unsafeEventNumberProp "clientX" e
      uy <- unsafeEventNumberProp "clientY" e
      let pixel = Tuple (toNumber ux) (toNumber uy)
          activeCoordinate = getActiveCoordinate state.grid state.currentPlayer pixel
      writeSTRef st $ state { selectedCoordinate = activeCoordinate }
      renderPage st (Just e)
      return unit
    _ -> return unit
  return unit

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