1ad2e9f · laop · git.iko.soy

git.iko.soy/laop

Improved 'Natural' type and added 'Dist' pretty printer

commit1ad2e9f4157ed91c4e8f33ae5b5dc56eed72545f authorArmando Santos <armandoifsantos@gmail.com> dateMon 30 Dec 2019, 13:21 (7 years ago) parentb216857

6 files changed+88−33

compare with master

unifiedsplit

app/Main.hs+18−7 src/Dist.hs+6 src/Dist/Internal.hs+36−2 src/Matrix/Type.hs+1−1 src/Utils.hs+5−5 src/Utils/Internal.hs+22−18

app/Main.hs+18−7

@@ -1,4 +1,5 @@

11{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE TypeOperators #-}

23{-# LANGUAGE TypeApplications #-}

34{-# LANGUAGE DataKinds #-}

@@ -26,18 +27,25 @@ secondChoice = fromF switch

2627

2728-- Dice sum

2829

29−sumSS :: Natural 6 -> Natural 6 -> Natural 12

30−sumSS = coerceNat (+)

30+type SS = Natural 1 6

3131

32−mulSS :: Natural 6 -> Natural 6 -> Natural 36

33−mulSS = coerceNat (*)

32+sumSS :: SS -> SS -> Natural 2 12

33+sumSS = coerceNat (+)

3434

3535sumSSM = fromF' (uncurry sumSS)

3636

37−mulSSM3 = fromF' (mulSS (nat 3))

37+condition :: (Int, Int) -> Int -> Int

38+condition (fst, snd) thrd = if fst == snd

39+ then fst * 3

40+ else fst + snd + thrd

41+

42+conditionSS :: (SS, SS) -> SS -> Natural 3 18

43+conditionSS = coerceNat2 condition

44+

45+conditionalThrows = fromF' (uncurry conditionSS) `comp` khatri die (khatri die die)

3846

39−die :: Dist (Natural 6) 6

40−die = uniform [nat @6 1 .. nat 6]

47+die :: Dist (Natural 1 6) 6

48+die = uniform [nat @1 @6 1 .. nat 6]

4149

4250-- Sprinkler

4351

@@ -62,6 +70,9 @@ main = do

6270 prettyPrint (p1 @Double @1 `comp` secondChoice `comp` firstChoice)

6371 putStrLn "\n Sum of dices probability:"

6472 prettyPrint (sumSSM `comp` khatri die die)

73+ prettyPrintDist @(Natural 2 12) (sumSSM `comp` khatri die die)

74+ putStrLn "\n Conditional dice throw:"

75+ prettyPrintDist @(Natural 3 18) conditionalThrows

6576 putStrLn "\n Checking that the last result is indeed a distribution: "

6677 prettyPrint (bang `comp` sumSSM `comp` khatri die die)

6778 putStrLn "\n Probability of grass being wet:"

src/Dist.hs+6

@@ -42,6 +42,12 @@ module Dist

4242 uniform,

4343 negExp,

4444 normal,

45+

46+ -- * Converto to list of pairs

47+ toValues,

48+ -- * Pretty print distribution

49+ prettyDist,

50+ prettyPrintDist

4551 )

4652where

4753

src/Dist/Internal.hs+36−2

@@ -1,3 +1,7 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE TypeApplications #-}

3+{-# LANGUAGE KindSignatures #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

15{-# LANGUAGE FlexibleContexts #-}

26{-# LANGUAGE DataKinds #-}

37{-# LANGUAGE RankNTypes #-}

@@ -11,19 +15,25 @@ module Dist.Internal

1115 linear,

1216 uniform,

1317 negExp,

14− normal

18+ normal,

19+ toValues,

20+ prettyDist,

21+ prettyPrintDist

1522 )

1623 where

1724

1825import Matrix.Nat

1926import Utils

27+import GHC.TypeLits

28+import Data.Proxy

29+import Data.List (sortBy)

2030

2131-- | Type synonym for probability value

2232type Prob = Double

2333

2434-- | Type synonym for column vector matrices. This represents a probability

2535-- distribution.

26−type Dist a m = (FromLists Prob () (FromNat m)) => Matrix Prob 1 m

36+type Dist a (m :: Nat) = (FromLists Prob () (FromNat m)) => Matrix Prob 1 m

2737

2838-- | Constructs a Bernoulli distribution

2939choose :: Prob -> Dist a 2

@@ -53,6 +63,30 @@ negExp = shape (\x -> exp (-x))

5363normal :: [a] -> Dist a m

5464normal = shape (normalCurve 0.5 0.5)

5565

66+-- | Transforms a 'Dist' into a list of pairs.

67+toValues :: forall a m . (Enum a, KnownNat m, FromLists Prob () (FromNat m)) => Dist a m -> [(a, Prob)]

68+toValues d =

69+ let rows = fromInteger (natVal (Proxy :: Proxy m))

70+ probs = toList d

71+ res = zip (map toEnum [0..rows]) probs

72+ in res

73+

74+-- | Pretty a distribution

75+prettyDist :: forall a m . (Show a, Enum a, KnownNat m, FromLists Prob () (FromNat m)) => Dist a m -> String

76+prettyDist d =

77+ let values = sortBy (\(a, p1) (b, p2) -> compare p2 p1) (toValues @a d)

78+ w = maximum (map (length . show . fst) values)

79+ in concatMap

80+ (\(x,p) -> showR w x ++ ' ': showProb p ++ "\n")

81+ values

82+ where

83+ showProb p = show (p * 100) ++ "%"

84+ showR n x = show x ++ " "

85+

86+-- | Pretty Print a distribution

87+prettyPrintDist :: forall a m . (Show a, Enum a, KnownNat m, FromLists Prob () (FromNat m)) => Dist a m -> IO ()

88+prettyPrintDist = putStrLn . prettyDist @a

89+

5690-- Auxiliary functions

5791

5892fromFreqs :: [(a,Prob)] -> Dist a m

src/Matrix/Type.hs+1−1

@@ -154,7 +154,7 @@ deriving instance (Show e) => Show (Matrix e cols rows)

154154-- It can also count the cardinality of custom types that implement the

155155-- 'Generic' instance.

156156type family Count (d :: Type) where

157− Count (Natural n) = n

157+ Count (Natural n m) = (m - n) + 1

158158 Count (Either a b) = (+) (Count a) (Count b)

159159 Count (a, b) = (*) (Count a) (Count b)

160160 Count (a -> b) = (^) (Count b) (Count a)

src/Utils.hs+5−5

@@ -19,8 +19,8 @@ module Utils

1919 ( -- | Utility module that provides the 'Natural' data type.

2020 -- The semantic associated with this data type is that

2121 -- it's meant to be a restricted 'Int' value. For example

22− -- the type @Natural 6@ can only be instanciated with @Nat n@

23− -- where @0 <= n <= 6@. Why, You might ask, because with normal

22+ -- the type @Natural 1 6@ can only be instanciated with @nat n@

23+ -- where @1 <= n <= 6@. Why, You might ask, because with normal

2424 -- 'Int's it is not possible to have a decent @Enum (Int, Int)@

2525 -- instance. See the following probabilistic programming model as and

2626 -- example:

@@ -74,13 +74,13 @@ module Utils

7474 -- allows one to model the sample in an easier way. See for instance:

7575 --

7676 -- @

77− -- ssAdd :: Natural 6 -> Natural 6 -> Natural 12

77+ -- ssAdd :: Natural 1 6 -> Natural 1 6 -> Natural 1 12

7878 -- ssAdd = coerceNat (+)

7979 --

8080 -- ssAddM = fromF' (uncurry sumSS)

8181 --

82− -- die :: Dist (Natural 6) 6

83− -- die = uniform [nat @6 1 .. nat 6]

82+ -- die :: Dist (Natural 1 6) 6

83+ -- die = uniform [nat @1 @6 1 .. nat 6]

8484 --

8585 -- dieSumProb = ssAddM `comp` (khatri die die)

8686 -- @

src/Utils/Internal.hs+22−18

@@ -92,42 +92,46 @@ import Data.Proxy

9292import GHC.TypeLits

9393

9494-- | Wrapper around 'Int's that have a restrictive semantic associated.

95−-- A value of type @'Natural' n@ can only be instanciated with some 'Int'

96−-- @i@ that's @0 <= i <= n@.

97−newtype Natural (nat :: Nat) = Nat Int

95+-- A value of type @'Natural' n m@ can only be instanciated with some 'Int'

96+-- @i@ that's @n <= i <= m@.

97+newtype Natural (start :: Nat) (end :: Nat) = Nat Int

9898 deriving (Show, Read, Eq, Num)

9999

100100-- | Natural constructor function. Throws a runtime error if the 'Int'

101−-- value is greater than the corresponding @n@ in the @'Natural' n@ type.

102−nat :: forall n. (KnownNat n) => Int -> Natural n

101+-- value is greater than the corresponding @m@ or lower than @n@ in the @'Natural' n m@ type.

102+nat :: forall n m . (KnownNat n, KnownNat m) => Int -> Natural n m

103103nat i =

104− let nat = fromInteger (natVal (Proxy :: Proxy n))

105− in if i <= nat

104+ let start = fromInteger (natVal (Proxy :: Proxy n))

105+ end = fromInteger (natVal (Proxy :: Proxy m))

106+ in if start <= i && i <= end

106107 then Nat i

107108 else error "Off limits"

108109

109110-- | Auxiliary function that promotes binary 'Int' functions to 'Natural'

110111-- binary functions.

111−coerceNat :: (Int -> Int -> Int) -> (Natural a -> Natural b -> Natural c)

112+coerceNat :: (Int -> Int -> Int) -> (Natural a a' -> Natural b b' -> Natural c c')

112113coerceNat = coerce

113114

114115-- | Auxiliary function that promotes ternary (binary) 'Int' functions to 'Natural'

115116-- functions.

116−coerceNat2 :: ((Int, Int) -> Int -> Int) -> ((Natural a, Natural b) -> Natural c -> Natural d)

117+coerceNat2 :: ((Int, Int) -> Int -> Int) -> ((Natural a a', Natural b b') -> Natural c c' -> Natural d d')

117118coerceNat2 = coerce

118119

119−instance KnownNat n => Bounded (Natural n) where

120− minBound = Nat 0

121− maxBound = Nat $ fromInteger (natVal (Proxy :: Proxy n))

120+instance (KnownNat n, KnownNat m) => Bounded (Natural n m) where

121+ minBound = Nat $ fromInteger (natVal (Proxy :: Proxy n))

122+ maxBound = Nat $ fromInteger (natVal (Proxy :: Proxy m))

122123

123−instance KnownNat n => Enum (Natural n) where

124− toEnum = nat

124+instance (KnownNat n, KnownNat m) => Enum (Natural n m) where

125+ toEnum i =

126+ let start = fromInteger (natVal (Proxy :: Proxy n))

127+ in nat (start + i)

125128 -- | Throws a runtime error if the value is off limits

126129 fromEnum (Nat nat) =

127− let val = fromInteger (natVal (Proxy :: Proxy n))

128− in if nat > val

129− then error "Off limits"

130− else nat

130+ let start = fromInteger (natVal (Proxy :: Proxy n))

131+ end = fromInteger (natVal (Proxy :: Proxy m))

132+ in if start <= nat && nat <= end

133+ then nat - start

134+ else error "Off limits"

131135

132136-- | Optimized 'Enum' instance for tuples that comply with the given

133137-- constraints.