{-# LANGUAGE NoImplicitPrelude, StandaloneDeriving, KindSignatures, DataKinds,
    GeneralizedNewtypeDeriving, ScopedTypeVariables, RebindableSyntax,
    NoMonomorphismRestriction, MultiParamTypeClasses, TypeFamilies,
    ConstraintKinds #-}

module Knots.Prelude
    ( module Prelude.YAP
    , module Control.Applicative
    , module Control.Monad
    , module Data.Default
    , module Data.YAP.Algebra
    , module GHC.TypeLits
    , module Data.Foldable
    , module Data.List
    , module Data.Monoid
    , module Data.Traversable
    , Ab
    , AbDef
    , AbEq
    , assert
    , castLabel
    , DefEq
    , F2
    , getArgs
    , ifThenElse
    , IntMap
    , L (..)
    , Map
    , Ordering (..)
    , Ratio (..)
    , Rational
    , RingDef
    , RingEq
    , Set
    , sum
    , swap
    , Vector
    , xor
    )
where

import Prelude.YAP ( (||)
                   , (^)
                   , (=<<)
                   , (>>=)
                   , (!!)
                   , (.)
                   , ($)
                   , (&&)
                   , (++)
                   , Bool (..)
                   , const
                   , curry
                   , Double
                   , Either (..)
                   , Enum (..)
                   , Eq (..)
                   , error
                   , even
                   , filter
                   , flip
                   , Float
                   , Fractional (..)
                   , fromIntegral
                   , fromRational
                   , fst
                   , Functor (..)
                   , id
                   , Int
                   , Integer
                   , Integral (..)
                   , IO
                   , length
                   , lines
                   , map
                   , maybe
                   , Maybe (..)
                   , mapM
                   , Monad (..)
                   , not
                   , Num (..)
                   , odd
                   , Ord (..)
                   , otherwise
                   , print
                   , putStr
                   , putStrLn
                   , read
                   , Read
                   , Real (..)
                   , reverse
                   , seq
                   , Show (..)
                   , showParen
                   , shows
                   , showString
                   , snd
                   , String
                   , subtract
                   , tail
                   , uncurry
                   , undefined
                   , unlines
                   , unwords
                   )
import Control.Applicative
import Control.DeepSeq (NFData)
import Control.Exception (assert)
import Control.Monad (guard)
import Data.Default
import Data.Foldable hiding (sum)
import Data.IntMap (IntMap)
import Data.List (intersperse, zip, zipWith, repeat, null, replicate, repeat, cycle, lookup)
import Data.Map (Map)
import Data.Monoid
import Data.Ord
import Data.Set (Set)
import Data.Traversable hiding (mapM)
import Data.Tuple (swap)
import Data.Vector (Vector)
import Data.YAP.Algebra
import GHC.TypeLits
import System.Environment (getArgs)

-- | Should be in scope when using the GHC extension RebindableSyntax
ifThenElse :: Bool -> a -> a -> a
ifThenElse x y z | x            = y
                 | otherwise    = z

xor :: Bool -> Bool -> Bool
xor a b = (a || b) && not (a && b)

-- | Like Data.Foldable.sum, but for any instance of AbelianGroup
sum :: (AbelianGroup a) => [a] -> a
sum = foldl' (+) zero

-- | A value with a label, with a Show instance that is suitable for
-- monomials. 'a' is then the index (multiindex, …) that describes the
-- monomial.
newtype L (l :: Symbol) a = L { unL :: a }

instance (Show a, SingI l) => Show (L l a) where
    show (L a) = fromSing (sing :: Sing l) ++ "^" ++ showsPrec 8 a ""

castLabel :: L l a -> L l' a
castLabel = L . unL

deriving instance Eq a => Eq (L l a)
deriving instance Ord a => Ord (L l a)
deriving instance AbelianGroup a => AbelianGroup (L l a)
deriving instance Ring a => Ring (L l a)
deriving instance EuclideanDomain a => EuclideanDomain (L l a)
deriving instance (Real a, SingI l) => Real (L l a)
deriving instance (Integral a, SingI l) => Integral (L l a)
deriving instance (Num a, SingI l) => Num (L l a)
deriving instance Enum a => Enum (L l a)
deriving instance Field a => Field (L l a)

-- The following instances are commented out now because they should really be
-- delegated to newtypes, to prevent great confusion.
--
--
--  instance (AbelianGroup a, Ord k) => AbelianGroup (Map k a) where
--      zero = M.empty
--      (+)  = M.unionWith (+)
--      negate  = fmap negate
--
--  instance (AbelianGroup a) => AbelianGroup (IntMap a) where
--      zero = IntMap.empty
--      (+)  = IntMap.unionWith (+)
--      negate  = fmap negate
--
--  instance (Ring a) => Ring (IntMap a) where
--      fromInteger = IntMap.singleton 0 . fromInteger
--      (*)  = IntMap.intersectionWith (*)

-- | Like the 'Ratio' from the base package, but with a custom Show instance,
-- and with some algebraic instances
data Ratio a = !a :% !a
type Rational = Ratio Integer

instance EuclideanDomain a => AbelianGroup (Ratio a) where
    {-# SPECIALIZE instance AbelianGroup Rational #-}
    zero = 0 :% 1
    negate (x :% y) = negate x :% y
    x1 :% y1 + x2 :% y2 = (a1 * x1 + a2 * x2) :% b
        where b = lcm y1 y2
              a1 = b `div` y1
              a2 = b `div` y2

instance EuclideanDomain a => Ring (Ratio a) where
    {-# SPECIALIZE instance Ring Rational #-}
    fromInteger a = fromInteger a :% 1
    (x1 :% y1) * (x2 :% y2) = (x1 * x2) :% (y1 * y2)

instance EuclideanDomain a => Field (Ratio a) where
    {-# SPECIALIZE instance Field Rational #-}
    (x1 :% y1) / (x2 :% y2) = (x1 * y2) :% (x2 * y1)

instance (Eq a, EuclideanDomain a) => Eq (Ratio a) where
    (x1 :% y1) == (x2 :% y2) = x1 * y2 == x2 * y1

instance (Ord a, EuclideanDomain a) => Ord (Ratio a) where
    a <= b  = case b - a of
                   x :% y -> (x >= 0 && y >= 0) || (x <= 0 && y <= 0)

instance (EuclideanDomain a, Eq a, Show a) => Show (Ratio a) where
    showsPrec p (x :% y)
        | y' == 1   = showsPrec p x'
        | otherwise = showParen (p > 7)
                    $ showsPrec 8 x'
                    . showString "/"
                    . showsPrec 8 y'
        where d = gcd x y
              x' = x `div` d
              y' = y `div` d

type Ab a = (Default a, AbelianGroup a)
type AbEq a = (Eq a, AbelianGroup a)
type AbDef a = (Default a, AbelianGroup a)
type RingEq a = (Default a, Eq a, Ring a)
type RingDef a = (Default a, Ring a)
type DefEq a = (Eq a, Default a)

instance (EuclideanDomain a) => Default (Ratio a) where
    def = 0

newtype F2 = F2 { asBoolean :: Bool }
    deriving (Eq,NFData)

instance Show F2 where
    show (F2 False) = "0"
    show (F2 True) = "1"
instance Default F2 where
    def = F2 False
instance AbelianGroup F2 where
    zero = def
    negate = id
    F2 x + F2 y = F2 (x `xor` y)
instance Ring F2 where
    fromInteger = F2 . odd
    F2 x * F2 y = F2 (x && y)
instance Field F2 where
    recip x | x == 1  = 1
            | otherwise = error "division by zero (field F2)"