stern-brocot (empty) → 0.1.0.0
raw patch · 7 files changed
+254/−0 lines, 7 filesdep +algdep +basedep +criterionsetup-changed
Dependencies added: alg, base, criterion, smallcheck, stern-brocot, tasty, tasty-smallcheck, universe-base
Files
- LICENSE +30/−0
- Numeric/Rational/Positive.hs +89/−0
- README.md +1/−0
- Setup.hs +2/−0
- bench/Main.hs +6/−0
- stern-brocot.cabal +103/−0
- test/Main.hs +23/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright M Farkas-Dyck © 2019++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 M Farkas-Dyck 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.
+ Numeric/Rational/Positive.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE ViewPatterns #-}++module Numeric.Rational.Positive (Qp, fromFraction, toFraction, fromRational, toRational) where++import Prelude hiding (Num (..), Fractional (..), Eq (..), Ord (..), Real (..))+import qualified Prelude++import Algebra+import Data.Bits+import Data.Bool+import Data.Function (on)+import Data.Ratio+import Data.Semigroup (Sum (..), Product (..))+import Data.Universe.Class+import Numeric.Natural+import Relation.Binary.Comparison++data Qp = Qp {-# UNPACK #-}!Word {-# UNPACK #-}!Natural+ deriving (Show)++fromBits :: [Bool] -> Qp+fromBits = go 0 0 where+ go :: Word -> Natural -> [Bool] -> Qp+ go k n = k `seq` n `seq` \ case+ [] -> Qp k n+ b:bs -> go (k+1) (bool id (flip setBit $ fromIntegral k) b n) bs++toBits :: Qp -> [Bool]+toBits (Qp l n) = testBit n <$> [0..fromIntegral l-1]++fromFraction :: (Natural, Natural) -> Qp+fromFraction = fromBits . uncurry go where+ go :: Natural -> Natural -> [Bool]+ go p q = case compare p q of+ EQ -> []+ GT -> False : go (p∸q) q+ LT -> True : go p (q∸p)++toFraction :: Qp -> (Natural, Natural)+toFraction = go . toBits where+ go [] = (1, 1)+ go (b:bs) | (p, q) <- go bs = bool (p+q, q) (p, p+q) b++fromRational :: Ratio Natural -> Qp+fromRational a = fromFraction (numerator a, denominator a)++toRational :: Qp -> Ratio Natural+toRational = go . toBits where+ go [] = 1+ go (False:bs) = 1 + go bs+ go (True :bs) = Prelude.recip (1 + Prelude.recip (go bs))++instance Preord Qp where a ≤ b = GT ≢ compare a b+instance PartialEq Qp where Qp l₁ n₁ ≡ Qp l₂ n₂ = (l₁, n₁) ≡ (l₂, n₂)+instance PartialOrd Qp where tryCompare a b = Just (compare a b)+instance Eq Qp+instance Ord Qp where+ compare = go `on` toBits where+ go [] [] = EQ+ go (a:_) [] = bool GT LT a+ go [] (b:_) = bool LT GT b+ go (a:as) (b:bs) = compare b a <> go as bs++instance {-# OVERLAPPING #-} Semigroup (Product Qp) where+ Product (toFraction -> (p₁, q₁)) <> Product (toFraction -> (p₂, q₂)) =+ (Product . fromFraction) (p₁ * p₂, q₁ * q₂)++instance {-# OVERLAPPING #-} Monoid (Product Qp) where+ mempty = Product (Qp 0 0)++instance Group (Product Qp) where+ invert (Product (Qp l n)) = Product (Qp l (xor n $ shiftL 1 (fromIntegral l) ∸ 1))++instance {-# OVERLAPPING #-} Semigroup (Sum Qp) where+ Sum (toFraction -> (p₁, q₁)) <> Sum (toFraction -> (p₂, q₂)) =+ (Sum . fromFraction) (p₁ * q₂ + p₂ * q₁, q₁ * q₂)++instance Universe Qp where+ universe = fromBits <$> go where go = [] : (go >>= traverse (:) [False, True])++instance Prelude.Eq Qp where (==) = (≡)+instance Prelude.Ord Qp where compare = compare+instance Prelude.Num Qp where+ fromInteger = fromRational . Prelude.fromInteger+ (+) = (+)+ a * b = fromRational $ ((*) `on` toRational) a b+ abs = id+ signum = pure 1+ (-) = undefined
+ README.md view
@@ -0,0 +1,1 @@+# stern-brocot
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Main.hs view
@@ -0,0 +1,6 @@+module Main where++import Criterion.Main++main :: IO ()+main = defaultMain []
+ stern-brocot.cabal view
@@ -0,0 +1,103 @@+name: stern-brocot+version: 0.1.0.0+synopsis: Positive rational numbers represented as paths in the Stern-Brocot tree+-- description:+license: BSD3+license-file: LICENSE+author: M Farkas-Dyck+maintainer: strake888@gmail.com+copyright: 2019 M Farkas-Dyck+category: Math, Numeric+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ hs-source-dirs: .+ exposed-modules: Numeric.Rational.Positive+ build-depends: alg >= 0.2.10 && < 0.3+ , base >= 4.7 && < 5+ , universe-base >= 1.0 && < 1.1+ default-language: Haskell2010+ default-extensions: UnicodeSyntax+ , LambdaCase+ , EmptyCase+ , InstanceSigs+ , PartialTypeSignatures+ , PolyKinds+ , ConstraintKinds+ , FlexibleContexts+ , FlexibleInstances+ , MonadComprehensions+ , StandaloneDeriving+ , DeriveFunctor, DeriveFoldable, DeriveTraversable+ ghc-options: -Wall -Wcompat -Wredundant-constraints -Wno-name-shadowing+ -Wincomplete-record-updates -Wincomplete-uni-patterns+ -Werror=incomplete-patterns+ -Werror=incomplete-uni-patterns+ -Werror=incomplete-record-updates+ -Werror=missing-fields+ -Werror=missing-methods++test-suite test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ build-depends: base >=4.11 && <5+ , smallcheck >=1.1.4+ , tasty >=1.0+ , tasty-smallcheck >=0.8+ , universe-base >= 1.0 && < 1.1+ , stern-brocot+ default-language: Haskell2010+ default-extensions: UnicodeSyntax+ , LambdaCase+ , EmptyCase+ , InstanceSigs+ , PartialTypeSignatures+ , PolyKinds+ , ConstraintKinds+ , FlexibleContexts+ , FlexibleInstances+ , MonadComprehensions+ , StandaloneDeriving+ , DeriveFunctor, DeriveFoldable, DeriveTraversable+ ghc-options: -Wall -Wcompat -Wredundant-constraints -Wno-name-shadowing+ -Wincomplete-record-updates -Wincomplete-uni-patterns+ -Werror=incomplete-patterns+ -Werror=incomplete-uni-patterns+ -Werror=incomplete-record-updates+ -Werror=missing-fields+ -Werror=missing-methods++benchmark bench+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ main-is: Main.hs+ build-depends: base >=4.11 && <5+ , criterion >=1.4.1+ , stern-brocot+ default-language: Haskell2010+ default-extensions: UnicodeSyntax+ , LambdaCase+ , EmptyCase+ , InstanceSigs+ , PartialTypeSignatures+ , PolyKinds+ , ConstraintKinds+ , FlexibleContexts+ , FlexibleInstances+ , MonadComprehensions+ , StandaloneDeriving+ , DeriveFunctor, DeriveFoldable, DeriveTraversable+ ghc-options: -Wall -Wcompat -Wredundant-constraints -Wno-name-shadowing+ -Wincomplete-record-updates -Wincomplete-uni-patterns+ -Werror=incomplete-patterns+ -Werror=incomplete-uni-patterns+ -Werror=incomplete-record-updates+ -Werror=missing-fields+ -Werror=missing-methods++source-repository head+ type: git+ location: https://github.com/strake/stern-brocot.hs
+ test/Main.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE MultiParamTypeClasses #-}++module Main where++import Data.Universe.Class+import Test.SmallCheck+import Test.SmallCheck.Series+import Test.Tasty+import Test.Tasty.SmallCheck++import Numeric.Rational.Positive++main :: IO ()+main = defaultMain $+ testGroup ""+ [testProperty "+-associative" $ \ a b c -> (a + b) + (c :: Qp) == a + (b + c),+ testProperty "+-commutative" $ \ a b -> a + b == (b + a :: Qp),+ testProperty "*-associative" $ \ a b c -> (a * b) * (c :: Qp) == a * (b * c),+ testProperty "*-commutative" $ \ a b -> a * b == (b * a :: Qp),+ testProperty "*-identity" $ \ a -> a * 1 == a && 1 * a == (a :: Qp),+ testProperty "+-distributive" $ \ a b c -> a * (b + c) == (a * b + a * c :: Qp)]++instance Monad m => Serial m Qp where series = generate $ \ d -> take (2^(d+1)-1) universe