diff --git a/src/Diagrams/Core.hs b/src/Diagrams/Core.hs
index 66c825e..4c1f8d7 100644
--- a/src/Diagrams/Core.hs
+++ b/src/Diagrams/Core.hs
@@ -88,6 +88,7 @@ module Diagrams.Core
          -- * Traces
 
        , Trace(Trace)
+       , SortedList(SortedList)
        , appTrace, mkTrace
        , Traced(..)
        , traceV, traceP
diff --git a/src/Diagrams/Core/Trace.hs b/src/Diagrams/Core/Trace.hs
index ab41a55..a391246 100644
--- a/src/Diagrams/Core/Trace.hs
+++ b/src/Diagrams/Core/Trace.hs
@@ -25,8 +25,11 @@
 -----------------------------------------------------------------------------
 
 module Diagrams.Core.Trace
-       ( -- * Traces
-         Trace(Trace)
+       ( -- * SortedList
+         SortedList(SortedList)
+
+         -- * Traces
+       , Trace(Trace)
 
        , appTrace
        , mkTrace
@@ -47,13 +50,11 @@ module Diagrams.Core.Trace
 
 import           Control.Applicative
 import           Control.Lens
-import           Data.List               (insert)
 import qualified Data.Map                as M
 import           Data.Semigroup
 import qualified Data.Set                as S
 
 import           Data.AffineSpace
-import           Data.Monoid.Inf
 import           Data.VectorSpace
 
 import           Diagrams.Core.HasOrigin
@@ -61,6 +62,28 @@ import           Diagrams.Core.Points
 import           Diagrams.Core.Transform
 import           Diagrams.Core.V
 
+------------------------------------------------------------
+--  SortedList  -------------------------------------------------
+------------------------------------------------------------
+
+newtype SortedList a = SortedList [a]
+
+instance Wrapped [a] [a] (SortedList a) (SortedList a)
+  where wrapped = iso SortedList $ \(SortedList x) -> x
+
+instance Ord a => Semigroup (SortedList a) where
+  sl0 <> sl1 = SortedList $ merge (view unwrapped sl0) (view unwrapped sl1)
+    where
+      merge xList@(x:xs) yList@(y:ys) =
+        if x <= y then x : merge xs yList else y : merge xList ys
+      merge xList@(_:_) []          = xList
+      merge []          yList@(_:_) = yList
+      merge []          []          = []
+
+instance Ord a => Monoid (SortedList a) where
+  mappend = (<>)
+  mempty = SortedList []
+
 ------------------------------------------------------------
 --  Trace  -------------------------------------------------
 ------------------------------------------------------------
@@ -82,32 +105,37 @@ import           Diagrams.Core.V
 --   scalar is @s@, the distance from the base point to the
 --   intersection is given by @s * magnitude v@.
 
-newtype Trace v = Trace { appTrace :: Point v -> v -> [PosInf (Scalar v)] }
+newtype Trace v = Trace { appTrace :: Point v -> v -> SortedList (Scalar v) }
 
 instance (Scalar v ~ s, Scalar v' ~ s', s ~ s') =>
          Wrapped
-         (Point v -> v -> [PosInf s])
-         (Point v' -> v' -> [PosInf s'])
+         (Point v -> v -> SortedList s)
+         (Point v' -> v' -> SortedList s')
          (Trace v) (Trace v')
          where wrapped = iso Trace appTrace
 
-mkTrace :: (Point v -> v -> [PosInf (Scalar v)]) -> Trace v
+mkTrace :: (Point v -> v -> SortedList (Scalar v)) -> Trace v
 mkTrace = Trace
 
 -- | Traces form a semigroup with pointwise minimum as composition.
 --   Hence, if @t1@ is the trace for diagram @d1@, and
 --   @e2@ is the trace for @d2@, then @e1 \`mappend\` e2@
 --   is the trace for @d1 \`atop\` d2@.
-instance Ord (Scalar v) => Semigroup (Trace v) where
-  ts1 <> ts2 = mkTrace tr
-    where
-      tr p v = foldr insert (appTrace ts1 p v) (appTrace ts2 p v)
+
+--instance Ord (Scalar v) => Semigroup (Trace v) where
+--  ts1 <> ts2 = mkTrace tr
+--    where
+--      tr p v = foldr insert (appTrace ts1 p v) (appTrace ts2 p v)
+
+deriving instance (Ord (Scalar v)) =>Semigroup (Trace v)
+
 
 -- | The identity for the 'Monoid' instance is the constantly infinite
 --   trace.
-instance Ord (Scalar v) => Monoid (Trace v) where
-  mappend = (<>)
-  mempty = mkTrace $ \_ _ -> [mempty]
+deriving instance (Ord (Scalar v)) => Monoid (Trace v)
+--instance Ord (Scalar v) => Monoid (Trace v) where
+--  mappend = (<>)
+--  mempty = mkTrace $ \_ _ -> []
 
 type instance V (Trace v) = v
 
@@ -170,9 +198,9 @@ instance (Traced b) => Traced (S.Set b) where
 --   given object in either the given direction or the opposite direction.
 --   Return @Nothing@ if there is no intersection.
 traceV :: Traced a => Point (V a) -> V a -> a -> Maybe (V a)
-traceV p v a = case head $ ((getTrace a)^.unwrapping Trace) p v of
-                 Finite s -> Just (s *^ v)
-                 Infinity -> Nothing
+traceV p v a = case view unwrapped $ ((getTrace a)^.unwrapping Trace) p v of
+                 (s:_) -> Just (s *^ v)
+                 []    -> Nothing
 
 -- | Given a base point and direction, compute the closest point on
 --   the boundary of the given object in the direction or its opposite.
@@ -194,26 +222,18 @@ maxTraceP p v a = (p .+^) <$> maxTraceV p v a
 --   but not in the opposite direction like `getTrace`. I.e. only return
 --   positive traces.
 getRayTrace :: (Traced a, Num (Scalar (V a))) => a -> Trace (V a)
-getRayTrace a = Trace tr
-  where
-    scalars [] = []
-    scalars (Infinity : xs) = scalars xs
-    scalars (Finite x : xs) = x : scalars xs
-    tr p v = let
-               ts = ((getTrace a)^.unwrapping Trace) p v
-               ps = filter (>= 0) (scalars ts)
-             in case ps of
-              [] -> [Infinity]
-              qs -> map Finite qs
+getRayTrace a = Trace $ \p v ->
+                  SortedList $ filter (>= 0) (view unwrapped
+                             $ (((getTrace a)^.unwrapping Trace) p v))
 
 -- | Compute the vector from the given point to the boundary of the
 --   given object in the given direction, or @Nothing@ if there is no
 --   intersection. Only positive scale muliples of the direction are returned
 rayTraceV :: (Traced a, Num (Scalar (V a)))
            => Point (V a) -> V a -> a -> Maybe (V a)
-rayTraceV p v a = case head $ ((getRayTrace a)^.unwrapping Trace) p v of
-                 Finite s -> Just (s *^ v)
-                 Infinity -> Nothing
+rayTraceV p v a = case view unwrapped $ ((getRayTrace a)^.unwrapping Trace) p v of
+                 (s:_) -> Just (s *^ v)
+                 []    -> Nothing
 
 -- | Given a base point and direction, compute the closest point on
 --   the boundary of the given object, or @Nothing@ if there is no
@@ -227,9 +247,9 @@ rayTraceP p v a = (p .+^) <$> rayTraceV p v a
 maxRayTraceV :: (Traced a, Num (Scalar (V a)))
               => Point (V a) -> V a -> a -> Maybe (V a)
 maxRayTraceV p v a =
-  case last $ ((getRayTrace a)^.unwrapping Trace) p v of
-    Finite s -> Just (s *^ v)
-    Infinity -> Nothing
+  case view unwrapped $ ((getRayTrace a)^.unwrapping Trace) p v of
+    [] -> Nothing
+    xs -> Just ((last xs) *^ v)
 
 -- | Like 'rayTraceP', but computes the *furthest* point on the boundary
 --   instead of the closest.