summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorqfpl <>2018-08-13 07:13:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-08-13 07:13:00 (GMT)
commitc3da37c8dbfbde12e7696057efb50456fbca63e2 (patch)
tree3ffee209ac5b6e76386941986c6555a02977c298
parent500df0926d60120c7106157f1b27ad3115ed47e7 (diff)
version 0.3.0.20.3.0.2
-rw-r--r--changelog.md11
-rw-r--r--natural.cabal3
-rw-r--r--src/Natural.hs332
3 files changed, 326 insertions, 20 deletions
diff --git a/changelog.md b/changelog.md
index 2b41136..ff167ed 100644
--- a/changelog.md
+++ b/changelog.md
@@ -1,3 +1,14 @@
+0.3.0.2
+
+* fix bug in `zero` and `one` prisms.
+* rename `Natural` to `Positive`.
+* rename `Whole` to `Natural`.
+
+0.2.0.2
+
+* change `data Natural` to have a minimum bound of 1.
+* add `data Whole` which has a minimum bound of 0.
+
0.1.0.2
* add `minus` function.
diff --git a/natural.cabal b/natural.cabal
index 0f3e966..89c318b 100644
--- a/natural.cabal
+++ b/natural.cabal
@@ -1,7 +1,7 @@
-- documentation, see http://haskell.org/cabal/users-guide/
name: natural
-version: 0.1.0.2
+version: 0.3.0.2
synopsis: Natural number
description:
<<http://i.imgur.com/uZnp9ke.png>>
@@ -28,6 +28,7 @@ library
exposed-modules: Natural
build-depends: base >=4.8 && <4.12
, lens >=4.15 && < 4.18
+ , semigroupoids >= 5 && < 6
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall
diff --git a/src/Natural.hs b/src/Natural.hs
index c68e936..6ba12a8 100644
--- a/src/Natural.hs
+++ b/src/Natural.hs
@@ -3,7 +3,7 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
-module Natural(
+module Natural (
Natural
, HasNatural(..)
, AsNatural(..)
@@ -12,8 +12,6 @@ module Natural(
, MinNatural(..)
, zero
, zero'
-, one
-, one'
, successor
, successor'
, length
@@ -28,11 +26,35 @@ module Natural(
, elemIndex
, minus
, list
+, Positive
+, HasPositive(..)
+, AsPositive(..)
+, SumPositive(..)
+, MaxPositive(..)
+, MinPositive(..)
+, one
+, one'
+, successor1
+, successor1'
+, successorW
+, notZero
+, length1
+, replicate1
+, take1
+, drop1
+, splitAt1
+, (!!!)
+, findIndices1
+, findIndex1
+, elemIndices1
+, elemIndex1
+, minus1
+, list1
) where
import Control.Applicative(Const)
import Control.Category((.), id)
-import Control.Lens(Wrapped(_Wrapped', Unwrapped), Rewrapped, Prism', Lens', Iso', (^?), ( # ), _Wrapped, prism', iso)
+import Control.Lens(Wrapped(_Wrapped', Unwrapped), Rewrapped, Prism', Lens', Iso', (^?), ( # ), (^.), _Wrapped, prism', iso)
import Control.Monad((>>=))
import Data.Bool(Bool)
import Data.Eq(Eq((==)))
@@ -41,10 +63,13 @@ import Data.Function(const)
import Data.Functor.Identity(Identity)
import Data.Int(Int)
import Data.List(iterate, zip, filter, map, repeat)
+import Data.List.NonEmpty(NonEmpty((:|)))
+import qualified Data.List.NonEmpty as NonEmpty(iterate, zip, filter)
import Data.Maybe(listToMaybe, Maybe(Just, Nothing))
import Data.Monoid(Monoid(mappend, mempty))
import Data.Ord(Ord((<)), min, max)
import Data.Semigroup(Semigroup((<>)))
+import Data.Semigroup.Foldable(Foldable1(foldMap1))
import Data.Tuple(fst, snd)
import Data.Word(Word)
import Prelude(Show, Integral, Integer, (-), (+), (*), fromIntegral)
@@ -208,27 +233,13 @@ zero ::
zero =
prism'
(\() -> Natural 0)
- (\(Natural n) -> if n == 0 then Nothing else Just ())
+ (\(Natural n) -> if n == 0 then Just () else Nothing)
zero' ::
Natural
zero' =
zero # ()
-one ::
- Prism'
- Natural
- ()
-one =
- prism'
- (\() -> Natural 1)
- (\(Natural n) -> if n == 1 then Nothing else Just ())
-
-one' ::
- Natural
-one' =
- one # ()
-
successor ::
Prism'
Natural
@@ -345,3 +356,286 @@ list =
iso
(\n -> replicate n ())
length
+
+----
+
+newtype Positive =
+ Positive
+ Integer
+ deriving (Eq, Ord, Show)
+
+instance Semigroup Positive where
+ Positive x <> Positive y =
+ Positive (x + y)
+
+instance Monoid Positive where
+ mappend =
+ (<>)
+ mempty =
+ Positive 0
+
+class HasPositive a where
+ positive ::
+ Lens'
+ a
+ Positive
+
+instance HasPositive Positive where
+ positive =
+ id
+
+class AsPositive a where
+ _Positive ::
+ Prism'
+ a
+ Positive
+
+instance AsPositive Positive where
+ _Positive =
+ id
+
+integralPrism1 ::
+ Integral a =>
+ Prism'
+ a
+ Positive
+integralPrism1 =
+ prism'
+ (\(Positive n) -> fromIntegral n)
+ (\n -> if n < 1 then Nothing else Just (Positive (fromIntegral n)))
+
+instance AsPositive Int where
+ _Positive =
+ integralPrism1
+
+instance AsPositive Integer where
+ _Positive =
+ integralPrism1
+
+instance AsPositive Word where
+ _Positive =
+ integralPrism1
+
+instance Integral a => AsPositive (Const a b) where
+ _Positive =
+ integralPrism1
+
+instance Integral a => AsPositive (Identity a) where
+ _Positive =
+ integralPrism1
+
+newtype SumPositive =
+ SumPositive
+ Positive
+ deriving (Eq, Ord, Show)
+
+instance HasPositive SumPositive where
+ positive =
+ _Wrapped . positive
+
+instance AsPositive SumPositive where
+ _Positive =
+ _Wrapped . _Positive
+
+instance SumPositive ~ a =>
+ Rewrapped SumPositive a
+
+instance Wrapped SumPositive where
+ type Unwrapped SumPositive = Positive
+ _Wrapped' =
+ iso
+ (\(SumPositive x) -> x)
+ SumPositive
+
+instance Semigroup SumPositive where
+ SumPositive (Positive x) <> SumPositive (Positive y) =
+ SumPositive (Positive (x + y))
+
+newtype MaxPositive =
+ MaxPositive
+ Positive
+ deriving (Eq, Ord, Show)
+
+instance HasPositive MaxPositive where
+ positive =
+ _Wrapped . positive
+
+instance AsPositive MaxPositive where
+ _Positive =
+ _Wrapped . _Positive
+
+instance MaxPositive ~ a =>
+ Rewrapped MaxPositive a
+
+instance Wrapped MaxPositive where
+ type Unwrapped MaxPositive = Positive
+ _Wrapped' =
+ iso
+ (\(MaxPositive x) -> x)
+ MaxPositive
+
+instance Semigroup MaxPositive where
+ MaxPositive (Positive x) <> MaxPositive (Positive y) =
+ MaxPositive (Positive (x `max` y))
+
+newtype MinPositive =
+ MinPositive
+ Positive
+ deriving (Eq, Ord, Show)
+
+instance HasPositive MinPositive where
+ positive =
+ _Wrapped . positive
+
+instance AsPositive MinPositive where
+ _Positive =
+ _Wrapped . _Positive
+
+instance MinPositive ~ a =>
+ Rewrapped MinPositive a
+
+instance Wrapped MinPositive where
+ type Unwrapped MinPositive = Positive
+ _Wrapped' =
+ iso
+ (\(MinPositive x) -> x)
+ MinPositive
+
+instance Semigroup MinPositive where
+ MinPositive (Positive x) <> MinPositive (Positive y) =
+ MinPositive (Positive (x `min` y))
+
+one ::
+ Prism'
+ Positive
+ ()
+one =
+ prism'
+ (\() -> Positive 1)
+ (\(Positive n) -> if n == 1 then Just () else Nothing)
+
+one' ::
+ Positive
+one' =
+ one # ()
+
+successor1 ::
+ Prism'
+ Positive
+ Positive
+successor1 =
+ prism'
+ (\(Positive n) -> Positive (n + 1))
+ (\(Positive n) -> if n == 1 then Nothing else Just (Positive (n - 1)))
+
+successor1' ::
+ Positive
+ -> Positive
+successor1' =
+ (successor1 #)
+
+successorW ::
+ Iso'
+ Natural
+ Positive
+successorW =
+ iso
+ (\(Natural n) -> Positive (n + 1))
+ (\(Positive n) -> Natural (n - 1))
+
+notZero ::
+ Prism'
+ Natural
+ Positive
+notZero =
+ prism'
+ (\(Positive n) -> Natural n)
+ (\(Natural n) -> if n == 0 then Nothing else Just (Positive n))
+
+length1 ::
+ Foldable1 f =>
+ f a
+ -> Positive
+length1 x =
+ foldMap1 (const (SumPositive one')) x ^. _Wrapped
+
+replicate1 ::
+ Positive
+ -> a
+ -> NonEmpty a
+replicate1 n a =
+ take1 n (a :| repeat a)
+
+take1 ::
+ Positive
+ -> NonEmpty a
+ -> NonEmpty a
+take1 n (h:|t) =
+ h :| take (successorW # n) t
+
+drop1 ::
+ Positive
+ -> NonEmpty a
+ -> [a]
+drop1 n (_:|t) =
+ drop (successorW # n) t
+
+splitAt1 ::
+ Positive
+ -> NonEmpty a
+ -> (NonEmpty a, [a])
+splitAt1 n x =
+ (take1 n x, drop1 n x)
+
+(!!!) ::
+ NonEmpty a
+ -> Positive
+ -> Maybe a
+(_:|t) !!! n =
+ t !! (successorW # n)
+
+findIndices1 ::
+ (a -> Bool)
+ -> NonEmpty a
+ -> [Positive]
+findIndices1 p x =
+ map snd (NonEmpty.filter (p . fst) (NonEmpty.zip x (NonEmpty.iterate successor1' one')))
+
+findIndex1 ::
+ (a -> Bool)
+ -> NonEmpty a
+ -> Maybe Positive
+findIndex1 p =
+ listToMaybe . findIndices1 p
+
+elemIndices1 ::
+ Eq a =>
+ a
+ -> NonEmpty a
+ -> [Positive]
+elemIndices1 =
+ findIndices1 . (==)
+
+elemIndex1 ::
+ Eq a =>
+ a
+ -> NonEmpty a
+ -> Maybe Positive
+elemIndex1 =
+ findIndex1 . (==)
+
+minus1 ::
+ Positive
+ -> Positive
+ -> Positive
+minus1 (Positive x) (Positive y) =
+ Positive (if x < y then 1 else x - y)
+
+list1 ::
+ Iso'
+ Positive
+ (NonEmpty ())
+list1 =
+ iso
+ (\n -> replicate1 n ())
+ length1