diff --git a/LICENCE b/LICENCE new file mode 100644 --- /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 --- /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 --- /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 --- /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: + <> + . + Natural number +license: BSD3 +license-file: LICENCE +author: Queensland Functional Programming Lab +maintainer: Queensland Functional Programming Lab +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 --- /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 --- /dev/null +++ b/test/Tests.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "test"