diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,7 @@ +2018-10-31 Ivan Perez + * Added basic travis setup. + * Added documentation (README), link to Yampa. + * Version imported from Yampa. + +Copyright (c) 2003, Henrik Nilsson, Antony Courtney and Yale University. +All rights reserved. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2003, Henrik Nilsson, Antony Courtney and Yale University. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +- Neither name of the copyright holders nor the names of its +contributors may be used to endorse or promote products derived from +this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDERS OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS +OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR +TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/simple-affine-space.cabal b/simple-affine-space.cabal new file mode 100644 --- /dev/null +++ b/simple-affine-space.cabal @@ -0,0 +1,78 @@ +name: simple-affine-space +version: 0.1 +cabal-version: >= 1.8 +license: BSD3 +license-file: LICENSE +author: Henrik Nilsson, Antony Courtney +maintainer: Ivan Perez (ivan.perez@keera.co.uk) +homepage: http://www.haskell.org/haskellwiki/Yampa +category: Reactivity, FRP +synopsis: A simple library for affine and vector spaces. + +description: + Affine spaces and vector spaces with a few basic instances. + . + This library implements affine spaces and vector spaces. Two instances are + provided for affine spaces (points) and two more for vector spaces (vectors). + These definitions are strict, implement deepseq, and are designed to have + minimal memory overhead. + +build-type: Simple +extra-source-files: + CHANGELOG + +-- You can disable the hlint test suite with -f-test-hlint +flag test-hlint + Description: Enable hlint test suite + default: True + manual: True + +-- You can disable the haddock coverage test suite with -f-test-doc-coverage +flag test-doc-coverage + Description: Enable haddock coverage test suite + default: True + manual: True + +library + hs-source-dirs: src + ghc-options : -O3 -Wall -fno-warn-name-shadowing + build-Depends: base < 5, deepseq + exposed-modules: + Data.AffineSpace + Data.Point2 + Data.Point3 + Data.Vector2 + Data.Vector3 + Data.VectorSpace + +test-suite hlint + type: exitcode-stdio-1.0 + main-is: hlint.hs + hs-source-dirs: tests + if !flag(test-hlint) + buildable: False + else + build-depends: + base, + hlint >= 1.7 + +-- Verify that the code is thoroughly documented +test-suite haddock-coverage + type: exitcode-stdio-1.0 + main-is: HaddockCoverage.hs + ghc-options: -Wall + hs-source-dirs: tests + + if !flag(test-doc-coverage) + buildable: False + else + build-depends: + base >= 4 && < 5, + directory, + filepath, + process, + regex-posix + +source-repository head + type: git + location: git://github.com/ivanperez-keera/simple-affine-space.git diff --git a/src/Data/AffineSpace.hs b/src/Data/AffineSpace.hs new file mode 100644 --- /dev/null +++ b/src/Data/AffineSpace.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} +----------------------------------------------------------------------------------------- +-- | +-- Module : Data.AffineSpace +-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Affine space type relation. +-- +----------------------------------------------------------------------------------------- + +module Data.AffineSpace where + +import Data.VectorSpace + +infix 6 .+^, .-^, .-. + +-- Maybe origin should not be a class method, even though an origin +-- can be assocoated with any affine space. +-- Maybe distance should not be a class method, in which case the constraint +-- on the coefficient space (a) could be Fractional (i.e., a Field), which +-- seems closer to the mathematical definition of affine space, provided +-- the constraint on the coefficient space for VectorSpace is also Fractional. + +-- | Affine Space type relation. +-- +-- An affine space is a set (type) @p@, and an associated vector space @v@ over +-- a field @a@. +class (Floating a, VectorSpace v a) => AffineSpace p v a | p -> v, v -> a where + + -- | Origin of the affine space. + origin :: p + + -- | Addition of affine point and vector. + (.+^) :: p -> v -> p + + -- | Subtraction of affine point and vector. + (.-^) :: p -> v -> p + p .-^ v = p .+^ (negateVector v) + + -- | Subtraction of two points in the affine space, giving a vector. + (.-.) :: p -> p -> v + + -- | Distance between two points in the affine space, same as the 'norm' of + -- the vector they form (see '(.-.)'. + distance :: p -> p -> a + distance p1 p2 = norm (p1 .-. p2) diff --git a/src/Data/Point2.hs b/src/Data/Point2.hs new file mode 100644 --- /dev/null +++ b/src/Data/Point2.hs @@ -0,0 +1,58 @@ +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} +{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, FlexibleInstances, StandaloneDeriving #-} +----------------------------------------------------------------------------------------- +-- | +-- Module : Data.Point2 +-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- 2D point abstraction (R^2). +-- +----------------------------------------------------------------------------------------- + +module Data.Point2 ( + Point2(..), -- Non-abstract, instance of AffineSpace + point2X, -- :: RealFloat a => Point2 a -> a + point2Y -- :: RealFloat a => Point2 a -> a +) where + +import Control.DeepSeq (NFData(..)) + +import Data.VectorSpace () +import Data.AffineSpace +import Data.Vector2 + +-- * 2D point, constructors and selectors + +-- | 2D point. +data Point2 a = RealFloat a => Point2 !a !a + +deriving instance Eq a => Eq (Point2 a) + +deriving instance Show a => Show (Point2 a) + +instance NFData a => NFData (Point2 a) where + rnf (Point2 x y) = rnf x `seq` rnf y `seq` () + +-- | X coordinate of a 2D point. +point2X :: RealFloat a => Point2 a -> a +point2X (Point2 x _) = x + +-- | Y coordinate of a 2D point. +point2Y :: RealFloat a => Point2 a -> a +point2Y (Point2 _ y) = y + +-- * Affine space instance + +instance RealFloat a => AffineSpace (Point2 a) (Vector2 a) a where + origin = Point2 0 0 + + (Point2 x y) .+^ v = Point2 (x + vector2X v) (y + vector2Y v) + + (Point2 x y) .-^ v = Point2 (x - vector2X v) (y - vector2Y v) + + (Point2 x1 y1) .-. (Point2 x2 y2) = vector2 (x1 - x2) (y1 - y2) diff --git a/src/Data/Point3.hs b/src/Data/Point3.hs new file mode 100644 --- /dev/null +++ b/src/Data/Point3.hs @@ -0,0 +1,66 @@ +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} +{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, FlexibleInstances, StandaloneDeriving #-} +----------------------------------------------------------------------------------------- +-- | +-- Module : Data.Point3 +-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- 3D point abstraction (R^3). +-- +----------------------------------------------------------------------------------------- + +module Data.Point3 ( + Point3(..), -- Non-abstract, instance of AffineSpace + point3X, -- :: RealFloat a => Point3 a -> a + point3Y, -- :: RealFloat a => Point3 a -> a + point3Z -- :: RealFloat a => Point3 a -> a +) where + +import Control.DeepSeq (NFData(..)) + +import Data.VectorSpace () +import Data.AffineSpace +import Data.Vector3 + +-- * 3D point, constructors and selectors + +-- | 3D point. +data Point3 a = RealFloat a => Point3 !a !a !a + +deriving instance Eq a => Eq (Point3 a) + +deriving instance Show a => Show (Point3 a) + +instance NFData a => NFData (Point3 a) where + rnf (Point3 x y z) = rnf x `seq` rnf y `seq` rnf z `seq` () + +-- | X coodinate of a 3D point. +point3X :: RealFloat a => Point3 a -> a +point3X (Point3 x _ _) = x + +-- | Y coodinate of a 3D point. +point3Y :: RealFloat a => Point3 a -> a +point3Y (Point3 _ y _) = y + +-- | Z coodinate of a 3D point. +point3Z :: RealFloat a => Point3 a -> a +point3Z (Point3 _ _ z) = z + +-- * Affine space instance + +instance RealFloat a => AffineSpace (Point3 a) (Vector3 a) a where + origin = Point3 0 0 0 + + (Point3 x y z) .+^ v = + Point3 (x + vector3X v) (y + vector3Y v) (z + vector3Z v) + + (Point3 x y z) .-^ v = + Point3 (x - vector3X v) (y - vector3Y v) (z - vector3Z v) + + (Point3 x1 y1 z1) .-. (Point3 x2 y2 z2) = + vector3 (x1 - x2) (y1 - y2) (z1 - z2) diff --git a/src/Data/Vector2.hs b/src/Data/Vector2.hs new file mode 100644 --- /dev/null +++ b/src/Data/Vector2.hs @@ -0,0 +1,106 @@ +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} +{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, FlexibleInstances, StandaloneDeriving #-} +----------------------------------------------------------------------------------------- +-- | +-- Module : Data.Vector2 +-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- 2D vector abstraction (R^2). +-- +----------------------------------------------------------------------------------------- + +module Data.Vector2 ( + Vector2, -- Abstract, instance of VectorSpace + vector2, -- :: RealFloat a => a -> a -> Vector2 a + vector2X, -- :: RealFloat a => Vector2 a -> a + vector2Y, -- :: RealFloat a => Vector2 a -> a + vector2XY, -- :: RealFloat a => Vector2 a -> (a, a) + vector2Polar, -- :: RealFloat a => a -> a -> Vector2 a + vector2Rho, -- :: RealFloat a => Vector2 a -> a + vector2Theta, -- :: RealFloat a => Vector2 a -> a + vector2RhoTheta, -- :: RealFloat a => Vector2 a -> (a, a) + vector2Rotate -- :: RealFloat a => a -> Vector2 a -> Vector2 a +) where + +import Control.DeepSeq (NFData(..)) + +import Data.VectorSpace + +-- * 2D vector, constructors and selectors + +-- | 2D Vector. + +-- Restrict coefficient space to RealFloat (rather than Floating) for now. +-- While unclear if a complex coefficient space would be useful (and if the +-- result really would be a 2d vector), the only thing causing trouble is the +-- use of atan2 in vector2Theta. Maybe atan2 can be generalized? + +data Vector2 a = RealFloat a => Vector2 !a !a + +deriving instance Eq a => Eq (Vector2 a) + +deriving instance Show a => Show (Vector2 a) + +instance NFData a => NFData (Vector2 a) where + rnf (Vector2 x y) = rnf x `seq` rnf y `seq` () + +-- | Creates a 2D vector from the cartesian coordinates. +vector2 :: RealFloat a => a -> a -> Vector2 a +vector2 = Vector2 + +-- | X cartesian coordinate. +vector2X :: RealFloat a => Vector2 a -> a +vector2X (Vector2 x _) = x + +-- | Y cartesian coordinate. +vector2Y :: RealFloat a => Vector2 a -> a +vector2Y (Vector2 _ y) = y + +-- | Returns a vector's cartesian coordinates. +vector2XY :: RealFloat a => Vector2 a -> (a, a) +vector2XY (Vector2 x y) = (x, y) + +-- | Creates a 2D vector from the polar coordinates. +vector2Polar :: RealFloat a => a -> a -> Vector2 a +vector2Polar rho theta = Vector2 (rho * cos theta) (rho * sin theta) + +-- | Calculates the vector's radial distance (magnitude). +vector2Rho :: RealFloat a => Vector2 a -> a +vector2Rho (Vector2 x y) = sqrt (x * x + y * y) + +-- | Calculates the vector's azimuth (angle). +vector2Theta :: RealFloat a => Vector2 a -> a +vector2Theta (Vector2 x y) = atan2 y x + +-- | Polar coordinate representation of a 2D vector. +vector2RhoTheta :: RealFloat a => Vector2 a -> (a, a) +vector2RhoTheta v = (vector2Rho v, vector2Theta v) + +-- * Vector space instance + +instance RealFloat a => VectorSpace (Vector2 a) a where + zeroVector = Vector2 0 0 + + a *^ (Vector2 x y) = Vector2 (a * x) (a * y) + + (Vector2 x y) ^/ a = Vector2 (x / a) (y / a) + + negateVector (Vector2 x y) = (Vector2 (-x) (-y)) + + (Vector2 x1 y1) ^+^ (Vector2 x2 y2) = Vector2 (x1 + x2) (y1 + y2) + + (Vector2 x1 y1) ^-^ (Vector2 x2 y2) = Vector2 (x1 - x2) (y1 - y2) + + (Vector2 x1 y1) `dot` (Vector2 x2 y2) = x1 * x2 + y1 * y2 + + +-- * Additional operations + +-- | Rotates a vector with a given angle. +vector2Rotate :: RealFloat a => a -> Vector2 a -> Vector2 a +vector2Rotate theta' v = vector2Polar (vector2Rho v) (vector2Theta v + theta') diff --git a/src/Data/Vector3.hs b/src/Data/Vector3.hs new file mode 100644 --- /dev/null +++ b/src/Data/Vector3.hs @@ -0,0 +1,125 @@ +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} +{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, FlexibleInstances, StandaloneDeriving #-} +----------------------------------------------------------------------------------------- +-- | +-- Module : Data.Vector3 +-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- 3D vector abstraction (R^3). +-- +----------------------------------------------------------------------------------------- + +module Data.Vector3 ( + Vector3, -- Abstract, instance of VectorSpace + vector3, -- :: RealFloat a => a -> a -> a -> Vector3 a + vector3X, -- :: RealFloat a => Vector3 a -> a + vector3Y, -- :: RealFloat a => Vector3 a -> a + vector3Z, -- :: RealFloat a => Vector3 a -> a + vector3XYZ, -- :: RealFloat a => Vector3 a -> (a, a, a) + vector3Spherical, -- :: RealFloat a => a -> a -> a -> Vector3 a + vector3Rho, -- :: RealFloat a => Vector3 a -> a + vector3Theta, -- :: RealFloat a => Vector3 a -> a + vector3Phi, -- :: RealFloat a => Vector3 a -> a + vector3RhoThetaPhi, -- :: RealFloat a => Vector3 a -> (a, a, a) + vector3Rotate -- :: RealFloat a => a -> a -> Vector3 a -> Vector3 a +) where + +import Control.DeepSeq (NFData(..)) + +import Data.VectorSpace + +-- * 3D vector, constructors and selectors + +-- | 3D Vector. + +-- Restrict coefficient space to RealFloat (rather than Floating) for now. +-- While unclear if a complex coefficient space would be useful (and if the +-- result really would be a 3d vector), the only thing causing trouble is the +-- use of atan2 in vector3Theta and vector3Phi. Maybe atan2 can be generalized? + +data Vector3 a = RealFloat a => Vector3 !a !a !a + +deriving instance Eq a => Eq (Vector3 a) + +deriving instance Show a => Show (Vector3 a) + +instance NFData a => NFData (Vector3 a) where + rnf (Vector3 x y z) = rnf x `seq` rnf y `seq` rnf z `seq` () + +-- | Creates a 3D vector from the cartesian coordinates. +vector3 :: RealFloat a => a -> a -> a -> Vector3 a +vector3 = Vector3 + +-- | X cartesian coordinate. +vector3X :: RealFloat a => Vector3 a -> a +vector3X (Vector3 x _ _) = x + +-- | Y cartesian coordinate. +vector3Y :: RealFloat a => Vector3 a -> a +vector3Y (Vector3 _ y _) = y + +-- | Z cartesian coordinate. +vector3Z :: RealFloat a => Vector3 a -> a +vector3Z (Vector3 _ _ z) = z + +-- | Returns a vector's cartesian coordinates. +vector3XYZ :: RealFloat a => Vector3 a -> (a, a, a) +vector3XYZ (Vector3 x y z) = (x, y, z) + +-- | Creates a 3D vector from the spherical coordinates. +vector3Spherical :: RealFloat a => a -> a -> a -> Vector3 a +vector3Spherical rho theta phi = + Vector3 (rhoSinPhi * cos theta) (rhoSinPhi * sin theta) (rho * cos phi) + where + rhoSinPhi = rho * sin phi + +-- | Calculates the vector's radial distance. +vector3Rho :: RealFloat a => Vector3 a -> a +vector3Rho (Vector3 x y z) = sqrt (x * x + y * y + z * z) + +-- | Calculates the vector's azimuth. +vector3Theta :: RealFloat a => Vector3 a -> a +vector3Theta (Vector3 x y _) = atan2 y x + +-- | Calculates the vector's inclination. +vector3Phi :: RealFloat a => Vector3 a -> a +vector3Phi v@(Vector3 _ _ z) = acos (z / vector3Rho v) + +-- | Spherical coordinate representation of a 3D vector. +vector3RhoThetaPhi :: RealFloat a => Vector3 a -> (a, a, a) +vector3RhoThetaPhi (Vector3 x y z) = (rho, theta, phi) + where + rho = sqrt (x * x + y * y + z * z) + theta = atan2 y x + phi = acos (z / rho) + +-- * Vector space instance + +instance RealFloat a => VectorSpace (Vector3 a) a where + zeroVector = Vector3 0 0 0 + + a *^ (Vector3 x y z) = Vector3 (a * x) (a * y) (a * z) + + (Vector3 x y z) ^/ a = Vector3 (x / a) (y / a) (z / a) + + negateVector (Vector3 x y z) = (Vector3 (-x) (-y) (-z)) + + (Vector3 x1 y1 z1) ^+^ (Vector3 x2 y2 z2) = Vector3 (x1+x2) (y1+y2) (z1+z2) + + (Vector3 x1 y1 z1) ^-^ (Vector3 x2 y2 z2) = Vector3 (x1-x2) (y1-y2) (z1-z2) + + (Vector3 x1 y1 z1) `dot` (Vector3 x2 y2 z2) = x1 * x2 + y1 * y2 + z1 * z2 + +-- * Additional operations + +-- | Rotates a vector with a given polar and azimuthal angles. +vector3Rotate :: RealFloat a => a -> a -> Vector3 a -> Vector3 a +vector3Rotate theta' phi' v = + vector3Spherical (vector3Rho v) + (vector3Theta v + theta') + (vector3Phi v + phi') diff --git a/src/Data/VectorSpace.hs b/src/Data/VectorSpace.hs new file mode 100644 --- /dev/null +++ b/src/Data/VectorSpace.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} +----------------------------------------------------------------------------------------- +-- | +-- Module : Data.VectorSpace +-- Copyright : (c) Antony Courtney and Henrik Nilsson, Yale University, 2003 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Vector space type relation and basic instances. +----------------------------------------------------------------------------------------- + +module Data.VectorSpace where + +infixr *^ +infixl ^/ +infix 7 `dot` +infixl 6 ^+^, ^-^ + +-- Maybe norm and normalize should not be class methods, in which case +-- the constraint on the coefficient space (a) should (or, at least, could) +-- be Fractional (roughly a Field) rather than Floating. + +-- | Vector space type relation. +-- +-- A vector space is a set (type) closed under addition and multiplication by +-- a scalar. The type of the scalar is the /field/ of the vector space, and +-- it is said that @v@ is a vector space over @a@. +-- +-- The encoding uses a type class |VectorSpace| @v a@, where @v@ represents +-- the type of the vectors and @a@ represents the types of the scalars. + +class (Eq a, Floating a) => VectorSpace v a | v -> a where + -- | Vector with no magnitude (unit for addition). + zeroVector :: v + + -- | Multiplication by a scalar. + (*^) :: a -> v -> v + + -- | Division by a scalar. + (^/) :: v -> a -> v + v ^/ a = (1/a) *^ v + + -- | Vector addition + (^+^) :: v -> v -> v + + -- | Vector subtraction + (^-^) :: v -> v -> v + v1 ^-^ v2 = v1 ^+^ negateVector v2 + + -- | Vector negation. Addition with a negated vector should be + -- same as subtraction. + negateVector :: v -> v + negateVector v = (-1) *^ v + + -- | Dot product (also known as scalar or inner product). + -- + -- For two vectors, mathematically represented as @a = a1,a2,...,an@ and @b + -- = b1,b2,...,bn@, the dot product is @a . b = a1*b1 + a2*b2 + ... + + -- an*bn@. + -- + -- Some properties are derived from this. The dot product of a vector with + -- itself is the square of its magnitude ('norm'), and the dot product of + -- two orthogonal vectors is zero. + dot :: v -> v -> a + + -- | Vector's norm (also known as magnitude). + -- + -- For a vector represented mathematically as @a = a1,a2,...,an@, the norm + -- is the square root of @a1^2 + a2^2 + ... + an^2@. + norm :: v -> a + norm v = sqrt (v `dot` v) + + -- | Return a vector with the same origin and orientation (angle), but such + -- that the norm is one (the unit for multiplication by a scalar). + normalize :: v -> v + normalize v = if nv /= 0 then v ^/ nv else error "normalize: zero vector" + where nv = norm v + +-- | Vector space instance for 'Float's, with 'Float' scalars. +instance VectorSpace Float Float where + zeroVector = 0 + + a *^ x = a * x + + x ^/ a = x / a + + negateVector x = (-x) + + x1 ^+^ x2 = x1 + x2 + + x1 ^-^ x2 = x1 - x2 + + x1 `dot` x2 = x1 * x2 + +-- | Vector space instance for 'Double's, with 'Double' scalars. +instance VectorSpace Double Double where + zeroVector = 0 + + a *^ x = a * x + + x ^/ a = x / a + + negateVector x = (-x) + + x1 ^+^ x2 = x1 + x2 + + x1 ^-^ x2 = x1 - x2 + + x1 `dot` x2 = x1 * x2 + + +-- | Vector space instance for pairs of 'Floating' point numbers. +instance (Eq a, Floating a) => VectorSpace (a,a) a where + zeroVector = (0,0) + + a *^ (x,y) = (a * x, a * y) + + (x,y) ^/ a = (x / a, y / a) + + negateVector (x,y) = (-x, -y) + + (x1,y1) ^+^ (x2,y2) = (x1 + x2, y1 + y2) + + (x1,y1) ^-^ (x2,y2) = (x1 - x2, y1 - y2) + + (x1,y1) `dot` (x2,y2) = x1 * x2 + y1 * y2 + +-- | Vector space instance for triplets of 'Floating' point numbers. +instance (Eq a, Floating a) => VectorSpace (a,a,a) a where + zeroVector = (0,0,0) + + a *^ (x,y,z) = (a * x, a * y, a * z) + + (x,y,z) ^/ a = (x / a, y / a, z / a) + + negateVector (x,y,z) = (-x, -y, -z) + + (x1,y1,z1) ^+^ (x2,y2,z2) = (x1+x2, y1+y2, z1+z2) + + (x1,y1,z1) ^-^ (x2,y2,z2) = (x1-x2, y1-y2, z1-z2) + + (x1,y1,z1) `dot` (x2,y2,z2) = x1 * x2 + y1 * y2 + z1 * z2 + +-- | Vector space instance for tuples with four 'Floating' point numbers. +instance (Eq a, Floating a) => VectorSpace (a,a,a,a) a where + zeroVector = (0,0,0,0) + + a *^ (x,y,z,u) = (a * x, a * y, a * z, a * u) + + (x,y,z,u) ^/ a = (x / a, y / a, z / a, u / a) + + negateVector (x,y,z,u) = (-x, -y, -z, -u) + + (x1,y1,z1,u1) ^+^ (x2,y2,z2,u2) = (x1+x2, y1+y2, z1+z2, u1+u2) + + (x1,y1,z1,u1) ^-^ (x2,y2,z2,u2) = (x1-x2, y1-y2, z1-z2, u1-u2) + + (x1,y1,z1,u1) `dot` (x2,y2,z2,u2) = x1 * x2 + y1 * y2 + z1 * z2 + u1 * u2 + +-- | Vector space instance for tuples with five 'Floating' point numbers. +instance (Eq a, Floating a) => VectorSpace (a,a,a,a,a) a where + zeroVector = (0,0,0,0,0) + + a *^ (x,y,z,u,v) = (a * x, a * y, a * z, a * u, a * v) + + (x,y,z,u,v) ^/ a = (x / a, y / a, z / a, u / a, v / a) + + negateVector (x,y,z,u,v) = (-x, -y, -z, -u, -v) + + (x1,y1,z1,u1,v1) ^+^ (x2,y2,z2,u2,v2) = (x1+x2, y1+y2, z1+z2, u1+u2, v1+v2) + + (x1,y1,z1,u1,v1) ^-^ (x2,y2,z2,u2,v2) = (x1-x2, y1-y2, z1-z2, u1-u2, v1-v2) + + (x1,y1,z1,u1,v1) `dot` (x2,y2,z2,u2,v2) = + x1 * x2 + y1 * y2 + z1 * z2 + u1 * u2 + v1 * v2 diff --git a/tests/HaddockCoverage.hs b/tests/HaddockCoverage.hs new file mode 100644 --- /dev/null +++ b/tests/HaddockCoverage.hs @@ -0,0 +1,93 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Main (HaddockCoverage) +-- Copyright : (C) 2015 Ivan Perez +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Ivan Perez +-- Stability : provisional +-- Portability : portable +-- +-- Copyright notice: This file borrows code +-- https://hackage.haskell.org/package/lens-4.7/src/tests/doctests.hsc +-- which is itself licensed BSD-style as well. +-- +-- Run haddock on a source tree and report if anything in any +-- module is not documented. +----------------------------------------------------------------------------- +module Main where + +import Control.Applicative +import Control.Monad +import Data.List +import System.Directory +import System.Exit +import System.FilePath +import System.IO +import System.Process +import Text.Regex.Posix + +main :: IO () +main = do + -- Find haskell modules + -- TODO: Ideally cabal should do this (provide us with the + -- list of modules). An alternative would be to use cabal haddock + -- but that would need a --no-html argument or something like that. + -- Alternatively, we could use cabal haddock with additional arguments. + -- + -- See: + -- https://github.com/keera-studios/haddock/commit/d5d752943c4e5c6c9ffcdde4dc136fcee967c495 + -- https://github.com/haskell/haddock/issues/309#issuecomment-150811929 + files <- getSources + + let haddockArgs = [ "--no-warnings" ] ++ files + let cabalArgs = [ "exec", "--", "haddock" ] ++ haddockArgs + print cabalArgs + (code, out, _err) <- readProcessWithExitCode "cabal" cabalArgs "" + + -- Filter out coverage lines, and find those that denote undocumented + -- modules. + -- + -- TODO: is there a way to annotate a function as self-documenting, + -- in the same way we do with ANN for hlint? + let isIncompleteModule :: String -> Bool + isIncompleteModule line = isCoverageLine line && not (line =~ "^ *100%") + where isCoverageLine :: String -> Bool + isCoverageLine line = line =~ "^ *[0-9]+%" + + let incompleteModules :: [String] + incompleteModules = filter isIncompleteModule $ lines out + + -- Based on the result of haddock, report errors and exit. + -- Note that, unline haddock, this script does not + -- output anything to stdout. It uses stderr instead + -- (as it should). + case (code, incompleteModules) of + (ExitSuccess , []) -> return () + (ExitFailure _, _) -> exitFailure + (_ , _) -> do + hPutStrLn stderr "The following modules are not fully documented:" + mapM_ (hPutStrLn stderr) incompleteModules + exitFailure + +getSources :: IO [FilePath] +getSources = filter isHaskellFile <$> go "src" + where + go dir = do + (dirs, files) <- getFilesAndDirectories dir + (files ++) . concat <$> mapM go dirs + + isHaskellFile fp = (isSuffixOf ".hs" fp || isSuffixOf ".lhs" fp) + && not (any (`isSuffixOf` fp) excludedFiles) + + excludedFiles = [ "Vector2.hs", "Vector3.hs" + , "Point2.hs", "Point3.hs" ] + +getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) +getFilesAndDirectories dir = do + c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir + (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c + +-- find-based implementation (not portable) +-- +-- getSources :: IO [FilePath] +-- getSources = fmap lines $ readProcess "find" ["src/", "-iname", "*hs"] "" diff --git a/tests/hlint.hs b/tests/hlint.hs new file mode 100644 --- /dev/null +++ b/tests/hlint.hs @@ -0,0 +1,23 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Main (hlint) +-- Copyright : (C) 2013 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : portable +-- +-- This module runs HLint on the lens source tree. +----------------------------------------------------------------------------- +module Main where + +import Control.Monad +import Language.Haskell.HLint +import System.Environment +import System.Exit + +main :: IO () +main = do + args <- getArgs + hints <- hlint $ ["src", "--cross"] ++ args + unless (null hints) exitFailure