summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorqfpl <>2018-07-26 00:39:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-07-26 00:39:00 (GMT)
commit6659fbf9432c998a6b13ade1ccaefd3c43c73484 (patch)
treeb0402bee50e3d698177f1af492cdd82ddfc3f62f
version 0.1.0.00.1.0.0
-rw-r--r--LICENCE31
-rw-r--r--Setup.hs2
-rw-r--r--changelog.md4
-rw-r--r--natural.cabal51
-rw-r--r--src/Natural.hs313
-rw-r--r--test/Tests.hs2
6 files changed, 403 insertions, 0 deletions
diff --git a/LICENCE b/LICENCE
new file mode 100644
index 0000000..cb7cd99
--- /dev/null
+++ b/LICENCE
@@ -0,0 +1,31 @@
+Copyright (c) 2018, Commonwealth Scientific and Industrial Research Organisation
+(CSIRO) ABN 41 687 119 230.
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of QFPL nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/changelog.md b/changelog.md
new file mode 100644
index 0000000..69a81a1
--- /dev/null
+++ b/changelog.md
@@ -0,0 +1,4 @@
+0.1.0.0
+
+* This change log starts.
+* The initial version of natural.
diff --git a/natural.cabal b/natural.cabal
new file mode 100644
index 0000000..fb0ab93
--- /dev/null
+++ b/natural.cabal
@@ -0,0 +1,51 @@
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name: natural
+version: 0.1.0.0
+synopsis: Natural number
+description:
+ <<http://i.imgur.com/uZnp9ke.png>>
+ .
+ Natural number
+license: BSD3
+license-file: LICENCE
+author: Queensland Functional Programming Lab <oᴉ˙ldɟb@llǝʞsɐɥ>
+maintainer: Queensland Functional Programming Lab <oᴉ˙ldɟb@llǝʞsɐɥ>
+copyright: Copyright (C) 2018 Commonwealth Scientific and Industrial Research Organisation (CSIRO)
+category: Control
+build-type: Simple
+extra-source-files: changelog.md
+cabal-version: >=1.10
+homepage: https://github.com/qfpl/natural
+bug-reports: https://github.com/qfpl/natural/issues
+tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1
+
+source-repository head
+ type: git
+ location: git@github.com:qfpl/natural.git
+
+library
+ exposed-modules: Natural
+ build-depends: base >=4.8 && <4.11
+ , lens >=4.15 && < 4.17
+ hs-source-dirs: src
+ default-language: Haskell2010
+ ghc-options: -Wall
+
+test-suite tests
+ build-depends: QuickCheck >=2.9.2 && <2.12
+ , base >=4.8 && <4.11
+ , checkers >=0.4.6 && <0.5
+ , natural
+ , hedgehog >=0.5 && <0.6
+ , lens >=4.15 && <4.17
+ , tasty >=0.11 && <1.1
+ , tasty-hunit >=0.9 && <0.11
+ , tasty-hedgehog >= 0.1 && <0.3
+ , tasty-quickcheck >=0.8.4 && <0.11
+ , transformers >=0.4.1 && <5.5
+ type: exitcode-stdio-1.0
+ main-is: Tests.hs
+ hs-source-dirs: test
+ default-language: Haskell2010
+ ghc-options: -Wall
diff --git a/src/Natural.hs b/src/Natural.hs
new file mode 100644
index 0000000..d202382
--- /dev/null
+++ b/src/Natural.hs
@@ -0,0 +1,313 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Natural(
+ Natural
+, HasNatural(..)
+, AsNatural(..)
+, ProductNatural(..)
+, MaxNatural(..)
+, MinNatural(..)
+, zero
+, zero'
+, successor
+, successor'
+, length
+, replicate
+, take
+, drop
+, splitAt
+, (!!)
+, findIndices
+, findIndex
+, elemIndices
+, elemIndex
+) where
+
+import Control.Applicative(Const)
+import Control.Category((.), id)
+import Control.Lens(Wrapped(_Wrapped', Unwrapped), Rewrapped, Prism', Lens', (^?), ( # ), _Wrapped, prism', iso)
+import Control.Monad((>>=))
+import Data.Bool(Bool)
+import Data.Eq(Eq((==)))
+import Data.Foldable(Foldable(foldl))
+import Data.Function(const)
+import Data.Functor.Identity(Identity)
+import Data.Int(Int)
+import Data.List(iterate, zip, filter, map, repeat)
+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.Tuple(fst, snd)
+import Data.Word(Word)
+import Prelude(Show, Integral, Integer, (-), (+), (*), fromIntegral)
+
+newtype Natural =
+ Natural
+ Integer
+ deriving (Eq, Ord, Show)
+
+instance Semigroup Natural where
+ Natural x <> Natural y =
+ Natural (x + y)
+
+instance Monoid Natural where
+ mappend =
+ (<>)
+ mempty =
+ Natural 0
+
+class HasNatural a where
+ natural ::
+ Lens'
+ a
+ Natural
+
+instance HasNatural Natural where
+ natural =
+ id
+
+class AsNatural a where
+ _Natural ::
+ Prism'
+ a
+ Natural
+
+instance AsNatural Natural where
+ _Natural =
+ id
+
+integralPrism ::
+ Integral a =>
+ Prism'
+ a
+ Natural
+integralPrism =
+ prism'
+ (\(Natural n) -> fromIntegral n)
+ (\n -> if n < 0 then Nothing else Just (Natural (fromIntegral n)))
+
+instance AsNatural Int where
+ _Natural =
+ integralPrism
+
+instance AsNatural Integer where
+ _Natural =
+ integralPrism
+
+instance AsNatural Word where
+ _Natural =
+ integralPrism
+
+instance Integral a => AsNatural (Const a b) where
+ _Natural =
+ integralPrism
+
+instance Integral a => AsNatural (Identity a) where
+ _Natural =
+ integralPrism
+
+newtype ProductNatural =
+ ProductNatural
+ Natural
+ deriving (Eq, Ord, Show)
+
+instance HasNatural ProductNatural where
+ natural =
+ _Wrapped . natural
+
+instance AsNatural ProductNatural where
+ _Natural =
+ _Wrapped . _Natural
+
+instance ProductNatural ~ a =>
+ Rewrapped ProductNatural a
+
+instance Wrapped ProductNatural where
+ type Unwrapped ProductNatural = Natural
+ _Wrapped' =
+ iso
+ (\(ProductNatural x) -> x)
+ ProductNatural
+
+instance Semigroup ProductNatural where
+ ProductNatural (Natural x) <> ProductNatural (Natural y) =
+ ProductNatural (Natural (x * y))
+
+instance Monoid ProductNatural where
+ mappend =
+ (<>)
+ mempty =
+ ProductNatural (Natural 1)
+
+newtype MaxNatural =
+ MaxNatural
+ Natural
+ deriving (Eq, Ord, Show)
+
+instance HasNatural MaxNatural where
+ natural =
+ _Wrapped . natural
+
+instance AsNatural MaxNatural where
+ _Natural =
+ _Wrapped . _Natural
+
+instance MaxNatural ~ a =>
+ Rewrapped MaxNatural a
+
+instance Wrapped MaxNatural where
+ type Unwrapped MaxNatural = Natural
+ _Wrapped' =
+ iso
+ (\(MaxNatural x) -> x)
+ MaxNatural
+
+instance Semigroup MaxNatural where
+ MaxNatural (Natural x) <> MaxNatural (Natural y) =
+ MaxNatural (Natural (x `max` y))
+
+newtype MinNatural =
+ MinNatural
+ Natural
+ deriving (Eq, Ord, Show)
+
+instance HasNatural MinNatural where
+ natural =
+ _Wrapped . natural
+
+instance AsNatural MinNatural where
+ _Natural =
+ _Wrapped . _Natural
+
+instance MinNatural ~ a =>
+ Rewrapped MinNatural a
+
+instance Wrapped MinNatural where
+ type Unwrapped MinNatural = Natural
+ _Wrapped' =
+ iso
+ (\(MinNatural x) -> x)
+ MinNatural
+
+instance Semigroup MinNatural where
+ MinNatural (Natural x) <> MinNatural (Natural y) =
+ MinNatural (Natural (x `min` y))
+
+zero ::
+ Prism'
+ Natural
+ ()
+zero =
+ prism'
+ (\() -> Natural 0)
+ (\(Natural n) -> if n == 0 then Nothing else Just ())
+
+zero' ::
+ Natural
+zero' =
+ zero # ()
+
+successor ::
+ Prism'
+ Natural
+ Natural
+successor =
+ prism'
+ (\(Natural n) -> Natural (n + 1))
+ (\(Natural n) -> if n == 0 then Nothing else Just (Natural (n - 1)))
+
+successor' ::
+ Natural
+ -> Natural
+successor' =
+ (successor #)
+
+length ::
+ Foldable f =>
+ f a
+ -> Natural
+length =
+ foldl (const . successor') zero'
+
+replicate ::
+ Natural
+ -> a
+ -> [a]
+replicate n =
+ take n . repeat
+
+take ::
+ Natural
+ -> [a]
+ -> [a]
+take _ [] =
+ []
+take n (h:t) =
+ case n ^? successor of
+ Nothing ->
+ []
+ Just p ->
+ h : take p t
+
+drop ::
+ Natural
+ -> [a]
+ -> [a]
+drop _ [] =
+ []
+drop n (h:t) =
+ case n ^? successor of
+ Nothing ->
+ h:t
+ Just p ->
+ drop p t
+
+splitAt ::
+ Natural
+ -> [a]
+ -> ([a], [a])
+splitAt n x =
+ (take n x, drop n x)
+
+(!!) ::
+ [a]
+ -> Natural
+ -> Maybe a
+[] !! _ =
+ Nothing
+(_:t) !! n =
+ (n ^? successor) >>= (t !!)
+
+findIndices ::
+ (a -> Bool)
+ -> [a]
+ -> [Natural]
+findIndices p x =
+ map snd (filter (p . fst) (zip x (iterate successor' zero')))
+
+findIndex ::
+ (a -> Bool)
+ -> [a]
+ -> Maybe Natural
+findIndex p =
+ listToMaybe . findIndices p
+
+elemIndices ::
+ Eq a =>
+ a
+ -> [a]
+ -> [Natural]
+elemIndices =
+ findIndices . (==)
+
+elemIndex ::
+ Eq a =>
+ a
+ -> [a]
+ -> Maybe Natural
+elemIndex =
+ findIndex . (==)
diff --git a/test/Tests.hs b/test/Tests.hs
new file mode 100644
index 0000000..885ad61
--- /dev/null
+++ b/test/Tests.hs
@@ -0,0 +1,2 @@
+main :: IO ()
+main = putStrLn "test"