├── .gitignore ├── .travis.yml ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── benchmarks ├── Folds.hs └── Samples.hs ├── diagrams ├── src_Geometry_Combinators_appendsEx.svg ├── src_Geometry_Combinators_besideEx.svg ├── src_Geometry_Combinators_positionEx.svg ├── src_Geometry_CubicSpline_cubicSplineEx.svg ├── src_Geometry_Trail_closeLineEx.svg ├── src_Geometry_Trail_explodeTrailEx.svg ├── src_Geometry_Trail_fromOffsetsEx.svg ├── src_Geometry_Trail_fromSegmentsEx.svg ├── src_Geometry_Trail_fromVerticesEx.svg ├── src_Geometry_Trail_glueLineEx.svg ├── src_Geometry_Trail_twiddleEx.svg ├── src_Geometry_TwoD_Arc_annularWedgeEx.svg ├── src_Geometry_TwoD_Arc_arc'Ex.svg ├── src_Geometry_TwoD_Arc_arcBetweenEx.svg ├── src_Geometry_TwoD_Arc_wedgeEx.svg ├── src_Geometry_TwoD_Curvature_diagramA.svg ├── src_Geometry_TwoD_Curvature_diagramNeg.svg ├── src_Geometry_TwoD_Curvature_diagramPos.svg ├── src_Geometry_TwoD_Curvature_diagramZero.svg ├── src_Geometry_TwoD_Offset_cubicOffsetExample.svg ├── src_Geometry_TwoD_Offset_expandLoopExample.svg ├── src_Geometry_TwoD_Offset_expandTrailExample.svg ├── src_Geometry_TwoD_Offset_offsetTrailExample.svg ├── src_Geometry_TwoD_Offset_offsetTrailLeftExample.svg ├── src_Geometry_TwoD_Offset_offsetTrailOuterExample.svg ├── src_Geometry_TwoD_Shapes_decagonEx.svg ├── src_Geometry_TwoD_Shapes_dodecagonEx.svg ├── src_Geometry_TwoD_Shapes_hendecagonEx.svg ├── src_Geometry_TwoD_Shapes_heptagonEx.svg ├── src_Geometry_TwoD_Shapes_hexagonEx.svg ├── src_Geometry_TwoD_Shapes_hruleEx.svg ├── src_Geometry_TwoD_Shapes_nonagonEx.svg ├── src_Geometry_TwoD_Shapes_octagonEx.svg ├── src_Geometry_TwoD_Shapes_pentagonEx.svg ├── src_Geometry_TwoD_Shapes_rectEx.svg ├── src_Geometry_TwoD_Shapes_roundedRectEx.svg ├── src_Geometry_TwoD_Shapes_squareEx.svg ├── src_Geometry_TwoD_Shapes_triangleEx.svg ├── src_Geometry_TwoD_Shapes_unitSquareEx.svg └── src_Geometry_TwoD_Shapes_vruleEx.svg ├── geometry.cabal └── src ├── Geometry.hs └── Geometry ├── Angle.hs ├── BoundingBox.hs ├── Combinators.hs ├── CubicSpline.hs ├── CubicSpline ├── Boehm.hs └── Internal.hs ├── Direction.hs ├── Envelope.hs ├── HasOrigin.hs ├── Juxtapose.hs ├── Located.hs ├── Parametric.hs ├── Path.hs ├── Points.hs ├── Query.hs ├── Segment.hs ├── Size.hs ├── Space.hs ├── ThreeD ├── Camera.hs ├── Combinators.hs ├── Shapes.hs ├── Size.hs ├── Transform.hs ├── Types.hs └── Vector.hs ├── Trace.hs ├── Trail.hs ├── Transform.hs └── TwoD ├── Arc.hs ├── Combinators.hs ├── Curvature.hs ├── Ellipse.hs ├── Offset.hs ├── Path.hs ├── Points.hs ├── Polygons.hs ├── Segment.hs ├── Segment └── Bernstein.hs ├── Shapes.hs ├── Size.hs ├── Transform.hs ├── Types.hs └── Vector.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-newstyle 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | .virthualenv 9 | *~ 10 | .hsenv_* 11 | dist_* 12 | history 13 | TAGS 14 | cabal.project.local 15 | .cabal-sandbox/ 16 | cabal.sandbox.config 17 | .stack-work/ 18 | codex.tags 19 | .ghc.environment.* 20 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This Travis job script has been generated by a script via 2 | # 3 | # runghc make_travis_yml_2.hs 'geometry.cabal' 4 | # 5 | # For more information, see https://github.com/haskell-CI/haskell-ci 6 | # 7 | language: c 8 | sudo: false 9 | 10 | git: 11 | submodules: false # whether to recursively clone submodules 12 | 13 | cache: 14 | directories: 15 | - $HOME/.cabal/packages 16 | - $HOME/.cabal/store 17 | 18 | before_cache: 19 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log 20 | # remove files that are regenerated by 'cabal update' 21 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* 22 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json 23 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache 24 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar 25 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx 26 | 27 | - rm -rfv $HOME/.cabal/packages/head.hackage 28 | 29 | matrix: 30 | include: 31 | - compiler: "ghc-8.6.3" 32 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 33 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.3], sources: [hvr-ghc]}} 34 | - compiler: "ghc-8.4.4" 35 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 36 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.4.4], sources: [hvr-ghc]}} 37 | - compiler: "ghc-8.2.2" 38 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 39 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.2.2], sources: [hvr-ghc]}} 40 | - compiler: "ghc-8.0.2" 41 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 42 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.0.2], sources: [hvr-ghc]}} 43 | 44 | before_install: 45 | - HC=${CC} 46 | - HCPKG=${HC/ghc/ghc-pkg} 47 | - unset CC 48 | - ROOTDIR=$(pwd) 49 | - mkdir -p $HOME/.local/bin 50 | - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH" 51 | - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) 52 | - echo $HCNUMVER 53 | 54 | install: 55 | - cabal --version 56 | - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" 57 | - BENCH=${BENCH---enable-benchmarks} 58 | - TEST=${TEST---enable-tests} 59 | - HADDOCK=${HADDOCK-true} 60 | - UNCONSTRAINED=${UNCONSTRAINED-true} 61 | - NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false} 62 | - GHCHEAD=${GHCHEAD-false} 63 | - travis_retry cabal update -v 64 | - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config" 65 | - rm -fv cabal.project cabal.project.local 66 | - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' 67 | - "printf 'packages: \".\"\\n' > cabal.project" 68 | - "printf 'write-ghc-environment-files: always\\n' >> cabal.project" 69 | - touch cabal.project.local 70 | - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- geometry | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi" 71 | - cat cabal.project || true 72 | - cat cabal.project.local || true 73 | - if [ -f "./configure.ac" ]; then 74 | (cd "." && autoreconf -i); 75 | fi 76 | - rm -f cabal.project.freeze 77 | - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all 78 | - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all 79 | - rm -rf .ghc.environment.* "."/dist 80 | - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) 81 | 82 | # Here starts the actual work to be performed for the package under test; 83 | # any command which exits with a non-zero exit code causes the build to fail. 84 | script: 85 | # test that source-distributions can be generated 86 | - cabal new-sdist all 87 | - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ 88 | - cd ${DISTDIR} || false 89 | - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; 90 | - "printf 'packages: geometry-*/*.cabal\\n' > cabal.project" 91 | - "printf 'write-ghc-environment-files: always\\n' >> cabal.project" 92 | - touch cabal.project.local 93 | - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- geometry | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi" 94 | - cat cabal.project || true 95 | - cat cabal.project.local || true 96 | # this builds all libraries and executables (without tests/benchmarks) 97 | - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all 98 | 99 | # build & run tests, build benchmarks 100 | - cabal new-build -w ${HC} ${TEST} ${BENCH} all 101 | 102 | # cabal check 103 | - (cd geometry-* && cabal check) 104 | 105 | # haddock 106 | - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi 107 | 108 | # Build without installed constraints for packages in global-db 109 | - if $UNCONSTRAINED; then rm -f cabal.project.local; echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks all; else echo "Not building without installed constraints"; fi 110 | 111 | # REGENDATA ["geometry.cabal"] 112 | # EOF 113 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/diagrams/geometry/945c8c36b22e71d0c0e4427f23de6614f4e7594a/ChangeLog.md -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016, Christopher Chalmers 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Christopher Chalmers nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## geometry 2 | 3 | A Haskell geometry library build on top of [`linear`](http://hackage.haskell.org/package/linear). 4 | 5 | ### Overview of changes from diagrams 6 | 7 | * Transformations are now in strict matrix form. The linear matrix is 8 | stored along with its inverse and a translation: 9 | 10 | ``` 11 | data Transformation v n = T !(v (v n)) !(v (v n)) !(v n) 12 | ``` 13 | 14 | This should give us O(1) transform, and I hope it's more efficient 15 | overall but I haven't benchmarked this yet. 16 | 17 | * Envelopes now return an `Interval` instead of a single value. The 18 | calculations to compute the lower interval are exactly the same, we 19 | just take the `min` instead of the `max`. This means that many 20 | operations like `boundingBox` and `hcat` are essentially twice as 21 | fast. 22 | 23 | The internal envelope function now always expects a unit vector. 24 | This means we no longer need to calculate the norm of the vector at 25 | every step. 26 | 27 | Since envelopes are an integral part of diagrams, a lot of time has 28 | been spent optimising them. Envelopes for trails are around 20x faster 29 | (and almost to 100x faster if we use unboxed trails (needs more 30 | benchmarking)). 31 | 32 | * Segments are now separated into `Segment` and `ClosingSegment`. A 33 | large part of this change is for performance reasons. There's one 34 | fewer constructors to unravel and ghc seemed to have a hard time 35 | optimising the previous GADT layout (especially for unboxed trails). 36 | 37 | I also believe this is a simpler representation to use, especially for 38 | beginners. The old system of `Open` segments are used to close loops 39 | was confusing (at least to me). 40 | 41 | * Lines now only cache the total offset and use `Data.Sequence` instead 42 | of `Data.FingerTree`s: 43 | 44 | ``` 45 | Line v n = Line (Seq (Segment v n)) !(v n) 46 | ``` 47 | 48 | The old system of caching envelopes didn't really work since you still 49 | have to go through each segment to calculate an envelope anyway. The 50 | total offset is still cached because it's used for operations like 51 | `closeLine` and is relatively cheap to cache. I don't cache the 52 | arc-length because this is less used value, much more expensive to 53 | calculate and can't be done exactly (in general). I plan to add other 54 | means for working with the arc length. 55 | 56 | There is still some benefit to using `Data.FingerTree` even if we're 57 | only caching the offset. Split operations with `Data.Sequence` are 58 | O(n) since we need to recompute the offset up to the split, but it's 59 | O(log n) for fingertrees. However the `splitAtParam` instance for 60 | lines is dubious at best (I can't see much practical use for it). 61 | Operations that do need to split lines, like path intersections, need 62 | to go through each segment anyway. 63 | 64 | `Data.Sequence` is a fingertree internally but I found it around 50% 65 | faster than `Data.FingerTree` so I've stuck with it. 66 | 67 | * The old `Trail'` is gone. The hierarchy is now: 68 | 69 | ``` 70 | Line v n = Line (Seq (Segment v n)) !(v n) 71 | Loop v n = Loop (Line v n) (ClosingSegment v n) 72 | Trail v n = Line v n | Loop v n 73 | ``` 74 | 75 | Again, I believe this is easier for beginners to understand as well as 76 | easier for ghc to optimise. 77 | 78 | * The `TrailLike` class has changed its name to `FromTrail`. I felt like 79 | `TrailLike` wasn't clear and `FromTrail` is a more consistent with 80 | other things like `ToPath`, `HasX` etc. 81 | 82 | * `Diagrams.Core.V` has moved to `Geometry.Space`. Also many of the 83 | alias type classes (`OrderedField`, etc.) have been moved here. 84 | 85 | * `Diagrams.Tangent` has merged into `Geometry.Parametric` since this is 86 | all it really gets used for. (I'm trying to reduce the total number 87 | of modules since there's so many) 88 | 89 | * The `Alignable` class has been removed. Alignment functions now use 90 | `Enveloped`. (The previous `Alignable` instances either used enveloped 91 | anyway, or had bogus definitions (like for functions)). This also 92 | lets us make more performant definitions for things like `hcat`. 93 | 94 | * Generally type constructors are strict and exposed. This is aimed at 95 | wider audience than just diagrams users and sometimes exposing the 96 | constructors allows more flexibility, especially for performance. It 97 | also may help people understand how something works. 98 | 99 | I'm undecided whether `Geometry` should hide the constructors (for 100 | example you'd have to import `Geometry.BoundingBox` explicitly to get 101 | the bounding box constructor). 102 | 103 | ### Things to still think about 104 | 105 | * I've added a `Rotational` class to help with 3D rotations (which turn 106 | out to be pretty tricky). I've also added Euler angles which are also 107 | pretty confusing and have no canonical form, I've just picked the one 108 | I needed for my camera. I'm still unsure about these. 109 | 110 | * I've rewritten the `Geometry.ThreeD.Camera` so I could use it with the 111 | GL backend. I'm still not happy with it. Part of the problem is 112 | there's no canonical representation for a camera (look vectors or 113 | euler angles or something else). Also I use GL camera conventions and 114 | it would be difficult for someone to use it with a 3D system with 115 | another camera convention. 116 | 117 | * I have written a working implementation for unboxed trails. These 118 | aren't as nice for constructing paths since they have O(n) 119 | concatenation, but once a path has been constructed they are around 120 | 4-8x faster for things like envelope calculations. Making them ideal 121 | for storing in diagrams. 122 | 123 | The implementation is more difficult, we have things like an ugly 124 | Unbox (v n) constraint and I'm not sure the best internal 125 | representation for them. I've left them out for now. There's already 126 | so much to do, I don't know if they'll make it to the initial release. 127 | 128 | * I haven't added the `Deformable` class yet. I'd like to a have a 129 | proper way to project 3D onto 2D but for now I'll probably just port 130 | `Deformable` as it is. 131 | 132 | ### Future work (doubt it'll make the initial release) 133 | 134 | * The cubic spline implementation is pretty inefficient. It keeps the 135 | whole list in memory and traverses it multiple times. It also has an 136 | ugly `Num (v n)` constraint. 137 | 138 | * I feel like we need to add quadratic segments sooner or later. They 139 | have lots of nice properties like being closed under projective 140 | transforms and an exact formula for arc length. They're also used a 141 | lot in fonts and rendering. 142 | 143 | * I'd like to have to have boolean path operations. I know kirstof's 144 | `cubicbezier` package has them and we use them in `diagrams-contrib` 145 | but I don't feel like it's a proper geometry library without native 146 | boolean operations. 147 | 148 | 149 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /benchmarks/Folds.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | 5 | -- | Benchmarks for folds over paths. This includes things like 6 | -- envelopes and traces. 7 | 8 | import Criterion.Main 9 | import Control.DeepSeq 10 | 11 | import Geometry 12 | 13 | import Samples 14 | 15 | main :: IO () 16 | main = do 17 | let path10 = toPath . take 10 18 | let !dragon8 = fromOffsets (dragonOffsets 8) :: Path V2 Double 19 | !squares10 = path10 (randomSquares 0) 20 | !rects10 = path10 (randomRects 1) 21 | !circles10 = path10 (randomCircles 2) 22 | !ellipses10 = path10 (randomEllipses 3) 23 | !triangles10 = path10 (randomTriangles 4) 24 | let trace = traceV origin (V2 0.4 0.7) 25 | let crossings = \t -> sample t origin 26 | defaultMain 27 | [ bgroup "bounding-box" 28 | [ bench "dragon-8" $ whnf (diameter unitX) dragon8 29 | , bench "squares-10" $ whnf (diameter unitX) squares10 30 | , bench "rects-10" $ whnf (diameter unitX) rects10 31 | , bench "circles-10" $ whnf (diameter unitX) circles10 32 | , bench "ellipses-10" $ whnf (diameter unitX) ellipses10 33 | , bench "triangles-10" $ whnf (diameter unitX) triangles10 34 | ] 35 | , bgroup "trace" 36 | [ bench "dragon-8" $ nf trace dragon8 37 | , bench "squares-10" $ nf trace squares10 38 | , bench "rects-10" $ nf trace rects10 39 | , bench "circles-10" $ nf trace circles10 40 | , bench "ellipses-10" $ nf trace ellipses10 41 | , bench "triangles-10" $ nf trace triangles10 42 | ] 43 | , bgroup "crossings" 44 | [ bench "dragon-8" $ whnf crossings dragon8 45 | , bench "squares-10" $ whnf crossings squares10 46 | , bench "rects-10" $ whnf crossings rects10 47 | , bench "circles-10" $ whnf crossings circles10 48 | , bench "ellipses-10" $ whnf crossings ellipses10 49 | , bench "triangles-10" $ whnf crossings triangles10 50 | ] 51 | ] 52 | 53 | -------------------------------------------------------------------------------- /benchmarks/Samples.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE GADTs #-} 3 | module Samples 4 | ( dragonOffsets 5 | , randomSquares 6 | , randomRects 7 | , randomCircles 8 | , randomEllipses 9 | , randomTriangles 10 | ) where 11 | 12 | import Geometry hiding (P) 13 | import System.Random.PCG.Pure 14 | import System.Random.PCG.Class 15 | import Data.Word 16 | 17 | (#) :: a -> (a -> b) -> b 18 | a # f = f a 19 | infixl 8 # 20 | 21 | -- | Infinite list of random doubles given some seed. 22 | floats :: Word64 -> [Double] 23 | floats seed = go (initFrozen 0xdcb850c5b9d7eeba seed) where 24 | go g = realToFrac (wordToFloat r) : go g' 25 | where 26 | (r, g') = next' g 27 | 28 | ------------------------------------------------------------------------ 29 | -- Generated 30 | ------------------------------------------------------------------------ 31 | 32 | -- Dragon curve -------------------------------------------------------- 33 | 34 | data Tok = F | P | M | X | Y 35 | 36 | rewriteFunction :: Tok -> [Tok] 37 | rewriteFunction X = [X, P, Y, F, P] 38 | rewriteFunction Y = [M, F, X, M, Y] 39 | rewriteFunction t = [t] 40 | {-# INLINE rewriteFunction #-} 41 | 42 | gens :: [[Tok]] 43 | gens = iterate (concatMap rewriteFunction) [F, X] 44 | {-# INLINE gens #-} 45 | 46 | toks2offsets :: [Tok] -> [V2 Double] 47 | toks2offsets xs = [v | (Just v, _) <- scanl f (Nothing, unitX) xs] where 48 | f (_, dir) F = (Just dir, dir) 49 | f (_, dir) P = (Nothing, perp dir) 50 | f (_, dir) M = (Nothing, negate $ perp dir) 51 | f (_, dir) _ = (Nothing, dir) 52 | {-# INLINE toks2offsets #-} 53 | 54 | dragonOffsets :: Int -> [V2 Double] 55 | dragonOffsets n = toks2offsets $ gens !! n 56 | {-# INLINE dragonOffsets #-} 57 | 58 | ------------------------------------------------------------------------ 59 | -- Random Shapes 60 | ------------------------------------------------------------------------ 61 | 62 | -- Squares ------------------------------------------------------------- 63 | 64 | randomSquares :: Word64 -> [Located (Trail V2 Double)] 65 | randomSquares = go . floats where 66 | go (r1:r2:r3:rs) = (square w `at` mkP2 x y) : go rs 67 | where 68 | w = r1 * 10 + 0.5 69 | x = r2 * 10 70 | y = r3 * 10 71 | {-# INLINE randomSquares #-} 72 | 73 | randomRects :: Word64 -> [Located (Trail V2 Double)] 74 | randomRects = go . floats where 75 | go (r1:r2:r3:r4:rs) = (rect w h `at` mkP2 x y) : go rs 76 | where 77 | w = r1 * 10 + 0.1 78 | h = r2 * 10 + 0.1 79 | x = r3 * 100 - 50 80 | y = r4 * 100 - 50 81 | {-# INLINE randomRects #-} 82 | 83 | -- Circles ------------------------------------------------------------- 84 | 85 | randomCircles :: Word64 -> [Located (Trail V2 Double)] 86 | randomCircles = go . floats where 87 | go (r1:r2:r3:rs) = (circle r `at` mkP2 x y) : go rs 88 | where 89 | r = r1 * 10 + 0.5 90 | x = r2 * 100 - 50 91 | y = r3 * 100 - 50 92 | {-# INLINE randomCircles #-} 93 | 94 | randomEllipses :: Word64 -> [Located (Trail V2 Double)] 95 | randomEllipses = go . floats where 96 | go (r1:r2:r3:r4:rs) = (ellipse e # scale r `at` mkP2 x y) : go rs 97 | where 98 | r = r1 * 10 + 0.1 99 | e = r2 * 0.9 100 | y = r3 * 100 - 50 101 | x = r4 * 100 - 50 102 | {-# INLINE randomEllipses #-} 103 | 104 | -- Triangles ----------------------------------------------------------- 105 | 106 | randomTriangles :: Word64 -> [Located (Trail V2 Double)] 107 | randomTriangles seed = go (floats seed) where 108 | go (r1:r2:r3:r4:rs) = (triangle w # rotate a `at` mkP2 x y) : go rs 109 | where 110 | w = r1 * 10 + 0.1 111 | a = r2 @@ turn 112 | x = r3 * 100 - 50 113 | y = r4 * 100 - 50 114 | {-# INLINE randomTriangles #-} 115 | 116 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_Combinators_appendsEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_Combinators_besideEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_Combinators_positionEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_CubicSpline_cubicSplineEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_Trail_closeLineEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_Trail_explodeTrailEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_Trail_fromOffsetsEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_Trail_fromSegmentsEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_Trail_fromVerticesEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_Trail_glueLineEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_Trail_twiddleEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Arc_annularWedgeEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Arc_arc'Ex.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Arc_arcBetweenEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Arc_wedgeEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Curvature_diagramA.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Curvature_diagramNeg.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Curvature_diagramPos.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Curvature_diagramZero.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Offset_cubicOffsetExample.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Offset_expandLoopExample.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Offset_expandTrailExample.svg: -------------------------------------------------------------------------------- 1 | 2 | LineCapSquareLineCapRoundLineCapButt -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Offset_offsetTrailExample.svg: -------------------------------------------------------------------------------- 1 | 2 | LineJoinBevelLineJoinRoundLineJoinMiter -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Offset_offsetTrailLeftExample.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Offset_offsetTrailOuterExample.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Shapes_decagonEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Shapes_dodecagonEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Shapes_hendecagonEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Shapes_heptagonEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Shapes_hexagonEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Shapes_hruleEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Shapes_nonagonEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Shapes_octagonEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Shapes_pentagonEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Shapes_rectEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Shapes_roundedRectEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Shapes_squareEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Shapes_triangleEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Shapes_unitSquareEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /diagrams/src_Geometry_TwoD_Shapes_vruleEx.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /geometry.cabal: -------------------------------------------------------------------------------- 1 | name: geometry 2 | version: 0.1.0.0 3 | synopsis: Generic library for describing and manipulating 2- and 3-dimensional 4 | geometry. 5 | description: This library consists of all the purely geometric 6 | definitions used in the diagrams vector graphics EDSL, split out into 7 | their own package for easier reuse in other projects. 8 | homepage: https://diagrams.github.io 9 | license: BSD3 10 | license-file: LICENSE 11 | author: Christopher Chalmers 12 | maintainer: diagrams-discuss@googlegroups.com 13 | bug-reports: https://github.com/diagrams/geometry/issues 14 | category: Graphics 15 | build-type: Simple 16 | extra-source-files: ChangeLog.md 17 | cabal-version: 1.18 18 | extra-source-files: ChangeLog.md, README.md, diagrams/*.svg 19 | extra-doc-files: diagrams/*.svg 20 | tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.3 21 | 22 | source-repository head 23 | type: git 24 | location: http://github.com/diagrams/geometry.git 25 | 26 | library 27 | exposed-modules: 28 | Geometry 29 | Geometry.CubicSpline 30 | Geometry.CubicSpline.Boehm 31 | Geometry.CubicSpline.Internal 32 | Geometry.ThreeD.Camera 33 | Geometry.ThreeD.Combinators 34 | Geometry.ThreeD.Shapes 35 | Geometry.ThreeD.Size 36 | Geometry.ThreeD.Transform 37 | Geometry.ThreeD.Types 38 | Geometry.ThreeD.Vector 39 | Geometry.Angle 40 | Geometry.BoundingBox 41 | Geometry.Combinators 42 | Geometry.Direction 43 | Geometry.Envelope 44 | Geometry.HasOrigin 45 | Geometry.Juxtapose 46 | Geometry.Located 47 | Geometry.Parametric 48 | Geometry.Path 49 | Geometry.Points 50 | Geometry.Query 51 | Geometry.Segment 52 | Geometry.Size 53 | Geometry.Space 54 | Geometry.Trace 55 | Geometry.Trail 56 | Geometry.Transform 57 | Geometry.TwoD.Arc 58 | Geometry.TwoD.Combinators 59 | Geometry.TwoD.Curvature 60 | Geometry.TwoD.Ellipse 61 | Geometry.TwoD.Offset 62 | Geometry.TwoD.Path 63 | Geometry.TwoD.Points 64 | Geometry.TwoD.Polygons 65 | Geometry.TwoD.Segment 66 | Geometry.TwoD.Segment.Bernstein 67 | Geometry.TwoD.Shapes 68 | Geometry.TwoD.Size 69 | Geometry.TwoD.Transform 70 | Geometry.TwoD.Types 71 | Geometry.TwoD.Vector 72 | other-extensions: 73 | BangPatterns DeriveFunctor EmptyDataDecls FlexibleContexts 74 | FlexibleInstances GADTs GeneralizedNewtypeDeriving 75 | MultiParamTypeClasses StandaloneDeriving TemplateHaskell 76 | TypeFamilies TypeOperators UndecidableInstances 77 | ConstrainedClassMethods RankNTypes NoMonomorphismRestriction 78 | ScopedTypeVariables ViewPatterns Rank2Types CPP DeriveGeneric 79 | DefaultSignatures DataKinds LambdaCase DeriveDataTypeable 80 | ConstraintKinds TypeSynonymInstances 81 | build-depends: 82 | base >= 4.6 && < 5.0, 83 | adjunctions >= 4.3 && < 4.5, 84 | array >= 0.5 && < 0.6, 85 | binary >= 0.8 && < 0.9, 86 | bytes >= 0.16 && < 0.18, 87 | cereal >= 0.5 && < 0.6, 88 | containers >= 0.5 && < 0.7, 89 | contravariant >= 1.4 && < 1.6, 90 | data-default-class >= 0.1 && < 0.2, 91 | deepseq >= 1.4 && < 1.5, 92 | diagrams-solve >= 0.1 && < 0.2, 93 | distributive >= 0.5 && < 0.7, 94 | hashable >= 1.2 && < 1.3, 95 | intervals >= 0.8 && < 0.9, 96 | lens >= 4.15 && < 4.20, 97 | linear >= 1.20.1 && < 1.21, 98 | monoid-extras >= 0.4 && < 0.6, 99 | profunctors >= 5.2 && < 5.4, 100 | unordered-containers >= 0.2 && < 0.3, 101 | vector >= 0.12 && < 0.13 102 | hs-source-dirs: src 103 | default-language: Haskell2010 104 | ghc-options: -Wall 105 | -------------------------------------------------------------------------------- /src/Geometry.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Geometry 4 | -- Copyright : (c) 2011-2017 diagrams team (see LICENSE) 5 | -- License : BSD-style (see LICENSE) 6 | -- Maintainer : diagrams-discuss@googlegroups.com 7 | -- 8 | -- This module reexports the geometry library. Constructors that are 9 | -- not safe to use directly are not reexported from here but the 10 | -- constructors are available by importing the module they are defined 11 | -- in. 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module Geometry 16 | ( module Geometry.Angle 17 | , module Geometry.BoundingBox 18 | , module Geometry.Combinators 19 | , module Geometry.CubicSpline 20 | , module Geometry.Direction 21 | , module Geometry.Envelope 22 | , module Geometry.HasOrigin 23 | , module Geometry.Juxtapose 24 | , module Geometry.Located 25 | , module Geometry.Parametric 26 | , module Geometry.Path 27 | , module Geometry.Points 28 | , module Geometry.Query 29 | , module Geometry.Segment 30 | , module Geometry.Size 31 | , module Geometry.Space 32 | , module Geometry.Trace 33 | , module Geometry.Trail 34 | , module Geometry.Transform 35 | 36 | -- * TwoD 37 | , module Geometry.TwoD.Arc 38 | , module Geometry.TwoD.Combinators 39 | , module Geometry.TwoD.Curvature 40 | , module Geometry.TwoD.Ellipse 41 | , module Geometry.TwoD.Path 42 | , module Geometry.TwoD.Points 43 | , module Geometry.TwoD.Polygons 44 | , module Geometry.TwoD.Segment 45 | , module Geometry.TwoD.Size 46 | , module Geometry.TwoD.Shapes 47 | , module Geometry.TwoD.Transform 48 | , module Geometry.TwoD.Types 49 | , module Geometry.TwoD.Vector 50 | 51 | -- * ThreeD 52 | , module Geometry.ThreeD.Camera 53 | , module Geometry.ThreeD.Combinators 54 | , module Geometry.ThreeD.Size 55 | , module Geometry.ThreeD.Shapes 56 | , module Geometry.ThreeD.Transform 57 | , module Geometry.ThreeD.Vector 58 | , module Geometry.ThreeD.Types 59 | 60 | ) where 61 | 62 | import Geometry.Angle 63 | import Geometry.BoundingBox hiding (BoundingBox (..)) 64 | import Geometry.BoundingBox (BoundingBox) 65 | import Geometry.Combinators 66 | import Geometry.CubicSpline 67 | import Geometry.Direction hiding (Direction (..)) 68 | import Geometry.Direction (Direction) 69 | import Geometry.Envelope hiding (Envelope (..)) 70 | import Geometry.Envelope (Envelope) 71 | import Geometry.HasOrigin 72 | import Geometry.Juxtapose 73 | import Geometry.Located 74 | import Geometry.Parametric 75 | import Geometry.Path hiding (pathPoints) 76 | import Geometry.Points 77 | import Geometry.Query 78 | import Geometry.Segment 79 | import Geometry.Size hiding (SizeSpec (..)) 80 | import Geometry.Size (SizeSpec) 81 | import Geometry.Space 82 | import Geometry.ThreeD.Camera 83 | import Geometry.ThreeD.Combinators 84 | import Geometry.ThreeD.Shapes 85 | import Geometry.ThreeD.Size 86 | import Geometry.ThreeD.Transform 87 | import Geometry.ThreeD.Types 88 | import Geometry.ThreeD.Vector 89 | import Geometry.Trace hiding (Trace (..)) 90 | import Geometry.Trace (Trace) 91 | import Geometry.Trail hiding (linePoints, loopPoints, 92 | trailPoints) 93 | import Geometry.Transform hiding (Transformation (..)) 94 | import Geometry.Transform (Transformation) 95 | import Geometry.TwoD.Arc 96 | import Geometry.TwoD.Combinators 97 | import Geometry.TwoD.Curvature 98 | import Geometry.TwoD.Ellipse 99 | import Geometry.TwoD.Path 100 | import Geometry.TwoD.Points 101 | import Geometry.TwoD.Polygons 102 | import Geometry.TwoD.Segment 103 | import Geometry.TwoD.Shapes 104 | import Geometry.TwoD.Size 105 | import Geometry.TwoD.Transform 106 | import Geometry.TwoD.Types 107 | import Geometry.TwoD.Vector hiding (e) 108 | -------------------------------------------------------------------------------- /src/Geometry/CubicSpline.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Geometry.CubicSpline 7 | -- Copyright : (c) 2011-2017 diagrams team (see LICENSE) 8 | -- License : BSD-style (see LICENSE) 9 | -- Maintainer : diagrams-discuss@googlegroups.com 10 | -- 11 | -- A /cubic spline/ is a smooth, connected sequence of cubic curves. 12 | -- This module provides two methods for constructing splines. 13 | -- 14 | -- The 'cubicSpline' method can be used to create closed or open cubic 15 | -- splines from a list of points. The resulting splines /pass through/ 16 | -- all the control points, but depend on the control points in a 17 | -- "global" way (that is, changing one control point may alter the 18 | -- entire curve). For access to the internals of the spline 19 | -- generation algorithm, see "Diagrams.CubicSpline.Internal". 20 | -- 21 | -- 'bspline' creates a cubic B-spline, which starts and ends at the 22 | -- first and last control points, but does not necessarily pass 23 | -- through any of the other control points. It depends on the control 24 | -- points in a "local" way, that is, changing one control point will 25 | -- only affect a local portion of the curve near that control point. 26 | -- 27 | ----------------------------------------------------------------------------- 28 | module Geometry.CubicSpline 29 | ( 30 | -- * Cubic splines 31 | cubicSpline 32 | , cubicSplineLine 33 | , cubicSplineLoop 34 | , cubicSplineLineVec 35 | , cubicSplineLoopVec 36 | 37 | -- * B-splines 38 | , bspline 39 | 40 | ) where 41 | 42 | 43 | import Geometry.CubicSpline.Boehm 44 | import Geometry.CubicSpline.Internal 45 | import Geometry.Located 46 | import Geometry.Segment 47 | import Geometry.Space 48 | import Geometry.Trail 49 | 50 | import Linear 51 | import Linear.Affine 52 | 53 | import qualified Data.Vector as B 54 | import qualified Data.Vector.Generic as V 55 | import qualified Data.Vector.Unboxed as U 56 | 57 | -- | Construct a spline path-like thing of cubic segments from a list of 58 | -- vertices, with the first vertex as the starting point. The first 59 | -- argument specifies whether the path should be closed. 60 | -- 61 | -- <> 62 | -- 63 | -- > import Geometry.CubicSpline 64 | -- > pts = map p2 [(0,0), (2,3), (5,-2), (-4,1), (0,3)] 65 | -- > spot = circle 0.2 # fc blue # lw none 66 | -- > mkPath closed = position (zip pts (repeat spot)) 67 | -- > <> cubicSpline closed pts 68 | -- > cubicSplineEx = (mkPath False ||| strutX 2 ||| mkPath True) 69 | -- > # centerXY # pad 1.1 70 | -- 71 | -- For more information, see . 72 | cubicSpline 73 | :: (InSpace v n t, FromTrail t, Additive v, Fractional n) 74 | => Bool -> [Point v n] -> t 75 | cubicSpline _ [] = fromLocTrail $ mempty `at` origin 76 | cubicSpline closed pps@(p:ps) 77 | | closed = fromLocLoop $ cubicSplineLoop offsets `at` p 78 | | otherwise = fromLocLine $ cubicSplineLine offsets `at` p 79 | where offsets = zipWith (flip (.-.)) pps ps 80 | 81 | -- $cubic-spline 82 | -- A cubic spline is a smooth curve made up of cubic bezier segments 83 | -- whose offsets match the input offsets. 84 | -- 85 | -- - For lines the curvatures at the start of the first segment and 86 | -- end of the last segment are both zero (a "natural" cubic spline). 87 | -- - For loops the tangent at the end of last segment matches the 88 | -- tangent at the begining of the first segment. 89 | -- 90 | -- These requirements uniquely define the cubic spline. In the case that 91 | -- only one offset is given, a linear segment is returned. 92 | 93 | -- Lines --------------------------------------------------------------- 94 | 95 | -- | See 'cubicSpline'. 96 | cubicSplineLineVec 97 | :: (V.Vector vec (v n), V.Vector vec n, Additive v, Fractional n) 98 | => vec (v n) 99 | -> Line v n 100 | cubicSplineLineVec vs 101 | | n <= 1 = lineFromSegments $ map Linear (V.toList vs) 102 | | otherwise = cubicSplineLineFromTangents vs off dv 103 | where 104 | n = V.length vs 105 | off = V.foldl' (^+^) zero vs 106 | dv = cubicSplineLineTangents vs 107 | {-# INLINE cubicSplineLineVec #-} 108 | 109 | cubicSplineLineV2D 110 | :: [V2 Double] 111 | -> Line V2 Double 112 | cubicSplineLineV2D = cubicSplineLineVec . U.fromList 113 | 114 | -- | See 'cubicSpline'. 115 | cubicSplineLine 116 | :: (Additive v, Fractional n) 117 | => [v n] -> Line v n 118 | cubicSplineLine = cubicSplineLineVec . B.fromList 119 | {-# INLINE [0] cubicSplineLine #-} 120 | 121 | -- Loops --------------------------------------------------------------- 122 | 123 | cubicSplineLoopVec 124 | :: (V.Vector vec (v n), V.Vector vec n, Additive v, Fractional n) 125 | => vec (v n) -> Loop v n 126 | cubicSplineLoopVec vs 127 | | n <= 1 = loopFromSegments (map Linear (V.toList vs)) linearClosing 128 | | otherwise = cubicSplineLoopFromTangents vs off dv 129 | where 130 | n = V.length vs 131 | off = V.foldl' (^+^) zero vs 132 | dv = cubicSplineLoopTangents vs (negated off) 133 | {-# INLINE cubicSplineLoopVec #-} 134 | 135 | -- | See 'cubicSpline'. 136 | cubicSplineLoopV2D 137 | :: [V2 Double] -> Loop V2 Double 138 | cubicSplineLoopV2D = cubicSplineLoopVec . U.fromList 139 | 140 | -- | See 'cubicSpline'. 141 | cubicSplineLoop 142 | :: (Additive v, Fractional n) 143 | => [v n] -> Loop v n 144 | cubicSplineLoop = cubicSplineLoopVec . B.fromList 145 | {-# INLINE [0] cubicSplineLoop #-} 146 | 147 | {-# RULES 148 | "cubicSplineLine/V2 Double" cubicSplineLine = cubicSplineLineV2D; 149 | "cubicSplineLoop/V2 Double" cubicSplineLoop = cubicSplineLoopV2D 150 | #-} 151 | 152 | -------------------------------------------------------------------------------- /src/Geometry/CubicSpline/Boehm.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Geometry.CubicSpline.Boehm 7 | -- Copyright : (c) 2015-2017 diagrams team (see LICENSE) 8 | -- License : BSD-style (see LICENSE) 9 | -- Maintainer : diagrams-discuss@googlegroups.com 10 | -- 11 | -- Boehm's algorithm for converting a cubic B-spline into a sequence 12 | -- of cubic Bezier curves. 13 | -- 14 | -- See 15 | -- 16 | -- * Thomas W. Sederberg, /An Introduction to B-Spline Curves/, 17 | -- 18 | -- 19 | -- * Lyle Ramshaw, /Blossoming: A Connect-the-Dots Approach to 20 | -- Splines/, 21 | -- 22 | -- 23 | ----------------------------------------------------------------------------- 24 | module Geometry.CubicSpline.Boehm 25 | ( BSpline 26 | , bsplineToBeziers 27 | , bspline 28 | ) where 29 | 30 | import Data.List (sort, tails) 31 | import Linear.Vector (Additive, lerp) 32 | import Control.Lens hiding (at) 33 | 34 | import Geometry.Space 35 | import Geometry.Points 36 | import Geometry.Located 37 | import Geometry.Trail 38 | import Geometry.Segment 39 | 40 | type BSpline v n = [Point v n] 41 | 42 | fromFixedSeg :: (Additive v, Num n) => FixedSegment v n -> (Located (Segment v n)) 43 | fromFixedSeg = view fixed 44 | 45 | -- | @affineCombo a b t x y@ computes an affine combination of x and y 46 | -- which lies at parameter t, if x has parameter a and y has parameter b. 47 | -- The usual @lerp@ arises by giving x parameter 0 and y parameter 1. 48 | affineCombo :: (Additive f, Fractional a) => a -> a -> a -> f a -> f a -> f a 49 | affineCombo a b t x y = lerp ((t-a)/(b-a)) y x 50 | {-# INLINE affineCombo #-} 51 | 52 | -- | @windows k xs@ yields all the length-@k@ windows from @xs@, e.g. 53 | -- @windows 3 [a,b,c,d,e] == [[a,b,c], [b,c,d], [c,d,e]]@. 54 | windows :: Int -> [a] -> [[a]] 55 | windows k = takeWhile ((==k) . length) . map (take k) . tails 56 | -- XXX inefficient 57 | 58 | -- | @extend k xs@ extends @xs@ on both ends by prepending @k@ copies 59 | -- of its head and appending @k@ copies of its last element. For example, 60 | -- @extend 2 [1..5] == [1,1,1,2,3,4,5,5,5]@. 61 | extend:: Int -> [a] -> [a] 62 | extend k xs = replicate k (head xs) ++ xs ++ replicate k (last xs) 63 | -- XXX inefficient 64 | 65 | -- | A "polar point" is a point along with three knot values. 66 | -- We consider the "blossom" of a cubic spline, a 3-ary symmetric 67 | -- polynomial; a polar point consists of 3 values paired with the 68 | -- output of the blossom at those input values. Blossoms have nice 69 | -- affine properties so this makes it easy to keep track of how 70 | -- points may be combined to yield other points of interest. 71 | -- 72 | -- Invariant: knot values are in nondecreasing order. 73 | data PolarPt v n = PP { unPP :: Point v n, _knots :: [n] } 74 | 75 | mkPolarPt :: Ord n => Point v n -> [n] -> PolarPt v n 76 | mkPolarPt pt kts = PP pt (sort kts) 77 | 78 | -- | Precondition: the knots of the two polar points overlap, like abc 79 | -- and bcd. The @Int@ should be 0 or 1, indicating which knot to 80 | -- replicate (0 means to replicate b, yielding bbc, 1 means to 81 | -- replicate c, yielding bcc). 82 | combine 83 | :: (Additive v, Fractional n, Ord n) 84 | => Int -> PolarPt v n -> PolarPt v n -> PolarPt v n 85 | combine k (PP pt1 kts1) (PP pt2 kts2) 86 | = mkPolarPt 87 | (affineCombo (head kts1) (last kts2) newKt pt1 pt2) 88 | (newKt : drop 1 kts1) 89 | where 90 | newKt = kts2 !! k 91 | 92 | -- | Convert a uniform cubic B-spline to a sequence of cubic beziers. 93 | -- (/Uniform/ refers to the fact that the knots are assumed to be 94 | -- evenly spaced, with no duplicates.) The knots at the end are 95 | -- replicated so the cubic spline begins and ends at the first and 96 | -- last control points, tangent to the line from the end control 97 | -- point to the next. 98 | bsplineToBeziers 99 | :: (Additive v, Fractional n, Num n, Ord n) 100 | => BSpline v n 101 | -> [FixedSegment v n] 102 | bsplineToBeziers controls = beziers 103 | where 104 | n = length controls 105 | numKnots = n + 2 106 | knots = take numKnots $ iterate (+1/(fromIntegral numKnots - 1)) 0 107 | 108 | -- The control points are P(a,b,c), P(b,c,d), P(c,d,e), and so on. 109 | controls' = zipWith mkPolarPt (extend 2 controls) (windows 3 $ extend 2 knots) 110 | 111 | -- The bezier internal control points are affine combinations of 112 | -- the spline control points. 113 | bezierControls = map combineC (windows 2 controls') 114 | combineC [pabc, pbcd] = (combine 0 pabc pbcd, combine 1 pabc pbcd) 115 | combineC _ = error "combineC must be called on a list of length 2" 116 | 117 | -- The bezier end points are affine combinations of the bezier 118 | -- control points. 119 | bezierEnds = map combineE (windows 2 bezierControls) 120 | combineE [(_,pabb),(pbbc,_)] = combine 0 pabb pbbc 121 | combineE _ = error "combineE must be called on a list of length 2" 122 | 123 | -- Finally, we actually put together the generated bezier segments. 124 | beziers = zipWith mkBezier (drop 1 bezierControls) (windows 2 bezierEnds) 125 | where 126 | mkBezier (paab,pabb) [paaa,pbbb] 127 | = FCubic (unPP paaa) (unPP paab) (unPP pabb) (unPP pbbb) 128 | mkBezier _ _ = error "mkBezier must be called on a list of length 2" 129 | 130 | -- Note that the above algorithm works in any dimension but is 131 | -- very specific to *cubic* splines. This can of course be 132 | -- generalized to higher degree splines but keeping track of 133 | -- everything gets a bit more complicated; to be honest I am not 134 | -- quite sure how to do it. 135 | 136 | -- | Generate a uniform cubic B-spline from the given control points. 137 | -- The spline starts and ends at the first and last control points, 138 | -- and is tangent to the line to the second(-to-last) control point. 139 | -- It does not necessarily pass through any of the other control 140 | -- points. 141 | bspline :: (InSpace v n t, FromTrail t, OrderedField n) => BSpline v n -> t 142 | bspline = fromLocSegments . fixup . map fromFixedSeg . bsplineToBeziers 143 | where 144 | fixup [] = [] `at` origin 145 | fixup (b1:rest) = (unLoc b1 : map unLoc rest) `at` loc b1 146 | -------------------------------------------------------------------------------- /src/Geometry/CubicSpline/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Geometry.CubicSpline.Internal 7 | -- Copyright : (c) 2011-2017 diagrams team (see LICENSE) 8 | -- License : BSD-style (see LICENSE) 9 | -- Maintainer : diagrams-discuss@googlegroups.com 10 | -- 11 | -- A /cubic spline/ is a smooth, connected sequence of cubic curves 12 | -- passing through a given sequence of points. This module implements 13 | -- a straightforward spline generation algorithm based on solving 14 | -- tridiagonal systems of linear equations. 15 | -- 16 | ----------------------------------------------------------------------------- 17 | module Geometry.CubicSpline.Internal 18 | ( 19 | -- * Solving for spline coefficents 20 | cubicSplineLineTangents 21 | , cubicSplineLoopTangents 22 | , cubicSplineLineFromTangents 23 | , cubicSplineLoopFromTangents 24 | ) where 25 | 26 | 27 | import Control.Monad.ST 28 | import Data.Foldable as F 29 | import qualified Data.Sequence as Seq 30 | import qualified Data.Vector.Generic as V 31 | import qualified Data.Vector.Generic.Mutable as M 32 | import qualified Data.Vector.Unboxed as U 33 | 34 | import Geometry.Segment 35 | import Geometry.Trail 36 | import Linear 37 | 38 | cubicSplineLineFromTangents 39 | :: (V.Vector vec (v n), Additive v, Fractional n) 40 | => vec (v n) -- ^ offsets 41 | -> v n -- ^ total offset 42 | -> vec (v n) -- ^ tangents (n+1 of them) 43 | -> Line v n 44 | cubicSplineLineFromTangents vv off dv = Line (Seq.fromFunction n f) off 45 | where 46 | n = V.length vv 47 | f i = bezier3 c1 c2 c3 where 48 | c1 = alpha ^/ 3 49 | c2 = (2*^alpha ^+^ beta)^/3 50 | c3 = v 51 | -- 52 | alpha = x 53 | beta = 3*^v ^-^ 2*^x ^-^ x' 54 | -- 55 | x' = dv V.! (i+1) 56 | x = dv V.! i 57 | v = vv V.! i 58 | 59 | {-# SPECIALISE 60 | cubicSplineLineFromTangents :: U.Vector (V2 Double) -> V2 Double -> U.Vector (V2 Double) -> Line V2 Double 61 | #-} 62 | 63 | cubicSplineLoopFromTangents 64 | :: (V.Vector vec (v n), Additive v, Fractional n) 65 | => vec (v n) -- ^ offsets 66 | -> v n -- ^ total offset 67 | -> vec (v n) -- ^ tangents (n+1 of them) 68 | -> Loop v n 69 | cubicSplineLoopFromTangents vv off dv = Loop line close 70 | where 71 | n = V.length vv 72 | line = cubicSplineLineFromTangents vv off dv 73 | close = cubicClosing c1 c2 where 74 | c1 = alpha ^/ 3 75 | c2 = (2*^alpha^+^ beta)^/3 76 | -- 77 | alpha = x 78 | beta = 3*^vn ^-^ 2*^x ^-^ x' 79 | -- 80 | x' = dv V.! 0 81 | x = dv V.! n 82 | vn = negated off 83 | 84 | {-# SPECIALISE 85 | cubicSplineLoopFromTangents :: U.Vector (V2 Double) -> V2 Double -> U.Vector (V2 Double) -> Loop V2 Double 86 | #-} 87 | 88 | -- | Get the tangents for the cubic spline of the input offsets, 89 | -- including the tangent at the end of the last segment. 90 | cubicSplineLineTangents 91 | :: forall vec v n. (V.Vector vec (v n), V.Vector vec n, Additive v, Fractional n) 92 | => vec (v n) -- ^ offsets 93 | -> vec (v n) -- ^ tangents (n+1 of them) 94 | cubicSplineLineTangents vs = V.create $ do 95 | let n = V.length vs 96 | cv <- M.new n :: ST s (V.Mutable vec s n) 97 | dv <- M.new (n+1) 98 | 99 | let v0 = vs V.! 0 100 | c0 = 1/2 101 | d0 = (3/2) *^ v0 102 | 103 | M.write cv 0 c0 104 | M.write dv 0 d0 105 | 106 | let forward !i !vm1 !cm1 !dm1 107 | | i < n = do 108 | let !v = vs V.! i 109 | let !c = 1 / (4 - cm1) 110 | let !d = c *^ (3*^(v ^+^ vm1) ^-^ dm1) 111 | M.write cv i c 112 | M.write dv i d 113 | forward (i+1) v c d 114 | | otherwise = do 115 | let !d = (3*^vm1 ^-^ dm1) ^/ (2 - cm1) 116 | M.write dv i d 117 | pure d 118 | 119 | xn <- forward 1 v0 c0 d0 120 | 121 | let backward !i !x' 122 | | i < 0 = pure () 123 | | otherwise = do 124 | d <- M.read dv i 125 | c <- M.read cv i 126 | let x = d ^-^ c*^x' 127 | M.write dv i x 128 | backward (i-1) x 129 | 130 | backward (n-1) xn 131 | pure dv 132 | 133 | {-# SPECIALISE 134 | cubicSplineLineTangents :: U.Vector (V2 Double) -> U.Vector (V2 Double) 135 | #-} 136 | 137 | ------------------------------------------------------------------------ 138 | -- Loop 139 | ------------------------------------------------------------------------ 140 | 141 | -- | Compute the nessesary tangents for the input vectors and closing 142 | -- segment for a natual cubic spline. 143 | cubicSplineLoopTangents 144 | :: forall vec v n. (V.Vector vec (v n), V.Vector vec n, Additive v, Fractional n) 145 | => vec (v n) -- ^ offsets 146 | -> v n -- ^ total offset 147 | -> vec (v n) -- ^ tangents (n+1 of them) 148 | cubicSplineLoopTangents vs vn = V.create $ do 149 | let n = V.length vs 150 | cv <- M.new n :: ST s (V.Mutable vec s n) 151 | dv <- M.new (n+1) 152 | uv <- M.new (n+1) :: ST s (V.Mutable vec s n) 153 | 154 | let v0 = vs V.! 0 155 | c0 = 1/3 156 | d0 = v0 ^+^ vn 157 | u0 = 1/3 158 | 159 | M.write cv 0 c0 160 | M.write dv 0 d0 161 | M.write uv 0 u0 162 | 163 | let forward i !vm1 !cm1 !dm1 !um1 164 | | i < n = do 165 | let !v = vs V.! i 166 | !c = 1 / (4 - cm1) 167 | !d = c *^ (3*^(v ^+^ vm1) ^-^ dm1) 168 | !u = c * (negate um1) 169 | M.write cv i c 170 | M.write dv i d 171 | M.write uv i u 172 | forward (i+1) v c d u 173 | | otherwise = do 174 | let c = 1 / (3 - cm1) 175 | u = c * (1 - um1) 176 | d = c *^ (3*^(vn ^+^ vm1) ^-^ dm1) 177 | M.write dv i d 178 | M.write uv i u 179 | 180 | forward 1 v0 c0 d0 u0 181 | 182 | let backward i !_ !_ | i < 0 = pure () 183 | backward i x' w' = do 184 | c <- M.read cv i 185 | d <- M.read dv i 186 | u <- M.read uv i 187 | let x = d ^-^ c*^x' 188 | w = u - c*w' 189 | M.write dv i x 190 | M.write uv i w 191 | backward (i-1) x w 192 | xn <- M.read dv n 193 | wn <- M.read uv n 194 | backward (n-1) xn wn 195 | 196 | x0 <- M.read dv 0 197 | w0 <- M.read uv 0 198 | 199 | let dsum = x0 ^+^ xn 200 | usum = w0 + wn 201 | !m = dsum ^/ (1 + usum) 202 | 203 | for_ [0..n] $ \i -> do 204 | x <- M.read dv i 205 | w <- M.read uv i 206 | let y = x ^-^ w *^ m 207 | M.write dv i y 208 | 209 | pure dv 210 | 211 | {-# SPECIALISE 212 | cubicSplineLoopTangents :: U.Vector (V2 Double) -> V2 Double -> U.Vector (V2 Double) 213 | #-} 214 | 215 | -- $cyclic-derivation 216 | -- 217 | -- For the cyclic case the matrix form of the equations is now 218 | -- 219 | -- | 4 1 1 | 220 | -- | 1 4 1 | 221 | -- | 1 4 1 | 222 | -- C = | ... | 223 | -- | 1 4 1 | 224 | -- | 1 1 4 | 225 | -- 226 | -- This matrix cannot be solved directly using the Thomas algorithm. 227 | -- Instead we make use of the Sherman-Morrison formula which states 228 | -- 229 | -- (A + uv^T)^-1 = A^-1 - (A^-1 uv^T A^-1)/(1 + v^T A^-1 u) 230 | -- 231 | -- for an invertable matrix A and column vectors u and v iff 232 | -- 1 + v^T A^-1 u /= 0. 233 | -- 234 | -- We choose column vectors 235 | -- 236 | -- u = v = [1, 0, ..., 0, 1]^T 237 | -- 238 | -- so that C = A + uv^T where 239 | -- 240 | -- | 3 1 | 241 | -- | 1 4 1 | 242 | -- | 1 4 1 | 243 | -- A = | ... | 244 | -- | 1 4 1 | 245 | -- | 1 3 | 246 | -- 247 | -- Now remember we wish to solve for x in the equation 248 | -- 249 | -- Cx = w 250 | -- 251 | -- where w is the vector containing sums of the offsets we're making the 252 | -- cubic spline out of. To solve we multiply by C^-1 on the left: 253 | -- 254 | -- x = C^-1 w 255 | -- = (A + uv^T)^-1 x 256 | -- 257 | -- Now we make use of the Sherman-Morrison formula 258 | -- 259 | -- x = (A^-1 - (A^-1 uv^T A^-1)/(1 + v^T A^-1 u)) w 260 | -- = A^-1 w - (A^-1 uv^T A^-1 w)/(1 + v^T A^-1 u) 261 | -- 262 | -- If we look carefully A^-1 is multiplied the two columns vectors w and 263 | -- u in this equation. Denoting 264 | -- 265 | -- w' = A^-1 w 266 | -- u' = A^-1 u 267 | -- 268 | -- we have 269 | -- 270 | -- x = w' - (u' v^T w')/(1 + v^T u') 271 | -- 272 | -- Let 273 | -- 274 | -- w_sum = v^T w' 275 | -- = w'[0] + w'[n] 276 | -- 277 | -- and 278 | -- 279 | -- u_sum = v^T u' 280 | -- = u'[0] + u'[n] 281 | -- 282 | -- Now v^T w' and 1 + v^T u' are scalars so we can write them as a 283 | -- coefficient to u': 284 | -- 285 | -- x = w' - (v^T w')/(1 + v^T u') u' 286 | -- = w' - w_sum/(1 + u_sum) u' 287 | -- 288 | -- Remember A is a tridiagonal matrix so we solve 289 | -- 290 | -- Aw' = w 291 | -- Au' = u 292 | -- 293 | -- using the Thomas algorithm (in one pass) to solve and use the 294 | -- equation for x above to get the values we need. 295 | 296 | -------------------------------------------------------------------------------- /src/Geometry/Direction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Geometry.Direction 8 | -- Copyright : (c) 2014-2017 diagrams team (see LICENSE) 9 | -- License : BSD-style (see LICENSE) 10 | -- Maintainer : diagrams-discuss@googlegroups.com 11 | -- 12 | -- A type for representing /directions/, which can be thought of as 13 | -- vectors whose magnitude has been forgotten, along with various 14 | -- utility functions. The 'Direction' type is polymorphic over the 15 | -- vector space. 16 | -- 17 | ----------------------------------------------------------------------------- 18 | 19 | module Geometry.Direction 20 | ( Direction (..) 21 | , _Dir 22 | , direction, dir 23 | , fromDirection, fromDir 24 | , angleBetweenDirs 25 | , dirBetween 26 | ) where 27 | 28 | import Control.Lens (Iso', iso, (%~)) 29 | import Data.Foldable as F 30 | import Data.Functor.Classes 31 | 32 | import Geometry.Angle 33 | import Geometry.Space 34 | import Geometry.Transform 35 | 36 | import Linear.Affine 37 | import Linear.Metric 38 | 39 | -------------------------------------------------------------------------------- 40 | -- Direction 41 | 42 | -- | A vector is described by a @Direction@ and a magnitude. So we 43 | -- can think of a @Direction@ as a vector that has forgotten its 44 | -- magnitude. @Direction@s can be used with 'fromDirection' and the 45 | -- lenses provided by its instances. 46 | -- 47 | -- If the constructor 'Dir' is used, the vector /must/ be a unit 48 | -- vector. 49 | newtype Direction v n = Dir (v n) 50 | deriving Functor 51 | 52 | instance (Eq1 v, Eq n) => Eq (Direction v n) where 53 | Dir v1 == Dir v2 = eq1 v1 v2 54 | {-# INLINE (==) #-} 55 | 56 | instance Show1 v => Show1 (Direction v) where 57 | liftShowsPrec x y d (Dir v) = showParen (d > 10) $ 58 | showString "direction " . liftShowsPrec x y 11 v 59 | 60 | instance (Show1 v, Show n) => Show (Direction v n) where 61 | showsPrec = showsPrec1 62 | 63 | type instance V (Direction v n) = v 64 | type instance N (Direction v n) = n 65 | 66 | instance (Metric v, F.Foldable v, Floating n) => Transformable (Direction v n) where 67 | transform t = _Dir %~ signorm . apply t 68 | 69 | instance HasTheta v => HasTheta (Direction v) where 70 | _theta = _Dir . _theta 71 | 72 | instance HasPhi v => HasPhi (Direction v) where 73 | _phi = _Dir . _phi 74 | 75 | -- | @_Dir@ is provided to allow efficient implementations of 76 | -- functions in particular vector-spaces, but should be used with 77 | -- care as it exposes too much information. In particular it must 78 | -- not be used to create a @Direction@ out of a non-unit vector. 79 | _Dir :: Iso' (Direction v n) (v n) 80 | _Dir = iso (\(Dir v) -> v) Dir 81 | {-# INLINE _Dir #-} 82 | 83 | -- | @direction v@ is the direction in which @v@ points. Returns an 84 | -- unspecified value when given the zero vector as input. 85 | direction :: (Metric v, Floating n) => v n -> Direction v n 86 | direction = Dir . signorm 87 | {-# INLINE direction #-} 88 | 89 | -- | A synonym for 'direction'. 90 | dir :: (Metric v, Floating n) => v n -> Direction v n 91 | dir = direction 92 | {-# INLINE dir #-} 93 | 94 | -- | @fromDirection d@ is the unit vector in the direction @d@. 95 | fromDirection :: Direction v n -> v n 96 | fromDirection (Dir v) = v 97 | {-# INLINE fromDirection #-} 98 | 99 | -- | A synonym for 'fromDirection'. 100 | fromDir :: Direction v n -> v n 101 | fromDir = fromDirection 102 | {-# INLINE fromDir #-} 103 | 104 | -- | Compute the positive angle between the two directions in their 105 | -- common plane, returning an angle in the range $[0,\pi]$. In 106 | -- particular, note that @angleBetweenDirs@ is commutative. 107 | angleBetweenDirs :: (Metric v, Floating n) 108 | => Direction v n -> Direction v n -> Angle n 109 | angleBetweenDirs d1 d2 = angleBetween (fromDir d1) (fromDir d2) 110 | 111 | -- | @dirBetween p q@ computes the direction from @p@ to @q@. 112 | dirBetween :: (Metric v, Floating n) => Point v n -> Point v n -> Direction v n 113 | dirBetween p q = dir $ q .-. p 114 | 115 | -------------------------------------------------------------------------------- /src/Geometry/HasOrigin.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Geometry.HasOrigin 9 | -- Copyright : (c) 2011-2017 diagrams team (see LICENSE) 10 | -- License : BSD-style (see LICENSE) 11 | -- Maintainer : diagrams-discuss@googlegroups.com 12 | -- 13 | -- Types which have an intrinsic notion of a \"local origin\", 14 | -- /i.e./ things which are /not/ invariant under translation. 15 | -- 16 | ----------------------------------------------------------------------------- 17 | 18 | module Geometry.HasOrigin 19 | ( HasOrigin(..) 20 | , moveOriginBy 21 | , moveTo 22 | , place 23 | ) where 24 | 25 | import qualified Data.Map as M 26 | import qualified Data.Set as S 27 | 28 | import Geometry.Space 29 | 30 | import Linear.Affine 31 | import Linear.Vector 32 | 33 | -- | Class of types which have an intrinsic notion of a \"local 34 | -- origin\", i.e. things which are not invariant under translation, 35 | -- and which allow the origin to be moved. 36 | -- 37 | -- One might wonder why not just use 'Transformable' instead of 38 | -- having a separate class for 'HasOrigin'; indeed, for types which 39 | -- are instances of both we should have the identity 40 | -- 41 | -- @ 42 | -- moveOriginTo (origin .^+ v) === translate (negated v) 43 | -- @ 44 | -- 45 | -- The reason is that some things (e.g. vectors, 'Trail's) are 46 | -- transformable but are translationally invariant, i.e. have no 47 | -- origin. Conversely, some types may have an origin and support 48 | -- translation, but not support arbitrary affine transformations. 49 | class HasOrigin t where 50 | 51 | -- | Move the local origin to another point. 52 | -- 53 | -- Note that this function is in some sense dual to 'translate' 54 | -- (for types which are also 'Transformable'); moving the origin 55 | -- itself while leaving the object \"fixed\" is dual to fixing the 56 | -- origin and translating the object. 57 | moveOriginTo :: Point (V t) (N t) -> t -> t 58 | 59 | -- | Move the local origin by a relative vector. 60 | moveOriginBy :: (InSpace v n t, HasOrigin t) => v n -> t -> t 61 | moveOriginBy = moveOriginTo . P 62 | {-# INLINE moveOriginBy #-} 63 | 64 | -- | Translate the object by the translation that sends the origin to 65 | -- the given point. Note that this is dual to 'moveOriginTo', i.e. we 66 | -- should have 67 | -- 68 | -- @ 69 | -- moveTo (origin .+^ v) === moveOriginTo (origin .-^ v) 70 | -- @ 71 | -- 72 | -- For types which are also 'Transformable', this is essentially the 73 | -- same as 'translate', i.e. 74 | -- 75 | -- @ 76 | -- moveTo (origin .+^ v) === translate v 77 | -- @ 78 | moveTo :: (InSpace v n t, HasOrigin t) => Point v n -> t -> t 79 | moveTo = moveOriginBy . (origin .-.) 80 | {-# INLINE moveTo #-} 81 | 82 | -- | A flipped variant of 'moveTo', provided for convenience. Useful 83 | -- when writing a function which takes a point as an argument, such 84 | -- as when using 'withName' and friends. 85 | place :: (InSpace v n t, HasOrigin t) => t -> Point v n -> t 86 | place = flip moveTo 87 | {-# INLINE place #-} 88 | 89 | instance (Additive v, Num n) => HasOrigin (Point v n) where 90 | moveOriginTo (P u) p = p .-^ u 91 | {-# INLINE moveOriginTo #-} 92 | 93 | instance (HasOrigin t, HasOrigin s, SameSpace s t) => HasOrigin (s, t) where 94 | moveOriginTo p (x,y) = (moveOriginTo p x, moveOriginTo p y) 95 | {-# INLINE moveOriginTo #-} 96 | 97 | instance HasOrigin t => HasOrigin [t] where 98 | moveOriginTo = map . moveOriginTo 99 | {-# INLINE moveOriginTo #-} 100 | 101 | instance (HasOrigin t, Ord t) => HasOrigin (S.Set t) where 102 | moveOriginTo = S.map . moveOriginTo 103 | {-# INLINE moveOriginTo #-} 104 | 105 | instance HasOrigin t => HasOrigin (M.Map k t) where 106 | moveOriginTo = M.map . moveOriginTo 107 | {-# INLINE moveOriginTo #-} 108 | 109 | -------------------------------------------------------------------------------- /src/Geometry/Juxtapose.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Geometry.Juxtapose 9 | -- Copyright : (c) 2011-2017 diagrams team (see LICENSE) 10 | -- License : BSD-style (see LICENSE) 11 | -- Maintainer : diagrams-discuss@googlegroups.com 12 | -- 13 | -- Things which can be placed \"next to\" other things, for some 14 | -- appropriate notion of \"next to\". 15 | -- 16 | ----------------------------------------------------------------------------- 17 | 18 | module Geometry.Juxtapose 19 | ( Juxtaposable (..) 20 | , juxtaposeDefault 21 | ) where 22 | 23 | import qualified Data.Map as M 24 | import qualified Data.Set as S 25 | 26 | import Geometry.Envelope 27 | import Geometry.HasOrigin 28 | import Geometry.Space 29 | 30 | import Linear.Metric 31 | import Linear.Vector 32 | 33 | -- | Class of things which can be placed \"next to\" other things, for some 34 | -- appropriate notion of \"next to\". 35 | class Juxtaposable a where 36 | 37 | -- | @juxtapose v a1 a2@ positions @a2@ next to @a1@ in the 38 | -- direction of @v@. In particular, place @a2@ so that @v@ points 39 | -- from the local origin of @a1@ towards the old local origin of 40 | -- @a2@; @a1@'s local origin becomes @a2@'s new local origin. The 41 | -- result is just a translated version of @a2@. (In particular, 42 | -- this operation does not /combine/ @a1@ and @a2@ in any way.) 43 | juxtapose :: Vn a -> a -> a -> a 44 | 45 | -- XXX Is there a reason not to move this into the class with a 46 | -- default method signature specification? 47 | 48 | -- | Default implementation of 'juxtapose' for things which are 49 | -- instances of 'Enveloped' and 'HasOrigin'. If either envelope is 50 | -- empty, the second object is returned unchanged. 51 | juxtaposeDefault :: (Enveloped a, HasOrigin a) => Vn a -> a -> a -> a 52 | juxtaposeDefault = \v a1 a2 -> 53 | -- the distance a2 needs to be translated such that the hyperplanes between 54 | -- a1 and a2 are touching 55 | 56 | -- XXX this is not correct given the semantics of extent. Should 57 | -- juxtapose take a Direction or a vector? Or should we normalize? 58 | let md = do 59 | (_,d1) <- extent v a1 60 | (d2,_) <- extent v a2 61 | Just (d1 - d2) 62 | in case md of 63 | Just d -> moveOriginBy (negate d *^ v) a2 64 | _ -> a2 65 | {-# INLINE juxtaposeDefault #-} 66 | 67 | instance (Metric v, OrderedField n) => Juxtaposable (Envelope v n) where 68 | juxtapose = juxtaposeDefault 69 | 70 | instance (SameSpace a b, Enveloped a, HasOrigin a, Enveloped b, HasOrigin b) 71 | => Juxtaposable (a,b) where 72 | juxtapose = juxtaposeDefault 73 | 74 | instance (Enveloped b, HasOrigin b) => Juxtaposable [b] where 75 | juxtapose = juxtaposeDefault 76 | 77 | instance (Enveloped b, HasOrigin b) => Juxtaposable (M.Map k b) where 78 | juxtapose = juxtaposeDefault 79 | 80 | instance (Enveloped b, HasOrigin b, Ord b) => Juxtaposable (S.Set b) where 81 | juxtapose = juxtaposeDefault 82 | 83 | instance Juxtaposable b => Juxtaposable (a -> b) where 84 | juxtapose v f1 f2 b = juxtapose v (f1 b) (f2 b) 85 | 86 | -------------------------------------------------------------------------------- /src/Geometry/Located.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE StandaloneDeriving #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | ----------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Geometry.Located 11 | -- Copyright : (c) 2013-2017 diagrams team (see LICENSE) 12 | -- License : BSD-style (see LICENSE) 13 | -- Maintainer : diagrams-discuss@googlegroups.com 14 | -- 15 | -- \"Located\" things, /i.e./ things with a concrete location: 16 | -- intuitively, @Located a ~ (a, Point)@. Wrapping a translationally 17 | -- invariant thing (/e.g./ a 'Segment' or 'Trail') in @Located@ pins 18 | -- it down to a particular location and makes it no longer 19 | -- translationally invariant. 20 | -- 21 | ----------------------------------------------------------------------------- 22 | 23 | module Geometry.Located 24 | ( Located (..) 25 | , at 26 | , viewLoc 27 | , mapLoc 28 | , located 29 | , location 30 | 31 | -- * Internals 32 | , serializeLocWith 33 | , deserializeLocWith 34 | ) 35 | where 36 | 37 | import Control.Lens (Lens, Lens') 38 | import Control.DeepSeq (NFData (..)) 39 | import qualified Data.Binary as Binary 40 | import Data.Bytes.Get (MonadGet) 41 | import Data.Bytes.Put (MonadPut) 42 | import Data.Bytes.Serial 43 | import Data.Hashable 44 | import Data.Hashable.Lifted 45 | import qualified Data.Serialize as Cereal 46 | import Text.Read 47 | 48 | import Data.Functor.Classes 49 | import Data.Typeable 50 | import Linear.Affine 51 | import Linear.Vector 52 | 53 | import Geometry.Envelope 54 | import Geometry.Juxtapose 55 | import Geometry.Query 56 | import Geometry.Space 57 | import Geometry.Trace 58 | import Geometry.Transform 59 | 60 | import GHC.Generics (Generic) 61 | 62 | -- | \"Located\" things, /i.e./ things with a concrete location: 63 | -- intuitively, @Located a ~ (Point, a)@. Wrapping a translationally 64 | -- invariant thing (/e.g./ a 'Segment' or 'Trail') in 'Located' pins 65 | -- it down to a particular location and makes it no longer 66 | -- translationally invariant. 67 | -- 68 | -- @Located@ is intentionally abstract. To construct @Located@ 69 | -- values, use 'at'. To destruct, use 'viewLoc', 'unLoc', or 'loc'. 70 | -- To map, use 'mapLoc'. 71 | -- 72 | -- Much of the utility of having a concrete type for the @Located@ 73 | -- concept lies in the type class instances we can give it. The 74 | -- 'HasOrigin', 'Transformable', 'HasQuery', 'Enveloped', 'Traced', 75 | -- and 'TrailLike' instances are particularly useful; see the 76 | -- documented instances below for more information. 77 | data Located a = Loc 78 | { loc :: !(Point (V a) (N a)) 79 | -- ^ Project out the location of a @Located@ value. 80 | , unLoc :: !a 81 | -- ^ Project the value of type @a@ out of a @Located a@, discarding 82 | -- the location. 83 | } deriving (Typeable, Generic) 84 | 85 | infix 5 `at` 86 | -- | Construct a @Located a@ from a value of type @a@ and a location. 87 | -- @at@ is intended to be used infix, like @x \`at\` origin@. 88 | at :: a -> Point (V a) (N a) -> Located a 89 | at a p = Loc p a 90 | {-# INLINE at #-} 91 | 92 | -- | Deconstruct a @Located a@ into a location and a value of type 93 | -- @a@. @viewLoc@ can be especially useful in conjunction with the 94 | -- @ViewPatterns@ extension. 95 | viewLoc :: Located a -> (Point (V a) (N a), a) 96 | viewLoc (Loc p a) = (p,a) 97 | {-# INLINE viewLoc #-} 98 | 99 | -- | A lens onto the location of a 'Located'. 100 | location :: Lens' (Located a) (Point (V a) (N a)) 101 | location f (Loc p a) = flip Loc a <$> f p 102 | {-# INLINE location #-} 103 | 104 | -- | A lens giving access to the object within a 'Located' wrapper. 105 | located :: SameSpace a b => Lens (Located a) (Located b) a b 106 | located f (Loc p a) = Loc p <$> f a 107 | {-# INLINE located #-} 108 | 109 | -- | 'Located' is not a @Functor@, since changing the type could 110 | -- change the type of the associated vector space, in which case the 111 | -- associated location would no longer have the right type. 'mapLoc' 112 | -- has an extra constraint specifying that the vector space must 113 | -- stay the same. 114 | -- 115 | -- (Technically, one can say that for every vector space @v@, 116 | -- @Located@ is an endofunctor on the category of types 117 | -- with associated vector space @v@; but that is not covered by the 118 | -- standard @Functor@ class.) 119 | mapLoc :: SameSpace a b => (a -> b) -> Located a -> Located b 120 | mapLoc f (Loc p a) = Loc p (f a) 121 | {-# INLINE mapLoc #-} 122 | 123 | deriving instance (Eq (V a (N a)), Eq a ) => Eq (Located a) 124 | deriving instance (Ord (V a (N a)), Ord a ) => Ord (Located a) 125 | 126 | instance (Show1 (V a), Show (N a), Show a) => Show (Located a) where 127 | showsPrec d (Loc p a) = showParen (d > 5) $ 128 | showsPrec 6 a . showString " `at` " . showsPrec1 6 p 129 | 130 | instance (Read (V a (N a)), Read a) => Read (Located a) where 131 | readPrec = parens . prec 5 $ do 132 | a <- readPrec 133 | Punc "`" <- lexP 134 | Ident "at" <- lexP 135 | Punc "`" <- lexP 136 | p <- readPrec 137 | return (Loc p a) 138 | 139 | type instance V (Located a) = V a 140 | type instance N (Located a) = N a 141 | 142 | -- | @Located a@ is an instance of @HasOrigin@ whether @a@ is or not. 143 | -- In particular, translating a @Located a@ simply translates the 144 | -- associated point (and does /not/ affect the value of type @a@). 145 | instance (Num (N a), Additive (V a)) => HasOrigin (Located a) where 146 | moveOriginTo o (Loc p a) = Loc (moveOriginTo o p) a 147 | 148 | -- | Applying a transformation @t@ to a @Located a@ results in the 149 | -- transformation being applied to the location, and the /linear/ 150 | -- /portion/ of @t@ being applied to the value of type @a@ (/i.e./ 151 | -- it is not translated). 152 | instance (InSpace v n a, Foldable v, Transformable a) => Transformable (Located a) where 153 | transform t@(T t1 t2 _) (Loc p a) 154 | = Loc (papply t p) (transform (T t1 t2 zero) a) 155 | {-# INLINE transform #-} 156 | 157 | -- | The envelope of a @Located a@ is the envelope of the @a@, 158 | -- translated to the location. 159 | instance Enveloped a => Enveloped (Located a) where 160 | getEnvelope (Loc p a) = moveTo p (getEnvelope a) 161 | {-# INLINE getEnvelope #-} 162 | 163 | -- | The query of a @Located a@ is the query of the @a@, translated to 164 | -- the location. 165 | instance (Additive (V a), Num (N a), HasQuery a m) => HasQuery (Located a) m where 166 | getQuery (Loc p a) = moveTo p (getQuery a) 167 | {-# INLINE getQuery #-} 168 | 169 | instance Enveloped a => Juxtaposable (Located a) where 170 | juxtapose = juxtaposeDefault 171 | 172 | -- | The trace of a @Located a@ is the trace of the @a@, 173 | -- translated to the location. 174 | instance (Traced a, Num (N a)) => Traced (Located a) where 175 | getTrace (Loc p a) = moveTo p (getTrace a) 176 | 177 | instance (NFData (Vn a), NFData a) => NFData (Located a) where 178 | rnf (Loc p a) = rnf p `seq` rnf a 179 | {-# INLINE rnf #-} 180 | 181 | instance (Hashable1 (V a), Hashable (N a), Hashable a) => Hashable (Located a) where 182 | hashWithSalt s (Loc (P p) a) = hashWithSalt1 s p `hashWithSalt` a 183 | {-# INLINE hashWithSalt #-} 184 | 185 | serializeLocWith 186 | :: (MonadPut m, Serial1 (V a)) 187 | => (N a -> m ()) -> (a -> m ()) -> Located a -> m () 188 | serializeLocWith nf af (Loc (P p) a) = do 189 | serializeWith nf p 190 | af a 191 | {-# INLINE serializeLocWith #-} 192 | 193 | deserializeLocWith 194 | :: (MonadGet m, Serial1 (V a)) 195 | => m (N a) -> m a -> m (Located a) 196 | deserializeLocWith mn ma = do 197 | p <- deserializeWith mn 198 | a <- ma 199 | return (Loc (P p) a) 200 | {-# INLINE deserializeLocWith #-} 201 | 202 | instance (Serial1 (V a), Serial (N a), Serial a) => Serial (Located a) where 203 | serialize = serializeLocWith serialize serialize 204 | {-# INLINE serialize #-} 205 | deserialize = deserializeLocWith deserialize deserialize 206 | {-# INLINE deserialize #-} 207 | 208 | instance (Serial1 (V a), Binary.Binary (N a), Binary.Binary a) 209 | => Binary.Binary (Located a) where 210 | put = serializeLocWith Binary.put Binary.put 211 | {-# INLINE put #-} 212 | get = deserializeLocWith Binary.get Binary.get 213 | {-# INLINE get #-} 214 | 215 | instance (Serial1 (V a), Cereal.Serialize (N a), Cereal.Serialize a) 216 | => Cereal.Serialize (Located a) where 217 | put = serializeLocWith Cereal.put Cereal.put 218 | {-# INLINE put #-} 219 | get = deserializeLocWith Cereal.get Cereal.get 220 | {-# INLINE get #-} 221 | 222 | -------------------------------------------------------------------------------- /src/Geometry/Points.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE PatternSynonyms #-} 5 | 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Geometry.Points 9 | -- Copyright : (c) 2011-2017 diagrams team (see LICENSE) 10 | -- License : BSD-style (see LICENSE) 11 | -- Maintainer : diagrams-discuss@googlegroups.com 12 | -- 13 | -- A type for /points/ (as distinct from vectors). 14 | -- 15 | ----------------------------------------------------------------------------- 16 | 17 | module Geometry.Points 18 | ( -- * Points 19 | Point (..) 20 | 21 | , P1 22 | , P2 23 | , P3 24 | , P4 25 | , pattern P1 26 | , pattern P2 27 | , pattern P3 28 | , pattern P4 29 | 30 | , Affine (..) 31 | , origin 32 | , (*.) 33 | , relative 34 | , _Point 35 | , centroid 36 | 37 | , reflectThrough 38 | , mirror 39 | , relative2 40 | , relative3 41 | ) where 42 | 43 | import Control.Lens (over) 44 | import qualified Data.Foldable as F 45 | 46 | import Linear.Affine 47 | import Linear 48 | 49 | import Geometry.Space 50 | 51 | type instance V (Point v n) = v 52 | type instance N (Point v n) = n 53 | 54 | type P1 = Point V1 55 | type P2 = Point V2 56 | type P3 = Point V3 57 | type P4 = Point V4 58 | 59 | pattern P1 :: a -> P1 a 60 | pattern P1 x = P (V1 x) 61 | pattern P2 :: a -> a -> P2 a 62 | pattern P2 x y = P (V2 x y) 63 | pattern P3 :: a -> a -> a -> P3 a 64 | pattern P3 x y z = P (V3 x y z) 65 | pattern P4 :: a -> a -> a -> a -> P4 a 66 | pattern P4 x y z w = P (V4 x y z w) 67 | 68 | #if __GLASGOW_HASKELL__ >= 802 69 | {-# COMPLETE P1 #-} 70 | {-# COMPLETE P2 #-} 71 | {-# COMPLETE P3 #-} 72 | {-# COMPLETE P4 #-} 73 | #endif 74 | 75 | -- | Reflect a point through the origin. 76 | mirror :: (Additive v, Num n) => Point v n -> Point v n 77 | mirror = reflectThrough origin 78 | 79 | -- | Scale a point by a scalar. Specialized version of '(*^)'. 80 | (*.) :: (Functor v, Num n) => n -> Point v n -> Point v n 81 | (*.) = (*^) 82 | 83 | -- | Apply a transformation relative to the given point. 84 | relative2 :: (Additive v, Num n) 85 | => Point v n -> (v n -> v n -> v n) 86 | -> Point v n -> Point v n -> Point v n 87 | relative2 p f x y = (p .+^) $ f (inj x) (inj y) where inj = (.-. p) 88 | 89 | -- | Apply a transformation relative to the given point. 90 | relative3 :: (Additive v, Num n) 91 | => Point v n -> (v n -> v n -> v n -> v n) 92 | -> Point v n -> Point v n -> Point v n -> Point v n 93 | relative3 p f x y z = (p .+^) $ f (inj x) (inj y) (inj z) where inj = (.-. p) 94 | 95 | -- | Mirror a point through a given point. 96 | reflectThrough :: (Additive v, Num n) => Point v n -> Point v n -> Point v n 97 | reflectThrough o = over (relative o) negated 98 | 99 | -- | The centroid of a set of /n/ points is their sum divided by /n/. 100 | centroid :: (Foldable f, Additive v, Fractional n) => f (Point v n) -> Point v n 101 | centroid = uncurry (^/) . F.foldl' (\(s,c) e -> (e ^+^ s,c+1)) (zero,0) 102 | {-# INLINE centroid #-} 103 | -------------------------------------------------------------------------------- /src/Geometry/Query.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | ----------------------------------------------------------------------------- 8 | -- | 9 | -- Module : Geometry.Query 10 | -- Copyright : (c) 2013-2017 diagrams team (see LICENSE) 11 | -- License : BSD-style (see LICENSE) 12 | -- Maintainer : diagrams-discuss@googlegroups.com 13 | -- 14 | -- A query is a function that maps points in a vector space to values 15 | -- in some monoid. Queries naturally form a monoid, with two queries 16 | -- being combined pointwise. 17 | -- 18 | ----------------------------------------------------------------------------- 19 | 20 | module Geometry.Query 21 | ( -- * Queries 22 | Query(..) 23 | , HasQuery (..) 24 | , sample 25 | , inquire 26 | , queryPoint 27 | ) where 28 | 29 | import Data.Monoid 30 | 31 | import Control.Lens 32 | import Data.Distributive 33 | import Data.Functor.Rep 34 | import Data.Profunctor 35 | import qualified Data.Profunctor.Rep as P 36 | import Data.Profunctor.Sieve 37 | import qualified Data.Semigroup as Sem 38 | 39 | import Linear.Affine 40 | import Linear.Vector 41 | 42 | import Geometry.HasOrigin 43 | import Geometry.Space 44 | import Geometry.Transform 45 | 46 | ------------------------------------------------------------------------ 47 | -- Queries 48 | ------------------------------------------------------------------------ 49 | 50 | -- | A query is a function that maps points in a vector space to 51 | -- values in some monoid. Queries naturally form a monoid, with 52 | -- two queries being combined pointwise. 53 | -- 54 | -- The idea for annotating diagrams with monoidal queries came from 55 | -- the graphics-drawingcombinators package, 56 | -- . 57 | newtype Query v n m = Query { runQuery :: Point v n -> m } 58 | deriving (Functor, Applicative, Monad, Sem.Semigroup, Monoid) 59 | 60 | instance Distributive (Query v n) where 61 | distribute a = Query $ \p -> fmap (\(Query q) -> q p) a 62 | {-# INLINE distribute #-} 63 | 64 | instance Representable (Query v n) where 65 | type Rep (Query v n) = Point v n 66 | tabulate = Query 67 | {-# INLINE tabulate #-} 68 | index = runQuery 69 | {-# INLINE index #-} 70 | 71 | instance Functor v => Profunctor (Query v) where 72 | lmap f (Query q) = Query $ \p -> q (fmap f p) 73 | {-# INLINE lmap #-} 74 | rmap = fmap 75 | {-# INLINE rmap #-} 76 | 77 | instance Functor v => Cosieve (Query v) (Point v) where 78 | cosieve = runQuery 79 | {-# INLINE cosieve #-} 80 | 81 | instance Functor v => Closed (Query v) where 82 | closed (Query fab) = Query $ \fxa x -> fab (fmap ($ x) fxa) 83 | {-# INLINE closed #-} 84 | 85 | instance Functor v => Costrong (Query v) where 86 | unfirst (Query f) = Query f' 87 | where f' fa = b where (b, d) = f ((\a -> (a, d)) <$> fa) 88 | unsecond (Query f) = Query f' 89 | where f' fa = b where (d, b) = f ((,) d <$> fa) 90 | 91 | instance Functor v => P.Corepresentable (Query v) where 92 | type Corep (Query v) = Point v 93 | cotabulate = Query 94 | 95 | -- | Setter over the input point of a query. 96 | queryPoint :: Setter (Query v' n' m) (Query v n m) (Point v n) (Point v' n') 97 | queryPoint = sets $ \f (Query q) -> Query $ q . f 98 | {-# INLINE queryPoint #-} 99 | 100 | instance Wrapped (Query v n m) where 101 | type Unwrapped (Query v n m) = Point v n -> m 102 | _Wrapped' = iso runQuery Query 103 | 104 | instance Rewrapped (Query v a m) (Query v' a' m') 105 | 106 | type instance V (Query v n m) = v 107 | type instance N (Query v n m) = n 108 | 109 | instance (Additive v, Num n) => HasOrigin (Query v n m) where 110 | moveOriginTo (P u) = queryPoint %~ (.+^ u) 111 | {-# INLINE moveOriginTo #-} 112 | 113 | instance (Additive v, Foldable v, Num n) => Transformable (Query v n m) where 114 | transform t = queryPoint %~ papply (inv t) 115 | {-# INLINE transform #-} 116 | 117 | -- Proof this definition satisfies the monoid homomorphism: 118 | -- 119 | -- transform (t1 <> t2) 120 | -- = queryPoint %~ papply (inv (t1 <> t2)) 121 | -- = queryPoint %~ papply (inv t2 <> inv t1) 122 | -- = queryPoint %~ (papply (inv t2) . papply (inv t1)) 123 | -- = transform t1 . (queryPoint %~ papply (inv t2)) 124 | -- = transform t1 . transform t2 125 | 126 | -- | Types which can answer a 'Query' about points inside the geometric 127 | -- object. 128 | -- 129 | -- If @t@ and @m@ are both a 'Semigroup's, 'getQuery' should satisfy 130 | -- 131 | -- @ 132 | -- 'getQuery' (t1 <> t2) = 'getQuery' t1 <> 'getQuery' t2 133 | -- @ 134 | class HasQuery t m | t -> m where 135 | -- | Extract the query of an object. 136 | getQuery :: t -> Query (V t) (N t) m 137 | 138 | instance HasQuery (Query v n m) m where 139 | getQuery = id 140 | {-# INLINE getQuery #-} 141 | 142 | -- | Test if a point is not equal to 'mempty'. 143 | -- 144 | -- @ 145 | -- 'inquire' :: 'QDiagram' b v n 'Any' -> 'Point' v n -> 'Bool' 146 | -- 'inquire' :: 'Query' v n 'Any' -> 'Point' v n -> 'Bool' 147 | -- 'inquire' :: 'Geometry.BoundingBox.BoundingBox' v n -> 'Point' v n -> 'Bool' 148 | -- @ 149 | inquire :: HasQuery t Any => t -> Point (V t) (N t) -> Bool 150 | inquire t = getAny . sample t 151 | {-# INLINE inquire #-} 152 | 153 | -- | Sample an object's query function at a given point. 154 | -- 155 | -- @ 156 | -- 'sample' :: 'QDiagram' b v n m -> 'Point' v n -> m 157 | -- 'sample' :: 'Query' v n m -> 'Point' v n -> m 158 | -- 'sample' :: 'Geometry.BoundingBox.BoundingBox' v n -> 'Point' v n -> 'Any' 159 | -- 'sample' :: 'Geometry.Path.Path' 'V2' 'Double' -> 'Point' v n -> 'Geometry.TwoD.Path.Crossings' 160 | -- @ 161 | sample :: HasQuery t m => t -> Point (V t) (N t) -> m 162 | sample = runQuery . getQuery 163 | {-# INLINE sample #-} 164 | 165 | -------------------------------------------------------------------------------- /src/Geometry/Size.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | {-# LANGUAGE ViewPatterns #-} 14 | 15 | ----------------------------------------------------------------------------- 16 | -- | 17 | -- Module : Geometry.Size 18 | -- Copyright : (c) 2014-2017 diagrams team (see LICENSE) 19 | -- License : BSD-style (see LICENSE) 20 | -- Maintainer : diagrams-discuss@googlegroups.com 21 | -- 22 | -- Utilities for working with sizes of objects. 23 | -- 24 | ----------------------------------------------------------------------------- 25 | module Geometry.Size 26 | ( -- * Size specs 27 | SizeSpec (..) 28 | 29 | -- ** Making size specs 30 | , mkSizeSpec 31 | , dims 32 | , absolute 33 | 34 | -- ** Extracting size specs 35 | , getSpec 36 | , specToSize 37 | 38 | -- ** Functions on size specs 39 | , requiredScale 40 | , requiredScaling 41 | , sized 42 | , sizedAs 43 | , sizeAdjustment 44 | ) where 45 | 46 | import Control.Applicative 47 | import Control.Lens hiding (transform) 48 | import Control.Monad 49 | import Data.Foldable as F 50 | import Data.Functor.Classes 51 | import Data.Hashable 52 | import Data.Maybe 53 | import qualified Data.Semigroup as Sem 54 | import Data.Typeable 55 | import GHC.Generics (Generic) 56 | import Prelude 57 | 58 | import Geometry.BoundingBox 59 | import Geometry.Envelope 60 | import Geometry.Space 61 | import Geometry.Transform 62 | 63 | import Linear.Affine 64 | import Linear.Vector 65 | 66 | ------------------------------------------------------------ 67 | -- Computing diagram sizes 68 | ------------------------------------------------------------ 69 | 70 | -- | A 'SizeSpec' is a way of specifying a size without needed lengths for all 71 | -- the dimensions. 72 | newtype SizeSpec v n = SizeSpec (v (Maybe n)) 73 | deriving (Typeable, Functor, Generic) 74 | 75 | -- instance (Hashable1 v, Hashable n) => Hashable (SizeSpec v n) where 76 | instance (Hashable (v (Maybe n))) => Hashable (SizeSpec v n) where 77 | hashWithSalt s (SizeSpec sz) = s `hashWithSalt` sz 78 | 79 | type instance V (SizeSpec v n) = v 80 | type instance N (SizeSpec v n) = n 81 | 82 | instance Show1 v => Show1 (SizeSpec v) where 83 | liftShowsPrec x y d (SizeSpec v) = showParen (d > 10) $ 84 | showString "mkSizeSpec " . liftShowsPrec x' y' 11 v 85 | where 86 | x' = liftShowsPrec x y 87 | y' = liftShowList x y 88 | 89 | instance (Show1 v, Show n) => Show (SizeSpec v n) where 90 | showsPrec = showsPrec1 91 | 92 | -- | Retrieve a size spec as a vector of maybe values. Only positive sizes are 93 | -- returned. 94 | getSpec :: (Functor v, Num n, Ord n) => SizeSpec v n -> v (Maybe n) 95 | getSpec (SizeSpec sp) = mfilter (>0) <$> sp 96 | 97 | -- | Make a 'SizeSpec' from a vector of maybe values. Any negative values will 98 | -- be ignored. For 2D 'SizeSpec's see 'mkWidth' and 'mkHeight' from 99 | -- "Diagrams.TwoD.Size". 100 | mkSizeSpec :: (Functor v, Num n) => v (Maybe n) -> SizeSpec v n 101 | mkSizeSpec = dims . fmap (fromMaybe 0) 102 | 103 | -- | Make a 'SizeSpec' from a vector. Any negative values will be ignored. 104 | dims :: Functor v => v n -> SizeSpec v n 105 | dims = SizeSpec . fmap Just 106 | 107 | -- | A size spec with no hints to the size. 108 | absolute :: Additive v => SizeSpec v n 109 | absolute = SizeSpec (fmap (const Nothing) (zero :: Additive v => v Int)) 110 | 111 | -- | @specToSize n spec@ extracts a size from a 'SizeSpec' @sz@. Any values not 112 | -- specified in the spec are replaced by the smallest of the values that are 113 | -- specified. If there are no specified values (i.e. 'absolute') then @n@ is 114 | -- used. 115 | specToSize :: (Foldable v, Functor v, Num n, Ord n) => n -> SizeSpec v n -> v n 116 | specToSize n (getSpec -> spec) = fmap (fromMaybe smallest) spec 117 | where 118 | smallest = fromMaybe n $ minimumOf (folded . _Just) spec 119 | 120 | -- | @requiredScale spec sz@ returns the largest scaling factor to make 121 | -- something of size @sz@ fit the requested size @spec@ without changing the 122 | -- aspect ratio. @sz@ should be non-zero (otherwise a scale of 1 is 123 | -- returned). For non-uniform scaling see 'boxFit'. 124 | requiredScale :: (Additive v, Foldable v, Fractional n, Ord n) 125 | => SizeSpec v n -> v n -> n 126 | requiredScale (getSpec -> spec) sz 127 | | allOf (folded . _Just) (<= 0) usedSz = 1 128 | | otherwise = fromMaybe 1 mScale 129 | where 130 | usedSz = liftI2 (<$) sz spec 131 | scales = liftI2 (^/) spec sz 132 | mScale = minimumOf (folded . _Just) scales 133 | 134 | -- | Return the 'Transformation' calcuated from 'requiredScale'. 135 | requiredScaling :: (HasBasis v, Foldable v, Fractional n, Ord n) 136 | => SizeSpec v n -> v n -> Transformation v n 137 | requiredScaling spec = scaling . requiredScale spec 138 | 139 | -- | Uniformly scale any enveloped object so that it fits within the 140 | -- given size. For non-uniform scaling see 'boxFit'. 141 | sized :: (InSpace v n a, HasLinearMap v, Transformable a, Enveloped a) 142 | => SizeSpec v n -> a -> a 143 | sized spec a = transform (requiredScaling spec (size a)) a 144 | 145 | -- | Uniformly scale an enveloped object so that it \"has the same 146 | -- size as\" (fits within the bounding box of) some other 147 | -- object. 148 | sizedAs :: (InSpace v n a, SameSpace a b, HasLinearMap v, Transformable a, 149 | Enveloped a, Enveloped b) 150 | => b -> a -> a 151 | sizedAs other = sized (dims $ size other) 152 | 153 | -- | Get the adjustment to fit a 'BoundingBox' in the given 'SizeSpec'. The 154 | -- vector is the new size and the transformation to position the lower 155 | -- corner at the origin and scale to the size spec. 156 | sizeAdjustment :: (HasBasis v, Foldable v, OrderedField n) 157 | => SizeSpec v n -> BoundingBox v n -> (v n, Transformation v n) 158 | sizeAdjustment spec bb = (sz', t) 159 | where 160 | v = (0.5 *^ P sz') .-. (s *^ fromMaybe origin (boxCenter bb)) 161 | 162 | sz = boxExtents bb 163 | sz' = if allOf folded isJust (getSpec spec) 164 | then specToSize 0 spec 165 | else s *^ sz 166 | 167 | s = requiredScale spec sz 168 | 169 | t = translation v Sem.<> scaling s 170 | 171 | -------------------------------------------------------------------------------- /src/Geometry/Space.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | 8 | ----------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Geometry.Space 11 | -- Copyright : (c) 2011-2017 diagrams team (see LICENSE) 12 | -- License : BSD-style (see LICENSE) 13 | -- Maintainer : diagrams-discuss@googlegroups.com 14 | -- 15 | -- Type families for identifying associated vector spaces. 16 | -- 17 | ----------------------------------------------------------------------------- 18 | 19 | module Geometry.Space 20 | ( -- * Type families 21 | V, N 22 | 23 | -- * Type symomyms 24 | , Vn 25 | , InSpace, SameSpace 26 | , HasLinearMap 27 | , HasBasis 28 | , OrderedField 29 | ) where 30 | 31 | import Control.Monad.ST 32 | import Data.Functor.Rep 33 | import Data.HashMap.Lazy 34 | import Data.IntMap 35 | import Data.Map 36 | import Data.Monoid.Coproduct 37 | import Data.Monoid.Deletable 38 | import Data.Monoid.Split 39 | import Data.Semigroup 40 | import Data.Sequence 41 | import Data.Set 42 | import Data.Tree 43 | 44 | import Linear.Affine 45 | import Linear.Metric 46 | import Linear.Vector 47 | 48 | ------------------------------------------------------------------------ 49 | -- Vector spaces 50 | ------------------------------------------------------------------------ 51 | 52 | -- | Many sorts of objects have an associated vector space in which 53 | -- they \"live\". The type function @V@ maps from object types to 54 | -- the associated vector space. The resulting vector space has kind 55 | -- @* -> *@ which means it takes another type (representing the type 56 | -- of scalars) and returns a concrete vector type. For example 'V2' 57 | -- has kind @* -> *@ and @V2 Double@ represents a vector. 58 | type family V a :: * -> * 59 | 60 | -- Note, to use these instances one often needs a constraint of the form 61 | -- V a ~ V b, etc. 62 | type instance V (a,b) = V a 63 | type instance V (a,b,c) = V a 64 | 65 | type instance V (Point v n) = v 66 | type instance V (a -> b) = V b 67 | type instance V [a] = V a 68 | type instance V (Option a) = V a 69 | type instance V (Set a) = V a 70 | type instance V (Seq a) = V a 71 | type instance V (Map k a) = V a 72 | type instance V (Tree a) = V a 73 | type instance V (IntMap a) = V a 74 | type instance V (HashMap k a) = V a 75 | type instance V (IO a) = V a 76 | type instance V (ST s a) = V a 77 | 78 | type instance V (Deletable m) = V m 79 | type instance V (Split m) = V m 80 | type instance V (m :+: n) = V m 81 | 82 | -- | N represents the numeric scalar type used for the vector space of 83 | -- an object. 84 | type family N a :: * 85 | 86 | type instance N (a,b) = N a 87 | type instance N (a,b,c) = N a 88 | 89 | type instance N (Point v n) = n 90 | type instance N (a -> b) = N b 91 | type instance N [a] = N a 92 | type instance N (Option a) = N a 93 | type instance N (Set a) = N a 94 | type instance N (Seq a) = N a 95 | type instance N (Map k a) = N a 96 | type instance N (Tree a) = N a 97 | type instance N (IntMap a) = N a 98 | type instance N (HashMap k a) = N a 99 | type instance N (IO a) = N a 100 | type instance N (ST s a) = N a 101 | 102 | type instance N (Deletable m) = N m 103 | type instance N (Split m) = N m 104 | type instance N (m :+: n) = N m 105 | 106 | -- | Conveient type alias to retrieve the vector type associated with an 107 | -- object's vector space. This is usually used as @Vn a ~ v n@ where @v@ is 108 | -- the vector space and @n@ is the scalar type. 109 | type Vn a = V a (N a) 110 | 111 | -- | @InSpace v n a@ means the type @a@ belongs to the vector space @v n@, 112 | -- where @v@ is 'Additive' and @n@ is 'Num'. 113 | type InSpace v n a = (V a ~ v, N a ~ n, Additive v, Num n) 114 | 115 | -- | @SameSpace a b@ means the types @a@ and @b@ belong to the same 116 | -- vector space @v n@. 117 | type SameSpace a b = (V a ~ V b, N a ~ N b) 118 | 119 | -- Symonyms ------------------------------------------------------------ 120 | 121 | -- | 'HasLinearMap' is a constraint synonym provided to help shorten 122 | -- some of the ridiculously long constraint sets. 123 | type HasLinearMap v = (Metric v, HasBasis v, Traversable v) 124 | 125 | -- | An 'Additive' vector space whose representation is made up of basis elements. 126 | type HasBasis v = (Additive v, Representable v, Rep v ~ E v) 127 | 128 | -- | When dealing with envelopes we often want scalars to be an 129 | -- ordered field (i.e. support all four arithmetic operations and be 130 | -- totally ordered) so we introduce this class as a convenient 131 | -- shorthand. 132 | type OrderedField s = (Floating s, Ord s) 133 | -------------------------------------------------------------------------------- /src/Geometry/ThreeD/Camera.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | ----------------------------------------------------------------------------- 11 | -- | 12 | -- Module : Geometry.ThreeD.Camera 13 | -- Copyright : (c) 2013-2017 diagrams team (see LICENSE) 14 | -- License : BSD-style (see LICENSE) 15 | -- Maintainer : diagrams-discuss@googlegroups.com 16 | -- 17 | -- Types to specify viewpoint for 3D rendering. 18 | -- 19 | ----------------------------------------------------------------------------- 20 | 21 | module Geometry.ThreeD.Camera 22 | ( 23 | -- * Cameras 24 | Camera -- do not export constructor 25 | , CameraLens (..) 26 | , cameraLocation 27 | , cameraAngle 28 | , cameraView 29 | , cameraLoc 30 | , mm50Camera 31 | 32 | -- * Perspective lens 33 | , PerspectiveLens(..) 34 | , mm50 35 | , mm50Wide 36 | , mm50Narrow 37 | , fovx 38 | 39 | -- * Orthographic lens 40 | , OrthoLens(..) 41 | , orthoBounds 42 | -- , horizontalFieldOfView, verticalFieldOfView 43 | -- , orthoWidth, orthoHeight 44 | -- , camLoc, camForward, camUp, camRight, camLens 45 | -- , facing_ZCamera, mm50Camera 46 | -- , mm50, mm50Wide, mm50Narrow 47 | -- , aspect, camAspect 48 | , camForwardRight 49 | , camForward 50 | , camUp 51 | , cameraLens 52 | ) 53 | where 54 | 55 | import Control.Lens 56 | import Data.Typeable 57 | 58 | import Geometry.Angle 59 | import Geometry.Points 60 | import Geometry.Space 61 | import Geometry.ThreeD.Transform 62 | import Geometry.ThreeD.Types 63 | 64 | import Linear.Matrix (M44, mkTransformationMat, transpose, 65 | (!*)) 66 | import Linear.Projection 67 | import Linear.Vector 68 | 69 | -- | A @Camera@ specifies a 3D viewpoint for rendering. It is 70 | -- parameterized on the lens type, so backends can express which 71 | -- lenses they handle. 72 | -- 73 | -- Note that the constructor is intentionally not exported; to 74 | -- construct a @Camera@, XXX? 75 | data Camera l n = Camera 76 | { cameraLocation :: !(P3 n) 77 | , cameraAngle :: !(Euler n) 78 | , _cameraUp :: !(V3 n) 79 | , camLens :: !(l n) 80 | } deriving Typeable 81 | 82 | type instance V (Camera l n) = V3 83 | type instance N (Camera l n) = n 84 | 85 | -- instance Num n => Transformable (Camera l n) where 86 | -- transform t (Camera p f u l) = 87 | -- Camera (transform t p) 88 | -- (transform t f) 89 | -- (transform t u) 90 | -- l 91 | 92 | class Typeable l => CameraLens l where 93 | -- | The natural aspect ratio of the projection. 94 | aspect :: Floating n => l n -> n 95 | 96 | -- | The projection of a lens as a homogeneous transformation matrix. 97 | lensProjection :: Floating n => l n -> M44 n 98 | 99 | -- | The inverse projection of a lens as a homogeneous transformation 100 | -- matrix. 101 | inverseLensProjection :: Floating n => l n -> M44 n 102 | 103 | instance Rotational (Camera l) where 104 | euler f cam = f (cameraAngle cam) <&> \e -> cam {cameraAngle = e} 105 | 106 | -- | The homogeneous view matrix for a camera, /not/ including the lens 107 | -- projection. 108 | cameraView :: RealFloat n => Camera l n -> M44 n 109 | cameraView cam = mkTransformationMat m v 110 | where 111 | -- To get the view matrix we want the inverse of translating and then 112 | -- rotating the camera. The inverse of a rotation matrix is its 113 | -- transpose and the camera location is negated. 114 | m = transpose (rotationMatrix cam) 115 | v = m !* (-cam^.cameraLoc._Point) 116 | 117 | cameraLoc :: Lens' (Camera l n) (P3 n) 118 | cameraLoc f cam = f (cameraLocation cam) <&> \p -> cam {cameraLocation = p} 119 | 120 | instance CameraLens l => CameraLens (Camera l) where 121 | aspect = aspect . camLens 122 | lensProjection = lensProjection . camLens 123 | inverseLensProjection = inverseLensProjection . camLens 124 | 125 | -- Perspective --------------------------------------------------------- 126 | 127 | -- | A perspective projection 128 | data PerspectiveLens n = PerspectiveLens 129 | { _fovx :: !(Angle n) -- ^ Horizontal field of view 130 | , _fovy :: !(Angle n) -- ^ Vertical field of view 131 | , _nearz :: !n -- ^ near clipping plane 132 | , _farz :: !n -- ^ far clipping plane 133 | } 134 | deriving Typeable 135 | 136 | makeLenses ''PerspectiveLens 137 | 138 | type instance V (PerspectiveLens n) = V3 139 | type instance N (PerspectiveLens n) = n 140 | 141 | instance CameraLens PerspectiveLens where 142 | aspect (PerspectiveLens h v _ _) = angleRatio h v 143 | lensProjection l = perspective (l^.fovy.rad) (aspect l) (l^.nearz) (l^.farz) 144 | inverseLensProjection l = inversePerspective (l^.fovy.rad) (aspect l) (l^.nearz) (l^.farz) 145 | 146 | -- | mm50 has the field of view of a 50mm lens on standard 35mm film, 147 | -- hence an aspect ratio of 3:2. 148 | mm50 :: Floating n => PerspectiveLens n 149 | mm50 = PerspectiveLens (40.5 @@ deg) (27 @@ deg) 0.1 1000 150 | 151 | -- | mm50blWide has the same vertical field of view as mm50, but an 152 | -- aspect ratio of 1.6, suitable for wide screen computer monitors. 153 | mm50Wide :: Floating n => PerspectiveLens n 154 | mm50Wide = PerspectiveLens (43.2 @@ deg) (27 @@ deg) 0.1 1000 155 | 156 | -- | mm50Narrow has the same vertical field of view as mm50, but an 157 | -- aspect ratio of 4:3, for VGA and similar computer resolutions. 158 | mm50Narrow :: Floating n => PerspectiveLens n 159 | mm50Narrow = PerspectiveLens (36 @@ deg) (27 @@ deg) 0.1 1000 160 | 161 | -- Orthographic -------------------------------------------------------- 162 | 163 | -- | An orthographic projection 164 | data OrthoLens n = OrthoLens 165 | { _orthoWidth :: n -- ^ Width 166 | , _orthoHeight :: n -- ^ Height 167 | , _orthoBounds :: V3 (n,n) 168 | } 169 | deriving Typeable 170 | 171 | makeLenses ''OrthoLens 172 | 173 | -- orthoRight, orthoLeft, orthoTom, orthoBottom, orthoNearZ, ortheFarX 174 | 175 | type instance V (OrthoLens n) = V3 176 | type instance N (OrthoLens n) = n 177 | 178 | instance CameraLens OrthoLens where 179 | aspect o = o^.orthoHeight / o^.orthoWidth 180 | lensProjection orthoLens = ortho l r b t n f where 181 | V3 (l,r) (b,t) (n,f) = orthoLens^.orthoBounds 182 | inverseLensProjection orthoLens = inverseOrtho l r b t n f where 183 | V3 (l,r) (b,t) (n,f) = orthoLens^.orthoBounds 184 | 185 | -- | A camera at the origin facing along the negative Z axis, with its 186 | -- up-axis coincident with the positive Y axis. The field of view is 187 | -- chosen to match a 50mm camera on 35mm film. Note that Cameras take 188 | -- up no space in the Diagram. 189 | mm50Camera :: Floating n => Camera PerspectiveLens n 190 | mm50Camera = facing_ZCamera mm50 191 | 192 | -- | 'facing_ZCamera l' is a camera at the origin facing along the 193 | -- negative Z axis, with its up-axis coincident with the positive Y 194 | -- axis, with the projection defined by l. 195 | facing_ZCamera :: Num n => l n -> Camera l n 196 | facing_ZCamera = Camera origin (Euler zero zero zero) (V3 0 1 0) 197 | {-# ANN facing_ZCamera ("HLint: ignore Use camelCase" :: String) #-} 198 | 199 | -- | The unit forward and right directions. 200 | camForwardRight :: RealFloat n => Camera l n -> (V3 n, V3 n) 201 | camForwardRight cam = (fw, V3 cy 0 (-sy)) 202 | where 203 | fw = V3 (-sy*cp) sp (-cy*cp) -- - ^/ sqrt (1 + sp*sp) 204 | y = cam^.yaw 205 | p = cam^.pitch 206 | sy = sinA y 207 | cy = cosA y 208 | sp = sinA p 209 | cp = cosA p 210 | {-# INLINE camForwardRight #-} 211 | 212 | camUp :: RealFloat n => Lens' (Camera l n) (V3 n) 213 | camUp f (Camera loc angle up l) = f up <&> \up' -> Camera loc angle up' l 214 | 215 | camForward :: RealFloat n => Lens' (Camera l n) (V3 n) 216 | camForward f cam = f (fst $ camForwardRight cam) <&> \v -> 217 | cam & pitch .~ atan2A (v^._x) (-v^._z) 218 | & yaw .~ acosA (v^._z) 219 | 220 | -- | The lens used for the camera. 221 | cameraLens :: Lens (Camera l n) (Camera l' n) (l n) (l' n) 222 | cameraLens f (Camera loc angle up l) = f l <&> Camera loc angle up 223 | 224 | -------------------------------------------------------------------------------- /src/Geometry/ThreeD/Combinators.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Geometry.ThreeD.Combinators 6 | -- Copyright : (c) 2013-2017 diagrams team (see LICENSE) 7 | -- License : BSD-style (see LICENSE) 8 | -- Maintainer : diagrams-discuss@googlegroups.com 9 | -- 10 | -- Alignment combinators specialized for three dimensions. See 11 | -- "Geometry.Combinators" for more general alignment combinators. 12 | -- 13 | -- The basic idea is that alignment is achieved by moving objects' 14 | -- local origins relative to their envelopes or traces (or some other 15 | -- sort of boundary). For example, to align several objects along 16 | -- their tops, we first move their local origins to the upper edge of 17 | -- their boundary (using e.g. @map 'alignZMax'@), and then put them 18 | -- together with their local origins along a line (using e.g. 'cat' 19 | -- from "Geometry.Combinators"). 20 | -- 21 | ----------------------------------------------------------------------------- 22 | 23 | module Geometry.ThreeD.Combinators 24 | ( -- * Absolute alignment 25 | -- ** Align by envelope 26 | alignXMin, alignXMax, alignYMin, alignYMax, alignZMin, alignZMax 27 | 28 | -- ** Align by trace 29 | , snugXMin, snugXMax, snugYMin, snugYMax, snugZMin, snugZMax 30 | 31 | -- * Relative alignment 32 | , alignX, snugX, alignY, snugY, alignZ, snugZ 33 | 34 | -- * Centering 35 | , centerX, centerY, centerZ 36 | , centerXY, centerXZ, centerYZ, centerXYZ 37 | , snugCenterX, snugCenterY, snugCenterZ 38 | 39 | ) where 40 | 41 | import Geometry.Combinators 42 | import Geometry.Envelope 43 | import Geometry.Space 44 | import Geometry.ThreeD.Types 45 | import Geometry.ThreeD.Vector 46 | import Geometry.Trace 47 | import Geometry.Transform 48 | import Geometry.TwoD.Combinators 49 | 50 | -- | Translate the object along @unitX@ so that all points have 51 | -- positive x-values. 52 | alignXMin :: (InSpace v n a, R1 v, Enveloped a, HasOrigin a) => a -> a 53 | alignXMin = align unit_X 54 | 55 | snugXMin :: (InSpace v n a, R1 v, Enveloped a, HasOrigin a, Traced a) => a -> a 56 | snugXMin = snug unit_X 57 | 58 | -- | Translate the object along @unitX@ so that all points have 59 | -- negative x-values. 60 | alignXMax :: (InSpace v n a, R1 v, Enveloped a, HasOrigin a) => a -> a 61 | alignXMax = align unitX 62 | 63 | snugXMax :: (InSpace v n a, R1 v, Enveloped a, HasOrigin a, Traced a) => a -> a 64 | snugXMax = snug unitX 65 | 66 | -- | Translate the object along @unitY@ so that all points have 67 | -- positive y-values. 68 | alignYMin :: (InSpace v n a, R2 v, Enveloped a, HasOrigin a) => a -> a 69 | alignYMin = align unit_Y 70 | 71 | snugYMin :: (InSpace v n a, R2 v, Enveloped a, HasOrigin a, Traced a) => a -> a 72 | snugYMin = snug unit_Y 73 | 74 | -- | Translate the object along @unitY@ so that all points have 75 | -- negative y-values. 76 | alignYMax :: (InSpace v n a, R2 v, Enveloped a, HasOrigin a) => a -> a 77 | alignYMax = align unitY 78 | 79 | snugYMax :: (InSpace v n a, R2 v, Enveloped a, HasOrigin a, Traced a) => a -> a 80 | snugYMax = snug unitY 81 | 82 | 83 | -- | Translate the object along @unitZ@ so that all points have 84 | -- positive z-values. 85 | alignZMin :: (InSpace v n a, R3 v, Enveloped a, HasOrigin a) => a -> a 86 | alignZMin = align unit_Z 87 | 88 | snugZMin :: (InSpace v n a, R3 v, Enveloped a, HasOrigin a, Traced a) => a -> a 89 | snugZMin = snug unit_Z 90 | 91 | -- | Translate the object along @unitZ@ so that all points have 92 | -- negative z-values. 93 | alignZMax :: (InSpace v n a, R3 v, Enveloped a, HasOrigin a) => a -> a 94 | alignZMax = align unitZ 95 | 96 | snugZMax :: (InSpace v n a, R3 v, Enveloped a, HasOrigin a, Traced a) => a -> a 97 | snugZMax = snug unitZ 98 | 99 | -- | Like 'alignX', but moving the local origin in the Z direction, with an 100 | -- argument of @1@ corresponding to the top edge and @(-1)@ corresponding 101 | -- to the bottom edge. 102 | alignZ :: (InSpace v n a, R3 v, Enveloped a, HasOrigin a) => n -> a -> a 103 | alignZ = alignBy unitZ 104 | 105 | -- | See the documentation for 'alignZ'. 106 | snugZ :: (InSpace v n a, Enveloped a, Traced a, HasOrigin a, R3 v) => n -> a -> a 107 | snugZ = snugBy unitZ 108 | 109 | -- | Center the local origin along the Z-axis. 110 | centerZ :: (InSpace v n a, R3 v, Enveloped a, HasOrigin a) => a -> a 111 | centerZ = alignBy unitZ 0 112 | 113 | snugCenterZ :: (InSpace v n a, R3 v, Enveloped a, HasOrigin a, Traced a) => a -> a 114 | snugCenterZ = snugBy unitZ 0 115 | 116 | -- | Center along both the X- and Z-axes. 117 | centerXZ :: (InSpace v n a, R3 v, Enveloped a, HasOrigin a) => a -> a 118 | centerXZ = centerX . centerZ 119 | 120 | -- | Center along both the Y- and Z-axes. 121 | centerYZ :: (InSpace v n a, R3 v, Enveloped a, HasOrigin a) => a -> a 122 | centerYZ = centerZ . centerY 123 | 124 | -- | Center an object in three dimensions. 125 | centerXYZ :: (InSpace v n a, R3 v, Enveloped a, HasOrigin a) => a -> a 126 | centerXYZ = centerX . centerY . centerZ 127 | -------------------------------------------------------------------------------- /src/Geometry/ThreeD/Size.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Geometry.ThreeD.Size 7 | -- Copyright : (c) 2014-2017 diagrams team (see LICENSE) 8 | -- License : BSD-style (see LICENSE) 9 | -- Maintainer : diagrams-discuss@googlegroups.com 10 | -- 11 | -- Utilities for working with sizes of three-dimensional objects. 12 | -- 13 | ----------------------------------------------------------------------------- 14 | module Geometry.ThreeD.Size 15 | ( 16 | -- * Computing sizes 17 | extentX, extentY, extentZ 18 | 19 | -- * Specifying sizes 20 | , mkSizeSpec3D 21 | , dims3D 22 | 23 | ) where 24 | 25 | import Geometry.Envelope 26 | import Geometry.Size 27 | import Geometry.Space 28 | import Geometry.ThreeD.Types 29 | import Geometry.ThreeD.Vector 30 | import Geometry.TwoD.Size 31 | 32 | ------------------------------------------------------------ 33 | -- Computing geometry sizes 34 | ------------------------------------------------------------ 35 | 36 | -- | Compute the absolute z-coordinate range of an enveloped object in 37 | -- the form @(lo,hi)@. Return @Nothing@ for objects with an empty 38 | -- envelope. 39 | extentZ :: (InSpace v n a, R3 v, Enveloped a) => a -> Maybe (n, n) 40 | extentZ = extent unitZ 41 | 42 | -- | Make a 3D 'SizeSpec' from possibly-specified width, height, and depth. 43 | mkSizeSpec3D :: Num n => Maybe n -> Maybe n -> Maybe n -> SizeSpec V3 n 44 | mkSizeSpec3D x y z = mkSizeSpec (V3 x y z) 45 | 46 | -- | Make a 3D 'SizeSpec' from a width, height, and depth. 47 | dims3D :: n -> n -> n -> SizeSpec V3 n 48 | dims3D x y z = dims (V3 x y z) 49 | 50 | -------------------------------------------------------------------------------- /src/Geometry/ThreeD/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Geometry.ThreeD.Types 7 | -- Copyright : (c) 2011-2017 diagrams team (see LICENSE) 8 | -- License : BSD-style (see LICENSE) 9 | -- Maintainer : diagrams-discuss@googlegroups.com 10 | -- 11 | -- Basic types for three-dimensional Euclidean space. 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module Geometry.ThreeD.Types 16 | ( -- * 3D Euclidean space 17 | r3, unr3, mkR3 18 | , p3, unp3, mkP3 19 | , r3Iso, p3Iso, project 20 | , r3SphericalIso, r3CylindricalIso 21 | , V3 (..), P3, T3 22 | , R1 (..), R2 (..), R3 (..) 23 | 24 | ) where 25 | 26 | import Control.Lens (Iso', iso, _1, _2, _3) 27 | 28 | import Geometry.Angle 29 | import Geometry.Points 30 | import Geometry.Space 31 | import Geometry.Transform 32 | import Geometry.TwoD.Types 33 | 34 | import Linear.Metric 35 | import Linear.V3 as V 36 | 37 | ------------------------------------------------------------ 38 | -- 3D Euclidean space 39 | 40 | -- Basic R3 types 41 | 42 | type T3 = Transformation V3 43 | 44 | r3Iso :: Iso' (V3 n) (n, n, n) 45 | r3Iso = iso unr3 r3 46 | 47 | -- | Construct a 3D vector from a triple of components. 48 | r3 :: (n, n, n) -> V3 n 49 | r3 (x,y,z) = V3 x y z 50 | 51 | -- | Curried version of `r3`. 52 | mkR3 :: n -> n -> n -> V3 n 53 | mkR3 = V3 54 | 55 | -- | Convert a 3D vector back into a triple of components. 56 | unr3 :: V3 n -> (n, n, n) 57 | unr3 (V3 x y z) = (x,y,z) 58 | 59 | -- | Construct a 3D point from a triple of coordinates. 60 | p3 :: (n, n, n) -> P3 n 61 | p3 = P . r3 62 | 63 | -- | Convert a 3D point back into a triple of coordinates. 64 | unp3 :: P3 n -> (n, n, n) 65 | unp3 (P (V3 x y z)) = (x,y,z) 66 | 67 | p3Iso :: Iso' (P3 n) (n, n, n) 68 | p3Iso = iso unp3 p3 69 | 70 | -- | Curried version of `p3`. 71 | mkP3 :: n -> n -> n -> P3 n 72 | mkP3 x y z = p3 (x, y, z) 73 | 74 | type instance V (V3 n) = V3 75 | type instance N (V3 n) = n 76 | 77 | instance Num n => Transformable (V3 n) where 78 | transform = apply 79 | 80 | -- | An isomorphism between 3D vectors and their representation in 81 | -- spherical coordinates. 82 | r3SphericalIso :: RealFloat n => Iso' (V3 n) (n, Angle n, Angle n) 83 | r3SphericalIso = iso 84 | (\v@(V3 x y z) -> (norm v, atan2A y x, acosA (z / norm v))) 85 | (\(r,θ,φ) -> V3 (r * cosA θ * sinA φ) (r * sinA θ * sinA φ) (r * cosA φ)) 86 | 87 | -- | An isomorphism between 3D vectors and their representation in 88 | -- cylindrical coordinates. 89 | r3CylindricalIso :: RealFloat n => Iso' (V3 n) (n, Angle n, n) 90 | r3CylindricalIso = iso 91 | (\(V3 x y z) -> (sqrt $ x*x + y*y, atan2A y x, z)) 92 | (\(r,θ,z) -> V3 (r*cosA θ) (r*sinA θ) z) 93 | 94 | instance HasR V3 where 95 | _r = r3SphericalIso . _1 96 | 97 | instance HasTheta V3 where 98 | _theta = r3CylindricalIso . _2 99 | 100 | instance HasPhi V3 where 101 | _phi = r3SphericalIso . _3 102 | 103 | -------------------------------------------------------------------------------- /src/Geometry/ThreeD/Vector.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Geometry.ThreeD.Vector 4 | -- Copyright : (c) 2013-2017 diagrams team (see LICENSE) 5 | -- License : BSD-style (see LICENSE) 6 | -- Maintainer : diagrams-discuss@googlegroups.com 7 | -- 8 | -- Three-dimensional vectors. 9 | -- 10 | ----------------------------------------------------------------------------- 11 | module Geometry.ThreeD.Vector 12 | ( -- * Special 3D vectors 13 | unitX, unitY, unitZ, unit_X, unit_Y, unit_Z 14 | , xDir, yDir, zDir, x_Dir, y_Dir, z_Dir 15 | ) where 16 | 17 | import Control.Lens ((&), (.~)) 18 | 19 | import Geometry.Direction 20 | import Geometry.ThreeD.Types 21 | import Geometry.TwoD.Vector 22 | 23 | import Linear.Vector 24 | 25 | -- | The unit vector in the positive Z direction. 26 | unitZ :: (R3 v, Additive v, Num n) => v n 27 | unitZ = zero & _z .~ 1 28 | 29 | -- | The unit vector in the negative Z direction. 30 | unit_Z :: (R3 v, Additive v, Num n) => v n 31 | unit_Z = zero & _z .~ (-1) 32 | 33 | -- | A 'Direction' pointing in the positive Z direction. 34 | zDir :: (R3 v, Additive v, Num n) => Direction v n 35 | zDir = Dir unitZ 36 | 37 | -- | A 'Direction' pointing in the negative Z direction. 38 | z_Dir :: (R3 v, Additive v, Num n) => Direction v n 39 | z_Dir = Dir unit_Z 40 | -------------------------------------------------------------------------------- /src/Geometry/TwoD/Arc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE ViewPatterns #-} 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Geometry.TwoD.Arc 9 | -- Copyright : (c) 2011-2017 diagrams team (see LICENSE) 10 | -- License : BSD-style (see LICENSE) 11 | -- Maintainer : diagrams-discuss@googlegroups.com 12 | -- 13 | -- Two-dimensional arcs, approximated by cubic bezier curves. 14 | -- 15 | ----------------------------------------------------------------------------- 16 | 17 | module Geometry.TwoD.Arc 18 | ( arc 19 | , arc' 20 | , arcT 21 | 22 | , arcCCW 23 | , arcCW 24 | 25 | , bezierFromSweep 26 | 27 | , wedge 28 | , arcBetween 29 | , annularWedge 30 | ) where 31 | 32 | import qualified Data.Semigroup as Sem 33 | import Geometry.Angle 34 | import Geometry.Direction 35 | import Geometry.Located (at) 36 | import Geometry.Segment 37 | import Geometry.Space 38 | import Geometry.Trail 39 | import Geometry.Transform 40 | import Geometry.TwoD.Transform 41 | import Geometry.TwoD.Types 42 | import Geometry.TwoD.Vector (e, unitX, unitY, unit_Y) 43 | 44 | import Control.Lens (each, over, reversing, (&), (<>~), 45 | (^.)) 46 | 47 | import Linear.Affine 48 | import Linear.Metric 49 | import Linear.Vector 50 | 51 | -- For details of this approximation see: 52 | -- http://www.tinaja.com/glib/bezcirc2.pdf 53 | 54 | -- | @bezierFromSweepQ1 s@ constructs a 'Cubic' segment that starts in 55 | -- the positive y direction and sweeps counterclockwise through an 56 | -- angle @s@. The approximation is only valid for angles in the 57 | -- first quadrant. 58 | bezierFromSweepQ1 :: Floating n => Angle n -> Segment V2 n 59 | bezierFromSweepQ1 s = over each (^-^ unitX) . rotate (s ^/ 2) $ bezier3 c2 c1 p0 60 | where p0@(V2 x y) = e (s ^/ 2) 61 | c1 = V2 ((4-x)/3) ((1-x)*(3-x)/(3*y)) 62 | c2 = reflectY c1 63 | 64 | -- | @bezierFromSweep s@ constructs a series of 'Cubic' segments that 65 | -- start in the positive y direction and sweep counter clockwise 66 | -- through the angle @s@. If @s@ is negative, it will start in the 67 | -- negative y direction and sweep clockwise. When @s@ is less than 68 | -- 0.0001 the empty list results. If the sweep is greater than @fullTurn@ 69 | -- later segments will overlap earlier segments. 70 | bezierFromSweep :: OrderedField n => Angle n -> [Segment V2 n] 71 | bezierFromSweep s 72 | | s < zero = fmap reflectY . bezierFromSweep $ negated s 73 | | s < 0.0001 @@ rad = [] 74 | | s < fullTurn^/4 = [bezierFromSweepQ1 s] 75 | | otherwise = bezierFromSweepQ1 (fullTurn^/4) 76 | : map (rotateBy (1/4)) (bezierFromSweep (max (s ^-^ fullTurn^/4) zero)) 77 | 78 | {- 79 | ~~~~ Note [segment spacing] 80 | 81 | There are a few obvious options for segment spacing: 82 | A. Evenly space segments each with sweep less than or equal 83 | to one quarter of a circle. This has the benefit of a better approximation 84 | (at least I think it is better). 85 | B. Use as much of the sweep in quarter-circle sized segments and one for 86 | the remainder. This potentially gives more opportunities for 87 | consistency (though not as much as option C) as the error in 88 | approximation would more often match the error from another arc 89 | in the diagram. 90 | C. Like option B but fixing the orientation and having a remnant at 91 | the beginning and the end. 92 | 93 | Option B is implemented and this note is for posterity if anyone comes 94 | across a situation with large enough arcs that they can actually see 95 | the approximation error. 96 | -} 97 | 98 | -- | Given a start direction @d@ and a sweep angle @s@, @'arcT' d s@ 99 | -- is the 'Trail' of a radius one arc starting at @d@ and sweeping out 100 | -- the angle @s@ counterclockwise (for positive s). The resulting 101 | -- @Trail@ is allowed to wrap around and overlap itself. 102 | arcT :: OrderedField n => Direction V2 n -> Angle n -> Trail V2 n 103 | arcT start sweep = fromSegments bs 104 | where 105 | bs = map (rotateTo start) . bezierFromSweep $ sweep 106 | 107 | -- | Given a start direction @d@ and a sweep angle @s@, @'arc' d s@ is the 108 | -- path of a radius one arc starting at @d@ and sweeping out the angle 109 | -- @s@ counterclockwise (for positive s). The resulting 110 | -- @Trail@ is allowed to wrap around and overlap itself. 111 | arc :: (InSpace V2 n t, OrderedField n, FromTrail t) => Direction V2 n -> Angle n -> t 112 | arc start sweep = fromLocTrail $ arcT start sweep `at` P (fromDirection start) 113 | 114 | -- | Given a radus @r@, a start direction @d@ and an angle @s@, 115 | -- @'arc'' r d s@ is the path of a radius @(abs r)@ arc starting at 116 | -- @d@ and sweeping out the angle @s@ counterclockwise (for positive 117 | -- s). The origin of the arc is its center. 118 | -- 119 | -- <> 120 | -- 121 | -- > arc'Ex = mconcat [ arc' r xDir (1/4 @@ turn) | r <- [0.5,-1,1.5] ] 122 | -- > # centerXY # pad 1.1 123 | arc' :: (InSpace V2 n t, OrderedField n, FromTrail t) => n -> Direction V2 n -> Angle n -> t 124 | arc' (abs -> r) start sweep = fromLocTrail $ scale r ts `at` P (r *^ fromDirection start) 125 | where ts = arcT start sweep 126 | 127 | arcCCWT :: RealFloat n => Direction V2 n -> Direction V2 n -> Trail V2 n 128 | arcCCWT start end = fromSegments bs 129 | where 130 | bs = map (rotateTo start) . bezierFromSweep $ sweep 131 | sweep = normalizeAngle $ end ^. _theta ^-^ start ^. _theta 132 | 133 | -- | Given a start direction @s@ and end direction @e@, @arcCCW s e@ is the 134 | -- path of a radius one arc counterclockwise between the two directions. 135 | -- The origin of the arc is its center. 136 | arcCCW :: (InSpace V2 n t, RealFloat n, FromTrail t) => Direction V2 n -> Direction V2 n -> t 137 | arcCCW start end = fromLocTrail $ arcCCWT start end `at` P (fromDirection start) 138 | 139 | -- | Like 'arcAngleCCW' but clockwise. 140 | arcCW :: (InSpace V2 n t, RealFloat n, FromTrail t) => Direction V2 n -> Direction V2 n -> t 141 | arcCW start end = fromLocTrail $ 142 | -- flipped arguments to get the path we want 143 | -- then reverse the trail to get the cw direction. 144 | reversing (arcCCWT end start) `at` P (fromDirection start) 145 | 146 | -- | Create a circular wedge of the given radius, beginning at the 147 | -- given direction and extending through the given angle. 148 | -- 149 | -- <> 150 | -- 151 | -- > wedgeEx = hsep 0.5 152 | -- > [ wedge 1 xDir (1/4 @@ turn) 153 | -- > , wedge 1 (rotate (7/30 @@ turn) xDir) (4/30 @@ turn) 154 | -- > , wedge 1 (rotate (1/8 @@ turn) xDir) (3/4 @@ turn) 155 | -- > ] 156 | -- > # fc blue 157 | -- > # centerXY # pad 1.1 158 | wedge :: (InSpace V2 n t, OrderedField n, FromTrail t) => n -> Direction V2 n -> Angle n -> t 159 | wedge r d s = fromLocTrail . (`at` origin) . glueTrail . wrapLine 160 | $ fromOffsets [r *^ fromDirection d] 161 | Sem.<> scale r (arc d s) 162 | Sem.<> fromOffsets [r *^ negated (rotate s $ fromDirection d)] 163 | 164 | -- | @arcBetween p q height@ creates an arc beginning at @p@ and 165 | -- ending at @q@, with its midpoint at a distance of @abs height@ 166 | -- away from the straight line from @p@ to @q@. A positive value of 167 | -- @height@ results in an arc to the left of the line from @p@ to 168 | -- @q@; a negative value yields one to the right. 169 | -- 170 | -- <> 171 | -- 172 | -- > arcBetweenEx = mconcat 173 | -- > [ arcBetween origin (p2 (2,1)) ht | ht <- [-0.2, -0.1 .. 0.2] ] 174 | -- > # centerXY # pad 1.1 175 | arcBetween :: (InSpace V2 n t, FromTrail t, RealFloat n) => Point V2 n -> Point V2 n -> n -> t 176 | arcBetween p q ht = fromLocTrail (a & rotate (v^._theta) & moveTo p) 177 | where 178 | h = abs ht 179 | isStraight = h < 0.00001 180 | v = q .-. p 181 | d = norm (q .-. p) 182 | th = acosA ((d*d - 4*h*h)/(d*d + 4*h*h)) 183 | r = d/(2*sinA th) 184 | mid | ht >= 0 = direction unitY 185 | | otherwise = direction unit_Y 186 | st = mid & _theta <>~ negated th 187 | a | isStraight 188 | = fromOffsets [d *^ unitX] 189 | | otherwise 190 | = arc st (2 *^ th) 191 | & scale r 192 | & translateY ((if ht > 0 then negate else id) (r - h)) 193 | & translateX (d/2) 194 | & (if ht > 0 then reversing else id) 195 | 196 | -- | Create an annular wedge of the given radii, beginning at the 197 | -- first direction and extending through the given sweep angle. 198 | -- The radius of the outer circle is given first. 199 | -- 200 | -- <> 201 | -- 202 | -- > annularWedgeEx = hsep 0.50 203 | -- > [ annularWedge 1 0.5 xDir (1/4 @@ turn) 204 | -- > , annularWedge 1 0.3 (rotate (7/30 @@ turn) xDir) (4/30 @@ turn) 205 | -- > , annularWedge 1 0.7 (rotate (1/8 @@ turn) xDir) (3/4 @@ turn) 206 | -- > ] 207 | -- > # fc blue 208 | -- > # centerXY # pad 1.1 209 | annularWedge :: (InSpace V2 n t, FromTrail t, RealFloat n) => 210 | n -> n -> Direction V2 n -> Angle n -> t 211 | annularWedge r1' r2' d1 s = fromLocTrail . (`at` o) . glueTrail . wrapLine 212 | $ fromOffsets [(r1' - r2') *^ fromDirection d1] 213 | Sem.<> scale r1' (arc d1 s) 214 | Sem.<> fromOffsets [(r1' - r2') *^ negated (fromDirection d2)] 215 | Sem.<> scale r2' (arc d2 (negated s)) 216 | where o = P (r2' *^ fromDirection d1) 217 | d2 = d1 & _theta <>~ s 218 | 219 | -------------------------------------------------------------------------------- /src/Geometry/TwoD/Curvature.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE DataKinds #-} 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Geometry.TwoD.Curvature 7 | -- Copyright : (c) 2013-2017 diagrams team (see LICENSE) 8 | -- License : BSD-style (see LICENSE) 9 | -- Maintainer : diagrams-discuss@googlegroups.com 10 | -- 11 | -- Compute curvature for segments in two dimensions. 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module Geometry.TwoD.Curvature 16 | ( 17 | curvature 18 | , radiusOfCurvature 19 | , squaredCurvature 20 | , squaredRadiusOfCurvature 21 | ) where 22 | 23 | import Control.Lens (over) 24 | import Control.Monad 25 | import Data.Monoid.Inf 26 | 27 | import Geometry.Segment 28 | import Geometry.Parametric 29 | import Geometry.TwoD.Types 30 | 31 | import Linear.Vector 32 | 33 | -- | Curvature measures how curved the segment is at a point. One intuition 34 | -- for the concept is how much you would turn the wheel when driving a car 35 | -- along the curve. When the wheel is held straight there is zero curvature. 36 | -- When turning a corner to the left we will have positive curvature. When 37 | -- turning to the right we will have negative curvature. 38 | -- 39 | -- Another way to measure this idea is to find the largest circle that we can 40 | -- push up against the curve and have it touch (locally) at exactly the point 41 | -- and not cross the curve. This is a tangent circle. The radius of that 42 | -- circle is the \"Radius of Curvature\" and it is the reciprocal of curvature. 43 | -- Note that if the circle is on the \"left\" of the curve, we have a positive 44 | -- radius, and if it is to the right we have a negative radius. Straight 45 | -- segments have an infinite radius which leads us to our representation. We 46 | -- result in a pair of numerator and denominator so we can include infinity and 47 | -- zero for both the radius and the curvature. 48 | -- 49 | -- 50 | -- Lets consider the following curve: 51 | -- 52 | -- <> 53 | -- 54 | -- The curve starts with positive curvature, 55 | -- 56 | -- <> 57 | -- 58 | -- approaches zero curvature 59 | -- 60 | -- <> 61 | -- 62 | -- then has negative curvature 63 | -- 64 | -- <> 65 | -- 66 | -- > import Geometry.TwoD.Curvature 67 | -- > import Data.Monoid.Inf 68 | -- > 69 | -- > segmentA :: Segment V2 Double 70 | -- > segmentA = bezier3 (V2 12 0) (V2 8 10) (V2 20 8) 71 | -- > 72 | -- > curveA = fromSegments [segmentA] # lw thick 73 | -- > 74 | -- > diagramA = pad 1.1 . centerXY $ curveA 75 | -- > 76 | -- > diagramPos = diagramWithRadius 0.2 77 | -- > 78 | -- > diagramZero = diagramWithRadius 0.45 79 | -- > 80 | -- > diagramNeg = diagramWithRadius 0.8 81 | -- > 82 | -- > diagramWithRadius t = pad 1.1 . centerXY 83 | -- > $ curveA 84 | -- > <> showCurvature segmentA t 85 | -- > # withEnvelope (curveA :: Diagram V2) 86 | -- > # lc red 87 | -- > 88 | -- > showCurvature :: Segment V2 Double -> Double -> Diagram V2 89 | -- > showCurvature bez@(Cubic b c d) t 90 | -- > | v == (0,0) = mempty 91 | -- > | otherwise = go (radiusOfCurvature bez t) 92 | -- > where 93 | -- > v@(x,y) = unr2 $ firstDerivative b c d t 94 | -- > vp = V2 (-y) x 95 | -- > 96 | -- > firstDerivative b c d t = let tt = t*t in (3*(3*tt-4*t+1))*^b + (3*(2-3*t)*t)*^c + (3*tt)*^d 97 | -- > 98 | -- > go Infinity = mempty 99 | -- > go (Finite r) = (circle (abs r) # translate vpr 100 | -- > <> (origin ~~ (origin .+^ vpr))) 101 | -- > # moveTo (origin .+^ atParam bez t) 102 | -- > where 103 | -- > vpr = signorm vp ^* r 104 | -- > 105 | -- 106 | curvature :: RealFloat n 107 | => Segment V2 n -- ^ Segment to measure on. 108 | -> n -- ^ Parameter to measure at. 109 | -> PosInf n -- ^ Result is a @PosInf@ value where @PosInfty@ represents 110 | -- infinite curvature or zero radius of curvature. 111 | curvature s = toPosInf . over _y sqrt . curvaturePair s 112 | 113 | -- | With @squaredCurvature@ we can compute values in spaces that do not support 114 | -- 'sqrt' and it is just as useful for relative ordering of curvatures or looking 115 | -- for zeros. 116 | squaredCurvature :: RealFloat n => Segment V2 n -> n -> PosInf n 117 | squaredCurvature s = toPosInf . over _x (join (*)) . curvaturePair s 118 | 119 | -- | Reciprocal of @curvature@. 120 | radiusOfCurvature :: RealFloat n 121 | => Segment V2 n -- ^ Segment to measure on. 122 | -> n -- ^ Parameter to measure at. 123 | -> PosInf n -- ^ Result is a @PosInf@ value where @PosInfty@ represents 124 | -- infinite radius of curvature or zero curvature. 125 | radiusOfCurvature s = toPosInf . (\(V2 p q) -> V2 (sqrt q) p) . curvaturePair s 126 | 127 | -- | Reciprocal of @squaredCurvature@ 128 | squaredRadiusOfCurvature :: RealFloat n => Segment V2 n -> n -> PosInf n 129 | squaredRadiusOfCurvature s = toPosInf . (\(V2 p q) -> (V2 q (p * p))) . curvaturePair s 130 | 131 | -- Package up problematic values with the appropriate infinity. 132 | toPosInf :: RealFloat a => V2 a -> PosInf a 133 | toPosInf (V2 _ 0) = Infinity 134 | toPosInf (V2 p q) 135 | | isInfinite r || isNaN r = Infinity 136 | | otherwise = Finite r 137 | where r = p / q 138 | 139 | -- Internal function that is not quite curvature or squaredCurvature but lets 140 | -- us get there by either taking the square root of the numerator or squaring 141 | -- the denominator respectively. 142 | curvaturePair :: Num n => Segment V2 n -> n -> V2 n 143 | curvaturePair (Linear _) _ = V2 0 1 -- Linear segments always have zero curvature (infinite radius). 144 | curvaturePair seg@(Cubic b c d) t 145 | = V2 (x'*y'' - y'*x'') ((x'*x' + y'*y')^(3 :: Int)) 146 | where 147 | (V2 x' y' ) = seg `tangentAtParam` t 148 | (V2 x'' y'') = secondDerivative 149 | secondDerivative = (6*(3*t-2))*^b ^+^ (6-18*t)*^c ^+^ (6*t)*^d 150 | 151 | -- TODO: We should be able to generalize this to higher dimensions. See 152 | -- 153 | -- 154 | -- TODO: I'm not sure what the best way to generalize squaredCurvature to other spaces is. 155 | 156 | -- curvaturePair :: (Num t, Num (Scalar t), VectorSpace t) 157 | -- => Segment (t, t) -> Scalar t -> (t, t) 158 | -- curvaturePair (Linear _) _ = (0,1) -- Linear segments always have zero curvature (infinite radius). 159 | -- curvaturePair seg@(Cubic b c d) t = ((x'*y'' - y'*x''), (x'*x' + y'*y')^(3 :: Integer)) 160 | -- where 161 | -- (x' ,y' ) = seg `tangentAtParam` t 162 | -- (x'',y'') = secondDerivative 163 | -- secondDerivative = (6*(3*t-2))*^b ^+^ (6-18*t)*^c ^+^ (6*t)*^d 164 | -------------------------------------------------------------------------------- /src/Geometry/TwoD/Ellipse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Geometry.TwoD.Ellipse 8 | -- Copyright : (c) 2011-2017 diagrams team (see LICENSE) 9 | -- License : BSD-style (see LICENSE) 10 | -- Maintainer : diagrams-discuss@googlegroups.com 11 | -- 12 | -- Two-dimensional ellipses (and, as a special case, circles). 13 | -- 14 | ----------------------------------------------------------------------------- 15 | 16 | module Geometry.TwoD.Ellipse 17 | ( 18 | unitCircle 19 | , circle 20 | , ellipse 21 | , ellipseXY 22 | ) where 23 | 24 | import Geometry.Space 25 | 26 | import Geometry.Angle 27 | import Geometry.Located (at) 28 | import Geometry.Trail 29 | import Geometry.Transform 30 | import Geometry.TwoD.Arc 31 | import Geometry.TwoD.Transform 32 | import Geometry.TwoD.Types 33 | import Geometry.TwoD.Vector (xDir) 34 | 35 | -- | A circle of radius 1, with center at the origin. 36 | unitCircle :: (InSpace V2 n t, FromTrail t, OrderedField n) => t 37 | unitCircle = fromLocTrail $ glueTrail (arcT xDir fullTurn) `at` p2 (1,0) 38 | 39 | -- | A circle of the given radius, centered at the origin. As a path, 40 | -- it begins at @(r,0)@. 41 | circle :: (InSpace V2 n t, FromTrail t, OrderedField n) => n -> t 42 | circle d = fromLocTrail $ scale d unitCircle 43 | 44 | -- | @ellipse e@ constructs an ellipse with eccentricity @e@ by 45 | -- scaling the unit circle in the X direction. The eccentricity must 46 | -- be within the interval [0,1). 47 | ellipse :: (InSpace V2 n t, FromTrail t, OrderedField n) => n -> t 48 | ellipse e 49 | | e >= 0 && e < 1 = fromLocTrail $ scaleX (sqrt (1 - e*e)) unitCircle 50 | | otherwise = error "Eccentricity of ellipse must be >= 0 and < 1." 51 | 52 | -- | @ellipseXY x y@ creates an axis-aligned ellipse, centered at the 53 | -- origin, with radius @x@ along the x-axis and radius @y@ along the 54 | -- y-axis. 55 | ellipseXY :: (InSpace V2 n t, FromTrail t, OrderedField n) => n -> n -> t 56 | ellipseXY x y = fromLocTrail $ scaleV (V2 x y) unitCircle 57 | -------------------------------------------------------------------------------- /src/Geometry/TwoD/Path.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE Rank2Types #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | {-# OPTIONS_GHC -fno-warn-orphans #-} 12 | ----------------------------------------------------------------------------- 13 | -- | 14 | -- Module : Geometry.TwoD.Path 15 | -- Copyright : (c) 2011-2017 diagrams team (see LICENSE) 16 | -- License : BSD-style (see LICENSE) 17 | -- Maintainer : diagrams-discuss@googlegroups.com 18 | -- 19 | -- Paths in two dimensions are special since we may stroke them to 20 | -- create a 2D diagram, and perform operations such as intersection 21 | -- and union. They also have a trace, whereas paths in higher 22 | -- dimensions do not. 23 | -- 24 | ----------------------------------------------------------------------------- 25 | 26 | module Geometry.TwoD.Path 27 | ( 28 | -- ** Inside/outside testing 29 | 30 | Crossings (..) 31 | , isInsideWinding 32 | , isInsideEvenOdd 33 | 34 | -- * Intersections 35 | 36 | , intersectPoints, intersectPoints' 37 | , intersectPointsP, intersectPointsP' 38 | , intersectPointsT, intersectPointsT' 39 | ) where 40 | 41 | import Control.Lens hiding (at, transform) 42 | import Geometry.Located (Located) 43 | import Geometry.Path 44 | import Geometry.Segment 45 | import Geometry.Space 46 | import Geometry.Trail 47 | import Geometry.TwoD.Segment 48 | import Geometry.TwoD.Types 49 | 50 | ------------------------------------------------------------ 51 | -- Intersections ----------------------------------------- 52 | ------------------------------------------------------------ 53 | 54 | -- | Find the intersect points of two objects that can be converted to a path. 55 | intersectPoints :: (InSpace V2 n t, SameSpace t s, ToPath t, ToPath s, OrderedField n) 56 | => t -> s -> [P2 n] 57 | intersectPoints = intersectPoints' 1e-8 58 | 59 | -- | Find the intersect points of two objects that can be converted to a path 60 | -- within the given tolerance. 61 | intersectPoints' :: (InSpace V2 n t, SameSpace t s, ToPath t, ToPath s, OrderedField n) 62 | => n -> t -> s -> [P2 n] 63 | intersectPoints' eps t s = intersectPointsP' eps (toPath t) (toPath s) 64 | 65 | -- | Compute the intersect points between two paths. 66 | intersectPointsP :: OrderedField n => Path V2 n -> Path V2 n -> [P2 n] 67 | intersectPointsP = intersectPointsP' 1e-8 68 | 69 | -- | Compute the intersect points between two paths within given tolerance. 70 | intersectPointsP' :: OrderedField n => n -> Path V2 n -> Path V2 n -> [P2 n] 71 | intersectPointsP' eps as bs = do 72 | a <- toListOf each as 73 | b <- toListOf each bs 74 | intersectPointsT' eps a b 75 | 76 | -- | Compute the intersect points between two located trails. 77 | intersectPointsT :: OrderedField n => Located (Trail V2 n) -> Located (Trail V2 n) -> [P2 n] 78 | intersectPointsT = intersectPointsT' 1e-8 79 | 80 | -- | Compute the intersect points between two located trails within the given 81 | -- tolerance. 82 | intersectPointsT' :: OrderedField n => n -> Located (Trail V2 n) -> Located (Trail V2 n) -> [P2 n] 83 | intersectPointsT' eps as bs = do 84 | a <- fixTrail as 85 | b <- fixTrail bs 86 | intersectPointsS' eps a b 87 | -------------------------------------------------------------------------------- /src/Geometry/TwoD/Points.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Geometry.TwoD.Points 4 | -- Copyright : (c) 2014-2017 diagrams team (see LICENSE) 5 | -- License : BSD-style (see LICENSE) 6 | -- Maintainer : diagrams-discuss@googlegroups.com 7 | -- 8 | -- Special functions for points in R2. 9 | -- 10 | ----------------------------------------------------------------------------- 11 | 12 | {-# LANGUAGE TypeFamilies #-} 13 | 14 | module Geometry.TwoD.Points where 15 | 16 | import Data.List 17 | import Linear.Affine 18 | 19 | import Geometry.Space 20 | import Geometry.TwoD.Types (P2) 21 | import Geometry.TwoD.Vector 22 | 23 | -- | Find the convex hull of a list of points using Andrew's monotone chain 24 | -- algorithm O(n log n). 25 | -- 26 | -- Returns clockwise list of points starting from the left-most point. 27 | convexHull2D :: OrderedField n => [P2 n] -> [P2 n] 28 | convexHull2D ps = init upper ++ reverse (tail lower) 29 | where 30 | (upper, lower) = sortedConvexHull (sort ps) 31 | 32 | -- | Find the convex hull of a set of points already sorted in the x direction. 33 | -- The first list of the tuple is the upper hull going clockwise from 34 | -- left-most to right-most point. The second is the lower hull from 35 | -- right-most to left-most in the anti-clockwise direction. 36 | sortedConvexHull :: OrderedField n => [P2 n] -> ([P2 n], [P2 n]) 37 | sortedConvexHull ps = (chain True ps, chain False ps) 38 | where 39 | chain upper (p1_:p2_:rest_) = 40 | case go (p2_ .-. p1_) p2_ rest_ of 41 | Right l -> p1_:l 42 | Left l -> chain upper (p1_:l) 43 | where 44 | test = if upper then (>0) else (<0) 45 | -- find the convex hull by comparing the angles of the vectors with 46 | -- the cross product and backtracking if necessary 47 | go d p1 l@(p2:rest) 48 | -- backtrack if the direction is outward 49 | | test $ d `crossZ` d' = Left l 50 | | otherwise = 51 | case go d' p2 rest of 52 | Left m -> go d p1 m 53 | Right m -> Right (p1:m) 54 | where 55 | d' = p2 .-. p1 56 | go _ p1 p = Right (p1:p) 57 | 58 | chain _ l = l 59 | -------------------------------------------------------------------------------- /src/Geometry/TwoD/Segment/Bernstein.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Diagrams.TwoD.Segment.Bernstein 6 | -- Copyright : (c) 2014-2015 diagrams-lib team (see LICENSE) 7 | -- License : BSD-style (see LICENSE) 8 | -- Maintainer : diagrams-discuss@googlegroups.com 9 | -- 10 | -- Bernstein polynomials, used internally by code to find 11 | -- intersections of paths. This module is probably not of any 12 | -- relevance to most users. 13 | ----------------------------------------------------------------------------- 14 | module Geometry.TwoD.Segment.Bernstein 15 | ( BernsteinPoly (..) 16 | , listToBernstein 17 | , evaluateBernstein 18 | 19 | , degreeElevate 20 | , bernsteinDeriv 21 | , evaluateBernsteinDerivs 22 | ) where 23 | 24 | import Data.List (tails) 25 | import Geometry.Parametric 26 | import Geometry.Space 27 | import Linear.V1 28 | 29 | -- | Compute the binomial coefficients of degree n. 30 | binomials :: Num n => Int -> [n] 31 | binomials n = map fromIntegral $ scanl (\x m -> x * (n - m+1) `quot` m) 1 [1..n] 32 | 33 | data BernsteinPoly n = BernsteinPoly 34 | { bernsteinDegree :: Int 35 | , bernsteinCoeffs :: [n] 36 | } deriving (Show, Functor) 37 | 38 | type instance V (BernsteinPoly n) = V1 39 | type instance N (BernsteinPoly n) = n 40 | type instance Codomain (BernsteinPoly n) = V1 41 | 42 | -- | Create a bernstein polynomial from a list of coëfficients. 43 | listToBernstein :: Fractional n => [n] -> BernsteinPoly n 44 | listToBernstein [] = 0 45 | listToBernstein l = BernsteinPoly (length l - 1) l 46 | 47 | -- | Degree elevate a bernstein polynomial a number of times. 48 | degreeElevate :: Fractional n => BernsteinPoly n -> Int -> BernsteinPoly n 49 | degreeElevate b 0 = b 50 | degreeElevate (BernsteinPoly lp p) times = 51 | degreeElevate (BernsteinPoly (lp+1) (head p:inner p 1)) (times-1) 52 | where 53 | n = fromIntegral lp 54 | 55 | inner [] _ = [0] 56 | inner [a] _ = [a] 57 | inner (a:b:rest) i = (i*a/(n+1) + b*(1 - i/(n+1))) : inner (b:rest) (i+1) 58 | 59 | -- | Evaluate the bernstein polynomial. 60 | evaluateBernstein :: Fractional n => BernsteinPoly n -> n -> n 61 | evaluateBernstein (BernsteinPoly _ []) _ = 0 62 | evaluateBernstein (BernsteinPoly _ [b]) _ = b 63 | evaluateBernstein (BernsteinPoly lp (b':bs)) t = go t n (b'*u) 2 bs 64 | where 65 | u = 1-t 66 | n = fromIntegral lp 67 | 68 | go tn bc tmp _ [b] = tmp + tn*bc*b 69 | go tn bc tmp i (b:rest) = 70 | go (tn*t) -- tn 71 | (bc*(n - i+1)/i) -- bc 72 | ((tmp + tn*bc*b)*u) -- tmp 73 | (i+1) -- i 74 | rest 75 | go _ _ _ _ [] = error "evaluateBernstein: impossible" 76 | 77 | -- | Evaluate the bernstein polynomial and its derivatives. 78 | evaluateBernsteinDerivs :: Fractional n => BernsteinPoly n -> n -> [n] 79 | evaluateBernsteinDerivs b t 80 | | bernsteinDegree b == 0 = [evaluateBernstein b t] 81 | | otherwise = evaluateBernstein b t : evaluateBernsteinDerivs (bernsteinDeriv b) t 82 | 83 | -- | Find the derivative of a bernstein polynomial. 84 | bernsteinDeriv :: Fractional n => BernsteinPoly n -> BernsteinPoly n 85 | bernsteinDeriv (BernsteinPoly 0 _) = 0 86 | bernsteinDeriv (BernsteinPoly lp p) = 87 | -- BernsteinPoly (lp-1) $ map (* fromIntegral lp) $ zipWith (-) (tail p) p 88 | BernsteinPoly (lp-1) $ zipWith (\a b -> (a - b) * fromIntegral lp) (tail p) p 89 | 90 | instance Fractional n => Parametric (BernsteinPoly n) where 91 | atParam b = V1 . evaluateBernstein b 92 | instance Num n => DomainBounds (BernsteinPoly n) 93 | instance Fractional n => EndValues (BernsteinPoly n) 94 | instance Fractional n => Sectionable (BernsteinPoly n) where 95 | splitAtParam = bernsteinSplit 96 | reverseDomain (BernsteinPoly i xs) = BernsteinPoly i (reverse xs) 97 | 98 | -- | Split a bernstein polynomial. 99 | bernsteinSplit :: Num n => BernsteinPoly n -> n -> (BernsteinPoly n, BernsteinPoly n) 100 | bernsteinSplit (BernsteinPoly lp p) t = 101 | (BernsteinPoly lp $ map head controls, 102 | BernsteinPoly lp $ reverse $ map last controls) 103 | where 104 | interp a b = (1-t)*a + t*b 105 | 106 | terp [_] = [] 107 | terp l = let ctrs = zipWith interp l (tail l) 108 | in ctrs : terp ctrs 109 | controls = p : terp p 110 | 111 | instance Fractional n => Num (BernsteinPoly n) where 112 | ba@(BernsteinPoly la a) + bb@(BernsteinPoly lb b) 113 | | la < lb = BernsteinPoly lb $ zipWith (+) (bernsteinCoeffs $ degreeElevate ba (lb - la)) b 114 | | la > lb = BernsteinPoly la $ zipWith (+) a (bernsteinCoeffs $ degreeElevate bb (la - lb)) 115 | | otherwise = BernsteinPoly la $ zipWith (+) a b 116 | 117 | ba@(BernsteinPoly la a) - bb@(BernsteinPoly lb b) 118 | | la < lb = BernsteinPoly lb $ zipWith (-) (bernsteinCoeffs $ degreeElevate ba (lb - la)) b 119 | | la > lb = BernsteinPoly la $ zipWith (-) a (bernsteinCoeffs $ degreeElevate bb (la - lb)) 120 | | otherwise = BernsteinPoly la $ zipWith (-) a b 121 | 122 | (BernsteinPoly la a) * (BernsteinPoly lb b) = 123 | BernsteinPoly (la+lb) $ 124 | zipWith (flip (/)) (binomials (la + lb)) $ 125 | init $ map sum $ 126 | map (zipWith (*) a') (down b') ++ 127 | map (zipWith (*) (reverse b')) (tail $ tails a') 128 | -- zipWith (zipWith (*)) (tail $ tails a') (repeat $ reverse b') 129 | where down l = tail $ scanl (flip (:)) [] l -- [[1], [2, 1], [3, 2, 1], ... 130 | a' = zipWith (*) a (binomials la) 131 | b' = zipWith (*) b (binomials lb) 132 | 133 | fromInteger a = BernsteinPoly 0 [fromInteger a] 134 | 135 | signum (BernsteinPoly _ []) = 0 136 | signum (BernsteinPoly _ (a:_)) = BernsteinPoly 0 [signum a] 137 | 138 | abs = fmap abs 139 | -------------------------------------------------------------------------------- /src/Geometry/TwoD/Size.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Geometry.TwoD.Size 7 | -- Copyright : (c) 2011-2017 diagrams team (see LICENSE) 8 | -- License : BSD-style (see LICENSE) 9 | -- Maintainer : diagrams-discuss@googlegroups.com 10 | -- 11 | -- Utilities for working with sizes of two-dimensional objects. 12 | -- 13 | ----------------------------------------------------------------------------- 14 | module Geometry.TwoD.Size 15 | ( 16 | -- ** Computing sizes 17 | width, height 18 | , extentX, extentY 19 | 20 | -- ** Specifying sizes 21 | , mkSizeSpec2D 22 | , mkWidth 23 | , mkHeight 24 | , dims2D 25 | 26 | ) where 27 | 28 | import Geometry.Envelope 29 | import Geometry.Size 30 | import Geometry.Space 31 | import Geometry.TwoD.Types 32 | import Geometry.TwoD.Vector 33 | 34 | ------------------------------------------------------------ 35 | -- Computing sizes 36 | ------------------------------------------------------------ 37 | 38 | -- | Compute the width of an enveloped object. 39 | -- 40 | -- Note this is just @diameter unitX@. 41 | width :: (InSpace V2 n a, Enveloped a) => a -> n 42 | width = diameter unitX 43 | 44 | -- | Compute the height of an enveloped object. 45 | height :: (InSpace V2 n a, Enveloped a) => a -> n 46 | height = diameter unitY 47 | 48 | -- | Compute the absolute x-coordinate range of an enveloped object in 49 | -- the form @(lo,hi)@. Return @Nothing@ for objects with an empty 50 | -- envelope. 51 | -- 52 | -- Note this is just @extent unitX@. 53 | extentX :: (InSpace v n a, R1 v, Enveloped a) => a -> Maybe (n, n) 54 | extentX = extent unitX 55 | 56 | -- | Compute the absolute y-coordinate range of an enveloped object in 57 | -- the form @(lo,hi)@. Return @Nothing@ for objects with an empty 58 | -- envelope. 59 | extentY :: (InSpace v n a, R2 v, Enveloped a) => a -> Maybe (n, n) 60 | extentY = extent unitY 61 | 62 | -- | Make a 'SizeSpec' from possibly-specified width and height. 63 | mkSizeSpec2D :: Num n => Maybe n -> Maybe n -> SizeSpec V2 n 64 | mkSizeSpec2D x y = mkSizeSpec (V2 x y) 65 | 66 | -- | Make a 'SizeSpec' from a width and height. 67 | dims2D :: n -> n -> SizeSpec V2 n 68 | dims2D x y = dims (V2 x y) 69 | 70 | -- | Make a 'SizeSpec' with only width defined. 71 | mkWidth :: Num n => n -> SizeSpec V2 n 72 | mkWidth w = dims (V2 w 0) 73 | 74 | -- | Make a 'SizeSpec' with only height defined. 75 | mkHeight :: Num n => n -> SizeSpec V2 n 76 | mkHeight h = dims (V2 0 h) 77 | 78 | -------------------------------------------------------------------------------- /src/Geometry/TwoD/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Geometry.TwoD.Types 8 | -- Copyright : (c) 2011-2017 diagrams team (see LICENSE) 9 | -- License : BSD-style (see LICENSE) 10 | -- Maintainer : diagrams-discuss@googlegroups.com 11 | -- 12 | -- Basic types for two-dimensional Euclidean space. 13 | -- 14 | ----------------------------------------------------------------------------- 15 | 16 | module Geometry.TwoD.Types 17 | ( -- * 2D Euclidean space 18 | V2 (..), R1 (..), R2 (..) 19 | , P2, T2 20 | , r2, unr2, mkR2, r2Iso 21 | , p2, mkP2, unp2, p2Iso 22 | , r2PolarIso 23 | , HasR (..) 24 | ) where 25 | 26 | import Control.Lens (Iso', Lens', iso, _1, _2) 27 | 28 | import Geometry.Angle 29 | import Geometry.Points 30 | 31 | import Geometry.Transform 32 | import Geometry.Space 33 | 34 | import Linear.Metric 35 | import Linear.V2 36 | 37 | type T2 = Transformation V2 38 | 39 | type instance V (V2 n) = V2 40 | type instance N (V2 n) = n 41 | 42 | -- | Construct a 2D vector from a pair of components. See also '&'. 43 | r2 :: (n, n) -> V2 n 44 | r2 = uncurry V2 45 | 46 | -- | Convert a 2D vector back into a pair of components. See also 'coords'. 47 | unr2 :: V2 n -> (n, n) 48 | unr2 (V2 x y) = (x, y) 49 | 50 | -- | Curried form of `r2`. 51 | mkR2 :: n -> n -> V2 n 52 | mkR2 = V2 53 | 54 | r2Iso :: Iso' (V2 n) (n, n) 55 | r2Iso = iso unr2 r2 56 | 57 | -- | Construct a 2D point from a pair of coordinates. See also '^&'. 58 | p2 :: (n, n) -> P2 n 59 | p2 = P . uncurry V2 60 | 61 | -- | Convert a 2D point back into a pair of coordinates. See also 'coords'. 62 | unp2 :: P2 n -> (n,n) 63 | unp2 (P (V2 x y)) = (x,y) 64 | 65 | -- | Curried form of `p2`. 66 | mkP2 :: n -> n -> P2 n 67 | mkP2 x y = P (V2 x y) 68 | 69 | p2Iso :: Iso' (Point V2 n) (n, n) 70 | p2Iso = iso unp2 p2 71 | 72 | instance Num n => Transformable (V2 n) where 73 | transform = apply 74 | 75 | r2PolarIso :: RealFloat n => Iso' (V2 n) (n, Angle n) 76 | r2PolarIso = iso (\v@(V2 x y) -> (norm v, atan2A y x)) 77 | (\(r,θ) -> V2 (r * cosA θ) (r * sinA θ)) 78 | {-# INLINE r2PolarIso #-} 79 | 80 | -- | A space which has magnitude '_r' that can be calculated numerically. 81 | class HasR t where 82 | _r :: RealFloat n => Lens' (t n) n 83 | 84 | instance HasR v => HasR (Point v) where 85 | _r = _Point . _r 86 | {-# INLINE _r #-} 87 | 88 | instance HasR V2 where 89 | _r = r2PolarIso . _1 90 | {-# INLINE _r #-} 91 | 92 | instance HasTheta V2 where 93 | _theta = r2PolarIso . _2 94 | {-# INLINE _theta #-} 95 | 96 | -------------------------------------------------------------------------------- /src/Geometry/TwoD/Vector.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Geometry.TwoD.Vector 4 | -- Copyright : (c) 2011-2017 diagrams team (see LICENSE) 5 | -- License : BSD-style (see LICENSE) 6 | -- Maintainer : diagrams-discuss@googlegroups.com 7 | -- 8 | -- Two-dimensional vectors. 9 | -- 10 | ----------------------------------------------------------------------------- 11 | module Geometry.TwoD.Vector 12 | ( -- * Special 2D vectors 13 | unitX, unitY, unit_X, unit_Y 14 | , xDir, yDir, x_Dir, y_Dir 15 | 16 | -- * Converting between vectors and angles 17 | , angleV, angleDir, e, signedAngleBetween, signedAngleBetweenDirs 18 | 19 | -- * 2D vector utilities 20 | , perp, leftTurn, crossZ 21 | 22 | ) where 23 | 24 | import Control.Lens (view, (&), (.~), (^.)) 25 | 26 | import Geometry.Angle 27 | import Geometry.Direction 28 | import Geometry.TwoD.Types 29 | 30 | import Linear.Metric 31 | import Linear.V2 32 | import Linear.Vector 33 | 34 | -- | The unit vector in the positive X direction. 35 | unitX :: (R1 v, Additive v, Num n) => v n 36 | unitX = zero & _x .~ 1 37 | 38 | -- | The unit vector in the negative X direction. 39 | unit_X :: (R1 v, Additive v, Num n) => v n 40 | unit_X = zero & _x .~ (-1) 41 | 42 | -- | The unit vector in the positive Y direction. 43 | unitY :: (R2 v, Additive v, Num n) => v n 44 | unitY = zero & _y .~ 1 45 | 46 | -- | The unit vector in the negative Y direction. 47 | unit_Y :: (R2 v, Additive v, Num n) => v n 48 | unit_Y = zero & _y .~ (-1) 49 | 50 | -- | A 'Direction' pointing in the positive X direction. 51 | xDir :: (R1 v, Additive v, Num n) => Direction v n 52 | xDir = Dir unitX 53 | 54 | -- | A 'Direction' pointing in the positive Y direction. 55 | yDir :: (R2 v, Additive v, Num n) => Direction v n 56 | yDir = Dir unitY 57 | 58 | -- | A 'Direction' pointing in the negative X direction. 59 | x_Dir :: (R1 v, Additive v, Num n) => Direction v n 60 | x_Dir = Dir unit_X 61 | 62 | -- | A 'Direction' pointing in the negative Y direction. 63 | y_Dir :: (R2 v, Additive v, Num n) => Direction v n 64 | y_Dir = Dir unit_Y 65 | 66 | -- | A direction at a specified angle counterclockwise from the 'xDir'. 67 | angleDir :: Floating n => Angle n -> Direction V2 n 68 | angleDir = Dir . angleV 69 | 70 | -- | A unit vector at a specified angle counterclockwise from the 71 | -- positive X axis (see also 'e'). 72 | angleV :: Floating n => Angle n -> V2 n 73 | angleV = angle . view rad 74 | 75 | -- | A unit vector at a specified angle counterclockwise from the 76 | -- positive X axis. 'e' is a synonym for 'angleV', but provided as a 77 | -- sort of pun: @r *^ e theta@ can be used to construct a vector of 78 | -- length @r@ in the direction @theta@, just as \(r e^{i \theta}\) 79 | -- constructs a corresponding complex number. 80 | e :: Floating n => Angle n -> V2 n 81 | e = angleV 82 | 83 | -- | @leftTurn v1 v2@ tests whether the direction of @v2@ is a left 84 | -- turn from @v1@ (that is, if the direction of @v2@ can be obtained 85 | -- from that of @v1@ by adding an angle 0 <= theta <= tau/2). 86 | leftTurn :: (Num n, Ord n) => V2 n -> V2 n -> Bool 87 | leftTurn v1 v2 = (v1 `dot` perp v2) < 0 88 | 89 | -- | Signed angle between two vectors. Currently defined as 90 | -- 91 | -- @ 92 | -- signedAngleBetween u v = (u ^. _theta) ^-^ (v ^. _theta) 93 | -- @ 94 | signedAngleBetween :: RealFloat n => V2 n -> V2 n -> Angle n 95 | signedAngleBetween u v = (u ^. _theta) ^-^ (v ^. _theta) 96 | -- do we need to use _theta here? 97 | 98 | -- | Same as 'signedAngleBetween' but for 'Directions's. 99 | signedAngleBetweenDirs :: RealFloat n => Direction V2 n -> Direction V2 n -> Angle n 100 | signedAngleBetweenDirs u v = (u ^. _theta) ^-^ (v ^. _theta) 101 | 102 | --------------------------------------------------------------------------------