Skip to content

Commit 68bc53c

Browse files
cchalmerscchalmers
committed
Merge pull request #229 from diagrams/projections
Projections
2 parents 1f8d7f0 + 844b100 commit 68bc53c

File tree

8 files changed

+405
-11
lines changed

8 files changed

+405
-11
lines changed

‎diagrams-lib.cabal‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -41,6 +41,7 @@ Library
4141
Diagrams.Deform
4242
Diagrams.Direction,
4343
Diagrams.Envelope,
44+
Diagrams.LinearMap,
4445
Diagrams.Located,
4546
Diagrams.Names,
4647
Diagrams.Parametric,
@@ -60,13 +61,15 @@ Library
6061
Diagrams.ThreeD.Shapes,
6162
Diagrams.ThreeD.Size,
6263
Diagrams.ThreeD.Transform,
64+
Diagrams.ThreeD.Projection,
6365
Diagrams.ThreeD.Types,
6466
Diagrams.ThreeD.Vector,
6567
Diagrams.Trace,
6668
Diagrams.Trail,
6769
Diagrams.TrailLike,
6870
Diagrams.Transform,
6971
Diagrams.Transform.ScaleInv,
72+
Diagrams.Transform.Matrix,
7073
Diagrams.TwoD,
7174
Diagrams.TwoD.Adjust,
7275
Diagrams.TwoD.Align,

‎src/Diagrams/Deform.hs‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -64,7 +64,7 @@ asDeformation t = Deformation (papply t)
6464
------------------------------------------------------------
6565
-- Instances
6666

67-
instance Deformable (Point v n) (Point u n) where
67+
instance r ~ Point u n => Deformable (Point v n) r where
6868
deform' = const deform
6969

7070
deform (Deformation l) = l
@@ -101,8 +101,8 @@ goodEnough e t s =
101101
all (< e) [norm $ deform t (s `atParam` u) .-. approx t s `atParam` u
102102
| u <- [0.25, 0.5, 0.75]]
103103

104-
instance (Metric v, Metric u, OrderedField n)
105-
=> Deformable (Located (Trail v n)) (Located (Trail u n)) where
104+
instance (Metric v, Metric u, OrderedField n, r ~ Located (Trail u n))
105+
=> Deformable (Located (Trail v n)) r where
106106
deform' eps p t
107107
| isLine $ unLoc t = line `at` p0
108108
| otherwise = glueTrail line `at` p0
@@ -121,7 +121,7 @@ instance (Metric v, Metric u, OrderedField n)
121121
extent = maximum . map dist . trailVertices $ t
122122
dist pt = norm $ pt .-. loc t
123123

124-
instance (Metric v, Metric u, OrderedField n) => Deformable (Path v n) (Path u n) where
124+
instance (Metric v, Metric u, OrderedField n, r ~ Path u n) => Deformable (Path v n) r where
125125
deform' eps p = over (_Wrapped . mapped) (deform' eps p)
126126
deform p = over (_Wrapped . mapped) (deform p)
127127

‎src/Diagrams/LinearMap.hs‎

