Skip to content

Commit

Permalink
Merge pull request #177 from diagrams/ht-size
Browse files Browse the repository at this point in the history 
make headSize and tailSize back into ArrowOpts fields
  • Loading branch information
@jeffreyrosenbluth
jeffreyrosenbluth committed Apr 13, 2014
2 parents 243c9c5 + 303827f commit 74fed72
Show file tree
Hide file tree
Showing 3 changed files with 16 additions and 97 deletions.
6 changes: 2 additions & 4 deletions src/Diagrams/TwoD.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -153,10 +153,8 @@ module Diagrams.TwoD
, tailStyle
, shaftColor
, shaftStyle
, HeadSize, headSize, headSizeA, getHeadSize
, headSizeO, headSizeL, headSizeN, headSizeG
, TailSize, tailSize, tailSizeA, getTailSize
, tailSizeO, tailSizeL, tailSizeN, tailSizeG
, headSize
, tailSize

-- * Text
, text, topLeftText, alignedText, baselineText
Expand Down
2 changes: 0 additions & 2 deletions src/Diagrams/TwoD/Adjust.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -22,7 +22,6 @@ module Diagrams.TwoD.Adjust
import Diagrams.Attributes (lineCap, lineColorA, lineJoin,
lineMiterLimitA)
import Diagrams.Core
import Diagrams.TwoD.Arrow (headSizeA, tailSizeA)
import Diagrams.TwoD.Attributes (lineWidthA)
import Diagrams.TwoD.Size (SizeSpec2D (..), center2D,
requiredScale, size2D)
Expand Down Expand Up @@ -52,7 +51,6 @@ import Data.Semigroup
setDefault2DAttributes :: Semigroup m => QDiagram b R2 m -> QDiagram b R2 m
setDefault2DAttributes d = d # lineWidthA def # lineColorA def # fontSizeA def
# lineCap def # lineJoin def # lineMiterLimitA def
# headSizeA def # tailSizeA def

-- | Adjust the size and position of a 2D diagram to fit within the
-- requested size. The first argument is a lens into the output
Expand Down
105 changes: 14 additions & 91 deletions src/Diagrams/TwoD/Arrow.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -71,12 +71,6 @@ module Diagrams.TwoD.Arrow
, arrow
, arrow'

-- * Attributes
, HeadSize, headSize, headSizeA, getHeadSize
, headSizeO, headSizeL, headSizeN, headSizeG
, TailSize, tailSize, tailSizeA, getTailSize
, tailSizeO, tailSizeL, tailSizeN, tailSizeG

-- * Options
, ArrowOpts(..)

Expand All @@ -88,8 +82,10 @@ module Diagrams.TwoD.Arrow
, gaps, gap
, headColor
, headStyle
, headSize
, tailColor
, tailStyle
, tailSize
, shaftColor
, shaftStyle
, straightShaft
Expand All @@ -105,7 +101,6 @@ import Control.Lens (Lens', Setter', Traversal',
makeLensesWith, (%~), (&), (.~),
(^.))
import Data.AffineSpace
import Data.Data
import Data.Default.Class
import Data.Functor ((<$>))
import Data.Maybe (fromMaybe)
Expand Down Expand Up @@ -140,7 +135,9 @@ data ArrowOpts
, _headGap :: Double
, _tailGap :: Double
, _headStyle :: Style R2
, _headSize :: Measure R2
, _tailStyle :: Style R2
, _tailSize :: Measure R2
, _shaftStyle :: Style R2
}

Expand All @@ -158,7 +155,9 @@ instance Default ArrowOpts where

-- See note [Default arrow style attributes]
, _headStyle = mempty
, _headSize = Normalized 0.05
, _tailStyle = mempty
, _tailSize = Normalized 0.05
, _shaftStyle = mempty
}

Expand Down Expand Up @@ -199,6 +198,12 @@ tailStyle :: Lens' ArrowOpts (Style R2)
-- | Style to apply to the shaft. See `headStyle`.
shaftStyle :: Lens' ArrowOpts (Style R2)

-- | The radius of the circumcircle around the head.
headSize :: Lens' ArrowOpts (Measure R2)

-- | The radius of the circumcircle around the tail.
tailSize :: Lens' ArrowOpts (Measure R2)

