{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
module Hcompta.Polarize where

import           Control.DeepSeq
import           Data.Data (Data)
import           Data.Eq (Eq(..))
import           Data.Ord (Ord(..))
import           Data.Functor (Functor(..))
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe (Maybe(..))
import           Data.Typeable
import           Data.Typeable ()
import           Prelude (Integer, seq)
import           Text.Show (Show)

import           Hcompta.Quantity

-- * Type 'Polarized'

-- | Polarize a 'Quantity' to distinctively keep track
--   of negative and positive 'Quantity's.
data Polarized q
 =   Polarized_Negative !q
 |   Polarized_Positive !q
 |   Polarized_Both     !q !q
 deriving (Data, Eq, Show, Typeable)
instance NFData q
 =>      NFData (Polarized q) where
	rnf (Polarized_Negative a) = rnf a
	rnf (Polarized_Positive a) = rnf a
	rnf (Polarized_Both a0 a1) = rnf a0 `seq` rnf a1
instance Functor Polarized where
	fmap f (Polarized_Negative a) = Polarized_Negative (f a)
	fmap f (Polarized_Positive a) = Polarized_Positive (f a)
	fmap f (Polarized_Both a0 a1) = Polarized_Both (f a0) (f a1)
instance ( Zero    q
         , Addable q)
 => Zero (Polarized q) where
	quantity_zero = Polarized_Positive quantity_zero
	quantity_null qty =
		case qty of
		 Polarized_Negative n -> quantity_null n
		 Polarized_Positive p -> quantity_null p
		 Polarized_Both n p   -> quantity_null (quantity_add n p)
instance Addable q
 =>      Addable (Polarized q) where
	quantity_add a0 a1 =
		case (a0, a1) of
		 (Polarized_Negative n0, Polarized_Negative n1) -> Polarized_Negative (quantity_add n0 n1)
		 (Polarized_Negative n , Polarized_Positive p)  -> Polarized_Both n p
		 (Polarized_Negative n0, Polarized_Both n1 p)   -> Polarized_Both (quantity_add n0 n1) p
		
		 (Polarized_Positive p , Polarized_Negative n)  -> Polarized_Both n p
		 (Polarized_Positive p0, Polarized_Positive p1) -> Polarized_Positive (quantity_add p0 p1)
		 (Polarized_Positive p , Polarized_Both n1 p1)  -> Polarized_Both n1 (quantity_add p p1)
		
		 (Polarized_Both n0 p0, Polarized_Negative n)  -> Polarized_Both (quantity_add n0 n) p0
		 (Polarized_Both n0 p0, Polarized_Positive p1) -> Polarized_Both n0 (quantity_add p0 p1)
		 (Polarized_Both n0 p0, Polarized_Both n1 p1)  -> Polarized_Both (quantity_add n0 n1) (quantity_add p0 p1)
instance Negable q
 =>      Negable (Polarized q) where
	quantity_neg qty =
		case qty of
		 Polarized_Negative n -> Polarized_Positive (quantity_neg n)
		 Polarized_Positive p -> Polarized_Negative (quantity_neg p)
		 Polarized_Both n p   -> Polarized_Both     (quantity_neg p) (quantity_neg n)

polarized_negative :: Polarized q -> Maybe q
polarized_negative qty =
	case qty of
	 Polarized_Negative n -> Just n
	 Polarized_Positive _ -> Nothing
	 Polarized_Both n _   -> Just n
polarized_positive :: Polarized q -> Maybe q
polarized_positive qty =
	case qty of
	 Polarized_Negative _ -> Nothing
	 Polarized_Positive p -> Just p
	 Polarized_Both _ p   -> Just p

-- * Class 'Polarizable'

class Polarizable q where
	polarizable_negative :: q -> Maybe q
	polarizable_positive :: q -> Maybe q
instance Polarizable Integer where
	polarizable_negative q =
		case q of
		 _ | q < 0 -> Just q
		 _         -> Nothing
	polarizable_positive q =
		case q of
		 _ | q <= 0 -> Nothing
		 _          -> Just q
instance Polarizable q
 =>      Polarizable (Polarized q) where
	polarizable_negative qty =
		case qty of
		 Polarized_Negative _ -> Just qty
		 Polarized_Positive _ -> Nothing
		 Polarized_Both n _   -> Just (Polarized_Negative n)
	polarizable_positive qty =
		case qty of
		 Polarized_Negative _ -> Nothing
		 Polarized_Positive _ -> Just qty
		 Polarized_Both _ p   -> Just (Polarized_Positive p)
instance
 ( Polarizable quantity
 , Data        unit
 , Ord         unit
 , Show        unit
 ) => Polarizable (Map unit quantity) where
	polarizable_positive q =
		case Map.mapMaybe polarizable_positive q of
		 m | Map.null m -> Nothing
		 m -> Just m
	polarizable_negative q =
		case Map.mapMaybe polarizable_negative q of
		 m | Map.null m -> Nothing
		 m -> Just m

polarize
 :: Polarizable q
 => q -> Polarized q
polarize qty =
	case ( polarizable_negative qty
	     , polarizable_positive qty ) of
	 (Just n, Nothing)  -> Polarized_Negative n
	 (Nothing, Just p)  -> Polarized_Positive p
	 (Just n, Just p)   -> Polarized_Both n p
	 (Nothing, Nothing) -> Polarized_Both qty qty
depolarize
 :: Addable q
 => Polarized q -> q
depolarize qty =
	case qty of
	 Polarized_Negative n -> n
	 Polarized_Positive p -> p
	 Polarized_Both n p   -> quantity_add n p