lib/Hcompta/Polarize.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 module Hcompta.Polarize where
   4
   5 import           Control.DeepSeq
   6 import           Data.Data (Data)
   7 import           Data.Eq (Eq(..))
   8 import           Data.Ord (Ord(..))
   9 import           Data.Functor (Functor(..))
  10 import           Data.Map.Strict (Map)
  11 import qualified Data.Map.Strict as Map
  12 import           Data.Maybe (Maybe(..))
  13 import           Data.Typeable
  14 import           Data.Typeable ()
  15 import           Prelude (Integer, seq)
  16 import           Text.Show (Show)
  17
  18 import           Hcompta.Quantity
  19
  20 -- * Type 'Polarized'
  21
  22 -- | Polarize a 'Quantity' to distinctively keep track
  23 --   of negative and positive 'Quantity's.
  24 data Polarized q
  25  =   Polarized_Negative !q
  26  |   Polarized_Positive !q
  27  |   Polarized_Both     !q !q
  28  deriving (Data, Eq, Show, Typeable)
  29 instance NFData q
  30  =>      NFData (Polarized q) where
  31         rnf (Polarized_Negative a) = rnf a
  32         rnf (Polarized_Positive a) = rnf a
  33         rnf (Polarized_Both a0 a1) = rnf a0 `seq` rnf a1
  34 instance Functor Polarized where
  35         fmap f (Polarized_Negative a) = Polarized_Negative (f a)
  36         fmap f (Polarized_Positive a) = Polarized_Positive (f a)
  37         fmap f (Polarized_Both a0 a1) = Polarized_Both (f a0) (f a1)
  38 instance ( Zero    q
  39          , Addable q)
  40  => Zero (Polarized q) where
  41         quantity_zero = Polarized_Positive quantity_zero
  42         quantity_null qty =
  43                 case qty of
  44                  Polarized_Negative n -> quantity_null n
  45                  Polarized_Positive p -> quantity_null p
  46                  Polarized_Both n p   -> quantity_null (quantity_add n p)
  47 instance Addable q
  48  =>      Addable (Polarized q) where
  49         quantity_add a0 a1 =
  50                 case (a0, a1) of
  51                  (Polarized_Negative n0, Polarized_Negative n1) -> Polarized_Negative (quantity_add n0 n1)
  52                  (Polarized_Negative n , Polarized_Positive p)  -> Polarized_Both n p
  53                  (Polarized_Negative n0, Polarized_Both n1 p)   -> Polarized_Both (quantity_add n0 n1) p
  54
  55                  (Polarized_Positive p , Polarized_Negative n)  -> Polarized_Both n p
  56                  (Polarized_Positive p0, Polarized_Positive p1) -> Polarized_Positive (quantity_add p0 p1)
  57                  (Polarized_Positive p , Polarized_Both n1 p1)  -> Polarized_Both n1 (quantity_add p p1)
  58
  59                  (Polarized_Both n0 p0, Polarized_Negative n)  -> Polarized_Both (quantity_add n0 n) p0
  60                  (Polarized_Both n0 p0, Polarized_Positive p1) -> Polarized_Both n0 (quantity_add p0 p1)
  61                  (Polarized_Both n0 p0, Polarized_Both n1 p1)  -> Polarized_Both (quantity_add n0 n1) (quantity_add p0 p1)
  62 instance Negable q
  63  =>      Negable (Polarized q) where
  64         quantity_neg qty =
  65                 case qty of
  66                  Polarized_Negative n -> Polarized_Positive (quantity_neg n)
  67                  Polarized_Positive p -> Polarized_Negative (quantity_neg p)
  68                  Polarized_Both n p   -> Polarized_Both     (quantity_neg p) (quantity_neg n)
  69
  70 polarized_negative :: Polarized q -> Maybe q
  71 polarized_negative qty =
  72         case qty of
  73          Polarized_Negative n -> Just n
  74          Polarized_Positive _ -> Nothing
  75          Polarized_Both n _   -> Just n
  76 polarized_positive :: Polarized q -> Maybe q
  77 polarized_positive qty =
  78         case qty of
  79          Polarized_Negative _ -> Nothing
  80          Polarized_Positive p -> Just p
  81          Polarized_Both _ p   -> Just p
  82
  83 -- * Class 'Polarizable'
  84
  85 class Polarizable q where
  86         polarizable_negative :: q -> Maybe q
  87         polarizable_positive :: q -> Maybe q
  88 instance Polarizable Integer where
  89         polarizable_negative q =
  90                 case q of
  91                  _ | q < 0 -> Just q
  92                  _         -> Nothing
  93         polarizable_positive q =
  94                 case q of
  95                  _ | q <= 0 -> Nothing
  96                  _          -> Just q
  97 instance Polarizable q
  98  =>      Polarizable (Polarized q) where
  99         polarizable_negative qty =
 100                 case qty of
 101                  Polarized_Negative _ -> Just qty
 102                  Polarized_Positive _ -> Nothing
 103                  Polarized_Both n _   -> Just (Polarized_Negative n)
 104         polarizable_positive qty =
 105                 case qty of
 106                  Polarized_Negative _ -> Nothing
 107                  Polarized_Positive _ -> Just qty
 108                  Polarized_Both _ p   -> Just (Polarized_Positive p)
 109 instance
 110  ( Polarizable quantity
 111  , Data        unit
 112  , Ord         unit
 113  , Show        unit
 114  ) => Polarizable (Map unit quantity) where
 115         polarizable_positive q =
 116                 case Map.mapMaybe polarizable_positive q of
 117                  m | Map.null m -> Nothing
 118                  m -> Just m
 119         polarizable_negative q =
 120                 case Map.mapMaybe polarizable_negative q of
 121                  m | Map.null m -> Nothing
 122                  m -> Just m
 123
 124 polarize
 125  :: Polarizable q
 126  => q -> Polarized q
 127 polarize qty =
 128         case ( polarizable_negative qty
 129              , polarizable_positive qty ) of
 130          (Just n, Nothing)  -> Polarized_Negative n
 131          (Nothing, Just p)  -> Polarized_Positive p
 132          (Just n, Just p)   -> Polarized_Both n p
 133          (Nothing, Nothing) -> Polarized_Both qty qty
 134 depolarize
 135  :: Addable q
 136  => Polarized q -> q
 137 depolarize qty =
 138         case qty of
 139          Polarized_Negative n -> n
 140          Polarized_Positive p -> p
 141          Polarized_Both n p   -> quantity_add n p