-- | A lens for setting or modifying the color of an arrowhead. For
-- example, one may write @... (with & headColor .~ blue)@ to get an
-- arrow with a blue head, or @... (with & headColor %~ blend 0.5
Expand Down Expand Up @@ -245,84 +250,6 @@ headSty opts = fc black (opts^.headStyle)
tailSty :: ArrowOpts -> Style R2
tailSty opts = fc black (opts^.tailStyle)


-- | Radius of a circumcircle around the head.
newtype HeadSize = HeadSize (Last (Measure R2))
deriving (Typeable, Data, Semigroup)
instance AttributeClass HeadSize

type instance V HeadSize = R2

instance Transformable HeadSize where
transform t (HeadSize (Last w)) = HeadSize (Last (transform t w))

instance Default HeadSize where
def = HeadSize (Last (Normalized 0.05))

-- | Set the radius of the circumcircle around the head.
headSize :: (HasStyle a, V a ~ R2) => Measure R2 -> a -> a
headSize = applyGTAttr . HeadSize . Last

headSizeA :: (HasStyle a, V a ~ R2) => HeadSize -> a -> a
headSizeA = applyGTAttr

getHeadSize :: HeadSize -> Measure R2
getHeadSize (HeadSize (Last s)) = s

-- | A convenient synonym for 'headSize (Global w)'.
headSizeG :: (HasStyle a, V a ~ R2) => Double -> a -> a
headSizeG w = headSize (Global w)

-- | A convenient synonym for 'headSize (Normalized w)'.
headSizeN :: (HasStyle a, V a ~ R2) => Double -> a -> a
headSizeN w = headSize (Normalized w)

-- | A convenient synonym for 'headSize (Output w)'.
headSizeO :: (HasStyle a, V a ~ R2) => Double -> a -> a
headSizeO w = headSize (Output w)

-- | A convenient sysnonym for 'headSize (Local w)'.
headSizeL :: (HasStyle a, V a ~ R2) => Double -> a -> a
headSizeL w = headSize (Local w)

newtype TailSize = TailSize (Last (Measure R2))
deriving (Typeable, Data, Semigroup)
instance AttributeClass TailSize

type instance V TailSize = R2

instance Transformable TailSize where
transform t (TailSize (Last w)) = TailSize (Last (transform t w))

instance Default TailSize where
def = TailSize (Last (Normalized 0.05))

-- | Set the radius of a circumcircle around the arrow tail.
tailSize :: (HasStyle a, V a ~ R2) => Measure R2 -> a -> a
tailSize = applyGTAttr . TailSize . Last

tailSizeA :: (HasStyle a, V a ~ R2) => TailSize -> a -> a
tailSizeA = applyGTAttr

getTailSize :: TailSize -> Measure R2
getTailSize (TailSize (Last s)) = s

-- | A convenient synonym for 'tailSize (Global w)'.
tailSizeG :: (HasStyle a, V a ~ R2) => Double -> a -> a
tailSizeG w = tailSize (Global w)

-- | A convenient synonym for 'tailSize (Normalized w)'.
tailSizeN :: (HasStyle a, V a ~ R2) => Double -> a -> a
tailSizeN w = tailSize (Normalized w)

-- | A convenient synonym for 'tailSize (Output w)'.
tailSizeO :: (HasStyle a, V a ~ R2) => Double -> a -> a
tailSizeO w = tailSize (Output w)

-- | A convenient sysnonym for 'tailSize (Local w)'.
tailSizeL :: (HasStyle a, V a ~ R2) => Double -> a -> a
tailSizeL w = tailSize (Local w)

fromMeasure :: Double -> Double -> Measure R2 -> Double
fromMeasure g n m = u
where Output u = toOutput g n m
Expand Down Expand Up @@ -473,15 +400,11 @@ arrow' opts len = mkQD' (DelayedLeaf delayedArrow)

-- The head size is obtained from the style and converted to output
-- units.
hSize = maybe (error "No head size.")
(fromMeasure gToO nToO)
(getHeadSize <$> getAttr sty)
hSize = fromMeasure gToO nToO (opts ^. headSize)

-- The tail size is obtained from the style and converted to output
-- units.
tSize = maybe (error "No tail size.")
(fromMeasure gToO nToO)
(getTailSize <$> getAttr sty)
tSize = fromMeasure gToO nToO (opts ^. tailSize)

-- Make the head and tail and save their widths.
(h, hWidth') = mkHead hSize opts' gToO nToO
Expand Down

8 comments on commit 74fed72

@jeffreyrosenbluth
Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Something like this seems to work, in a small test I tried.
I'm not sure whether or not _Global is a valid setter, but if it is perhaps this
is the answer to what to do about headSizeG and friends.

_Global :: Setter' (Measure R2) Double
_Global f (Global w) = (\x -> Global x) <$> f w
_Global f (Normalized w) = (\x -> Global x) <$> f w
...
headSizeG = headSize . _Global

@byorgey
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

What goes in the ...? I.e. what do you do with constructors like MaxM and so on?

@byorgey
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Also, the Normalized case doesn't really make sense... applying a function to a Normalized value and then turning it into Global is totally bogus. Of course, if we only ever used _Global for setting (via (.~)) and not for modifying (via (%~)) it wouldn't matter, but I still wouldn't feel good about it.

@jeffreyrosenbluth
Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

As far as what to do with constructors like MaxM, I honestly hadn't thought of a solution, I wanted to see if there was some more fundamental problem with the approach first, like "applying a function to a Normalized value and then turning is into a Global is totally bogus". Can you explain why, i.e. does it violate any lens or functor laws? Or is it simply something like,
headSizeG ~* 2
taking a Normalized to Global feels like it violates the meaning of multiplication.

@byorgey
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

It doesn't violate any laws, it's just mixing units. The Double -> Double function gets applied indiscriminately to Normalized and Global and Output... values, but the result is interpreted as Global (or whatever). There is no way to meaningfully write a Double -> Double function which can take a value measured in any units (without knowing which it is!). Or rather, the only meaningful such functions are constant functions. Your example of headSizeG ~* 2 is a good example. Turning Global 2 into Global 4 makes good sense. Turning Normalized 0.1 into Global 0.2 is just meaningless.

@jeffreyrosenbluth
Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Fair enough, thanks for clarifying.

@byorgey
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I wish there was something in lens that was truly write, only, i.e. it only let you set and not modify. But I'm not sure that such a thing would have nice properties.

@jeffreyrosenbluth
Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I was think the same. I would be curios what it would look like and what the properties are, but that's a project for another day.

Please sign in to comment.