Lines changed: 153 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,153 @@
1+
{-# LANGUAGE ConstraintKinds #-}
2+
{-# LANGUAGE FlexibleContexts #-}
3+
{-# LANGUAGE FlexibleInstances #-}
4+
{-# LANGUAGE GADTs #-}
5+
{-# LANGUAGE ImpredicativeTypes #-}
6+
{-# LANGUAGE MultiParamTypeClasses #-}
7+
{-# LANGUAGE RankNTypes #-}
8+
{-# LANGUAGE TypeFamilies #-}
9+
{-# LANGUAGE UndecidableInstances #-}
10+
-----------------------------------------------------------------------------
11+
-- |
12+
-- Module : Diagrams.LinearMap
13+
-- Copyright : (c) 2014 diagrams team (see LICENSE)
14+
-- License : BSD-style (see LICENSE)
15+
-- Maintainer : [email protected]
16+
--
17+
-- Linear maps. Unlike 'Transformation's these are not restricted to the
18+
-- same space. In practice these are used for projections in
19+
-- "Diagrams.ThreeD.Projection".
20+
--
21+
-----------------------------------------------------------------------------
22+
23+
module Diagrams.LinearMap where
24+
25+
import Control.Lens
26+
import Data.FingerTree as FT
27+
import Data.Foldable (Foldable)
28+
29+
import Diagrams.Core
30+
import Diagrams.Core.Transform
31+
import Diagrams.Located
32+
import Diagrams.Path
33+
import Diagrams.Segment
34+
import Diagrams.Trail hiding (offset)
35+
36+
import Linear.Affine
37+
import Linear.Metric
38+
import Linear.Vector
39+
40+
41+
-- | Type for holding linear maps. Note that these are not affine transforms so
42+
-- attemping apply a translation with 'LinearMap' will likely produce incorrect
43+
-- results.
44+
newtype LinearMap v u n = LinearMap { lapply :: v n -> u n }
45+
46+
toLinearMap :: Transformation v n -> LinearMap v v n
47+
toLinearMap (Transformation (m :-: _) _ _) = LinearMap m
48+
49+
-- | Traversal over all the vmap of an object.
50+
class LinearMappable a b where
51+
vmap :: (Vn a -> Vn b) -> a -> b
52+
-- this uses a function instead of LinearMap so we can also use this
53+
-- class to change number types
54+
55+
-- Note: instances need to be of the form
56+
--
57+
-- r ~ A u m => LinearMappable (A v n) r
58+
--
59+
-- so ghc knows there's only one possible result from calling vmap.
60+
61+
-- | Apply a linear map.
62+
linmap :: (InSpace v n a, Foldable v, LinearMappable a b, N b ~ n)
63+
=> LinearMap v (V b) n -> a -> b
64+
linmap = vmap . lapply
65+
66+
instance r ~ Offset c u m => LinearMappable (Offset c v n) r where
67+
vmap f (OffsetClosed v) = OffsetClosed (f v)
68+
vmap _ OffsetOpen = OffsetOpen
69+
{-# INLINE vmap #-}
70+
71+
instance r ~ Segment c u m => LinearMappable (Segment c v n) r where
72+
vmap f (Linear offset) = Linear (vmap f offset)
73+
vmap f (Cubic v1 v2 offset) = Cubic (f v1) (f v2) (vmap f offset)
74+
{-# INLINE vmap #-}
75+
76+
instance (Metric v, Metric u, OrderedField n, OrderedField m, r ~ SegTree u m)
77+
=> LinearMappable (SegTree v n) r where
78+
vmap f = over _Wrapped (fmap' (vmap f))
79+
{-# INLINE vmap #-}
80+
81+
instance (Metric v, Metric u, OrderedField n, OrderedField m, r ~ Trail' l u m)
82+
=> LinearMappable (Trail' l v n) r where
83+
vmap f (Line st) = Line (vmap f st)
84+
vmap f (Loop st offset) = Loop (vmap f st) (vmap f offset)
85+
{-# INLINE vmap #-}
86+
87+
instance (Metric v, Metric u, OrderedField n, OrderedField m, r ~ Trail u m)
88+
=> LinearMappable (Trail v n) r where
89+
vmap f (Trail (Line st)) = Trail $ Line (vmap f st)
90+
vmap f (Trail (Loop st offset)) = Trail $ Loop (vmap f st) (vmap f offset)
91+
{-# INLINE vmap #-}
92+
93+
instance LinearMappable (Point v n) (Point u m) where
94+
vmap f (P v) = P (f v)
95+
{-# INLINE vmap #-}
96+
97+
instance r ~ FixedSegment u m => LinearMappable (FixedSegment v n) r where
98+
vmap f (FLinear p0 p1) = FLinear (vmap f p0) (vmap f p1)
99+
vmap f (FCubic p0 p1 p2 p3) = FCubic (vmap f p0) (vmap f p1)
100+
(vmap f p2) (vmap f p3)
101+
{-# INLINE vmap #-}
102+
103+
instance (LinearMappable a b, r ~ Located b) => LinearMappable (Located a) r where
104+
vmap f (Loc p a) = Loc (vmap f p) (vmap f a)
105+
{-# INLINE vmap #-}
106+
107+
instance (Metric v, Metric u, OrderedField n, OrderedField m, r ~ Path u m)
108+
=> LinearMappable (Path v n) r where
109+
vmap f = _Wrapped . mapped %~ vmap f
110+
{-# INLINE vmap #-}
111+
112+
-- | Affine linear maps. Unlike Transformation these do not have to be
113+
-- invertable so we can map between spaces.
114+
data AffineMap v u n = AffineMap (LinearMap v u n) (u n)
115+
116+
-- | Make an affine map from a linear function and a translation.
117+
mkAffineMap :: (v n -> u n) -> u n -> AffineMap v u n
118+
mkAffineMap f = AffineMap (LinearMap f)
119+
120+
toAffineMap :: (HasBasis v, Num n)
121+
=> Transformation v n -> AffineMap v v n
122+
toAffineMap t = AffineMap (toLinearMap t) (transl t)
123+
124+
class (LinearMappable a b, N a ~ N b) => AffineMappable a b where
125+
amap :: (Additive (V a), Foldable (V a), Additive (V b), Num (N b))
126+
=> AffineMap (V a) (V b) (N b) -> a -> b
127+
amap (AffineMap f _) = linmap f
128+
{-# INLINE amap #-}
129+
130+
instance r ~ Offset c u n => AffineMappable (Offset c v n) r
131+
instance r ~ Segment c u n => AffineMappable (Segment c v n) r
132+
instance (Metric v, Metric u, OrderedField n, r ~ SegTree u n) => AffineMappable (SegTree v n) r
133+
instance (Metric v, Metric u, OrderedField n, r ~ Trail' l u n) => AffineMappable (Trail' l v n) r
134+
instance (Metric v, Metric u, OrderedField n, r ~ Trail u n) => AffineMappable (Trail v n) r
135+
136+
instance (Additive v, Foldable v, Num n, r ~ Point u n) => AffineMappable (Point v n) r where
137+
amap (AffineMap f v) p = linmap f p .+^ v
138+
{-# INLINE amap #-}
139+
140+
instance r ~ FixedSegment u n => AffineMappable (FixedSegment v n) r where
141+
amap m (FLinear p0 p1) = FLinear (amap m p0) (amap m p1)
142+
amap m (FCubic p0 p1 p2 p3) = FCubic (amap m p0) (amap m p1) (amap m p2) (amap m p3)
143+
{-# INLINE amap #-}
144+
145+
instance (LinearMappable a b, N a ~ N b, r ~ Located b) => AffineMappable (Located a) r where
146+
amap m@(AffineMap l _) (Loc p x) = Loc (amap m p) (linmap l x)
147+
{-# INLINE amap #-}
148+
149+
instance (Metric v, Metric u, OrderedField n, r ~ Path u n)
150+
=> AffineMappable (Path v n) r where
151+
amap m = _Wrapped . mapped %~ amap m
152+
{-# INLINE amap #-}
153+

‎src/Diagrams/ThreeD/Projection.hs‎

Lines changed: 168 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,168 @@
1+
{-# LANGUAGE ConstraintKinds #-}
2+
{-# LANGUAGE FlexibleContexts #-}
3+
{-# LANGUAGE FlexibleInstances #-}
4+
{-# LANGUAGE MultiParamTypeClasses #-}
5+
{-# LANGUAGE RankNTypes #-}
6+
{-# LANGUAGE TypeFamilies #-}
7+
8+
-----------------------------------------------------------------------------
9+
-- |
10+
-- Module : Diagrams.ThreeD.Projection
11+
-- Copyright : (c) 2014 diagrams team (see LICENSE)
12+
-- License : BSD-style (see LICENSE)
13+
-- Maintainer : [email protected]
14+
--
15+
-- 3D projections are a way of viewing a three-dimensional objects on a
16+
-- two-dimensional plane.
17+
--
18+
-- This module can be used with the functions in "Linear.Projection".
19+
--
20+
-- Disclaimer: This module should be considered experimental and is
21+
-- likely to change.
22+
--
23+
-----------------------------------------------------------------------------
24+
25+
module Diagrams.ThreeD.Projection
26+
( -- * Orthographic projections
27+
28+
-- $orthographic
29+
-- ** Parallel projections
30+
facingXY
31+
, facingXZ
32+
, facingYZ
33+
34+
-- ** axonometric
35+
-- $axonometric
36+
37+
-- *** Isometric projections
38+
-- $isometric
39+
, isometricApply
40+
, isometric
41+
42+
, lookingAt
43+
44+
-- ** Affine maps
45+
, m44AffineApply
46+
, m44AffineMap
47+
, m33AffineApply
48+
, m33AffineMap
49+
50+
-- * Perspective projections
51+
-- $perspective
52+
-- ** Perspective deformations
53+
, m44Deformation
54+
, module Linear.Projection
55+
) where
56+
57+
import Control.Lens hiding (transform)
58+
import Data.Functor.Rep
59+
60+
import Diagrams.Core
61+
import Diagrams.Deform
62+
import Diagrams.Direction
63+
import Diagrams.LinearMap
64+
import Diagrams.ThreeD.Types (P3)
65+
import Diagrams.ThreeD.Vector
66+
67+
import Linear as L
68+
import Linear.Affine
69+
import Linear.Projection
70+
71+
------------------------------------------------------------------------
72+
-- Orthographic projections
73+
------------------------------------------------------------------------
74+
75+
-- $orthographic
76+
-- Orthographic projections are a form of parallel projections where are
77+
-- projection lines are orthogonal to the projection plane.
78+
79+
-- Parallel projections
80+
81+
-- | Look at the xy-plane with y as the up direction.
82+
facingXY :: (Epsilon n, Floating n) => AffineMap V3 V2 n
83+
facingXY = lookingAt unitZ origin yDir
84+
85+
-- | Look at the xz-plane with z as the up direction.
86+
facingXZ :: (Epsilon n, Floating n) => AffineMap V3 V2 n
87+
facingXZ = lookingAt unitY origin zDir
88+
89+
-- | Look at the yz-plane with z as the up direction.
90+
facingYZ :: (Epsilon n, Floating n) => AffineMap V3 V2 n
91+
facingYZ = lookingAt unitX origin zDir
92+
93+
-- $axonometric
94+
-- Axonometric projections are a type of orthographic projection where
95+
-- the object is rotated along one or more of its axes relative to the
96+
-- plane of projection.
97+
98+
-- $isometric
99+
-- Isometric projections are when the scale along each axis of the
100+
-- projection is the same and the angle between any axis is 120
101+
-- degrees.
102+
103+
-- | Apply an isometric projection given the up direction
104+
isometricApply :: (InSpace V3 n a, InSpace V2 n b, AffineMappable a b, Floating n, Epsilon n)
105+
=> Direction V3 n -> a -> b
106+
isometricApply up = amap (isometric up)
107+
108+
-- | Make an isometric affine map with the given up direction.
109+
isometric :: (Floating n, Epsilon n) => Direction V3 n -> AffineMap V3 V2 n
110+
isometric up = m44AffineMap m
111+
where
112+
m = lookAt (V3 1 1 1) zero (fromDirection up)
113+
114+
lookingAt :: (Epsilon n, Floating n)
115+
=> P3 n -- ^ Eye
116+
-> P3 n -- ^ Center
117+
-> Direction V3 n -- ^ Up
118+
-> AffineMap V3 V2 n
119+
lookingAt (P cam) (P center) d = m44AffineMap m
120+
where
121+
m = lookAt cam center (d^._Dir)
122+
123+
-- | Apply the affine part of a homogeneous matrix.
124+
m44AffineApply :: (InSpace V3 n a, InSpace V2 n b, AffineMappable a b)
125+
=> M44 n -> a -> b
126+
m44AffineApply = amap . m44AffineMap
127+
128+
-- | Create an 'AffineMap' from a 4x4 homogeneous matrix, ignoring any
129+
-- perspective transforms.
130+
m44AffineMap :: Num n => M44 n -> AffineMap V3 V2 n
131+
m44AffineMap m = AffineMap (LinearMap f) (f v)
132+
where
133+
f = view _xy . (m' !*)
134+
m' = m ^. linearTransform
135+
v = m ^. L.translation
136+
137+
-- | Apply a transformation matrix and translation.
138+
m33AffineApply :: (InSpace V3 n a, InSpace V2 n b, AffineMappable a b)
139+
=> M33 n -> V2 n -> a -> b
140+
m33AffineApply m = amap . m33AffineMap m
141+
142+
-- | Create an 'AffineMap' from a 3x3 transformation matrix and a
143+
-- translation vector.
144+
m33AffineMap :: Num n => M33 n -> V2 n -> AffineMap V3 V2 n
145+
m33AffineMap m = AffineMap (LinearMap f)
146+
where
147+
f = view _xy . (m !*)
148+
149+
-- | Extract the linear transform part of a homogeneous matrix.
150+
linearTransform :: (Representable u, R3 v, R3 u) => Lens' (u (v n)) (M33 n)
151+
linearTransform = column _xyz . _xyz
152+
153+
------------------------------------------------------------------------
154+
-- Perspective transforms
155+
------------------------------------------------------------------------
156+
157+
-- For the time being projective transforms use the deformable class.
158+
-- Eventually we would like to replace this with a more specialised
159+
-- method.
160+
161+
-- $perspective
162+
-- Perspective projections are when closer objects appear bigger.
163+
164+
-- | Make a deformation from a 4x4 homogeneous matrix.
165+
m44Deformation :: Fractional n => M44 n -> Deformation V3 V2 n
166+
m44Deformation m =
167+
Deformation (P . view _xy . normalizePoint . (m !*) . point . view _Point)
168+

‎src/Diagrams/ThreeD/Transform.hs‎

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -129,7 +129,7 @@ rotationAbout (P t) d (view rad -> a)
129129
-- ± 1/4 turn.
130130
pointAt :: Floating n
131131
=> Direction V3 n -> Direction V3 n -> Direction V3 n
132-
-> Transformation V3 n
132+
-> Transformation V3 n
133133
pointAt a i f = pointAt' (fromDirection a) (fromDirection i) (fromDirection f)
134134

135135
-- | pointAt' has the same behavior as 'pointAt', but takes vectors
@@ -192,10 +192,10 @@ reflectionAcross :: (Metric v, R3 v, Fractional n)
192192
=> Point v n -> v n -> Transformation v n
193193
reflectionAcross p v =
194194
conjugate (translation (origin .-. p)) reflect
195-
where
196-
reflect = fromLinear t (linv t)
197-
t = f v <-> f (negated v)
198-
f u w = w ^-^ 2 *^ project u w
195+
where
196+
reflect = fromLinear t (linv t)
197+
t = f v <-> f (negated v)
198+
f u w = w ^-^ 2 *^ project u w
199199

200200
-- | @reflectAcross p v@ reflects a diagram across the plane though
201201
-- the point @p@ and the vector @v@.

0 commit comments

Comments
 (0)