]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Quantity.hs
Remove cli/
[comptalang.git] / lib / Hcompta / Quantity.hs
1 {-# LANGUAGE DefaultSignatures #-}
2 {-# LANGUAGE DeriveFunctor #-}
3 {-# LANGUAGE StandaloneDeriving #-}
4 {-# LANGUAGE UndecidableInstances #-}
5 {-# OPTIONS_GHC -fno-warn-orphans #-}
6 module Hcompta.Quantity where
7
8 import Control.DeepSeq (NFData(..))
9 import Data.Bool
10 import Data.Data (Data)
11 import Data.Decimal (Decimal, DecimalRaw(..), roundTo)
12 import Data.Eq (Eq(..))
13 import Data.Function (const, flip)
14 import Data.Functor (Functor(..), (<$>))
15 import Data.Map.Strict (Map)
16 import Data.Maybe (Maybe(..))
17 import Data.Ord (Ord(..), Ordering(..))
18 import Data.Semigroup (Semigroup(..))
19 import Data.Sequence (Seq)
20 import Data.TreeMap.Strict (TreeMap)
21 import Data.Tuple (curry, uncurry)
22 import Data.Typeable (Typeable)
23 import Data.Word (Word8)
24 import Prelude (Integer, Integral, fromIntegral, seq)
25 import Text.Show (Show(..))
26 import qualified Data.Foldable as Foldable
27 import qualified Data.List as L
28 import qualified Data.Map.Strict as Map
29 import qualified Data.Sequence as Seq
30 import qualified Data.TreeMap.Strict as TM
31 import qualified Prelude
32
33 -- * Class 'Zeroable'
34 class Zeroable a where
35 zero :: a
36
37 instance Zeroable () where
38 zero = ()
39 instance Zeroable Integer where
40 zero = 0
41 instance Zeroable Decimal where
42 zero = 0
43 instance Zeroable (Seq a) where
44 zero = Seq.empty
45 instance Zeroable [a] where
46 zero = []
47 instance Zeroable (Map k a) where
48 zero = Map.empty
49 instance Zeroable (TreeMap k a) where
50 zero = TM.empty
51
52 -- * Class 'Nullable'
53 class Zeroable a => Nullable a where
54 null :: a -> Bool
55 default null :: Eq a => a -> Bool
56 null = (== zero)
57
58 instance Nullable Integer where
59 null = (==) 0
60 instance Nullable Decimal where
61 null = (==) 0
62 instance Nullable [a] where
63 null = L.null
64 instance Nullable (Seq a) where
65 null = Seq.null
66 instance Nullable a => Nullable (Map k a) where
67 null = Foldable.all null
68 instance Nullable (TreeMap k a) where
69 null = TM.null
70
71 -- * Class 'Signable'
72 class Signable a where
73 sign :: a -> Ordering
74 default sign :: (Nullable a, Ord a) => a -> Ordering
75 sign a =
76 case () of
77 _ | null a -> EQ
78 _ | a < zero -> LT
79 _ -> GT
80
81 instance Signable Integer
82 instance Signable Decimal
83
84 -- * Class 'Addable'
85 class Addable a where
86 (+) :: a -> a -> a; infixl 6 +
87 instance Addable () where
88 (+) = const
89 instance Addable Integer where
90 (+) = (Prelude.+)
91 instance Addable Decimal where
92 (+) x y =
93 Decimal e (fromIntegral (nx Prelude.+ ny))
94 where (e, nx, ny) = roundMinDecimal x y
95 instance Addable [a] where
96 (+) = (<>)
97 instance Addable (Seq a) where
98 (+) = (<>)
99 instance (Ord k, Addable a) => Addable (Map k a) where
100 (+) = Map.unionWith (flip (+))
101 instance (Ord k, Addable a) => Addable (TreeMap k a) where
102 (+) = TM.union (+)
103
104 -- * Class 'Negable'
105 class Negable a where
106 neg :: a -> a
107 instance Negable Integer where
108 neg = Prelude.negate
109 instance Negable Decimal where
110 neg = Prelude.negate
111 instance Negable a => Negable (Map k a) where
112 neg = Map.map neg
113
114 -- * Class 'Subable'
115 class Subable a where
116 (-) :: a -> a -> a; infixl 6 -
117 instance Subable Integer where
118 (-) = (Prelude.-)
119 instance Subable Decimal where
120 (-) = (Prelude.-)
121 instance (Ord k, Addable a, Negable a) => Subable (Map k a) where
122 (-) x y = Map.unionWith (flip (+)) x (neg y)
123
124 -- * Class 'Sumable'
125 class Sumable s a where
126 (+=) :: s -> a -> s; infix 4 +=
127 sum :: a -> s
128 default sum :: Zeroable s => a -> s
129 sum = (zero +=)
130 instance (Sumable s a, Zeroable s) => Sumable s [a] where
131 (+=) = Foldable.foldr (flip (+=))
132 sum = (zero +=)
133 instance (Ord k, Addable a) => Sumable (TreeMap k a) (TM.Path k, a) where
134 (+=) = flip (uncurry (TM.insert (flip (+))))
135 instance (Ord k, Addable a, Sumable (Map k b) (TM.Path k, a)) =>
136 Sumable (Map k b) (TreeMap k a) where
137 (+=) = TM.foldr_with_Path (curry (flip (+=)))
138
139 -- * Class 'Polarizable'
140 class Polarizable a where
141 negativeOf :: a -> Maybe a
142 positiveOf :: a -> Maybe a
143 instance Polarizable Integer where
144 negativeOf q =
145 case q of
146 _ | q < 0 -> Just q
147 _ -> Nothing
148 positiveOf q =
149 case q of
150 _ | q <= 0 -> Nothing
151 _ -> Just q
152 instance Polarizable Decimal where
153 negativeOf q =
154 case q of
155 _ | q < 0 -> Just q
156 _ -> Nothing
157 positiveOf q =
158 case q of
159 _ | q <= 0 -> Nothing
160 _ -> Just q
161 instance Polarizable (Polarized a) where
162 negativeOf qty =
163 case qty of
164 PolNegative _ -> Just qty
165 PolPositive _ -> Nothing
166 PolBoth n _ -> Just (PolNegative n)
167 positiveOf qty =
168 case qty of
169 PolNegative _ -> Nothing
170 PolPositive _ -> Just qty
171 PolBoth _ p -> Just (PolPositive p)
172 instance Polarizable a => Polarizable (Map k a) where
173 positiveOf q =
174 case Map.mapMaybe positiveOf q of
175 m | Map.null m -> Nothing
176 m -> Just m
177 negativeOf q =
178 case Map.mapMaybe negativeOf q of
179 m | Map.null m -> Nothing
180 m -> Just m
181 instance Polarizable a => Polarizable (k, a) where
182 positiveOf (u, q) = (u,) <$> positiveOf q
183 negativeOf (u, q) = (u,) <$> negativeOf q
184
185 -- ** Type 'Polarized'
186 -- | Polarize a quantity to distinctively keep track
187 -- of negative and positive ones.
188 data Polarized a
189 = PolNegative !a
190 | PolPositive !a
191 | PolBoth !a !a
192 deriving (Data, Eq, Functor, Ord, Show, Typeable)
193 instance NFData a => NFData (Polarized a) where
194 rnf (PolNegative n) = rnf n
195 rnf (PolPositive p) = rnf p
196 rnf (PolBoth n p) = rnf n `seq` rnf p
197 instance Zeroable a => Zeroable (Polarized a) where
198 zero = PolPositive zero
199 instance (Nullable a, Addable a) => Nullable (Polarized a) where
200 null qty =
201 case qty of
202 PolNegative n -> null n
203 PolPositive p -> null p
204 PolBoth n p -> null (n + p)
205 instance Addable a => Addable (Polarized a) where
206 PolNegative nx + PolNegative ny = PolNegative (nx + ny)
207 PolNegative n + PolPositive p = PolBoth n p
208 PolNegative nx + PolBoth ny p = PolBoth (nx + ny) p
209
210 PolPositive p + PolNegative n = PolBoth n p
211 PolPositive px + PolPositive py = PolPositive (px + py)
212 PolPositive p + PolBoth ny py = PolBoth ny (p + py)
213
214 PolBoth nx px + PolNegative n = PolBoth (nx + n) px
215 PolBoth nx px + PolPositive py = PolBoth nx (px + py)
216 PolBoth nx px + PolBoth ny py = PolBoth (nx + ny) (px + py)
217 instance Negable a => Negable (Polarized a) where
218 neg (PolNegative n) = PolPositive (neg n)
219 neg (PolPositive p) = PolNegative (neg p)
220 neg (PolBoth n p) = PolBoth (neg p) (neg n)
221
222 unNegative :: Polarized a -> Maybe a
223 unNegative qty =
224 case qty of
225 PolNegative n -> Just n
226 PolPositive _ -> Nothing
227 PolBoth n _ -> Just n
228
229 unPositive :: Polarized a -> Maybe a
230 unPositive qty =
231 case qty of
232 PolNegative _ -> Nothing
233 PolPositive p -> Just p
234 PolBoth _ p -> Just p
235
236 polarize :: Polarizable a => a -> Polarized a
237 polarize qty =
238 case (negativeOf qty, positiveOf qty) of
239 (Just n, Nothing) -> PolNegative n
240 (Nothing, Just p) -> PolPositive p
241 (Just n, Just p) -> PolBoth n p
242 (Nothing, Nothing) -> PolBoth qty qty
243 depolarize :: Addable a => Polarized a -> a
244 depolarize qty =
245 case qty of
246 PolNegative n -> n
247 PolPositive p -> p
248 PolBoth n p -> n + p
249
250 -- * Type 'Decimal'
251
252 -- Orphan instance
253 deriving instance Data Decimal
254
255 -- | Round the two 'DecimalRaw' values to the smallest exponent.
256 roundMinDecimal :: Integral i => DecimalRaw i -> DecimalRaw i -> (Word8, i, i)
257 roundMinDecimal d1@(Decimal e1 _) d2@(Decimal e2 _) = (e, n1, n2)
258 where
259 e = min e1 e2
260 Decimal _ n1 = roundTo e d1
261 Decimal _ n2 = roundTo e d2