diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,7 @@ +- arguments: [-XCPP] + +- ignore: {name: Use fmap} +- ignore: {name: Avoid lambda} +- ignore: {name: Redundant lambda} +- ignore: {name: Unused LANGUAGE pragma} +- ignore: {name: Eta reduce, within: [Linear.Plucker, Linear.Quaternion, Linear.V, Linear.V0, Linear.V1, Linear.V2, Linear.V3, Linear.V4]} diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 --- a/.travis.yml +++ /dev/null @@ -1,172 +0,0 @@ -# This Travis job script has been generated by a script via -# -# haskell-ci '--output=.travis.yml' '--config=cabal.haskell-ci' 'cabal.project' -# -# For more information, see https://github.com/haskell-CI/haskell-ci -# -# version: 0.3.20190425 -# -language: c -dist: xenial -git: - # whether to recursively clone submodules - submodules: false -notifications: - irc: - channels: - - irc.freenode.org#haskell-lens - skip_join: true - template: - - "\"\\x0313linear\\x03/\\x0306%{branch}\\x03 \\x0314%{commit}\\x03 %{build_url} %{message}\"" -cache: - directories: - - $HOME/.cabal/packages - - $HOME/.cabal/store -before_cache: - - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log - # remove files that are regenerated by 'cabal update' - - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* - - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx - - rm -rfv $CABALHOME/packages/head.hackage -matrix: - include: - - compiler: ghc-8.8.1 - addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}} - env: GHCHEAD=true - - compiler: ghc-8.6.5 - addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-2.4"]}} - - compiler: ghc-8.4.4 - addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-2.4"]}} - - compiler: ghc-8.2.2 - addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-2.4"]}} - - compiler: ghc-8.0.2 - addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-2.4"]}} - - compiler: ghc-7.10.3 - addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.10.3","cabal-install-2.4"]}} - - compiler: ghc-7.8.4 - addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.8.4","cabal-install-2.4"]}} - - compiler: ghc-7.6.3 - addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.6.3","cabal-install-2.4"]}} - - compiler: ghc-7.4.2 - addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.4.2","cabal-install-2.4"]}} - - compiler: ghc-head - addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-head","cabal-install-head"]}} - env: GHCHEAD=true - allow_failures: - - compiler: ghc-head - - compiler: ghc-8.8.1 -before_install: - - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') - - HCPKG="$HC-pkg" - - unset CC - - CABAL=/opt/ghc/bin/cabal - - CABALHOME=$HOME/.cabal - - export PATH="$CABALHOME/bin:$PATH" - - TOP=$(pwd) - - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) - - echo $HCNUMVER - - CABAL="$CABAL -vnormal+nowrap+markoutput" - - set -o pipefail - - | - echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk - echo 'BEGIN { state = "output"; }' >> .colorful.awk - echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk - echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk - echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk - echo ' if (state == "cabal") {' >> .colorful.awk - echo ' print blue($0)' >> .colorful.awk - echo ' } else {' >> .colorful.awk - echo ' print $0' >> .colorful.awk - echo ' }' >> .colorful.awk - echo '}' >> .colorful.awk - - cat .colorful.awk - - | - color_cabal_output () { - awk -f $TOP/.colorful.awk - } - - echo text | color_cabal_output -install: - - ${CABAL} --version - - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - - TEST=--enable-tests - - BENCH=--enable-benchmarks - - GHCHEAD=${GHCHEAD-false} - - rm -f $CABALHOME/config - - | - echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config - echo "remote-build-reporting: anonymous" >> $CABALHOME/config - echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config - echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config - echo "world-file: $CABALHOME/world" >> $CABALHOME/config - echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config - echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config - echo "installdir: $CABALHOME/bin" >> $CABALHOME/config - echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config - echo "store-dir: $CABALHOME/store" >> $CABALHOME/config - echo "install-dirs user" >> $CABALHOME/config - echo " prefix: $CABALHOME" >> $CABALHOME/config - echo "repository hackage.haskell.org" >> $CABALHOME/config - echo " url: http://hackage.haskell.org/" >> $CABALHOME/config - - | - if $GHCHEAD; then - echo "allow-newer: $($HCPKG list --simple-output | sed -E 's/([a-zA-Z-]+)-[0-9.]+/*:\1/g')" >> $CABALHOME/config - - echo "repository head.hackage" >> $CABALHOME/config - echo " url: http://head.hackage.haskell.org/" >> $CABALHOME/config - echo " secure: True" >> $CABALHOME/config - echo " root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740" >> $CABALHOME/config - echo " 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb" >> $CABALHOME/config - echo " 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e" >> $CABALHOME/config - echo " key-threshold: 3" >> $CABALHOME/config - fi - - cat $CABALHOME/config - - rm -fv cabal.project cabal.project.local cabal.project.freeze - - travis_retry ${CABAL} v2-update -v - # Generate cabal.project - - rm -rf cabal.project cabal.project.local cabal.project.freeze - - touch cabal.project - - | - echo 'packages: "."' >> cabal.project - - | - echo "write-ghc-environment-files: always" >> cabal.project - - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(linear)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - - cat cabal.project || true - - cat cabal.project.local || true - - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi - - ${CABAL} v2-freeze -w ${HC} ${TEST} ${BENCH} | color_cabal_output - - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" - - rm cabal.project.freeze - - ${CABAL} v2-build -w ${HC} ${TEST} ${BENCH} --dep -j2 all | color_cabal_output -script: - - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) - # Packaging... - - ${CABAL} v2-sdist all | color_cabal_output - # Unpacking... - - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ - - cd ${DISTDIR} || false - - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; - # Generate cabal.project - - rm -rf cabal.project cabal.project.local cabal.project.freeze - - touch cabal.project - - | - echo 'packages: "linear-*/*.cabal"' >> cabal.project - - | - echo "write-ghc-environment-files: always" >> cabal.project - - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(linear)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - - cat cabal.project || true - - cat cabal.project.local || true - # Building with tests and benchmarks... - # build & run tests, build benchmarks - - ${CABAL} v2-build -w ${HC} ${TEST} ${BENCH} all | color_cabal_output - # Testing... - - ${CABAL} v2-test -w ${HC} ${TEST} ${BENCH} all | color_cabal_output - # cabal check... - - (cd linear-* && ${CABAL} -vnormal check) - # haddock... - - ${CABAL} v2-haddock -w ${HC} ${TEST} ${BENCH} all | color_cabal_output - -# REGENDATA ["--output=.travis.yml","--config=cabal.haskell-ci","cabal.project"] -# EOF diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,104 @@ +1.23.3 [2026.01.10] +------------------- +* Remove unused `ghc-prim`, `tagged, `transformers-compat`, and `void` + dependencies. + +1.23.2 [2025.06.17] +------------------- +* Replace `test-framework` with `tasty` in the test suite. + +1.23.1 [2025.03.03] +------------------- +* Add `Uniform` and `UniformRange` instances for `Plucker`, `Quaternion`, `V`, + and `V{0,1,2,3,4}`. + +1.23 [2024.04.15] +----------------- +* The direction of interpolation of `lerp` has been reversed; + now `lerp 0 a b == a` and `lerp 1 a b == b`. + This brings `lerp` in line not only with its implementation + in other languages and frameworks, but also with `slerp` in this package. + +1.22 [2022.11.30] +----------------- +* The types of `_Point` and `lensP` have been generalized: + + ```diff + -_Point :: Iso' (Point f a) (f a) + +_Point :: Iso (Point f a) (Point g b) (f a) (g b) + + -lensP :: Lens' (Point g a) (g a) + +lensP :: Lens (Point f a) (Point g b) (f a) (g b) + ``` + + There is a chance that existing uses of `_Point` or `lensP` will fail to + typecheck due to their more general types. You can use `_Point.simple` or + `lensP.simple` to restore their old, more restricted types (where `simple` + comes from `Control.Lens` in the `lens` library). + +1.21.10 [2022.06.21] +-------------------- +* Allow building with `vector-0.13.*`. + +1.21.9 [2022.05.18] +------------------- +* Allow building with `transformers-0.6.*`. + +1.21.8 [2021.11.15] +------------------- +* Allow building with `hashable-1.4.*`. +* Drop support for pre-8.0 versions of GHC. + +1.21.7 [2021.09.20] +------------------- +* Fix a build error when using `random-1.2.1` or later. + +1.21.6 [2021.07.05] +------------------- +* Fix a build error when configured with `-template-haskell`. + +1.21.5 [2021.02.18] +------------------- +* Allow building with `lens-5.*`. + +1.21.4 [2021.01.29] +------------------- +* Allow building with `vector-0.12.2` or later. +* The build-type has been changed from `Custom` to `Simple`. + To achieve this, the `doctests` test suite has been removed in favor of using + [`cabal-docspec`](https://github.com/phadej/cabal-extras/tree/master/cabal-docspec) + to run the doctests. + +1.21.3 [2020.10.03] +------------------- +* Allow building with GHC 9.0. + +1.21.2 [2020.09.30] +------------------- +* Use `base-orphans-0.8.3` or later. This means that the `Linear.Instances` + module no longer defines any orphan instances of its own, and the module is + now a simple shim on top of `Data.Orphans` from `base-orphans`. + +1.21.1 [2020.06.25] +------------------- +* Allow building with `random-1.2.*`. + +1.21 [2020.02.03] +----------------- +* Add instances for direct sums (`Product`) and tensor products (`Compose`) of + other vector spaces. This makes is much more convenient to do things like treat + a matrix temporarily as a vector through Compose, or to consider things like + Gauss-Jordan elimination, which wants augmented structures. +* Add `frobenius` for computing the Frobenius norm of a matrix. +* Added `Random` instances for `System.Random`. We had an indirect dependency + through `vector` anyways. +* Add "obvious" zipping `Semigroup` and `Monoid` instances to all the + representable vector spaces. +* Add `R1`..`R4` instances to `Quaternion`. `_w` is the scalar component so that + `_x`,`_y`,`_z` can be directional. +* Add more solvers to `Linear.Matrix`, available with `base-4.8` or later. +* Add `unangle` function to `Linear.V2`. + 1.20.9 [2019.05.02] ------------------- * Derive `Lift` instances for `Plucker`, `Quaternion`, and `V{0,1,2,3,4}`. diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,7 +1,7 @@ linear ====== -[![Hackage](https://img.shields.io/hackage/v/linear.svg)](https://hackage.haskell.org/package/linear) [![Build Status](https://secure.travis-ci.org/ekmett/linear.svg)](http://travis-ci.org/ekmett/linear) +[![Hackage](https://img.shields.io/hackage/v/linear.svg)](https://hackage.haskell.org/package/linear) [![Build Status](https://github.com/ekmett/linear/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/linear/actions?query=workflow%3AHaskell-CI) Highly polymorphic vector space operations on sparse and free vector spaces. diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,34 +1,7 @@ -\begin{code} -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wall #-} -module Main (main) where - -#ifndef MIN_VERSION_cabal_doctest -#define MIN_VERSION_cabal_doctest(x,y,z) 0 -#endif - -#if MIN_VERSION_cabal_doctest(1,0,0) - -import Distribution.Extra.Doctest ( defaultMainWithDoctests ) -main :: IO () -main = defaultMainWithDoctests "doctests" - -#else - -#ifdef MIN_VERSION_Cabal --- If the macro is defined, we have new cabal-install, --- but for some reason we don't have cabal-doctest in package-db --- --- Probably we are running cabal sdist, when otherwise using new-build --- workflow -import Warning () -#endif - -import Distribution.Simple - -main :: IO () -main = defaultMain +#!/usr/bin/runhaskell +> module Main (main) where -#endif +> import Distribution.Simple -\end{code} +> main :: IO () +> main = defaultMain diff --git a/Warning.hs b/Warning.hs deleted file mode 100644 --- a/Warning.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Warning - {-# WARNING ["You are configuring this package without cabal-doctest installed.", - "The doctests test-suite will not work as a result.", - "To fix this, install cabal-doctest before configuring."] #-} - () where diff --git a/linear.cabal b/linear.cabal --- a/linear.cabal +++ b/linear.cabal @@ -1,8 +1,8 @@ name: linear category: Math, Algebra -version: 1.20.9 +version: 1.23.3 license: BSD3 -cabal-version: >= 1.8 +cabal-version: >= 1.10 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett @@ -12,25 +12,27 @@ copyright: Copyright (C) 2012-2015 Edward A. Kmett synopsis: Linear Algebra description: Types and combinators for linear algebra on free vector spaces -build-type: Custom -tested-with: GHC == 7.4.2 - , GHC == 7.6.3 - , GHC == 7.8.4 - , GHC == 7.10.3 - , GHC == 8.0.2 +build-type: Simple +tested-with: GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 - , GHC == 8.8.1 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.8 + , GHC == 9.4.8 + , GHC == 9.6.7 + , GHC == 9.8.4 + , GHC == 9.10.3 + , GHC == 9.12.2 + , GHC == 9.14.1 extra-source-files: .gitignore - .travis.yml + .hlint.yaml .vim.custom - travis/cabal-apt-install - travis/config CHANGELOG.markdown README.markdown - Warning.hs flag template-haskell description: @@ -49,38 +51,29 @@ type: git location: https://github.com/ekmett/linear -custom-setup - setup-depends: - base >= 4 && < 5, - Cabal, - cabal-doctest >= 1 && < 1.1 - library build-depends: adjunctions >= 4 && < 5, - base >= 4.5 && < 5, - base-orphans >= 0.5 && < 1, + base >= 4.9 && < 5, + base-orphans >= 0.8.3 && < 1, binary >= 0.5 && < 0.9, bytes >= 0.15 && < 1, cereal >= 0.4.1.1 && < 0.6, - containers >= 0.4 && < 0.7, - deepseq >= 1.1 && < 1.5, - distributive >= 0.2.2 && < 1, - ghc-prim, - hashable >= 1.1 && < 1.3, - lens >= 4.15.2 && < 5, - reflection >= 1.3.2 && < 3, - semigroups >= 0.9 && < 1, - semigroupoids >= 5.2.1 && < 6, - tagged >= 0.4.4 && < 1, - transformers >= 0.2 && < 0.6, - transformers-compat >= 0.4 && < 1, + containers >= 0.4 && < 0.9, + deepseq >= 1.1 && < 1.6, + distributive >= 0.5.1 && < 1, + hashable >= 1.2.7.0 && < 1.6, + indexed-traversable >= 0.1.1 && < 0.2, + lens >= 4.15.2 && < 6, + random >= 1.2 && < 1.4, + reflection >= 2 && < 3, + semigroupoids >= 5.2.1 && < 7, + transformers >= 0.5 && < 0.7, unordered-containers >= 0.2.3 && < 0.3, - vector >= 0.10 && < 0.13, - void >= 0.6 && < 1 + vector >= 0.12.1.2 && < 0.14 if flag(template-haskell) && impl(ghc) - build-depends: template-haskell >= 2.7 && < 3.0 + build-depends: template-haskell >= 2.11.1.0 && < 3.0 if flag(herbie) build-depends: HerbiePlugin >= 0.1 && < 0.2 @@ -111,35 +104,33 @@ Linear.V4 Linear.Vector - ghc-options: -Wall -fwarn-tabs -O2 -fdicts-cheap -funbox-strict-fields + ghc-options: -Wall -Wtabs -O2 -fdicts-cheap -funbox-strict-fields -Wno-trustworthy-safe hs-source-dirs: src - if impl(ghc >= 7.10) - ghc-options: -fno-warn-trustworthy-safe + default-language: Haskell2010 - -- hack around the buggy unused matches check for class associated types in ghc 8 rc1 - if impl(ghc >= 8) - ghc-options: -fno-warn-unused-matches + x-docspec-extra-packages: simple-reflect --- Verify the results of the examples +-- We need this dummy test-suite to add simple-reflect to the install plan +-- +-- When cabal-install's extra-packages support becomes widely available +-- (i.e. after 3.4 release), we can remove this test-suite. test-suite doctests - type: exitcode-stdio-1.0 - main-is: doctests.hs - ghc-options: -Wall -threaded - hs-source-dirs: tests - build-depends: - base, - doctest >= 0.11.1 && < 0.17, - lens, - linear, - simple-reflect >= 0.3.1 + type: exitcode-stdio-1.0 + main-is: doctests.hs + hs-source-dirs: tests + default-language: Haskell2010 -test-suite UnitTests + build-depends: base < 5, simple-reflect >= 0.3.1 + +test-suite test type: exitcode-stdio-1.0 - main-is: UnitTests.hs - other-modules: Plucker, Binary - if impl(ghc >= 7.7) - other-modules: V + main-is: Test.hs + other-modules: Prop.Quaternion + Prop.V3 + Unit.Binary + Unit.Plucker + Unit.V ghc-options: -Wall -threaded hs-source-dirs: tests build-depends: @@ -147,10 +138,12 @@ binary, bytestring, deepseq, - test-framework >= 0.8, - test-framework-hunit >= 0.3, - HUnit >= 1.2.5, + tasty >= 1.4 && < 1.6, + tasty-hunit >= 0.10 && < 0.11, + tasty-quickcheck >= 0.10 && < 0.12, linear, + QuickCheck >= 2.5, reflection, vector + default-language: Haskell2010 diff --git a/src/Linear.hs b/src/Linear.hs --- a/src/Linear.hs +++ b/src/Linear.hs @@ -46,5 +46,3 @@ import Linear.V3 import Linear.V4 import Linear.Vector - -{-# ANN module "Hlint: ignore Use import/export shortcut" #-} diff --git a/src/Linear/Affine.hs b/src/Linear/Affine.hs --- a/src/Linear/Affine.hs +++ b/src/Linear/Affine.hs @@ -6,21 +6,14 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE RankNTypes #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} {-# LANGUAGE DeriveGeneric #-} -#endif {-# LANGUAGE DeriveDataTypeable #-} -#if defined(__GLASGOW_HASKELL__) {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} -#endif -#ifndef MIN_VERSION_hashable -#define MIN_VERSION_hashable(x,y,z) 1 -#endif - ----------------------------------------------------------------------------- -- | -- License : BSD-style (see the file LICENSE) @@ -38,36 +31,32 @@ import Control.Lens import Data.Binary as Binary import Data.Bytes.Serial -#if __GLASGOW_HASKELL__ >= 708 import Data.Coerce -#endif import Data.Complex (Complex) import Data.Data import Data.Distributive import Data.Foldable as Foldable import Data.Functor.Bind import Data.Functor.Classes +import Data.Functor.Product import Data.Functor.Rep as Rep import Data.HashMap.Lazy (HashMap) import Data.Hashable -#if (MIN_VERSION_hashable(1,2,5)) import Data.Hashable.Lifted -#endif import Data.IntMap (IntMap) import Data.Ix +import Data.Kind import Data.Map (Map) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup (Semigroup) +#endif import Data.Serialize as Cereal import Data.Vector (Vector) import qualified Data.Vector.Generic.Mutable as M import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed.Base as U import Foreign.Storable -#if __GLASGOW_HASKELL__ >= 702 -import GHC.Generics (Generic) -#endif -#if __GLASGOW_HASKELL__ >= 706 -import GHC.Generics (Generic1) -#endif +import GHC.Generics (Generic, Generic1) import Linear.Epsilon import Linear.Metric import Linear.Plucker @@ -79,10 +68,7 @@ import Linear.V3 import Linear.V4 import Linear.Vector - -#ifdef HLINT -{-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-} -#endif +import System.Random (Random(..)) -- | An affine space is roughly a vector space in which we have -- forgotten or at least pretend to have forgotten the origin. @@ -91,7 +77,7 @@ -- > (a .+^ u) .+^ v = a .+^ (u ^+^ v)@ -- > (a .-. b) ^+^ v = (a .+^ v) .-. q@ class Additive (Diff p) => Affine p where - type Diff p :: * -> * + type Diff p :: Type -> Type infixl 6 .-. -- | Get the difference between two points as a vector offset. @@ -107,6 +93,12 @@ p .-^ v = p .+^ negated v {-# INLINE (.-^) #-} +instance (Affine f, Affine g) => Affine (Product f g) where + type Diff (Product f g) = Product (Diff f) (Diff g) + Pair a b .-. Pair c d = Pair (a .-. c) (b .-. d) + Pair a b .+^ Pair c d = Pair (a .+^ c) (b .+^ d) + Pair a b .-^ Pair c d = Pair (a .+^ c) (b .+^ d) + -- | Compute the quadrance of the difference (the square of the distance) qdA :: (Affine p, Foldable (Diff p), Num a) => p a -> p a -> a qdA a b = Foldable.sum (fmap (join (*)) (a .-. b)) @@ -148,24 +140,15 @@ , Eq1, Ord1, Show1, Read1 , Traversable, Apply, Additive, Metric , Fractional , Num, Ix, Storable, Epsilon - , Hashable -#if __GLASGOW_HASKELL__ >= 702 - , Generic -#endif -#if __GLASGOW_HASKELL__ >= 706 - , Generic1 -#endif -#if __GLASGOW_HASKELL__ >= 708 - , Typeable, Data -#endif + , Semigroup, Monoid + , Random, Hashable + , Generic, Generic1, Data ) -#if __GLASGOW_HASKELL__ >= 707 instance Finite f => Finite (Point f) where type Size (Point f) = Size f toV (P v) = toV v fromV v = P (fromV v) -#endif instance NFData (f a) => NFData (Point f a) where rnf (P x) = rnf x @@ -186,25 +169,15 @@ put (P p) = Cereal.put p get = P `liftM` Cereal.get -#if (MIN_VERSION_hashable(1,2,5)) instance Hashable1 f => Hashable1 (Point f) where liftHashWithSalt h s (P f) = liftHashWithSalt h s f {-# INLINE liftHashWithSalt #-} -#endif -#if __GLASGOW_HASKELL__ < 708 -instance forall f. Typeable1 f => Typeable1 (Point f) where - typeOf1 _ = mkTyConApp (mkTyCon3 "linear" "Linear.Affine" "Point") [] `mkAppTy` - typeOf1 (undefined :: f a) - -deriving instance (Data (f a), Typeable1 f, Typeable a) => Data (Point f a) -#endif - -lensP :: Lens' (Point g a) (g a) +lensP :: Lens (Point f a) (Point g b) (f a) (g b) lensP afb (P a) = P <$> afb a {-# INLINE lensP #-} -_Point :: Iso' (Point f a) (f a) +_Point :: Iso (Point f a) (Point g b) (f a) (g b) _Point = iso (\(P a) -> a) P {-# INLINE _Point #-} @@ -214,7 +187,6 @@ _Wrapped' = _Point {-# INLINE _Wrapped' #-} -#if __GLASGOW_HASKELL__ >= 708 -- These are stolen from Data.Profunctor.Unsafe (.#) :: Coercible b a => (b -> c) -> (a -> b) -> a -> c f .# _ = coerce f @@ -223,13 +195,6 @@ (#.) :: Coercible c b => (b -> c) -> (a -> b) -> a -> c (#.) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b {-# INLINE (#.) #-} -#else -(.#), (#.) :: (b -> c) -> (a -> b) -> a -> c -(.#) = (.) -{-# INLINE (.#) #-} -(#.) = (.) -{-# INLINE (#.) #-} -#endif unP :: Point f a -> f a unP (P x) = x @@ -239,11 +204,7 @@ -- role troubles. However, GHC 7.8 and above let us use -- explicit coercions for (>>-). instance Bind f => Bind (Point f) where -#if __GLASGOW_HASKELL__ >= 708 (>>-) = ((P .) . (. (unP .))) #. (>>-) .# unP -#else - P m >>- f = P $ m >>- unP . f -#endif join (P m) = P $ m >>- \(P m') -> m' instance Distributive f => Distributive (Point f) where @@ -326,10 +287,8 @@ basicUnsafeNew n = MV_P `liftM` M.basicUnsafeNew n basicUnsafeRead (MV_P v) i = P `liftM` M.basicUnsafeRead v i basicUnsafeWrite (MV_P v) i (P x) = M.basicUnsafeWrite v i x -#if MIN_VERSION_vector(0,11,0) basicInitialize (MV_P v) = M.basicInitialize v {-# INLINE basicInitialize #-} -#endif instance U.Unbox (f a) => G.Vector U.Vector (Point f a) where {-# INLINE basicUnsafeFreeze #-} diff --git a/src/Linear/Algebra.hs b/src/Linear/Algebra.hs --- a/src/Linear/Algebra.hs +++ b/src/Linear/Algebra.hs @@ -2,9 +2,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -#if __GLASGOW_HASKELL__ >= 800 -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -- they are mathematically required, not redundant, damn it. -#endif ----------------------------------------------------------------------------- -- | -- License : BSD-style (see the file LICENSE) diff --git a/src/Linear/Binary.hs b/src/Linear/Binary.hs --- a/src/Linear/Binary.hs +++ b/src/Linear/Binary.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2013-2015 Edward Kmett and Anthony Cowley @@ -16,16 +15,8 @@ , getLinear ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Data.Binary -#if __GLASGOW_HASKELL__ < 710 -import Data.Foldable (Foldable, traverse_) -import Data.Traversable (Traversable, sequenceA) -#else import Data.Foldable (traverse_) -#endif -- | Serialize a linear type. putLinear :: (Binary a, Foldable t) => t a -> Put diff --git a/src/Linear/Conjugate.hs b/src/Linear/Conjugate.hs --- a/src/Linear/Conjugate.hs +++ b/src/Linear/Conjugate.hs @@ -1,8 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} -#if __GLASGOW_HASKELL__ >= 800 -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -#endif ----------------------------------------------------------------------------- -- | @@ -24,6 +21,10 @@ import Data.Int import Data.Word import Foreign.C.Types (CFloat, CDouble) + +-- $setup +-- >>> import Data.Complex (Complex (..)) + -- | An involutive ring class Num a => Conjugate a where diff --git a/src/Linear/Covector.hs b/src/Linear/Covector.hs --- a/src/Linear/Covector.hs +++ b/src/Linear/Covector.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} +{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- License : BSD-style (see the file LICENSE) @@ -44,7 +44,9 @@ Covector m >>- f = Covector $ \k -> m $ \a -> runCovector (f a) k instance Monad (Covector r) where +#if !(MIN_VERSION_base(4,11,0)) return a = Covector $ \k -> k a +#endif Covector m >>= f = Covector $ \k -> m $ \a -> runCovector (f a) k instance Num r => Alt (Covector r) where diff --git a/src/Linear/Instances.hs b/src/Linear/Instances.hs --- a/src/Linear/Instances.hs +++ b/src/Linear/Instances.hs @@ -1,8 +1,4 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710 -{-# LANGUAGE Trustworthy #-} -#endif +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2012-2015 Edward Kmett @@ -11,18 +7,8 @@ -- Stability : provisional -- Portability : portable -- --- Orphans +-- Re-exports orphan instances for @Complex@ from the @base-orphans@ package. ----------------------------------------------------------------------------- module Linear.Instances () where -import Control.Applicative -import Control.Monad.Fix -import Control.Monad.Zip -import Data.Complex import Data.Orphans () - -instance MonadZip Complex where - mzipWith = liftA2 - -instance MonadFix Complex where - mfix f = (let a :+ _ = f a in a) :+ (let _ :+ a = f a in a) diff --git a/src/Linear/Matrix.hs b/src/Linear/Matrix.hs --- a/src/Linear/Matrix.hs +++ b/src/Linear/Matrix.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} -#endif +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} --------------------------------------------------------------------------- -- | @@ -33,17 +34,28 @@ , _m22, _m23, _m24 , _m32, _m33, _m34 , _m42, _m43, _m44 + , lu + , luFinite + , forwardSub + , forwardSubFinite + , backwardSub + , backwardSubFinite + , luSolve + , luSolveFinite + , luInv + , luInvFinite + , luDet + , luDetFinite ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Lens hiding (index) import Control.Lens.Internal.Context import Data.Distributive import Data.Foldable as Foldable import Data.Functor.Rep +import GHC.TypeLits import Linear.Quaternion +import Linear.V import Linear.V2 import Linear.V3 import Linear.V4 @@ -51,9 +63,14 @@ import Linear.Conjugate import Linear.Trace -#ifdef HLINT -{-# ANN module "HLint: ignore Reduce duplication" #-} -#endif +-- $setup +-- >>> import Control.Lens hiding (index) +-- >>> import Data.Complex (Complex (..)) +-- >>> import Linear.V2 +-- >>> import Linear.V3 +-- >>> import Linear.V +-- >>> import qualified Data.IntMap as IntMap +-- >>> import Debug.SimpleReflect.Vars -- | This is a generalization of 'Control.Lens.inside' to work over any corepresentable 'Functor'. -- @@ -74,19 +91,13 @@ i = tabulate $ \ e -> ipos $ go (index es e) o eb = tabulate $ \ e -> ipeek (index eb e) (go (index es e)) --- $setup --- >>> import Data.Complex --- >>> import Data.IntMap --- >>> import Debug.SimpleReflect.Vars --- >>> import Linear.V - infixl 7 !*! -- | Matrix product. This can compute any combination of sparse and dense multiplication. -- -- >>> V2 (V3 1 2 3) (V3 4 5 6) !*! V3 (V2 1 2) (V2 3 4) (V2 4 5) -- V2 (V2 19 25) (V2 43 58) -- --- >>> V2 (fromList [(1,2)]) (fromList [(2,3)]) !*! fromList [(1,V3 0 0 1), (2, V3 0 0 5)] +-- >>> V2 (IntMap.fromList [(1,2)]) (IntMap.fromList [(2,3)]) !*! IntMap.fromList [(1,V3 0 0 1), (2, V3 0 0 5)] -- V2 (V3 0 0 2) (V3 0 0 15) (!*!) :: (Functor m, Foldable t, Additive t, Additive n, Num a) => m (t a) -> t (n a) -> m (n a) f !*! g = fmap (\ f' -> Foldable.foldl' (^+^) zero $ liftI2 (*^) f' g) f @@ -224,12 +235,10 @@ (V4 d e f 0) (V4 g h i 0) (V4 j k l 1) -{-# ANN m43_to_m44 "HLint: ignore Use camelCase" #-} -- | Convert a 3x3 matrix to a 4x4 matrix extending it with 0's in the new row and column. m33_to_m44 :: Num a => M33 a -> M44 a m33_to_m44 (V3 r1 r2 r3) = V4 (vector r1) (vector r2) (vector r3) (point 0) -{-# ANN m33_to_m44 "HLint: ignore Use camelCase" #-} -- |The identity matrix for any dimension vector. -- @@ -418,3 +427,305 @@ (-i30 * s3 + i31 * s1 - i32 * s0) (i20 * s3 - i21 * s1 + i22 * s0)) {-# INLINE inv44 #-} + +-- | Compute the (L, U) decomposition of a square matrix using Crout's +-- algorithm. The 'Index' of the vectors must be 'Integral'. +lu :: ( Num a + , Fractional a + , Foldable m + , Traversable m + , Applicative m + , Additive m + , Ixed (m a) + , Ixed (m (m a)) + , i ~ Index (m a) + , i ~ Index (m (m a)) + , Eq i + , Integral i + , a ~ IxValue (m a) + , m a ~ IxValue (m (m a)) + , Num (m a) + ) + => m (m a) + -> (m (m a), m (m a)) +lu a = + let n = fromIntegral (length a) + initU = identity + initL = zero + buildLVal !i !j !l !u = + let go !k !s + | k == j = s + | otherwise = go (k+1) + ( s + + ( (l ^?! ix i ^?! ix k) + * (u ^?! ix k ^?! ix j) + ) + ) + s' = go 0 0 + in l & (ix i . ix j) .~ ((a ^?! ix i ^?! ix j) - s') + buildL !i !j !l !u + | i == n = l + | otherwise = buildL (i+1) j (buildLVal i j l u) u + buildUVal !i !j !l !u = + let go !k !s + | k == j = s + | otherwise = go (k+1) + ( s + + ( (l ^?! ix j ^?! ix k) + * (u ^?! ix k ^?! ix i) + ) + ) + s' = go 0 0 + in u & (ix j . ix i) .~ ( ((a ^?! ix j ^?! ix i) - s') + / (l ^?! ix j ^?! ix j) + ) + buildU !i !j !l !u + | i == n = u + | otherwise = buildU (i+1) j l (buildUVal i j l u) + buildLU !j !l !u + | j == n = (l, u) + | otherwise = + let l' = buildL j j l u + u' = buildU j j l' u + in buildLU (j+1) l' u' + in buildLU 0 initL initU + +-- | Compute the (L, U) decomposition of a square matrix using Crout's +-- algorithm, using the vector's 'Finite' instance to provide an index. +luFinite :: ( Num a + , Fractional a + , Functor m + , Finite m + , n ~ Size m + , KnownNat n + , Num (m a) + ) + => m (m a) + -> (m (m a), m (m a)) +luFinite a = + bimap (fmap fromV . fromV) + (fmap fromV . fromV) + (lu (fmap toV (toV a))) + +-- | Solve a linear system with a lower-triangular matrix of coefficients with +-- forwards substitution. +forwardSub :: ( Num a + , Fractional a + , Foldable m + , Additive m + , Ixed (m a) + , Ixed (m (m a)) + , i ~ Index (m a) + , i ~ Index (m (m a)) + , Eq i + , Ord i + , Integral i + , a ~ IxValue (m a) + , m a ~ IxValue (m (m a)) + ) + => m (m a) + -> m a + -> m a +forwardSub a b = + let n = fromIntegral (length b) + initX = zero + coeff !i !j !s !x + | j == i = s + | otherwise = coeff i (j+1) (s + ((a ^?! ix i ^?! ix j) * (x ^?! ix j))) x + go !i !x + | i == n = x + | otherwise = go (i + 1) (x & ix i .~ ( ((b ^?! ix i) - coeff i 0 0 x) + / (a ^?! ix i ^?! ix i) + )) + in go 0 initX + +-- | Solve a linear system with a lower-triangular matrix of coefficients with +-- forwards substitution, using the vector's 'Finite' instance to provide an +-- index. +forwardSubFinite :: ( Num a + , Fractional a + , Foldable m + , n ~ Size m + , KnownNat n + , Additive m + , Finite m + ) + => m (m a) + -> m a + -> m a +forwardSubFinite a b = fromV (forwardSub (fmap toV (toV a)) (toV b)) + +-- | Solve a linear system with an upper-triangular matrix of coefficients with +-- backwards substitution. +backwardSub :: ( Num a + , Fractional a + , Foldable m + , Additive m + , Ixed (m a) + , Ixed (m (m a)) + , i ~ Index (m a) + , i ~ Index (m (m a)) + , Eq i + , Ord i + , Integral i + , a ~ IxValue (m a) + , m a ~ IxValue (m (m a)) + ) + => m (m a) + -> m a + -> m a +backwardSub a b = + let n = fromIntegral (length b) + initX = zero + coeff !i !j !s !x + | j == n = s + | otherwise = coeff i + (j+1) + (s + ((a ^?! ix i ^?! ix j) * (x ^?! ix j))) + x + go !i !x + | i < 0 = x + | otherwise = go (i-1) + (x & ix i .~ ( ((b ^?! ix i) - coeff i (i+1) 0 x) + / (a ^?! ix i ^?! ix i) + )) + in go (n-1) initX + +-- | Solve a linear system with an upper-triangular matrix of coefficients with +-- backwards substitution, using the vector's 'Finite' instance to provide an +-- index. +backwardSubFinite :: ( Num a + , Fractional a + , Foldable m + , n ~ Size m + , KnownNat n + , Additive m + , Finite m + ) + => m (m a) + -> m a + -> m a +backwardSubFinite a b = fromV (backwardSub (fmap toV (toV a)) (toV b)) + +-- | Solve a linear system with LU decomposition. +luSolve :: ( Num a + , Fractional a + , Foldable m + , Traversable m + , Applicative m + , Additive m + , Ixed (m a) + , Ixed (m (m a)) + , i ~ Index (m a) + , i ~ Index (m (m a)) + , Eq i + , Integral i + , a ~ IxValue (m a) + , m a ~ IxValue (m (m a)) + , Num (m a) + ) + => m (m a) + -> m a + -> m a +luSolve a b = + let (l, u) = lu a + in backwardSub u (forwardSub l b) + +-- | Solve a linear system with LU decomposition, using the vector's 'Finite' +-- instance to provide an index. +luSolveFinite :: ( Num a + , Fractional a + , Functor m + , Finite m + , n ~ Size m + , KnownNat n + , Num (m a) + ) + => m (m a) + -> m a + -> m a +luSolveFinite a b = fromV (luSolve (fmap toV (toV a)) (toV b)) + +-- | Invert a matrix with LU decomposition. +luInv :: ( Num a + , Fractional a + , Foldable m + , Traversable m + , Applicative m + , Additive m + , Distributive m + , Ixed (m a) + , Ixed (m (m a)) + , i ~ Index (m a) + , i ~ Index (m (m a)) + , Eq i + , Integral i + , a ~ IxValue (m a) + , m a ~ IxValue (m (m a)) + , Num (m a) + ) + => m (m a) + -> m (m a) +luInv a = + let n = fromIntegral (length a) + initA' = zero + (l, u) = lu a + go !i !a' + | i == n = a' + | otherwise = let e = zero & ix i .~ 1 + a'r = backwardSub u (forwardSub l e) + in go (i+1) (a' & ix i .~ a'r) + in transpose (go 0 initA') + +-- | Invert a matrix with LU decomposition, using the vector's 'Finite' instance +-- to provide an index. +luInvFinite :: ( Num a + , Fractional a + , Functor m + , Finite m + , n ~ Size m + , KnownNat n + , Num (m a) + ) + => m (m a) + -> m (m a) +luInvFinite a = fmap fromV (fromV (luInv (fmap toV (toV a)))) + +-- | Compute the determinant of a matrix using LU decomposition. +luDet :: ( Num a + , Fractional a + , Foldable m + , Traversable m + , Applicative m + , Additive m + , Trace m + , Ixed (m a) + , Ixed (m (m a)) + , i ~ Index (m a) + , i ~ Index (m (m a)) + , Eq i + , Integral i + , a ~ IxValue (m a) + , m a ~ IxValue (m (m a)) + , Num (m a) + ) + => m (m a) + -> a +luDet a = + let (l, u) = lu a + p = Foldable.foldl (*) 1 + in p (diagonal l) * p (diagonal u) + +-- | Compute the determinant of a matrix using LU decomposition, using the +-- vector's 'Finite' instance to provide an index. +luDetFinite :: ( Num a + , Fractional a + , Functor m + , Finite m + , n ~ Size m + , KnownNat n + , Num (m a) + ) + => m (m a) + -> a +luDetFinite = luDet . fmap toV . toV diff --git a/src/Linear/Metric.hs b/src/Linear/Metric.hs --- a/src/Linear/Metric.hs +++ b/src/Linear/Metric.hs @@ -1,8 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} -#endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2012-2015 Edward Kmett @@ -20,7 +18,9 @@ import Control.Applicative import Data.Foldable as Foldable +import Data.Functor.Compose import Data.Functor.Identity +import Data.Functor.Product import Data.Vector (Vector) import Data.IntMap (IntMap) import Data.Map (Map) @@ -31,6 +31,7 @@ -- $setup -- >>> import Linear +-- -- | Free and sparse inner product/metric spaces. class Additive f => Metric f where @@ -67,6 +68,18 @@ signorm v = fmap (/m) v where m = norm v +instance (Metric f, Metric g) => Metric (Product f g) where + dot (Pair a b) (Pair c d) = dot a c + dot b d + quadrance (Pair a b) = quadrance a + quadrance b + qd (Pair a b) (Pair c d) = qd a c + qd b d + distance p q = sqrt (qd p q) + +instance (Metric f, Metric g) => Metric (Compose f g) where + dot (Compose a) (Compose b) = quadrance (liftI2 dot a b) + quadrance = quadrance . fmap quadrance . getCompose + qd (Compose a) (Compose b) = quadrance (liftI2 qd a b) + distance (Compose a) (Compose b) = norm (liftI2 qd a b) + instance Metric Identity where dot (Identity x) (Identity y) = x * y @@ -95,4 +108,3 @@ -- | @project u v@ computes the projection of @v@ onto @u@. project :: (Metric v, Fractional a) => v a -> v a -> v a project u v = ((v `dot` u) / quadrance u) *^ u - diff --git a/src/Linear/Plucker.hs b/src/Linear/Plucker.hs --- a/src/Linear/Plucker.hs +++ b/src/Linear/Plucker.hs @@ -4,25 +4,11 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GADTs #-} -#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} {-# LANGUAGE DeriveGeneric #-} -#endif -#if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DataKinds #-} -#endif - -#if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE DeriveLift #-} -#endif -#ifndef MIN_VERSION_vector -#define MIN_VERSION_vector(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_transformers -#define MIN_VERSION_transformers(x,y,z) 1 -#endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2012-2015 Edward Kmett @@ -60,73 +46,89 @@ , e01, e02, e03, e12, e31, e23 ) where +#if !MIN_VERSION_base(4,18,0) import Control.Applicative +#endif import Control.DeepSeq (NFData(rnf)) import Control.Monad (liftM) import Control.Monad.Fix import Control.Monad.Zip -import Control.Lens hiding (index, (<.>)) +import Control.Lens as Lens hiding (index, (<.>)) import Data.Binary as Binary import Data.Bytes.Serial import Data.Distributive import Data.Foldable as Foldable +import qualified Data.Foldable.WithIndex as WithIndex import Data.Functor.Bind import Data.Functor.Classes import Data.Functor.Rep +import qualified Data.Functor.WithIndex as WithIndex import Data.Hashable import Data.Semigroup import Data.Semigroup.Foldable import Data.Serialize as Cereal -#if __GLASGOW_HASKELL__ >= 707 +import qualified Data.Traversable.WithIndex as WithIndex import qualified Data.Vector as V -#endif import qualified Data.Vector.Generic.Mutable as M import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed.Base as U import Foreign.Ptr (castPtr) import Foreign.Storable (Storable(..)) import GHC.Arr (Ix(..)) -#if __GLASGOW_HASKELL__ >= 702 -import GHC.Generics (Generic) -#endif -#if __GLASGOW_HASKELL__ >= 706 -import GHC.Generics (Generic1) -#endif -#if __GLASGOW_HASKELL__ >= 800 +import GHC.Generics (Generic, Generic1) +#if defined(MIN_VERSION_template_haskell) import Language.Haskell.TH.Syntax (Lift) #endif import Linear.Epsilon import Linear.Metric -#if __GLASGOW_HASKELL__ >= 707 import Linear.V -#endif import Linear.V2 import Linear.V3 import Linear.V4 import Linear.Vector - -{-# ANN module "HLint: ignore Reduce duplication" #-} +import System.Random (Random(..), Uniform) +import System.Random.Stateful (UniformRange(..)) -- | Plücker coordinates for lines in a 3-dimensional space. data Plucker a = Plucker !a !a !a !a !a !a deriving (Eq,Ord,Show,Read -#if __GLASGOW_HASKELL__ >= 702 - ,Generic -#endif -#if __GLASGOW_HASKELL__ >= 706 - ,Generic1 -#endif -#if __GLASGOW_HASKELL__ >= 800 + ,Generic,Generic1 +#if defined(MIN_VERSION_template_haskell) ,Lift #endif ) -#if __GLASGOW_HASKELL__ >= 707 instance Finite Plucker where type Size Plucker = 6 toV (Plucker a b c d e f) = V (V.fromListN 6 [a,b,c,d,e,f]) fromV (V v) = Plucker (v V.! 0) (v V.! 1) (v V.! 2) (v V.! 3) (v V.! 4) (v V.! 5) -#endif +instance Random a => Random (Plucker a) where + random g = case random g of + (a, g1) -> case random g1 of + (b, g2) -> case random g2 of + (c, g3) -> case random g3 of + (d, g4) -> case random g4 of + (e, g5) -> case random g5 of + (f, g6) -> (Plucker a b c d e f, g6) + randomR (Plucker a b c d e f, Plucker a' b' c' d' e' f') g = case randomR (a,a') g of + (a'', g1) -> case randomR (b,b') g1 of + (b'', g2) -> case randomR (c,c') g2 of + (c'', g3) -> case randomR (d,d') g3 of + (d'', g4) -> case randomR (e,e') g4 of + (e'', g5) -> case randomR (f,f') g5 of + (f'', g6) -> (Plucker a'' b'' c'' d'' e'' f'', g6) + +instance Uniform a => Uniform (Plucker a) where + +instance UniformRange a => UniformRange (Plucker a) where + uniformRM (Plucker a b c d e f, Plucker a' b' c' d' e' f') g = Plucker + <$> uniformRM (a, a') g + <*> uniformRM (b, b') g + <*> uniformRM (c, c') g + <*> uniformRM (d, d') g + <*> uniformRM (e, e') g + <*> uniformRM (f, f') g + instance Functor Plucker where fmap g (Plucker a b c d e f) = Plucker (g a) (g b) (g c) (g d) (g e) (g f) {-# INLINE fmap #-} @@ -162,8 +164,10 @@ {-# INLINE (>>-) #-} instance Monad Plucker where +#if !(MIN_VERSION_base(4,11,0)) return a = Plucker a a a a a a {-# INLINE return #-} +#endif Plucker a b c d e f >>= g = Plucker a' b' c' d' e' f' where Plucker a' _ _ _ _ _ = g a Plucker _ b' _ _ _ _ = g b @@ -193,10 +197,8 @@ foldMap g (Plucker a b c d e f) = g a `mappend` g b `mappend` g c `mappend` g d `mappend` g e `mappend` g f {-# INLINE foldMap #-} -#if __GLASGOW_HASKELL__ >= 710 null _ = False length _ = 6 -#endif instance Traversable Plucker where traverse g (Plucker a b c d e f) = @@ -416,25 +418,31 @@ e31 = E p31 e12 = E p12 -instance FunctorWithIndex (E Plucker) Plucker where +instance WithIndex.FunctorWithIndex (E Plucker) Plucker where imap f (Plucker a b c d e g) = Plucker (f e01 a) (f e02 b) (f e03 c) (f e23 d) (f e31 e) (f e12 g) {-# INLINE imap #-} -instance FoldableWithIndex (E Plucker) Plucker where +instance WithIndex.FoldableWithIndex (E Plucker) Plucker where ifoldMap f (Plucker a b c d e g) = f e01 a `mappend` f e02 b `mappend` f e03 c `mappend` f e23 d `mappend` f e31 e `mappend` f e12 g {-# INLINE ifoldMap #-} -instance TraversableWithIndex (E Plucker) Plucker where +instance WithIndex.TraversableWithIndex (E Plucker) Plucker where itraverse f (Plucker a b c d e g) = Plucker <$> f e01 a <*> f e02 b <*> f e03 c <*> f e23 d <*> f e31 e <*> f e12 g {-# INLINE itraverse #-} +#if !MIN_VERSION_lens(5,0,0) +instance Lens.FunctorWithIndex (E Plucker) Plucker where imap = WithIndex.imap +instance Lens.FoldableWithIndex (E Plucker) Plucker where ifoldMap = WithIndex.ifoldMap +instance Lens.TraversableWithIndex (E Plucker) Plucker where itraverse = WithIndex.itraverse +#endif + type instance Index (Plucker a) = E Plucker type instance IxValue (Plucker a) = a instance Ixed (Plucker a) where - ix = el + ix i = el i {-# INLINE ix #-} instance Each (Plucker a) (Plucker b) a b where @@ -477,11 +485,7 @@ | Counterclockwise -- ^ The lines pass each other counterclockwise -- (left-handed screw). - deriving (Eq, Show -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 - ,Generic -#endif - ) + deriving (Eq, Show,Generic) -- | Check how two lines pass each other. @passes l1 l2@ describes -- @l2@ when looking down @l1@. @@ -510,20 +514,49 @@ -- | Checks if two lines coincide in space. In other words, undirected equality. coincides :: (Epsilon a, Fractional a) => Plucker a -> Plucker a -> Bool coincides p1 p2 = Foldable.all nearZero $ (s *^ p2) - p1 - where s = maybe 1 getFirst . getOption . fold $ saveDiv <$> p1 <*> p2 - saveDiv x y | nearZero y = Option Nothing - | otherwise = Option . Just $ First (x / y) + where s = maybe 1 getFirst . getOptionCompat . fold $ saveDiv <$> p1 <*> p2 + saveDiv x y | nearZero y = optionCompat Nothing + | otherwise = optionCompat . Just $ First (x / y) {-# INLINABLE coincides #-} -- | Checks if two lines coincide in space, and have the same -- orientation. coincides' :: (Epsilon a, Fractional a, Ord a) => Plucker a -> Plucker a -> Bool coincides' p1 p2 = Foldable.all nearZero ((s *^ p2) - p1) && s > 0 - where s = maybe 1 getFirst . getOption . fold $ saveDiv <$> p1 <*> p2 - saveDiv x y | nearZero y = Option Nothing - | otherwise = Option . Just $ First (x / y) + where s = maybe 1 getFirst . getOptionCompat . fold $ saveDiv <$> p1 <*> p2 + saveDiv x y | nearZero y = optionCompat Nothing + | otherwise = optionCompat . Just $ First (x / y) {-# INLINABLE coincides' #-} +-- The coincides and coincides' functions above require the use of a Maybe type +-- with the following Monoid instance: +-- +-- instance Semigroup a => Monoid (Maybe a) where ... +-- +-- Unfortunately, Maybe has only had such an instance since base-4.11. Prior +-- to that, its Monoid instance had an instance context of Monoid a, which is +-- too strong. To compensate, we use CPP to define an OptionCompat type +-- synonym, which is an alias for Maybe on recent versions of base and an alias +-- for Data.Semigroup.Option on older versions of base. We don't want to use +-- Option on recent versions of base, as it is deprecated. +#if MIN_VERSION_base(4,11,0) +type OptionCompat = Maybe + +optionCompat :: Maybe a -> OptionCompat a +optionCompat = id + +getOptionCompat :: OptionCompat a -> Maybe a +getOptionCompat = id +#else +type OptionCompat = Option + +optionCompat :: Maybe a -> OptionCompat a +optionCompat = Option + +getOptionCompat :: OptionCompat a -> Maybe a +getOptionCompat = getOption +#endif + -- | The minimum squared distance of a line from the origin. quadranceToOrigin :: Fractional a => Plucker a -> a quadranceToOrigin p = (v `dot` v) / (u `dot` u) @@ -573,9 +606,7 @@ M.basicUnsafeWrite a (o+3) w M.basicUnsafeWrite a (o+4) v M.basicUnsafeWrite a (o+5) u -#if MIN_VERSION_vector(0,11,0) basicInitialize (MV_Plucker _ v) = M.basicInitialize v -#endif instance U.Unbox a => G.Vector U.Vector (Plucker a) where basicUnsafeFreeze (MV_Plucker n v) = liftM ( V_Plucker n) (G.basicUnsafeFreeze v) @@ -623,8 +654,6 @@ put = serializeWith Cereal.put get = deserializeWith Cereal.get - -#if (MIN_VERSION_transformers(0,5,0)) || !(MIN_VERSION_transformers(0,4,0)) instance Eq1 Plucker where liftEq k (Plucker a1 b1 c1 d1 e1 f1) (Plucker a2 b2 c2 d2 e2 f2) @@ -647,12 +676,6 @@ instance Show1 Plucker where liftShowsPrec k _ z (Plucker a b c d e f) = showParen (z > 10) $ showString "Plucker " . k 11 a . showChar ' ' . k 11 b . showChar ' ' . k 11 c . showChar ' ' . k 11 d . showChar ' ' . k 11 e . showChar ' ' . k 11 f -#else -instance Eq1 Plucker where eq1 = (==) -instance Ord1 Plucker where compare1 = compare -instance Show1 Plucker where showsPrec1 = showsPrec -instance Read1 Plucker where readsPrec1 = readsPrec -#endif instance Field1 (Plucker a) (Plucker a) a a where _1 f (Plucker x y z u v w) = f x <&> \x' -> Plucker x' y z u v w @@ -671,3 +694,12 @@ instance Field6 (Plucker a) (Plucker a) a a where _6 f (Plucker x y z u v w) = f w <&> \w' -> Plucker x y z u v w' + +instance Semigroup a => Semigroup (Plucker a) where + (<>) = liftA2 (<>) + +instance Monoid a => Monoid (Plucker a) where + mempty = pure mempty +#if !(MIN_VERSION_base(4,11,0)) + mappend = liftA2 mappend +#endif diff --git a/src/Linear/Projection.hs b/src/Linear/Projection.hs --- a/src/Linear/Projection.hs +++ b/src/Linear/Projection.hs @@ -30,9 +30,10 @@ import Linear.Epsilon import Linear.Metric -#ifdef HLINT -{-# ANN module "HLint: ignore Reduce duplication" #-} -#endif +-- $setup +-- >>> import Linear.Matrix +-- >>> import Linear.V2 +-- >>> import Linear.V4 -- | Build a look at view matrix lookAt diff --git a/src/Linear/Quaternion.hs b/src/Linear/Quaternion.hs --- a/src/Linear/Quaternion.hs +++ b/src/Linear/Quaternion.hs @@ -5,25 +5,11 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} -#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} {-# LANGUAGE DeriveGeneric #-} -#endif -#if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DataKinds #-} -#endif - -#if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE DeriveLift #-} -#endif -#ifndef MIN_VERSION_hashable -#define MIN_VERSION_hashable(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_vector -#define MIN_VERSION_vector(x,y,z) 1 -#endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2012-2015 Edward Kmett @@ -58,74 +44,78 @@ import Control.Monad (liftM) import Control.Monad.Fix import Control.Monad.Zip -import Control.Lens hiding ((<.>)) +import Control.Lens as Lens hiding ((<.>)) import Data.Binary as Binary import Data.Bytes.Serial import Data.Complex (Complex((:+))) import Data.Data import Data.Distributive import Data.Foldable +import qualified Data.Foldable.WithIndex as WithIndex import Data.Functor.Bind import Data.Functor.Classes import Data.Functor.Rep +import qualified Data.Functor.WithIndex as WithIndex import Data.Hashable -#if (MIN_VERSION_hashable(1,2,5)) import Data.Hashable.Lifted +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup (Semigroup(..)) #endif import Data.Serialize as Cereal import GHC.Arr (Ix(..)) import qualified Data.Foldable as F -import Data.Monoid -#if __GLASGOW_HASKELL__ >= 707 +import qualified Data.Traversable.WithIndex as WithIndex import qualified Data.Vector as V -#endif import qualified Data.Vector.Generic.Mutable as M import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed.Base as U import Foreign.Ptr (castPtr, plusPtr) import Foreign.Storable (Storable(..)) -#if __GLASGOW_HASKELL__ >= 702 -import GHC.Generics (Generic) -#endif -#if __GLASGOW_HASKELL__ >= 706 -import GHC.Generics (Generic1) -#endif -#if __GLASGOW_HASKELL__ >= 800 +import GHC.Generics (Generic, Generic1) +#if defined(MIN_VERSION_template_haskell) import Language.Haskell.TH.Syntax (Lift) #endif import Linear.Epsilon import Linear.Conjugate import Linear.Metric -#if __GLASGOW_HASKELL__ >= 707 import Linear.V -#endif +import Linear.V2 import Linear.V3 +import Linear.V4 import Linear.Vector import Prelude hiding (any) - -{-# ANN module "HLint: ignore Reduce duplication" #-} +import System.Random (Random(..), Uniform) +import System.Random.Stateful (UniformRange(..)) -- | Quaternions data Quaternion a = Quaternion !a {-# UNPACK #-}!(V3 a) - deriving (Eq,Ord,Read,Show,Data,Typeable -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 - ,Generic -#endif -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 - ,Generic1 -#endif -#if __GLASGOW_HASKELL__ >= 800 + deriving (Eq,Ord,Read,Show,Data + ,Generic,Generic1 +#if defined(MIN_VERSION_template_haskell) ,Lift #endif ) -#if __GLASGOW_HASKELL__ >= 707 instance Finite Quaternion where type Size Quaternion = 4 toV (Quaternion a (V3 b c d)) = V (V.fromListN 4 [a, b, c, d]) fromV (V v) = Quaternion (v V.! 0) (V3 (v V.! 1) (v V.! 2) (v V.! 3)) -#endif +instance Random a => Random (Quaternion a) where + random g = case random g of + (a, g') -> case random g' of + (b, g'') -> (Quaternion a b, g'') + randomR (Quaternion a b, Quaternion c d) g = case randomR (a,c) g of + (e, g') -> case randomR (b,d) g' of + (f, g'') -> (Quaternion e f, g'') + +instance Uniform a => Uniform (Quaternion a) where + +instance UniformRange a => UniformRange (Quaternion a) where + uniformRM (Quaternion a b, Quaternion c d) g = Quaternion + <$> uniformRM (a, c) g + <*> uniformRM (b, d) g + instance Functor Quaternion where fmap f (Quaternion e v) = Quaternion (f e) (fmap f v) {-# INLINE fmap #-} @@ -191,23 +181,29 @@ index xs (E l) = view l xs {-# INLINE index #-} -instance FunctorWithIndex (E Quaternion) Quaternion where +instance WithIndex.FunctorWithIndex (E Quaternion) Quaternion where imap f (Quaternion a (V3 b c d)) = Quaternion (f ee a) $ V3 (f ei b) (f ej c) (f ek d) {-# INLINE imap #-} -instance FoldableWithIndex (E Quaternion) Quaternion where +instance WithIndex.FoldableWithIndex (E Quaternion) Quaternion where ifoldMap f (Quaternion a (V3 b c d)) = f ee a `mappend` f ei b `mappend` f ej c `mappend` f ek d {-# INLINE ifoldMap #-} -instance TraversableWithIndex (E Quaternion) Quaternion where +instance WithIndex.TraversableWithIndex (E Quaternion) Quaternion where itraverse f (Quaternion a (V3 b c d)) = Quaternion <$> f ee a <*> (V3 <$> f ei b <*> f ej c <*> f ek d) {-# INLINE itraverse #-} +#if !MIN_VERSION_lens(5,0,0) +instance Lens.FunctorWithIndex (E Quaternion) Quaternion where imap = WithIndex.imap +instance Lens.FoldableWithIndex (E Quaternion) Quaternion where ifoldMap = WithIndex.ifoldMap +instance Lens.TraversableWithIndex (E Quaternion) Quaternion where itraverse = WithIndex.itraverse +#endif + type instance Index (Quaternion a) = E Quaternion type instance IxValue (Quaternion a) = a instance Ixed (Quaternion a) where - ix = el + ix i = el i {-# INLINE ix #-} instance Each (Quaternion a) (Quaternion b) a b where @@ -219,10 +215,8 @@ {-# INLINE foldMap #-} foldr f z (Quaternion e v) = f e (F.foldr f z v) {-# INLINE foldr #-} -#if __GLASGOW_HASKELL__ >= 710 null _ = False length _ = 4 -#endif instance Traversable Quaternion where traverse f (Quaternion e v) = Quaternion <$> f e <*> traverse f v @@ -279,11 +273,9 @@ hashWithSalt s (Quaternion a b) = s `hashWithSalt` a `hashWithSalt` b {-# INLINE hashWithSalt #-} -#if (MIN_VERSION_hashable(1,2,5)) instance Hashable1 Quaternion where liftHashWithSalt h s (Quaternion a b) = liftHashWithSalt h (h s a) b {-# INLINE liftHashWithSalt #-} -#endif qNaN :: RealFloat a => Quaternion a qNaN = Quaternion fNaN (V3 fNaN fNaN fNaN) where fNaN = 0/0 @@ -621,9 +613,7 @@ M.basicUnsafeWrite v (o+1) y M.basicUnsafeWrite v (o+2) z M.basicUnsafeWrite v (o+3) w -#if MIN_VERSION_vector(0,11,0) basicInitialize (MV_Quaternion _ v) = M.basicInitialize v -#endif instance U.Unbox a => G.Vector U.Vector (Quaternion a) where basicUnsafeFreeze (MV_Quaternion n v) = liftM ( V_Quaternion n) (G.basicUnsafeFreeze v) @@ -666,7 +656,6 @@ put = serializeWith Cereal.put get = deserializeWith Cereal.get -#if (MIN_VERSION_transformers(0,5,0)) || !(MIN_VERSION_transformers(0,4,0)) instance Eq1 Quaternion where liftEq f (Quaternion a b) (Quaternion c d) = f a c && liftEq f b d instance Ord1 Quaternion where @@ -675,12 +664,6 @@ liftShowsPrec f g d (Quaternion a b) = showsBinaryWith f (liftShowsPrec f g) "Quaternion" d a b instance Read1 Quaternion where liftReadsPrec f g = readsData $ readsBinaryWith f (liftReadsPrec f g) "Quaternion" Quaternion -#else -instance Eq1 Quaternion where eq1 = (==) -instance Ord1 Quaternion where compare1 = compare -instance Show1 Quaternion where showsPrec1 = showsPrec -instance Read1 Quaternion where readsPrec1 = readsPrec -#endif instance Field1 (Quaternion a) (Quaternion a) a a where _1 f (Quaternion w xyz) = f w <&> \w' -> Quaternion w' xyz @@ -693,3 +676,28 @@ instance Field4 (Quaternion a) (Quaternion a) a a where _4 f (Quaternion w (V3 x y z)) = f z <&> \z' -> Quaternion w (V3 x y z') + +instance Semigroup a => Semigroup (Quaternion a) where + (<>) = liftA2 (<>) + +instance Monoid a => Monoid (Quaternion a) where + mempty = pure mempty +#if !(MIN_VERSION_base(4,11,0)) + mappend = liftA2 mappend +#endif + +instance R1 Quaternion where + _x f (Quaternion w (V3 x y z)) = f x <&> \x' -> Quaternion w (V3 x' y z) + +instance R2 Quaternion where + _y f (Quaternion w (V3 x y z)) = f y <&> \y' -> Quaternion w (V3 x y' z) + _xy f (Quaternion w (V3 x y z)) = f (V2 x y) <&> \(V2 x' y') -> Quaternion w (V3 x' y' z) + +instance R3 Quaternion where + _z f (Quaternion w (V3 x y z)) = f z <&> \z' -> Quaternion w (V3 x y z') + _xyz f (Quaternion w xyz) = Quaternion w <$> f xyz + +instance R4 Quaternion where + _w f (Quaternion w xyz) = f w <&> \w' -> Quaternion w' xyz + _xyzw f (Quaternion w (V3 x y z)) = f (V4 x y z w) <&> \(V4 x' y' z' w') -> Quaternion w' (V3 x' y' z') + diff --git a/src/Linear/Trace.hs b/src/Linear/Trace.hs --- a/src/Linear/Trace.hs +++ b/src/Linear/Trace.hs @@ -1,12 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DefaultSignatures #-} -#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} -#endif -#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710 {-# LANGUAGE Trustworthy #-} -#endif --------------------------------------------------------------------------- -- | -- Copyright : (C) 2012-2015 Edward Kmett @@ -20,6 +16,7 @@ --------------------------------------------------------------------------- module Linear.Trace ( Trace(..) + , frobenius ) where import Control.Monad as Monad @@ -31,9 +28,8 @@ import Linear.Plucker import Linear.Quaternion import Linear.V -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 704 +import Linear.Vector import Data.Complex -#endif import Data.Distributive import Data.Foldable as Foldable import Data.Functor.Bind as Bind @@ -41,13 +37,13 @@ import Data.Functor.Product import Data.Hashable import Data.HashMap.Lazy -import Data.IntMap -import Data.Map +import Data.IntMap (IntMap) +import Data.Map (Map) -- $setup -- >>> import Data.Complex --- >>> import Data.IntMap -- >>> import Debug.SimpleReflect.Vars +-- >>> import Linear.V2 class Functor m => Trace m where -- | Compute the trace of a matrix @@ -93,13 +89,11 @@ instance Trace Plucker instance Trace Quaternion -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 704 instance Trace Complex where trace ((a :+ _) :+ (_ :+ b)) = a + b {-# INLINE trace #-} diagonal ((a :+ _) :+ (_ :+ b)) = a :+ b {-# INLINE diagonal #-} -#endif instance (Trace f, Trace g) => Trace (Product f g) where trace (Pair xx yy) = trace (pfst <$> xx) + trace (psnd <$> yy) where @@ -116,3 +110,7 @@ {-# INLINE trace #-} diagonal = Compose . fmap diagonal . diagonal . fmap distribute . getCompose . fmap getCompose {-# INLINE diagonal #-} + +-- | Compute the of a matrix. +frobenius :: (Num a, Foldable f, Additive f, Additive g, Distributive g, Trace g) => f (g a) -> a +frobenius m = trace $ fmap (\ f' -> Foldable.foldl' (^+^) zero $ liftI2 (*^) f' m) (distribute m) diff --git a/src/Linear/V.hs b/src/Linear/V.hs --- a/src/Linear/V.hs +++ b/src/Linear/V.hs @@ -9,29 +9,12 @@ {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances #-} {-# LANGUAGE DeriveDataTypeable #-} -#if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} -#endif -#if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE RoleAnnotations #-} -#define USE_TYPE_LITS 1 -#endif {-# LANGUAGE Trustworthy #-} {-# LANGUAGE DeriveGeneric #-} -#ifndef MIN_VERSION_hashable -#define MIN_VERSION_hashable(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_reflection -#define MIN_VERSION_reflection(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_transformers -#define MIN_VERSION_transformers(x,y,z) 1 -#endif - ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2012-2015 Edward Kmett @@ -53,89 +36,67 @@ , Dim(..) , reifyDim , reifyVector -#if (MIN_VERSION_reflection(2,0,0)) && __GLASGOW_HASKELL__ >= 708 , reifyDimNat , reifyVectorNat -#endif , fromVector -#if __GLASGOW_HASKELL__ >= 707 , Finite(..) , _V, _V' -#endif ) where -#if __GLASGOW_HASKELL__ < 710 import Control.Applicative -#endif import Control.DeepSeq (NFData) import Control.Monad import Control.Monad.Fix +import Control.Monad.Trans.State import Control.Monad.Zip import Control.Lens as Lens import Data.Binary as Binary import Data.Bytes.Serial -#if __GLASGOW_HASKELL__ >= 707 import Data.Complex -#endif import Data.Data import Data.Distributive import Data.Foldable as Foldable +import qualified Data.Foldable.WithIndex as WithIndex import Data.Functor.Bind import Data.Functor.Classes import Data.Functor.Rep as Rep +import qualified Data.Functor.WithIndex as WithIndex import Data.Hashable -#if (MIN_VERSION_hashable(1,2,5)) import Data.Hashable.Lifted -#endif -#if __GLASGOW_HASKELL__ < 708 -import Data.Proxy -#endif +import Data.Kind import Data.Reflection as R import Data.Serialize as Cereal -#if __GLASGOW_HASKELL__ < 710 -import Data.Traversable (sequenceA) -#endif -import Data.Vector as V +import qualified Data.Traversable.WithIndex as WithIndex +import qualified Data.Vector as V +import Data.Vector (Vector) +import Data.Vector.Fusion.Util (Box(..)) import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Generic.Mutable as M import Foreign.Ptr import Foreign.Storable -#ifdef USE_TYPE_LITS import GHC.TypeLits -#endif -#if __GLASGOW_HASKELL__ >= 702 -import GHC.Generics (Generic) -#endif -#if __GLASGOW_HASKELL__ >= 707 -import GHC.Generics (Generic1) -#endif +import GHC.Generics (Generic, Generic1) #if !(MIN_VERSION_reflection(1,3,0)) && defined(MIN_VERSION_template_haskell) import Language.Haskell.TH #endif import Linear.Epsilon import Linear.Metric import Linear.Vector -#if (MIN_VERSION_transformers(0,5,0)) || !(MIN_VERSION_transformers(0,4,0)) import Prelude as P -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid -#endif -#endif - - -#ifdef HLINT -{-# ANN module "hlint: ignore Eta reduce" #-} +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup #endif +import System.Random (Random(..)) +import System.Random.Stateful (Uniform(..), UniformRange(..)) class Dim n where reflectDim :: p n -> Int -#if __GLASGOW_HASKELL__ >= 707 type role V nominal representational class Finite v where - type Size (v :: * -> *) :: Nat -- this should allow kind k, for Reifies k Int + type Size (v :: Type -> Type) :: Nat -- this should allow kind k, for Reifies k Int toV :: v a -> V (Size v) a default toV :: Foldable v => v a -> V (Size v) a toV = V . V.fromList . Foldable.toList @@ -156,27 +117,33 @@ type Size (V n) = n toV = id fromV = id -#endif -newtype V n a = V { toVector :: V.Vector a } deriving (Eq,Ord,Show,Read,Typeable,NFData - , Generic --- GHC bug: https://ghc.haskell.org/trac/ghc/ticket/8468 -#if __GLASGOW_HASKELL__ >= 707 - ,Generic1 -#endif +newtype V n a = V { toVector :: V.Vector a } deriving (Eq,Ord,Show,Read,NFData + ,Generic,Generic1 ) dim :: forall n a. Dim n => V n a -> Int dim _ = reflectDim (Proxy :: Proxy n) {-# INLINE dim #-} -#ifdef USE_TYPE_LITS instance KnownNat n => Dim (n :: Nat) where reflectDim = fromInteger . natVal {-# INLINE reflectDim #-} + +instance (Dim n, Random a) => Random (V n a) where + random = runState (V <$> V.replicateM (reflectDim (Proxy :: Proxy n)) (state random)) + randomR (V ls,V hs) = runState (V <$> V.zipWithM (\l h -> state $ randomR (l,h)) ls hs) + +instance (Dim n, Uniform a) => Uniform (V n a) where + uniformM g = V <$> V.replicateM (reflectDim (Proxy :: Proxy n)) (uniformM g) + +instance (Dim n, UniformRange a) => UniformRange (V n a) where + uniformRM (V ls, V hs) g = V <$> V.zipWithM (\l h -> uniformRM (l, h) g) ls hs +#if (MIN_VERSION_random(1,3,0)) + isInRange (V ls, V hs) (V xs) = V.and $ V.zipWith3 (\l h x -> isInRange (l, h) x) ls hs xs #endif -data ReifiedDim (s :: *) +data ReifiedDim (s :: Type) retagDim :: (Proxy s -> a) -> proxy (ReifiedDim s) -> a retagDim f _ = f Proxy @@ -186,8 +153,6 @@ reflectDim = retagDim reflect {-# INLINE reflectDim #-} -#if (MIN_VERSION_reflection(2,0,0)) && __GLASGOW_HASKELL__ >= 708 - reifyDimNat :: Int -> (forall (n :: Nat). KnownNat n => Proxy n -> r) -> r reifyDimNat i f = R.reifyNat (fromIntegral i) f {-# INLINE reifyDimNat #-} @@ -196,15 +161,13 @@ reifyVectorNat v f = reifyNat (fromIntegral $ V.length v) $ \(Proxy :: Proxy n) -> f (V v :: V n a) {-# INLINE reifyVectorNat #-} -#endif - -reifyDim :: Int -> (forall (n :: *). Dim n => Proxy n -> r) -> r +reifyDim :: Int -> (forall (n :: Type). Dim n => Proxy n -> r) -> r reifyDim i f = R.reify i (go f) where go :: (Proxy (ReifiedDim n) -> a) -> proxy n -> a go g _ = g Proxy {-# INLINE reifyDim #-} -reifyVector :: forall a r. Vector a -> (forall (n :: *). Dim n => V n a -> r) -> r +reifyVector :: forall a r. Vector a -> (forall (n :: Type). Dim n => V n a -> r) -> r reifyVector v f = reifyDim (V.length v) $ \(Proxy :: Proxy n) -> f (V v :: V n a) {-# INLINE reifyVector #-} @@ -212,35 +175,40 @@ reflectDim _ = reflectDim (Proxy :: Proxy n) {-# INLINE reflectDim #-} +instance (Dim n, Semigroup a) => Semigroup (V n a) where + (<>) = liftA2 (<>) + +instance (Dim n, Monoid a) => Monoid (V n a) where + mempty = pure mempty +#if !(MIN_VERSION_base(4,11,0)) + mappend = liftA2 mappend +#endif + instance Functor (V n) where fmap f (V as) = V (fmap f as) {-# INLINE fmap #-} -instance FunctorWithIndex Int (V n) where +instance WithIndex.FunctorWithIndex Int (V n) where imap f (V as) = V (Lens.imap f as) {-# INLINE imap #-} instance Foldable (V n) where fold (V as) = fold as {-# INLINE fold #-} - foldMap f (V as) = foldMap f as + foldMap f (V as) = Foldable.foldMap f as {-# INLINE foldMap #-} foldr f z (V as) = V.foldr f z as {-# INLINE foldr #-} foldl f z (V as) = V.foldl f z as {-# INLINE foldl #-} -#if __GLASGOW_HASKELL__ >= 706 foldr' f z (V as) = V.foldr' f z as {-# INLINE foldr' #-} foldl' f z (V as) = V.foldl' f z as {-# INLINE foldl' #-} -#endif foldr1 f (V as) = V.foldr1 f as {-# INLINE foldr1 #-} foldl1 f (V as) = V.foldl1 f as {-# INLINE foldl1 #-} - -#if __GLASGOW_HASKELL__ >= 710 length (V as) = V.length as {-# INLINE length #-} null (V as) = V.null as @@ -257,9 +225,8 @@ {-# INLINE sum #-} product (V as) = V.product as {-# INLINE product #-} -#endif -instance FoldableWithIndex Int (V n) where +instance WithIndex.FoldableWithIndex Int (V n) where ifoldMap f (V as) = ifoldMap f as {-# INLINE ifoldMap #-} @@ -267,10 +234,16 @@ traverse f (V as) = V <$> traverse f as {-# INLINE traverse #-} -instance TraversableWithIndex Int (V n) where +instance WithIndex.TraversableWithIndex Int (V n) where itraverse f (V as) = V <$> itraverse f as {-# INLINE itraverse #-} +#if !MIN_VERSION_lens(5,0,0) +instance Lens.FunctorWithIndex Int (V n) where imap = WithIndex.imap +instance Lens.FoldableWithIndex Int (V n) where ifoldMap = WithIndex.ifoldMap +instance Lens.TraversableWithIndex Int (V n) where itraverse = WithIndex.itraverse +#endif + instance Apply (V n) where V as <.> V bs = V (V.zipWith id as bs) {-# INLINE (<.>) #-} @@ -283,15 +256,17 @@ {-# INLINE (<*>) #-} instance Bind (V n) where - V as >>- f = V $ generate (V.length as) $ \i -> - toVector (f (as `unsafeIndex` i)) `unsafeIndex` i + V as >>- f = V $ V.generate (V.length as) $ \i -> + toVector (f (as `V.unsafeIndex` i)) `V.unsafeIndex` i {-# INLINE (>>-) #-} instance Dim n => Monad (V n) where +#if !(MIN_VERSION_base(4,11,0)) return = V . V.replicate (reflectDim (Proxy :: Proxy n)) {-# INLINE return #-} - V as >>= f = V $ generate (reflectDim (Proxy :: Proxy n)) $ \i -> - toVector (f (as `unsafeIndex` i)) `unsafeIndex` i +#endif + V as >>= f = V $ V.generate (reflectDim (Proxy :: Proxy n)) $ \i -> + toVector (f (as `V.unsafeIndex` i)) `V.unsafeIndex` i {-# INLINE (>>=) #-} instance Dim n => Additive (V n) where @@ -365,7 +340,7 @@ {-# INLINE acosh #-} instance Dim n => Distributive (V n) where - distribute f = V $ V.generate (reflectDim (Proxy :: Proxy n)) $ \i -> fmap (\(V v) -> unsafeIndex v i) f + distribute f = V $ V.generate (reflectDim (Proxy :: Proxy n)) $ \i -> fmap (\(V v) -> V.unsafeIndex v i) f {-# INLINE distribute #-} instance Hashable a => Hashable (V n a) where @@ -373,13 +348,11 @@ V.foldl' (\s a -> s `hashWithSalt` a) s0 v `hashWithSalt` V.length v -#if (MIN_VERSION_hashable(1,2,5)) instance Dim n => Hashable1 (V n) where liftHashWithSalt h s0 (V v) = V.foldl' (\s a -> h s a) s0 v `hashWithSalt` V.length v {-# INLINE liftHashWithSalt #-} -#endif instance (Dim n, Storable a) => Storable (V n a) where sizeOf _ = reflectDim (Proxy :: Proxy n) * sizeOf (undefined:: a) @@ -387,10 +360,10 @@ alignment _ = alignment (undefined :: a) {-# INLINE alignment #-} poke ptr (V xs) = Foldable.forM_ [0..reflectDim (Proxy :: Proxy n)-1] $ \i -> - pokeElemOff ptr' i (unsafeIndex xs i) + pokeElemOff ptr' i (V.unsafeIndex xs i) where ptr' = castPtr ptr {-# INLINE poke #-} - peek ptr = V <$> generateM (reflectDim (Proxy :: Proxy n)) (peekElemOff ptr') + peek ptr = V <$> V.generateM (reflectDim (Proxy :: Proxy n)) (peekElemOff ptr') where ptr' = castPtr ptr {-# INLINE peek #-} @@ -458,7 +431,7 @@ instance Dim n => Representable (V n) where type Rep (V n) = Int - tabulate = V . generate (reflectDim (Proxy :: Proxy n)) + tabulate = V . V.generate (reflectDim (Proxy :: Proxy n)) {-# INLINE tabulate #-} index (V xs) i = xs V.! i {-# INLINE index #-} @@ -497,15 +470,11 @@ vDataType = mkDataType "Linear.V.V" [vConstr] {-# NOINLINE vDataType #-} -#if __GLASGOW_HASKELL__ >= 708 -#define Typeable1 Typeable -#endif - -instance (Typeable1 (V n), Typeable (V n a), Dim n, Data a) => Data (V n a) where - gfoldl f z (V as) = z (V . fromList) `f` V.toList as +instance (Typeable (V n), Typeable (V n a), Dim n, Data a) => Data (V n a) where + gfoldl f z (V as) = z (V . V.fromList) `f` V.toList as toConstr _ = vConstr gunfold k z c = case constrIndex c of - 1 -> k (z (V . fromList)) + 1 -> k (z (V . V.fromList)) _ -> error "gunfold" dataTypeOf _ = vDataType dataCast1 f = gcast1 f @@ -526,7 +495,6 @@ put = serializeWith Cereal.put get = deserializeWith Cereal.get -#if (MIN_VERSION_transformers(0,5,0)) || !(MIN_VERSION_transformers(0,4,0)) instance Eq1 (V n) where liftEq f0 (V as0) (V bs0) = go f0 (V.toList as0) (V.toList bs0) where go _ [] [] = True @@ -550,14 +518,7 @@ , (as, r2) <- g r1 , P.length as == reflectDim (Proxy :: Proxy n) ] -#else -instance Dim n => Eq1 (V n) where eq1 = (==) -instance Dim n => Ord1 (V n) where compare1 = compare -instance Dim n => Show1 (V n) where showsPrec1 = showsPrec -instance Dim n => Read1 (V n) where readsPrec1 = readsPrec -#endif - data instance U.Vector (V n a) = V_VN {-# UNPACK #-} !Int !(U.Vector a) data instance U.MVector s (V n a) = MV_VN {-# UNPACK #-} !Int !(U.MVector s a) instance (Dim n, U.Unbox a) => U.Unbox (V n a) @@ -583,14 +544,16 @@ go v vn d o j | j >= d = return () | otherwise = do - a <- G.basicUnsafeIndexM vn j + a <- liftBox $ G.basicUnsafeIndexM vn j M.basicUnsafeWrite v o a go v vn d (o+1) (j+1) -#if MIN_VERSION_vector(0,11,0) basicInitialize (MV_VN _ v) = M.basicInitialize v {-# INLINE basicInitialize #-} -#endif +liftBox :: Monad m => Box a -> m a +liftBox (Box a) = return a +{-# INLINE liftBox #-} + instance (Dim n, U.Unbox a) => G.Vector U.Vector (V n a) where {-# INLINE basicUnsafeFreeze #-} {-# INLINE basicUnsafeThaw #-} @@ -610,7 +573,6 @@ vLens i = \f (V v) -> f (v V.! i) <&> \a -> V (v V.// [(i, a)]) {-# INLINE vLens #-} -#ifdef USE_TYPE_LITS instance ( 1 <= n) => Field1 (V n a) (V n a) a a where _1 = vLens 0 instance ( 2 <= n) => Field2 (V n a) (V n a) a a where _2 = vLens 1 instance ( 3 <= n) => Field3 (V n a) (V n a) a a where _3 = vLens 2 @@ -630,4 +592,3 @@ instance (17 <= n) => Field17 (V n a) (V n a) a a where _17 = vLens 16 instance (18 <= n) => Field18 (V n a) (V n a) a a where _18 = vLens 17 instance (19 <= n) => Field19 (V n a) (V n a) a a where _19 = vLens 18 -#endif diff --git a/src/Linear/V0.hs b/src/Linear/V0.hs --- a/src/Linear/V0.hs +++ b/src/Linear/V0.hs @@ -4,33 +4,11 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} - -#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE Trustworthy #-} -#endif - -#if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DataKinds #-} -#endif - -#if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE DeriveLift #-} -#endif -#ifndef MIN_VERSION_hashable -#define MIN_VERSION_hashable(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_vector -#define MIN_VERSION_vector(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_transformers -#define MIN_VERSION_transformers(x,y,z) 1 -#endif - - ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2012-2015 Edward Kmett @@ -48,7 +26,7 @@ import Control.Applicative import Control.DeepSeq (NFData(rnf)) -import Control.Lens +import Control.Lens as Lens import Control.Monad.Fix import Control.Monad.Zip import Data.Binary -- binary @@ -56,29 +34,23 @@ import Data.Data import Data.Distributive import Data.Foldable +import qualified Data.Foldable.WithIndex as WithIndex import Data.Functor.Bind import Data.Functor.Classes import Data.Functor.Rep +import qualified Data.Functor.WithIndex as WithIndex import Data.Hashable -#if (MIN_VERSION_hashable(1,2,5)) import Data.Hashable.Lifted -#endif import Data.Ix #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup #endif import Data.Serialize -- cereal -#if __GLASGOW_HASKELL__ >= 707 +import qualified Data.Traversable.WithIndex as WithIndex import qualified Data.Vector as V -#endif import Foreign.Storable (Storable(..)) -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 -import GHC.Generics (Generic) -#endif -#if __GLASGOW_HASKELL__ >= 706 -import GHC.Generics (Generic1) -#endif -#if __GLASGOW_HASKELL__ >= 800 +import GHC.Generics (Generic, Generic1) +#if defined(MIN_VERSION_template_haskell) import Language.Haskell.TH.Syntax (Lift) #endif import qualified Data.Vector.Generic.Mutable as M @@ -87,13 +59,16 @@ import Linear.Metric import Linear.Epsilon import Linear.Vector -#if __GLASGOW_HASKELL__ >= 707 import Linear.V -#endif +import System.Random (Random(..), Uniform) +import System.Random.Stateful (UniformRange(..)) import Prelude hiding (sum) -- $setup +-- >>> import Control.Applicative -- >>> import Control.Lens +-- >>> import qualified Data.Foldable as F +-- >>> let sum xs = F.sum xs -- | A 0-dimensional vector -- @@ -103,25 +78,29 @@ -- >>> V0 + V0 -- V0 -- -data V0 a = V0 deriving (Eq,Ord,Show,Read,Ix,Enum,Data,Typeable -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 - ,Generic -#endif -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 - ,Generic1 -#endif -#if __GLASGOW_HASKELL__ >= 800 +data V0 a = V0 deriving (Eq,Ord,Show,Read,Ix,Enum,Data + ,Generic,Generic1 +#if defined(MIN_VERSION_template_haskell) ,Lift #endif ) -#if __GLASGOW_HASKELL__ >= 707 instance Finite V0 where type Size V0 = 0 toV _ = V V.empty fromV _ = V0 -#endif +instance Random (V0 a) where + random g = (V0, g) + randomR _ g = (V0, g) + randomRs _ _ = repeat V0 + randoms _ = repeat V0 + +instance Uniform (V0 a) where + +instance UniformRange (V0 a) where + uniformRM (_, _) _ = pure V0 + instance Serial1 V0 where serializeWith _ = serialize deserializeWith _ = deserialize @@ -147,10 +126,8 @@ instance Foldable V0 where foldMap _ V0 = mempty {-# INLINE foldMap #-} -#if __GLASGOW_HASKELL__ >= 710 null _ = True length _ = 0 -#endif instance Traversable V0 where traverse _ V0 = pure V0 @@ -166,6 +143,15 @@ V0 <*> V0 = V0 {-# INLINE (<*>) #-} +instance Semigroup (V0 a) where + _ <> _ = V0 + +instance Monoid (V0 a) where + mempty = V0 +#if !(MIN_VERSION_base(4,11,0)) + mappend _ _ = V0 +#endif + instance Additive V0 where zero = V0 {-# INLINE zero #-} @@ -179,8 +165,10 @@ {-# INLINE (>>-) #-} instance Monad V0 where +#if !(MIN_VERSION_base(4,11,0)) return _ = V0 {-# INLINE return #-} +#endif V0 >>= _ = V0 {-# INLINE (>>=) #-} @@ -255,18 +243,14 @@ {-# INLINE distribute #-} instance Hashable (V0 a) where -#if (MIN_VERSION_hashable(1,2,1)) || !(MIN_VERSION_hashable(1,2,0)) hash V0 = 0 {-# INLINE hash #-} -#endif hashWithSalt s V0 = s {-# INLINE hashWithSalt #-} -#if (MIN_VERSION_hashable(1,2,5)) instance Hashable1 V0 where liftHashWithSalt _ s V0 = s {-# INLINE liftHashWithSalt #-} -#endif instance Epsilon (V0 a) where nearZero _ = True @@ -282,18 +266,24 @@ peek _ = return V0 {-# INLINE peek #-} -instance FunctorWithIndex (E V0) V0 where +instance WithIndex.FunctorWithIndex (E V0) V0 where imap _ V0 = V0 {-# INLINE imap #-} -instance FoldableWithIndex (E V0) V0 where +instance WithIndex.FoldableWithIndex (E V0) V0 where ifoldMap _ V0 = mempty {-# INLINE ifoldMap #-} -instance TraversableWithIndex (E V0) V0 where +instance WithIndex.TraversableWithIndex (E V0) V0 where itraverse _ V0 = pure V0 {-# INLINE itraverse #-} +#if !MIN_VERSION_lens(5,0,0) +instance Lens.FunctorWithIndex (E V0) V0 where imap = WithIndex.imap +instance Lens.FoldableWithIndex (E V0) V0 where ifoldMap = WithIndex.ifoldMap +instance Lens.TraversableWithIndex (E V0) V0 where itraverse = WithIndex.itraverse +#endif + instance Representable V0 where type Rep V0 = E V0 tabulate _ = V0 @@ -305,7 +295,7 @@ type instance IxValue (V0 a) = a instance Ixed (V0 a) where - ix = el + ix i = el i {-# INLINE ix #-} instance Each (V0 a) (V0 b) a b where @@ -329,10 +319,8 @@ basicUnsafeNew n = return (MV_V0 n) basicUnsafeRead _ _ = return V0 basicUnsafeWrite _ _ _ = return () -#if MIN_VERSION_vector(0,11,0) basicInitialize _ = return () {-# INLINE basicInitialize #-} -#endif instance G.Vector U.Vector (V0 a) where {-# INLINE basicUnsafeFreeze #-} @@ -363,7 +351,6 @@ instance NFData (V0 a) where rnf V0 = () -#if (MIN_VERSION_transformers(0,5,0)) || !(MIN_VERSION_transformers(0,4,0)) instance Eq1 V0 where liftEq _ _ _ = True instance Ord1 V0 where @@ -372,9 +359,3 @@ liftShowsPrec _ _ = showsPrec instance Read1 V0 where liftReadsPrec _ _ = readsPrec -#else -instance Eq1 V0 where eq1 = (==) -instance Ord1 V0 where compare1 = compare -instance Show1 V0 where showsPrec1 = showsPrec -instance Read1 V0 where readsPrec1 = readsPrec -#endif diff --git a/src/Linear/V1.hs b/src/Linear/V1.hs --- a/src/Linear/V1.hs +++ b/src/Linear/V1.hs @@ -8,30 +8,11 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ScopedTypeVariables #-} -#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} {-# LANGUAGE DeriveGeneric #-} -#endif -#if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DataKinds #-} -#endif - -#if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE DeriveLift #-} -#endif -#ifndef MIN_VERSION_hashable -#define MIN_VERSION_hashable(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_vector -#define MIN_VERSION_vector(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_transformers -#define MIN_VERSION_transformers(x,y,z) 1 -#endif - ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2012-2015 Edward Kmett @@ -54,52 +35,49 @@ import Control.Monad (liftM) import Control.Monad.Fix import Control.Monad.Zip -import Control.Lens +import Control.Lens as Lens import Data.Binary as Binary import Data.Bytes.Serial import Data.Serialize as Cereal import Data.Data import Data.Distributive import Data.Foldable +import qualified Data.Foldable.WithIndex as WithIndex import Data.Functor.Bind import Data.Functor.Classes import Data.Functor.Rep +import qualified Data.Functor.WithIndex as WithIndex import Data.Hashable -#if (MIN_VERSION_hashable(1,2,5)) import Data.Hashable.Lifted -#endif import Data.Semigroup.Foldable -#if __GLASGOW_HASKELL__ >= 707 +import qualified Data.Traversable.WithIndex as WithIndex import qualified Data.Vector as V import Linear.V -#endif import Foreign.Storable (Storable) import GHC.Arr (Ix(..)) -#if __GLASGOW_HASKELL__ >= 702 -import GHC.Generics (Generic) -#endif -#if __GLASGOW_HASKELL__ >= 706 -import GHC.Generics (Generic1) -#endif -#if __GLASGOW_HASKELL__ >= 800 +import GHC.Generics (Generic, Generic1) +#if defined(MIN_VERSION_template_haskell) import Language.Haskell.TH.Syntax (Lift) #endif import Linear.Metric import Linear.Epsilon import Linear.Vector import Prelude hiding (sum) +import System.Random (Random(..), Uniform) +import System.Random.Stateful (UniformRange(..)) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup +#endif import qualified Data.Vector.Generic.Mutable as M import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed.Base as U -#ifdef HLINT --- HLint is delusional -{-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-} -#endif - -- $setup +-- >>> import Control.Applicative -- >>> import Control.Lens +-- >>> import qualified Data.Foldable as F +-- >>> let sum xs = F.sum xs -- | A 1-dimensional vector -- @@ -115,35 +93,29 @@ -- >>> sum (V1 2) -- 2 ---data V2 a = V2 !a !a deriving (Eq,Ord,Show,Read,Data,Typeable) +--data V2 a = V2 !a !a deriving (Eq,Ord,Show,Read,Data) newtype V1 a = V1 a - deriving (Eq,Ord,Show,Read,Data,Typeable, + deriving (Eq,Ord,Show,Read,Data, Functor,Traversable, Epsilon,Storable,NFData -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 - ,Generic -#endif -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 - ,Generic1 -#endif -#if __GLASGOW_HASKELL__ >= 800 + ,Generic,Generic1 +#if defined(MIN_VERSION_template_haskell) ,Lift #endif ) instance Foldable V1 where foldMap f (V1 a) = f a -#if __GLASGOW_HASKELL__ >= 710 +#if MIN_VERSION_base(4,13,0) + foldMap' f (V1 a) = f a +#endif null _ = False length _ = 1 -#endif -#if __GLASGOW_HASKELL__ >= 707 instance Finite V1 where type Size V1 = 1 toV (V1 a) = V (V.singleton a) fromV (V v) = V1 (v V.! 0) -#endif instance Foldable1 V1 where foldMap1 f (V1 a) = f a @@ -176,8 +148,10 @@ {-# INLINE (>>-) #-} instance Monad V1 where +#if !(MIN_VERSION_base(4,11,0)) return = V1 {-# INLINE return #-} +#endif V1 a >>= f = f a {-# INLINE (>>=) #-} @@ -244,16 +218,12 @@ {-# INLINE acosh #-} instance Hashable a => Hashable (V1 a) where -#if (MIN_VERSION_hashable(1,2,1)) || !(MIN_VERSION_hashable(1,2,0)) hash (V1 a) = hash a -#endif hashWithSalt s (V1 a) = s `hashWithSalt` a -#if (MIN_VERSION_hashable(1,2,5)) instance Hashable1 V1 where liftHashWithSalt h s (V1 a) = h s a {-# INLINE liftHashWithSalt #-} -#endif instance Metric V1 where dot (V1 a) (V1 b) = a * b @@ -305,23 +275,29 @@ index xs (E l) = view l xs {-# INLINE index #-} -instance FunctorWithIndex (E V1) V1 where +instance WithIndex.FunctorWithIndex (E V1) V1 where imap f (V1 a) = V1 (f ex a) {-# INLINE imap #-} -instance FoldableWithIndex (E V1) V1 where +instance WithIndex.FoldableWithIndex (E V1) V1 where ifoldMap f (V1 a) = f ex a {-# INLINE ifoldMap #-} -instance TraversableWithIndex (E V1) V1 where +instance WithIndex.TraversableWithIndex (E V1) V1 where itraverse f (V1 a) = V1 <$> f ex a {-# INLINE itraverse #-} +#if !MIN_VERSION_lens(5,0,0) +instance Lens.FunctorWithIndex (E V1) V1 where imap = WithIndex.imap +instance Lens.FoldableWithIndex (E V1) V1 where ifoldMap = WithIndex.ifoldMap +instance Lens.TraversableWithIndex (E V1) V1 where itraverse = WithIndex.itraverse +#endif + type instance Index (V1 a) = E V1 type instance IxValue (V1 a) = a instance Ixed (V1 a) where - ix = el + ix i = el i {-# INLINE ix #-} instance Each (V1 a) (V1 b) a b where @@ -345,10 +321,8 @@ basicUnsafeNew n = liftM MV_V1 (M.basicUnsafeNew n) basicUnsafeRead (MV_V1 v) i = liftM V1 (M.basicUnsafeRead v i) basicUnsafeWrite (MV_V1 v) i (V1 x) = M.basicUnsafeWrite v i x -#if MIN_VERSION_vector(0,11,0) basicInitialize (MV_V1 v) = M.basicInitialize v {-# INLINE basicInitialize #-} -#endif instance U.Unbox a => G.Vector U.Vector (V1 a) where {-# INLINE basicUnsafeFreeze #-} @@ -392,7 +366,17 @@ put = serializeWith Cereal.put get = deserializeWith Cereal.get -#if (MIN_VERSION_transformers(0,5,0)) || !(MIN_VERSION_transformers(0,4,0)) +instance Random a => Random (V1 a) where + random g = case random g of (a, g') -> (V1 a, g') + randoms g = V1 <$> randoms g + randomR (V1 a, V1 b) g = case randomR (a, b) g of (a', g') -> (V1 a', g') + randomRs (V1 a, V1 b) g = V1 <$> randomRs (a, b) g + +instance Uniform a => Uniform (V1 a) where + +instance UniformRange a => UniformRange (V1 a) where + uniformRM (V1 a, V1 b) g = V1 <$> uniformRM (a, b) g + instance Eq1 V1 where liftEq f (V1 a) (V1 b) = f a b instance Ord1 V1 where @@ -401,12 +385,16 @@ liftShowsPrec f _ d (V1 a) = showParen (d >= 10) $ showString "V1 " . f d a instance Read1 V1 where liftReadsPrec f _ = readsData $ readsUnaryWith f "V1" V1 -#else -instance Eq1 V1 where eq1 = (==) -instance Ord1 V1 where compare1 = compare -instance Show1 V1 where showsPrec1 = showsPrec -instance Read1 V1 where readsPrec1 = readsPrec -#endif instance Field1 (V1 a) (V1 b) a b where _1 f (V1 x) = V1 <$> f x + +instance Semigroup a => Semigroup (V1 a) where + (<>) = liftA2 (<>) + +instance Monoid a => Monoid (V1 a) where + mempty = pure mempty +#if !(MIN_VERSION_base(4,11,0)) + mappend = liftA2 mappend +#endif + diff --git a/src/Linear/V2.hs b/src/Linear/V2.hs --- a/src/Linear/V2.hs +++ b/src/Linear/V2.hs @@ -5,31 +5,11 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} {-# LANGUAGE DeriveGeneric #-} -#endif -#if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DataKinds #-} -#endif - -#if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE DeriveLift #-} -#endif -#ifndef MIN_VERSION_hashable -#define MIN_VERSION_hashable(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_vector -#define MIN_VERSION_vector(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_transformers -#define MIN_VERSION_transformers(x,y,z) 1 -#endif - - ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2012-2015 Edward Kmett @@ -49,6 +29,7 @@ , ex, ey , perp , angle + , unangle , crossZ ) where @@ -57,35 +38,29 @@ import Control.Monad (liftM) import Control.Monad.Fix import Control.Monad.Zip -import Control.Lens hiding ((<.>)) +import Control.Lens as Lens hiding ((<.>)) import Data.Binary as Binary import Data.Bytes.Serial import Data.Data import Data.Distributive import Data.Foldable +import qualified Data.Foldable.WithIndex as WithIndex import Data.Functor.Bind import Data.Functor.Classes import Data.Functor.Rep +import qualified Data.Functor.WithIndex as WithIndex import Data.Hashable -#if (MIN_VERSION_hashable(1,2,5)) import Data.Hashable.Lifted -#endif import Data.Semigroup import Data.Semigroup.Foldable import Data.Serialize as Cereal -#if __GLASGOW_HASKELL__ >= 707 +import qualified Data.Traversable.WithIndex as WithIndex import qualified Data.Vector as V -#endif import Foreign.Ptr (castPtr) import Foreign.Storable (Storable(..)) import GHC.Arr (Ix(..)) -#if __GLASGOW_HASKELL__ >= 702 -import GHC.Generics (Generic) -#endif -#if __GLASGOW_HASKELL__ >= 706 -import GHC.Generics (Generic1) -#endif -#if __GLASGOW_HASKELL__ >= 800 +import GHC.Generics (Generic, Generic1) +#if defined(MIN_VERSION_template_haskell) import Language.Haskell.TH.Syntax (Lift) #endif import qualified Data.Vector.Generic.Mutable as M @@ -93,15 +68,18 @@ import qualified Data.Vector.Unboxed.Base as U import Linear.Metric import Linear.Epsilon -#if __GLASGOW_HASKELL__ >= 707 import Linear.V -#endif import Linear.Vector import Linear.V1 (R1(..),ex) import Prelude hiding (sum) +import System.Random (Random(..), Uniform) +import System.Random.Stateful (UniformRange(..)) -- $setup +-- >>> import Control.Applicative -- >>> import Control.Lens +-- >>> import qualified Data.Foldable as F +-- >>> let sum xs = F.sum xs -- | A 2-dimensional vector -- @@ -118,25 +96,33 @@ -- 3 data V2 a = V2 !a !a deriving - (Eq,Ord,Show,Read,Data,Typeable -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 - ,Generic -#endif -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 - ,Generic1 -#endif -#if __GLASGOW_HASKELL__ >= 800 + (Eq,Ord,Show,Read,Data + ,Generic,Generic1 +#if defined(MIN_VERSION_template_haskell) ,Lift #endif ) -#if __GLASGOW_HASKELL__ >= 707 instance Finite V2 where type Size V2 = 2 toV (V2 a b) = V (V.fromListN 2 [a,b]) fromV (V v) = V2 (v V.! 0) (v V.! 1) -#endif +instance Random a => Random (V2 a) where + random g = case random g of + (a, g') -> case random g' of + (b, g'') -> (V2 a b, g'') + {-# inline random #-} + randomR (V2 a b, V2 c d) g = case randomR (a, c) g of + (x, g') -> case randomR (b, d) g' of + (y, g'') -> (V2 x y, g'') + {-# inline randomR #-} + +instance Uniform a => Uniform (V2 a) where + +instance UniformRange a => UniformRange (V2 a) where + uniformRM (V2 a b, V2 c d) g = V2 <$> uniformRM (a, c) g <*> uniformRM (b, d) g + instance Functor V2 where fmap f (V2 a b) = V2 (f a) (f b) {-# INLINE fmap #-} @@ -146,10 +132,12 @@ instance Foldable V2 where foldMap f (V2 a b) = f a `mappend` f b {-# INLINE foldMap #-} -#if __GLASGOW_HASKELL__ >= 710 +#if MIN_VERSION_base(4,13,0) + foldMap' f (V2 a b) = f a `mappend` f b + {-# INLINE foldMap' #-} +#endif null _ = False length _ = 2 -#endif instance Traversable V2 where traverse f (V2 a b) = V2 <$> f a <*> f b @@ -177,11 +165,9 @@ hashWithSalt s (V2 a b) = s `hashWithSalt` a `hashWithSalt` b {-# INLINE hashWithSalt #-} -#if (MIN_VERSION_hashable(1,2,5)) instance Hashable1 V2 where liftHashWithSalt h s (V2 a b) = s `h` a `h` b {-# INLINE liftHashWithSalt #-} -#endif instance Additive V2 where zero = pure 0 @@ -198,8 +184,10 @@ {-# INLINE (>>-) #-} instance Monad V2 where +#if !(MIN_VERSION_base(4,11,0)) return a = V2 a a {-# INLINE return #-} +#endif V2 a b >>= f = V2 a' b' where V2 a' _ = f a V2 _ b' = f b @@ -356,23 +344,29 @@ index xs (E l) = view l xs {-# INLINE index #-} -instance FunctorWithIndex (E V2) V2 where +instance WithIndex.FunctorWithIndex (E V2) V2 where imap f (V2 a b) = V2 (f ex a) (f ey b) {-# INLINE imap #-} -instance FoldableWithIndex (E V2) V2 where +instance WithIndex.FoldableWithIndex (E V2) V2 where ifoldMap f (V2 a b) = f ex a `mappend` f ey b {-# INLINE ifoldMap #-} -instance TraversableWithIndex (E V2) V2 where +instance WithIndex.TraversableWithIndex (E V2) V2 where itraverse f (V2 a b) = V2 <$> f ex a <*> f ey b {-# INLINE itraverse #-} +#if !MIN_VERSION_lens(5,0,0) +instance Lens.FunctorWithIndex (E V2) V2 where imap = WithIndex.imap +instance Lens.FoldableWithIndex (E V2) V2 where ifoldMap = WithIndex.ifoldMap +instance Lens.TraversableWithIndex (E V2) V2 where itraverse = WithIndex.itraverse +#endif + type instance Index (V2 a) = E V2 type instance IxValue (V2 a) = a instance Ixed (V2 a) where - ix = el + ix i = el i {-# INLINE ix #-} instance Each (V2 a) (V2 b) a b where @@ -403,10 +397,8 @@ do let o = 2*i M.basicUnsafeWrite v o x M.basicUnsafeWrite v (o+1) y -#if MIN_VERSION_vector(0,11,0) basicInitialize (MV_V2 _ v) = M.basicInitialize v {-# INLINE basicInitialize #-} -#endif instance U.Unbox a => G.Vector U.Vector (V2 a) where {-# INLINE basicUnsafeFreeze #-} @@ -434,6 +426,13 @@ angle :: Floating a => a -> V2 a angle a = V2 (cos a) (sin a) +unangle :: (Floating a, Ord a) => V2 a -> a +unangle a@(V2 ax ay) = + let alpha = asin $ ay / norm a + in if ax < 0 + then pi - alpha + else alpha + -- | The Z-component of the cross product of two vectors in the XY-plane. -- -- >>> crossZ (V2 1 0) (V2 0 1) @@ -467,7 +466,6 @@ put = serializeWith Cereal.put get = deserializeWith Cereal.get -#if (MIN_VERSION_transformers(0,5,0)) || !(MIN_VERSION_transformers(0,4,0)) instance Eq1 V2 where liftEq f (V2 a b) (V2 c d) = f a c && f b d instance Ord1 V2 where @@ -476,15 +474,18 @@ liftReadsPrec f _ = readsData $ readsBinaryWith f f "V2" V2 instance Show1 V2 where liftShowsPrec f _ d (V2 a b) = showsBinaryWith f f "V2" d a b -#else -instance Eq1 V2 where eq1 = (==) -instance Ord1 V2 where compare1 = compare -instance Show1 V2 where showsPrec1 = showsPrec -instance Read1 V2 where readsPrec1 = readsPrec -#endif instance Field1 (V2 a) (V2 a) a a where _1 f (V2 x y) = f x <&> \x' -> V2 x' y instance Field2 (V2 a) (V2 a) a a where _2 f (V2 x y) = f y <&> \y' -> V2 x y' + +instance Semigroup a => Semigroup (V2 a) where + (<>) = liftA2 (<>) + +instance Monoid a => Monoid (V2 a) where + mempty = pure mempty +#if !(MIN_VERSION_base(4,11,0)) + mappend = liftA2 mappend +#endif diff --git a/src/Linear/V3.hs b/src/Linear/V3.hs --- a/src/Linear/V3.hs +++ b/src/Linear/V3.hs @@ -5,30 +5,11 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} {-# LANGUAGE DeriveGeneric #-} -#endif -#if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DataKinds #-} -#endif - -#if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE DeriveLift #-} -#endif -#ifndef MIN_VERSION_hashable -#define MIN_VERSION_hashable(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_vector -#define MIN_VERSION_vector(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_transformers -#define MIN_VERSION_transformers(x,y,z) 1 -#endif - ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2012-2015 Edward Kmett @@ -52,76 +33,66 @@ , ex, ey, ez ) where +#if !MIN_VERSION_base(4,18,0) import Control.Applicative +#endif import Control.DeepSeq (NFData(rnf)) import Control.Monad (liftM) import Control.Monad.Fix import Control.Monad.Zip -import Control.Lens hiding ((<.>)) +import Control.Lens as Lens hiding ((<.>)) import Data.Binary as Binary -- binary import Data.Bytes.Serial -- bytes import Data.Data import Data.Distributive import Data.Foldable +import qualified Data.Foldable.WithIndex as WithIndex import Data.Functor.Bind import Data.Functor.Classes import Data.Functor.Rep +import qualified Data.Functor.WithIndex as WithIndex import Data.Hashable -#if (MIN_VERSION_hashable(1,2,5)) import Data.Hashable.Lifted -#endif #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup #endif import Data.Semigroup.Foldable import Data.Serialize as Cereal -- cereal -#if __GLASGOW_HASKELL__ >= 707 +import qualified Data.Traversable.WithIndex as WithIndex import qualified Data.Vector as V -#endif import qualified Data.Vector.Generic.Mutable as M import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed.Base as U import Foreign.Ptr (castPtr) import Foreign.Storable (Storable(..)) import GHC.Arr (Ix(..)) -#if __GLASGOW_HASKELL__ >= 702 -import GHC.Generics (Generic) -#endif -#if __GLASGOW_HASKELL__ >= 706 -import GHC.Generics (Generic1) -#endif -#if __GLASGOW_HASKELL__ >= 800 +import GHC.Generics (Generic, Generic1) +#if defined(MIN_VERSION_template_haskell) import Language.Haskell.TH.Syntax (Lift) #endif import Linear.Epsilon import Linear.Metric -#if __GLASGOW_HASKELL__ >= 707 import Linear.V -#endif import Linear.V2 import Linear.Vector +import System.Random (Random(..), Uniform) +import System.Random.Stateful (UniformRange(..)) -{-# ANN module "HLint: ignore Reduce duplication" #-} +-- $setup +-- >>> import Control.Lens hiding (index) -- | A 3-dimensional vector -data V3 a = V3 !a !a !a deriving (Eq,Ord,Show,Read,Data,Typeable -#if __GLASGOW_HASKELL__ >= 702 - ,Generic -#endif -#if __GLASGOW_HASKELL__ >= 706 - ,Generic1 -#endif -#if __GLASGOW_HASKELL__ >= 800 +data V3 a = V3 !a !a !a deriving (Eq,Ord,Show,Read,Data + ,Generic,Generic1 +#if defined(MIN_VERSION_template_haskell) ,Lift #endif ) -#if __GLASGOW_HASKELL__ >= 707 instance Finite V3 where type Size V3 = 3 toV (V3 a b c) = V (V.fromListN 3 [a,b,c]) fromV (V v) = V3 (v V.! 0) (v V.! 1) (v V.! 2) -#endif instance Functor V3 where fmap f (V3 a b c) = V3 (f a) (f b) (f c) @@ -132,11 +103,31 @@ instance Foldable V3 where foldMap f (V3 a b c) = f a `mappend` f b `mappend` f c {-# INLINE foldMap #-} -#if __GLASGOW_HASKELL__ >= 710 +#if MIN_VERSION_base(4,13,0) + foldMap' f (V3 a b c) = (f a `mappend` f b) `mappend` f c + {-# INLINE foldMap' #-} +#endif null _ = False length _ = 3 -#endif +instance Random a => Random (V3 a) where + random g = case random g of + (a, g') -> case random g' of + (b, g'') -> case random g'' of + (c, g''') -> (V3 a b c, g''') + randomR (V3 a b c, V3 a' b' c') g = case randomR (a,a') g of + (a'', g') -> case randomR (b,b') g' of + (b'', g'') -> case randomR (c,c') g'' of + (c'', g''') -> (V3 a'' b'' c'', g''') + +instance Uniform a => Uniform (V3 a) where + +instance UniformRange a => UniformRange (V3 a) where + uniformRM (V3 a b c, V3 a' b' c') g = V3 + <$> uniformRM (a, a') g + <*> uniformRM (b, b') g + <*> uniformRM (c, c') g + instance Traversable V3 where traverse f (V3 a b c) = V3 <$> f a <*> f b <*> f c {-# INLINE traverse #-} @@ -175,8 +166,10 @@ {-# INLINE (>>-) #-} instance Monad V3 where +#if !(MIN_VERSION_base(4,11,0)) return a = V3 a a a {-# INLINE return #-} +#endif V3 a b c >>= f = V3 a' b' c' where V3 a' _ _ = f a V3 _ b' _ = f b @@ -249,11 +242,9 @@ hashWithSalt s (V3 a b c) = s `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c {-# INLINE hashWithSalt #-} -#if (MIN_VERSION_hashable(1,2,5)) instance Hashable1 V3 where liftHashWithSalt h s (V3 a b c) = s `h` a `h` b `h` c {-# INLINE liftHashWithSalt #-} -#endif instance Metric V3 where dot (V3 a b c) (V3 d e f) = a * d + b * e + c * f @@ -378,23 +369,29 @@ index xs (E l) = view l xs {-# INLINE index #-} -instance FunctorWithIndex (E V3) V3 where +instance WithIndex.FunctorWithIndex (E V3) V3 where imap f (V3 a b c) = V3 (f ex a) (f ey b) (f ez c) {-# INLINE imap #-} -instance FoldableWithIndex (E V3) V3 where +instance WithIndex.FoldableWithIndex (E V3) V3 where ifoldMap f (V3 a b c) = f ex a `mappend` f ey b `mappend` f ez c {-# INLINE ifoldMap #-} -instance TraversableWithIndex (E V3) V3 where +instance WithIndex.TraversableWithIndex (E V3) V3 where itraverse f (V3 a b c) = V3 <$> f ex a <*> f ey b <*> f ez c {-# INLINE itraverse #-} +#if !MIN_VERSION_lens(5,0,0) +instance Lens.FunctorWithIndex (E V3) V3 where imap = WithIndex.imap +instance Lens.FoldableWithIndex (E V3) V3 where ifoldMap = WithIndex.ifoldMap +instance Lens.TraversableWithIndex (E V3) V3 where itraverse = WithIndex.itraverse +#endif + type instance Index (V3 a) = E V3 type instance IxValue (V3 a) = a instance Ixed (V3 a) where - ix = el + ix i = el i {-# INLINE ix #-} instance Each (V3 a) (V3 b) a b where @@ -427,10 +424,8 @@ M.basicUnsafeWrite v o x M.basicUnsafeWrite v (o+1) y M.basicUnsafeWrite v (o+2) z -#if MIN_VERSION_vector(0,11,0) basicInitialize (MV_V3 _ v) = M.basicInitialize v {-# INLINE basicInitialize #-} -#endif instance U.Unbox a => G.Vector U.Vector (V3 a) where {-# INLINE basicUnsafeFreeze #-} @@ -482,7 +477,6 @@ put = serializeWith Cereal.put get = deserializeWith Cereal.get -#if (MIN_VERSION_transformers(0,5,0)) || !(MIN_VERSION_transformers(0,4,0)) instance Eq1 V3 where liftEq k (V3 a b c) (V3 d e f) = k a d && k b e && k c f instance Ord1 V3 where @@ -498,12 +492,6 @@ instance Show1 V3 where liftShowsPrec f _ d (V3 a b c) = showParen (d > 10) $ showString "V3 " . f 11 a . showChar ' ' . f 11 b . showChar ' ' . f 11 c -#else -instance Eq1 V3 where eq1 = (==) -instance Ord1 V3 where compare1 = compare -instance Show1 V3 where showsPrec1 = showsPrec -instance Read1 V3 where readsPrec1 = readsPrec -#endif instance Field1 (V3 a) (V3 a) a a where _1 f (V3 x y z) = f x <&> \x' -> V3 x' y z @@ -513,3 +501,13 @@ instance Field3 (V3 a) (V3 a) a a where _3 f (V3 x y z) = f z <&> \z' -> V3 x y z' + +instance Semigroup a => Semigroup (V3 a) where + (<>) = liftA2 (<>) + +instance Monoid a => Monoid (V3 a) where + mempty = pure mempty +#if !(MIN_VERSION_base(4,11,0)) + mappend = liftA2 mappend +#endif + diff --git a/src/Linear/V4.hs b/src/Linear/V4.hs --- a/src/Linear/V4.hs +++ b/src/Linear/V4.hs @@ -5,29 +5,11 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} {-# LANGUAGE DeriveGeneric #-} -#endif -#if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DataKinds #-} -#endif - -#if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE DeriveLift #-} -#endif -#ifndef MIN_VERSION_hashable -#define MIN_VERSION_hashable(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_vector -#define MIN_VERSION_vector(x,y,z) 1 -#endif - -#ifndef MIN_VERSION_transformers -#define MIN_VERSION_transformers(x,y,z) 1 -#endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2012-2015 Edward Kmett @@ -58,77 +40,67 @@ , ex, ey, ez, ew ) where +#if !MIN_VERSION_base(4,18,0) import Control.Applicative +#endif import Control.DeepSeq (NFData(rnf)) import Control.Monad (liftM) import Control.Monad.Fix import Control.Monad.Zip -import Control.Lens hiding ((<.>)) +import Control.Lens as Lens hiding ((<.>)) import Data.Binary as Binary import Data.Bytes.Serial import Data.Data import Data.Distributive import Data.Foldable +import qualified Data.Foldable.WithIndex as WithIndex import Data.Functor.Bind import Data.Functor.Classes import Data.Functor.Rep +import qualified Data.Functor.WithIndex as WithIndex import Data.Hashable -#if (MIN_VERSION_hashable(1,2,5)) import Data.Hashable.Lifted -#endif #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup #endif import Data.Semigroup.Foldable import Data.Serialize as Cereal -#if __GLASGOW_HASKELL__ >= 707 +import qualified Data.Traversable.WithIndex as WithIndex import qualified Data.Vector as V -#endif import qualified Data.Vector.Generic.Mutable as M import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed.Base as U import Foreign.Ptr (castPtr) import Foreign.Storable (Storable(..)) import GHC.Arr (Ix(..)) -#if __GLASGOW_HASKELL__ >= 702 -import GHC.Generics (Generic) -#endif -#if __GLASGOW_HASKELL__ >= 706 -import GHC.Generics (Generic1) -#endif -#if __GLASGOW_HASKELL__ >= 800 +import GHC.Generics (Generic, Generic1) +#if defined(MIN_VERSION_template_haskell) import Language.Haskell.TH.Syntax (Lift) #endif import Linear.Epsilon import Linear.Metric -#if __GLASGOW_HASKELL__ >= 707 import Linear.V -#endif import Linear.V2 import Linear.V3 import Linear.Vector +import System.Random (Random(..), Uniform) +import System.Random.Stateful (UniformRange(..)) -{-# ANN module "HLint: ignore Reduce duplication" #-} +-- $setup +-- >>> import Control.Lens hiding (index) -- | A 4-dimensional vector. -data V4 a = V4 !a !a !a !a deriving (Eq,Ord,Show,Read,Data,Typeable -#if __GLASGOW_HASKELL__ >= 702 - ,Generic -#endif -#if __GLASGOW_HASKELL__ >= 706 - ,Generic1 -#endif -#if __GLASGOW_HASKELL__ >= 800 +data V4 a = V4 !a !a !a !a deriving (Eq,Ord,Show,Read,Data + ,Generic,Generic1 +#if defined(MIN_VERSION_template_haskell) ,Lift #endif ) -#if __GLASGOW_HASKELL__ >= 707 instance Finite V4 where type Size V4 = 4 toV (V4 a b c d) = V (V.fromListN 4 [a,b,c,d]) fromV (V v) = V4 (v V.! 0) (v V.! 1) (v V.! 2) (v V.! 3) -#endif instance Functor V4 where fmap f (V4 a b c d) = V4 (f a) (f b) (f c) (f d) @@ -139,11 +111,34 @@ instance Foldable V4 where foldMap f (V4 a b c d) = f a `mappend` f b `mappend` f c `mappend` f d {-# INLINE foldMap #-} -#if __GLASGOW_HASKELL__ >= 710 +#if MIN_VERSION_base(4,13,0) + foldMap' f (V4 a b c d) = ((f a `mappend` f b) `mappend` f c) `mappend` f d + {-# INLINE foldMap' #-} +#endif null _ = False length _ = 4 -#endif +instance Random a => Random (V4 a) where + random g = case random g of + (a, g') -> case random g' of + (b, g'') -> case random g'' of + (c, g''') -> case random g''' of + (d, g'''') -> (V4 a b c d, g'''') + randomR (V4 a b c d, V4 a' b' c' d') g = case randomR (a,a') g of + (a'', g') -> case randomR (b,b') g' of + (b'', g'') -> case randomR (c,c') g'' of + (c'', g''') -> case randomR (d,d') g''' of + (d'', g'''') -> (V4 a'' b'' c'' d'', g'''') + +instance Uniform a => Uniform (V4 a) where + +instance UniformRange a => UniformRange (V4 a) where + uniformRM (V4 a b c d, V4 a' b' c' d') g = V4 + <$> uniformRM (a, a') g + <*> uniformRM (b, b') g + <*> uniformRM (c, c') g + <*> uniformRM (d, d') g + instance Traversable V4 where traverse f (V4 a b c d) = V4 <$> f a <*> f b <*> f c <*> f d {-# INLINE traverse #-} @@ -183,8 +178,10 @@ {-# INLINE (>>-) #-} instance Monad V4 where +#if !(MIN_VERSION_base(4,11,0)) return a = V4 a a a a {-# INLINE return #-} +#endif V4 a b c d >>= f = V4 a' b' c' d' where V4 a' _ _ _ = f a V4 _ b' _ _ = f b @@ -269,11 +266,9 @@ hashWithSalt s (V4 a b c d) = s `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c `hashWithSalt` d {-# INLINE hashWithSalt #-} -#if (MIN_VERSION_hashable(1,2,5)) instance Hashable1 V4 where liftHashWithSalt h s (V4 a b c d) = s `h` a `h` b `h` c `h` d {-# INLINE liftHashWithSalt #-} -#endif -- | A space that distinguishes orthogonal basis vectors '_x', '_y', '_z', '_w'. (It may have more.) class R3 t => R4 t where @@ -525,23 +520,29 @@ index xs (E l) = view l xs {-# INLINE index #-} -instance FunctorWithIndex (E V4) V4 where +instance WithIndex.FunctorWithIndex (E V4) V4 where imap f (V4 a b c d) = V4 (f ex a) (f ey b) (f ez c) (f ew d) {-# INLINE imap #-} -instance FoldableWithIndex (E V4) V4 where +instance WithIndex.FoldableWithIndex (E V4) V4 where ifoldMap f (V4 a b c d) = f ex a `mappend` f ey b `mappend` f ez c `mappend` f ew d {-# INLINE ifoldMap #-} -instance TraversableWithIndex (E V4) V4 where +instance WithIndex.TraversableWithIndex (E V4) V4 where itraverse f (V4 a b c d) = V4 <$> f ex a <*> f ey b <*> f ez c <*> f ew d {-# INLINE itraverse #-} +#if !MIN_VERSION_lens(5,0,0) +instance Lens.FunctorWithIndex (E V4) V4 where imap = WithIndex.imap +instance Lens.FoldableWithIndex (E V4) V4 where ifoldMap = WithIndex.ifoldMap +instance Lens.TraversableWithIndex (E V4) V4 where itraverse = WithIndex.itraverse +#endif + type instance Index (V4 a) = E V4 type instance IxValue (V4 a) = a instance Ixed (V4 a) where - ix = el + ix i = el i instance Each (V4 a) (V4 b) a b where each = traverse @@ -568,9 +569,7 @@ M.basicUnsafeWrite v (o+1) y M.basicUnsafeWrite v (o+2) z M.basicUnsafeWrite v (o+3) w -#if MIN_VERSION_vector(0,11,0) basicInitialize (MV_V4 _ v) = M.basicInitialize v -#endif instance U.Unbox a => G.Vector U.Vector (V4 a) where basicUnsafeFreeze (MV_V4 n v) = liftM ( V_V4 n) (G.basicUnsafeFreeze v) @@ -619,7 +618,6 @@ put = serializeWith Cereal.put get = deserializeWith Cereal.get -#if (MIN_VERSION_transformers(0,5,0)) || !(MIN_VERSION_transformers(0,4,0)) instance Eq1 V4 where liftEq k (V4 a b c d) (V4 e f g h) = k a e && k b f && k c g && k d h instance Ord1 V4 where @@ -636,12 +634,6 @@ instance Show1 V4 where liftShowsPrec f _ z (V4 a b c d) = showParen (z > 10) $ showString "V4 " . f 11 a . showChar ' ' . f 11 b . showChar ' ' . f 11 c . showChar ' ' . f 11 d -#else -instance Eq1 V4 where eq1 = (==) -instance Ord1 V4 where compare1 = compare -instance Show1 V4 where showsPrec1 = showsPrec -instance Read1 V4 where readsPrec1 = readsPrec -#endif instance Field1 (V4 a) (V4 a) a a where _1 f (V4 x y z w) = f x <&> \x' -> V4 x' y z w @@ -654,3 +646,13 @@ instance Field4 (V4 a) (V4 a) a a where _4 f (V4 x y z w) = f w <&> \w' -> V4 x y z w' + +instance Semigroup a => Semigroup (V4 a) where + (<>) = liftA2 (<>) + +instance Monoid a => Monoid (V4 a) where + mempty = pure mempty +#if !(MIN_VERSION_base(4,11,0)) + mappend = liftA2 mappend +#endif + diff --git a/src/Linear/Vector.hs b/src/Linear/Vector.hs --- a/src/Linear/Vector.hs +++ b/src/Linear/Vector.hs @@ -2,12 +2,10 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} {-# LANGUAGE DefaultSignatures #-} -#define USE_GHC_GENERICS -#endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2012-2015 Edward Kmett @@ -36,27 +34,19 @@ import Control.Applicative import Control.Lens import Data.Complex -#if __GLASGOW_HASKELL__ < 710 -import Data.Foldable as Foldable (Foldable, forM_, foldl') -#else import Data.Foldable as Foldable (forM_, foldl') -#endif +import Data.Functor.Compose +import Data.Functor.Product import Data.HashMap.Lazy as HashMap import Data.Hashable import Data.IntMap as IntMap import Data.Map as Map -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid (mempty) -#endif -import Data.Vector as Vector -import Data.Vector.Mutable as Mutable -#ifdef USE_GHC_GENERICS +import qualified Data.Vector as Vector +import Data.Vector (Vector) +import qualified Data.Vector.Mutable as Mutable import GHC.Generics -#endif import Linear.Instances () -{-# ANN module "HLint: ignore Redundant lambda" #-} - -- $setup -- >>> import Linear.V2 @@ -66,7 +56,6 @@ infixl 6 ^+^, ^-^ infixl 7 ^*, *^, ^/ -#ifdef USE_GHC_GENERICS class GAdditive f where gzero :: Num a => f a gliftU2 :: (a -> a -> a) -> f a -> f a -> f a @@ -88,6 +77,14 @@ gliftI2 f (a :*: b) (c :*: d) = gliftI2 f a c :*: gliftI2 f b d {-# INLINE gliftI2 #-} +instance (Additive f, GAdditive g) => GAdditive (f :.: g) where + gzero = Comp1 $ gzero <$ (zero :: f Int) + {-# INLINE gzero #-} + gliftU2 f (Comp1 a) (Comp1 b) = Comp1 $ liftU2 (gliftU2 f) a b + {-# INLINE gliftU2 #-} + gliftI2 f (Comp1 a) (Comp1 b) = Comp1 $ liftI2 (gliftI2 f) a b + {-# INLINE gliftI2 #-} + instance Additive f => GAdditive (Rec1 f) where gzero = Rec1 zero {-# INLINE gzero #-} @@ -110,19 +107,15 @@ {-# INLINE gliftU2 #-} gliftI2 f (Par1 a) (Par1 b) = Par1 (f a b) {-# INLINE gliftI2 #-} -#endif - -- | A vector is an additive group with additional structure. class Functor f => Additive f where -- | The zero vector zero :: Num a => f a -#ifdef USE_GHC_GENERICS #ifndef HLINT default zero :: (GAdditive (Rep1 f), Generic1 f, Num a) => f a zero = to1 gzero #endif -#endif -- | Compute the sum of two vectors -- @@ -140,8 +133,13 @@ x ^-^ y = x ^+^ negated y -- | Linearly interpolate between two vectors. + -- + -- /Since linear version 1.23, interpolation direction has been reversed; now/ + -- + -- > lerp 0 a b == a + -- > lerp 1 a b == b lerp :: Num a => a -> f a -> f a -> f a - lerp alpha u v = alpha *^ u ^+^ (1 - alpha) *^ v + lerp alpha u v = (1 - alpha) *^ u ^+^ alpha *^ v {-# INLINE lerp #-} -- | Apply a function to merge the 'non-zero' components of two vectors, unioning the rest of the values. @@ -150,13 +148,11 @@ -- -- * For a sparse vector this is equivalent to 'unionWith'. liftU2 :: (a -> a -> a) -> f a -> f a -> f a -#ifdef USE_GHC_GENERICS #ifndef HLINT default liftU2 :: Applicative f => (a -> a -> a) -> f a -> f a -> f a liftU2 = liftA2 {-# INLINE liftU2 #-} #endif -#endif -- | Apply a function to the components of two vectors. -- @@ -164,14 +160,32 @@ -- -- * For a sparse vector this is equivalent to 'intersectionWith'. liftI2 :: (a -> b -> c) -> f a -> f b -> f c -#ifdef USE_GHC_GENERICS #ifndef HLINT default liftI2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c liftI2 = liftA2 {-# INLINE liftI2 #-} #endif -#endif +instance (Additive f, Additive g) => Additive (Product f g) where + zero = Pair zero zero + liftU2 f (Pair a b) (Pair c d) = Pair (liftU2 f a c) (liftU2 f b d) + liftI2 f (Pair a b) (Pair c d) = Pair (liftI2 f a c) (liftI2 f b d) + Pair a b ^+^ Pair c d = Pair (a ^+^ c) (b ^+^ d) + Pair a b ^-^ Pair c d = Pair (a ^-^ c) (b ^-^ d) + lerp alpha (Pair a b) (Pair c d) = Pair (lerp alpha a c) (lerp alpha b d) + +instance (Additive f, Additive g) => Additive (Compose f g) where + zero = Compose $ zero <$ (zero :: f Int) + {-# INLINE zero #-} + Compose a ^+^ Compose b = Compose $ liftU2 (^+^) a b + {-# INLINE (^+^) #-} + Compose a ^-^ Compose b = Compose $ liftU2 (^-^) a b + {-# INLINE (^-^) #-} + liftU2 f (Compose a) (Compose b) = Compose $ liftU2 (liftU2 f) a b + {-# INLINE liftU2 #-} + liftI2 f (Compose a) (Compose b) = Compose $ liftI2 (liftI2 f) a b + {-# INLINE liftI2 #-} + instance Additive ZipList where zero = ZipList [] {-# INLINE zero #-} @@ -185,10 +199,10 @@ {-# INLINE zero #-} liftU2 f u v = case compare lu lv of LT | lu == 0 -> v - | otherwise -> Vector.modify (\ w -> Foldable.forM_ [0..lu-1] $ \i -> unsafeWrite w i $ f (unsafeIndex u i) (unsafeIndex v i)) v + | otherwise -> Vector.modify (\ w -> Foldable.forM_ [0..lu-1] $ \i -> Mutable.unsafeWrite w i $ f (Vector.unsafeIndex u i) (Vector.unsafeIndex v i)) v EQ -> Vector.zipWith f u v GT | lv == 0 -> u - | otherwise -> Vector.modify (\ w -> Foldable.forM_ [0..lv-1] $ \i -> unsafeWrite w i $ f (unsafeIndex u i) (unsafeIndex v i)) u + | otherwise -> Vector.modify (\ w -> Foldable.forM_ [0..lv-1] $ \i -> Mutable.unsafeWrite w i $ f (Vector.unsafeIndex u i) (Vector.unsafeIndex v i)) u where lu = Vector.length u lv = Vector.length v diff --git a/tests/Binary.hs b/tests/Binary.hs deleted file mode 100644 --- a/tests/Binary.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE CPP #-} -module Binary (tests) where - -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative -#endif -import Data.Binary.Put -import Data.Binary.Get -import Linear -import qualified Data.ByteString.Lazy as BS -import Test.HUnit - -originalVecs :: (V3 Float, V2 Char) -originalVecs = (V3 1 2 3, V2 'a' 'b') - -bytes :: BS.ByteString -bytes = runPut $ do putLinear $ fst originalVecs - putLinear $ snd originalVecs - -tests :: Test -tests = test [ "Serialized length" ~: BS.length bytes ~?= 3*13+2 - , "Deserialization" ~: deserialized ~?= originalVecs ] - where deserialized = runGet ((,) <$> getLinear <*> getLinear) bytes diff --git a/tests/Plucker.hs b/tests/Plucker.hs deleted file mode 100644 --- a/tests/Plucker.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Plucker (tests) where -import Linear -import Linear.Plucker -import Linear.Plucker.Coincides -import Test.HUnit - -ln2,ln3,ln4,ln5,ln6,ln7,ln8,ln9 :: Plucker Float -ln2 = plucker3D (V3 1 3 0) (V3 1 3 (-2)) -- starting line -ln3 = plucker3D (V3 2 3 0) (V3 2 3 (-2)) -- parallel -ln4 = plucker3D (V3 2 4 0) (V3 1 4 (-2)) -- ccw -ln5 = plucker3D (V3 (-2) 4 0) (V3 2 4 (-2)) -- cw -ln6 = plucker3D (V3 2 3 0) (V3 1 3 (-2)) -- intersect -ln7 = plucker3D (V3 1 3 0) (V3 1 3 2) -- reversed -ln8 = plucker3D (V3 0 4 4) (V3 0 (-4) (-4)) -- through origin -ln9 = Plucker 1 2 3 4 5 6 -- not a 3D line - -tests :: Test -tests = test [ "parallel" ~: parallel ln2 ln3 ~?= True - , "CCW" ~: passes ln2 ln4 ~?= Counterclockwise - , "CW" ~: passes ln2 ln5 ~?= Clockwise - , "intersect1" ~: intersects ln2 ln6 ~?= True - , "intersect2" ~: intersects ln2 ln3 ~?= False - , "line equality 1" ~: Line ln2 == Line ln2 ~?= True - , "line equality 2" ~: Line ln2 == Line ln7 ~?= True - , "line equality 3" ~: Line ln2 == Ray ln7 ~?= True - , "line equality 4" ~: Ray ln2 == Line ln7 ~?= True - , "ray equality 1" ~: Ray ln2 == Ray ln7 ~?= False - , "ray equality 2" ~: Ray ln2 == Ray (3 *^ ln2) ~?= True - , "ray equality 3" ~: Ray ln2 == Ray (negate ln7) ~?= True - , "quadrance" ~: nearZero (quadranceToOrigin ln2 - 10) ~?= True - , "closest 1" ~: - nearZero (qd (V3 1 3 0) $ closestToOrigin ln2) ~?= True - , "closest 2" ~: nearZero (qd 0 $ closestToOrigin ln8) ~?= True - , "isLine 1" ~: isLine ln2 ~?= True - , "isLine 2" ~: isLine ln9 ~?= False ] diff --git a/tests/Prop/Quaternion.hs b/tests/Prop/Quaternion.hs new file mode 100644 --- /dev/null +++ b/tests/Prop/Quaternion.hs @@ -0,0 +1,28 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +module Prop.Quaternion (tests) where + +import Linear.Quaternion (Quaternion(..)) +import Linear.Epsilon (nearZero) +import Linear.Vector (lerp) +import Test.QuickCheck (Arbitrary(..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Prop.V3 () + +instance Arbitrary a => Arbitrary (Quaternion a) where + arbitrary = Quaternion <$> arbitrary <*> arbitrary + +prop_lerp0 :: Quaternion Double -> Quaternion Double -> Bool +prop_lerp0 a b = nearZero (lerp 0 a b - a) + +prop_lerp1 :: Quaternion Double -> Quaternion Double -> Bool +prop_lerp1 a b = nearZero (lerp 1 a b - b) + +tests :: [TestTree] +tests = + [ testGroup "lerp" + [ testProperty "lerp 0 a b == a" prop_lerp0 + , testProperty "lerp 1 a b == b" prop_lerp1 + ] + ] diff --git a/tests/Prop/V3.hs b/tests/Prop/V3.hs new file mode 100644 --- /dev/null +++ b/tests/Prop/V3.hs @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +module Prop.V3 () where + +import Linear.V3 (V3(..)) +import Test.QuickCheck (Arbitrary(..)) + +instance Arbitrary a => Arbitrary (V3 a) where + arbitrary = V3 <$> arbitrary <*> arbitrary <*> arbitrary diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE CPP #-} +module Main (main) where + +import Test.Tasty (defaultMain, testGroup, TestTree) + +import qualified Prop.Quaternion +import qualified Unit.Binary +import qualified Unit.Plucker +import qualified Unit.V + +tests :: [TestTree] +tests = + [ testGroup "Property tests" + [ testGroup "Quaternion" Prop.Quaternion.tests + ] + , testGroup "Unit tests" + [ testGroup "Binary" Unit.Binary.tests + , testGroup "Plucker" Unit.Plucker.tests + , testGroup "V" Unit.V.tests + ] + ] + +main :: IO () +main = defaultMain $ testGroup "linear" tests diff --git a/tests/Unit/Binary.hs b/tests/Unit/Binary.hs new file mode 100644 --- /dev/null +++ b/tests/Unit/Binary.hs @@ -0,0 +1,20 @@ +module Unit.Binary (tests) where + +import Data.Binary.Put +import Data.Binary.Get +import Linear +import qualified Data.ByteString.Lazy as BS +import Test.Tasty (TestTree) +import Test.Tasty.HUnit ((@?=), testCase) + +originalVecs :: (V3 Float, V2 Char) +originalVecs = (V3 1 2 3, V2 'a' 'b') + +bytes :: BS.ByteString +bytes = runPut $ do putLinear $ fst originalVecs + putLinear $ snd originalVecs + +tests :: [TestTree] +tests = [ testCase "Serialized length" $ BS.length bytes @?= 3*13+2 + , testCase "Deserialization" $ deserialized @?= originalVecs ] + where deserialized = runGet ((,) <$> getLinear <*> getLinear) bytes diff --git a/tests/Unit/Plucker.hs b/tests/Unit/Plucker.hs new file mode 100644 --- /dev/null +++ b/tests/Unit/Plucker.hs @@ -0,0 +1,36 @@ +module Unit.Plucker (tests) where +import Linear +import Linear.Plucker +import Linear.Plucker.Coincides +import Test.Tasty (TestTree) +import Test.Tasty.HUnit ((@?=), testCase) + +ln2,ln3,ln4,ln5,ln6,ln7,ln8,ln9 :: Plucker Float +ln2 = plucker3D (V3 1 3 0) (V3 1 3 (-2)) -- starting line +ln3 = plucker3D (V3 2 3 0) (V3 2 3 (-2)) -- parallel +ln4 = plucker3D (V3 2 4 0) (V3 1 4 (-2)) -- ccw +ln5 = plucker3D (V3 (-2) 4 0) (V3 2 4 (-2)) -- cw +ln6 = plucker3D (V3 2 3 0) (V3 1 3 (-2)) -- intersect +ln7 = plucker3D (V3 1 3 0) (V3 1 3 2) -- reversed +ln8 = plucker3D (V3 0 4 4) (V3 0 (-4) (-4)) -- through origin +ln9 = Plucker 1 2 3 4 5 6 -- not a 3D line + +tests :: [TestTree] +tests = [ testCase "parallel" $ parallel ln2 ln3 @?= True + , testCase "CCW" $ passes ln2 ln4 @?= Counterclockwise + , testCase "CW" $ passes ln2 ln5 @?= Clockwise + , testCase "intersect1" $ intersects ln2 ln6 @?= True + , testCase "intersect2" $ intersects ln2 ln3 @?= False + , testCase "line equality 1" $ Line ln2 == Line ln2 @?= True + , testCase "line equality 2" $ Line ln2 == Line ln7 @?= True + , testCase "line equality 3" $ Line ln2 == Ray ln7 @?= True + , testCase "line equality 4" $ Ray ln2 == Line ln7 @?= True + , testCase "ray equality 1" $ Ray ln2 == Ray ln7 @?= False + , testCase "ray equality 2" $ Ray ln2 == Ray (3 *^ ln2) @?= True + , testCase "ray equality 3" $ Ray ln2 == Ray (negate ln7) @?= True + , testCase "quadrance" $ nearZero (quadranceToOrigin ln2 - 10) @?= True + , testCase "closest 1" $ + nearZero (qd (V3 1 3 0) $ closestToOrigin ln2) @?= True + , testCase "closest 2" $ nearZero (qd 0 $ closestToOrigin ln8) @?= True + , testCase "isLine 1" $ isLine ln2 @?= True + , testCase "isLine 2" $ isLine ln9 @?= False ] diff --git a/tests/Unit/V.hs b/tests/Unit/V.hs new file mode 100644 --- /dev/null +++ b/tests/Unit/V.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DataKinds #-} +module Unit.V (tests) where + +import Control.DeepSeq (rnf) +import qualified Data.Vector.Unboxed as U (fromList) +import Linear.V (V) +import Test.Tasty (TestTree) +import Test.Tasty.HUnit ((@?=), testCase) + +v10 :: V 10 Int +v10 = return 5 + +tests :: [TestTree] +tests = [ testCase "GH124" $ rnf (U.fromList [v10]) @?= () ] diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs deleted file mode 100644 --- a/tests/UnitTests.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE CPP #-} -module Main (main) where -import Test.Framework (defaultMain, testGroup, Test) -import Test.Framework.Providers.HUnit -import qualified Plucker -import qualified Binary -#if __GLASGOW_HASKELL__ >= 707 -import qualified V -#endif - -tests :: [Test] -tests = [ testGroup "Plucker" $ hUnitTestToTests Plucker.tests - , testGroup "Binary" $ hUnitTestToTests Binary.tests -#if __GLASGOW_HASKELL__ >= 707 - , testGroup "V" $ hUnitTestToTests V.tests -#endif - ] - -main :: IO () -main = defaultMain tests diff --git a/tests/V.hs b/tests/V.hs deleted file mode 100644 --- a/tests/V.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE DataKinds #-} -module V (tests) where - -import Control.DeepSeq (rnf) -import qualified Data.Vector.Unboxed as U (fromList) -import Linear.V (V) -import Test.HUnit - -v10 :: V 10 Int -v10 = return 5 - -tests :: Test -tests = test [ "GH124" ~: rnf (U.fromList [v10]) ~?= () ] diff --git a/tests/doctests.hs b/tests/doctests.hs --- a/tests/doctests.hs +++ b/tests/doctests.hs @@ -7,19 +7,13 @@ -- Stability : provisional -- Portability : portable -- --- This module provides doctests for a project based on the actual versions --- of the packages it was built with. It requires a corresponding Setup.lhs --- to be added to the project +-- This module exists to add dependencies ----------------------------------------------------------------------------- module Main where -import Build_doctests (flags, pkgs, module_sources) -import Data.Foldable (traverse_) -import Test.DocTest - main :: IO () main = do - traverse_ putStrLn args - doctest args - where - args = flags ++ pkgs ++ module_sources + putStrLn "This test-suite exists only to add dependencies" + putStrLn "To run doctests: " + putStrLn " cabal build all --enable-tests" + putStrLn " cabal-docspec" diff --git a/travis/cabal-apt-install b/travis/cabal-apt-install deleted file mode 100644 --- a/travis/cabal-apt-install +++ /dev/null @@ -1,27 +0,0 @@ -#! /bin/bash -set -eu - -APT="sudo apt-get -q -y" -CABAL_INSTALL_DEPS="cabal install --only-dependencies --force-reinstall" - -$APT update -$APT install dctrl-tools - -# Find potential system packages to satisfy cabal dependencies -deps() -{ - local M='^\([^ ]\+\)-[0-9.]\+ (.*$' - local G=' -o ( -FPackage -X libghc-\L\1\E-dev )' - local E="$($CABAL_INSTALL_DEPS "$@" --dry-run -v 2> /dev/null \ - | sed -ne "s/$M/$G/p" | sort -u)" - grep-aptavail -n -sPackage \( -FNone -X None \) $E | sort -u -} - -$APT install $(deps "$@") libghc-quickcheck2-dev # QuickCheck is special -$CABAL_INSTALL_DEPS "$@" # Install the rest via Hackage - -if ! $APT install hlint ; then - $APT install $(deps hlint) - cabal install hlint -fi - diff --git a/travis/config b/travis/config deleted file mode 100644 --- a/travis/config +++ /dev/null @@ -1,16 +0,0 @@ --- This provides a custom ~/.cabal/config file for use when hackage is down that should work on unix --- --- This is particularly useful for travis-ci to get it to stop complaining --- about a broken build when everything is still correct on our end. --- --- This uses Luite Stegeman's mirror of hackage provided by his 'hdiff' site instead --- --- To enable this, uncomment the before_script in .travis.yml - -remote-repo: hdiff.luite.com:http://hdiff.luite.com/packages/archive -remote-repo-cache: ~/.cabal/packages -world-file: ~/.cabal/world -build-summary: ~/.cabal/logs/build.log -remote-build-reporting: anonymous -install-dirs user -install-dirs global