Commit d58cd793 authored by Steffen Michels's avatar Steffen Michels

Merge branch 'remove-fragile-dependency-on-ord-for-Set-in-graphics' into 'master'

Image attributes now uses a Data.SetBy instead of Data.Set;

See merge request !335
parents f742ac48 4ea0ae89
Pipeline #43132 passed with stage
in 2 minutes and 31 seconds
......@@ -97,10 +97,10 @@ singleton x = BinBy 1 x TipBy TipBy
*--------------------------------------------------------------------*/
insertBy :: !(a a -> Bool) !a !.(SetBy a) -> SetBy a
insertBy comp x t=:(BinBy _ y l r)
insertBy comp x (BinBy c y l r)
| comp x y = balanceL y (insertBy comp x l) r
| comp y x = balanceR y l (insertBy comp x r)
| otherwise = t
| otherwise = BinBy c x l r
insertBy _ x _ = singleton x
deleteBy :: !(a a -> Bool) !a !.(SetBy a) -> SetBy a
......
......@@ -2,6 +2,7 @@ definition module Graphics.Scalable.Internal.Image`
from Data.Maybe import :: Maybe
from Data.Set import :: Set
from Data.SetBy import :: SetBy
from Data.Map import :: Map
from Data.Error import :: MaybeError (..)
from Math.Geometry import :: Angle
......@@ -110,7 +111,7 @@ instance == DefuncImgEventhandler`
, offsets :: ![ImageOffset] // the offsets matching one-by-one with .overlays
}
:: HostImg
= BasicHostImg !BasicImg !(Set BasicImgAttr)
= BasicHostImg !BasicImg !(SetBy BasicImgAttr)
| RawHostImg !String
| CompositeImg !Img
:: BasicImg
......
......@@ -10,8 +10,10 @@ import Data.Monoid
import Data.MapCollection
import qualified Data.Foldable
import qualified Data.Set
import qualified Data.SetBy
import qualified Data.Map
from Data.Set import :: Set, instance == (Set a), instance < (Set a), instance Foldable Set
from Data.SetBy import :: SetBy, isEqualBy, instance Foldable SetBy
from Data.Map import :: Map, findKeyWith, instance Functor (Map k)
from Control.Applicative import class Applicative (..)
import Control.Monad
......@@ -42,7 +44,7 @@ equivImg {Img | transform = tfs, offsets = offs, host = h, overlays = overs }
= tfs == tfs` && offs === offs` && equivHostImg h h` && gEq{|*->*|} equivImg overs overs`
equivHostImg :: !HostImg !HostImg -> Bool
equivHostImg (BasicHostImg basic attrs) (BasicHostImg basic` attrs`) = basic === basic` && attrs === attrs`
equivHostImg (BasicHostImg basic attrs) (BasicHostImg basic` attrs`) = basic === basic` && isEqualBy smallerBasicImgAttr attrs attrs`
equivHostImg (RawHostImg txt) (RawHostImg txt`) = txt == txt`
equivHostImg (CompositeImg img) (CompositeImg img`) = equivImg img img`
equivHostImg _ _ = False
......@@ -145,17 +147,19 @@ defunc (ImgEventhandlerOnMouseMoveAttr {OnMouseMoveAttr | local}) = {ImgEventhan
defunc (ImgEventhandlerOnMouseOutAttr {OnMouseOutAttr | local}) = {ImgEventhandler` | handler = ImgEventhandlerOnMouseOutAttr`, local=local}
defunc (ImgEventhandlerDraggableAttr _) = {ImgEventhandler` | handler = ImgEventhandlerDraggableAttr`, local=False}
defaultFilledImgAttributes :: Set BasicImgAttr
defaultFilledImgAttributes :: SetBy BasicImgAttr
defaultFilledImgAttributes
= 'Data.Set'.fromList [ BasicImgStrokeAttr (toSVGColor "black")
= 'Data.SetBy'.fromListBy smallerBasicImgAttr
[ BasicImgStrokeAttr (toSVGColor "black")
, BasicImgStrokeWidthAttr (PxSpan 1.0)
, BasicImgFillAttr (toSVGColor "black")
, BasicImgFillOpacityAttr 1.0
]
defaultOutlineImgAttributes :: Set BasicImgAttr
defaultOutlineImgAttributes :: SetBy BasicImgAttr
defaultOutlineImgAttributes
= 'Data.Set'.fromList [ BasicImgFillAttr (toSVGColor "none")
= 'Data.SetBy'.fromListBy smallerBasicImgAttr
[ BasicImgFillAttr (toSVGColor "none")
, BasicImgStrokeAttr (toSVGColor "black")
, BasicImgStrokeWidthAttr (PxSpan 1.0)
]
......@@ -166,7 +170,7 @@ defaultMargins` = {Margins` | n=zero, e=zero, s=zero, w=zero}
defaultMarkers` :: Markers` m
defaultMarkers` = {Markers` | markerStart` = Nothing, markerMid` = Nothing, markerEnd` = Nothing}
mkBasicHostImg :: !ImgTagNo !BasicImg !(Set BasicImgAttr) -> Img
mkBasicHostImg :: !ImgTagNo !BasicImg !(SetBy BasicImgAttr) -> Img
mkBasicHostImg no basicImg atts = {Img | uniqId = no
, host = BasicHostImg basicImg atts
, transform = Nothing
......@@ -252,7 +256,7 @@ empty` xspan yspan font_spans text_spans imgTables=:{ImgTables | imgNewTexts = t
#! (yspan`,txts) = spanImgTexts text_spans yspan txts
#! dx = positive_span xspan`
#! dy = positive_span yspan`
= ( mkBasicHostImg no EmptyImg 'Data.Set'.newSet
= ( mkBasicHostImg no EmptyImg 'Data.SetBy'.newSet
, {ImgTables | imgTables & imgNewTexts = txts
, imgSpans = 'Data.Map'.put no (dx,dy) curSpans
, imgUniqIds = no-1
......@@ -263,7 +267,7 @@ text` :: !FontDef !String !FontSpans !TextSpans !ImgTables -> (!Img,!ImgTables)
text` font str font_spans text_spans imgTables=:{ImgTables | imgNewFonts = curFonts, imgNewTexts = txts, imgSpans = curSpans, imgUniqIds = no}
#! (w,txts) = spanImgTexts text_spans (LookupSpan (TextXSpan font str)) txts
#! curFonts = if ('Data.Map'.member font font_spans) curFonts ('Data.Set'.insert font curFonts)
= ( mkBasicHostImg no (TextImg font str) 'Data.Set'.newSet
= ( mkBasicHostImg no (TextImg font str) 'Data.SetBy'.newSet
, {ImgTables | imgTables & imgNewFonts = curFonts
, imgNewTexts = txts
, imgSpans = 'Data.Map'.put no (w,PxSpan (getfontysize font)) curSpans
......@@ -458,7 +462,7 @@ margin` {Margins` | n,e,s,w} image p font_spans text_spans imgTables=:{ImgTables
#! (img_w,img_h) = 'Data.Map'.find img.Img.uniqId curSpans
#! span_host = (w + img_w + e, n + img_h + s)
= ({Img | uniqId = no
, host = BasicHostImg EmptyImg 'Data.Set'.newSet
, host = BasicHostImg EmptyImg 'Data.SetBy'.newSet
, transform = Nothing
, overlays = [img]
, offsets = [(w,n)]
......@@ -481,7 +485,7 @@ where
#! span_imgs = [(uniqId,'Data.Map'.find uniqId curSpans) \\ {Img | uniqId} <- imgs]
#! span_host = bounding_box_of_spans span_imgs
= ({Img | uniqId = no
, host = BasicHostImg EmptyImg 'Data.Set'.newSet
, host = BasicHostImg EmptyImg 'Data.SetBy'.newSet
, transform = Nothing
, overlays = imgs
, offsets = [ offset_within_host span_img align offset span_host
......@@ -607,7 +611,7 @@ attr` (BasicImageAttr` attr) image p font_spans text_spans imgTables
= (img`,{ImgTables | imgTables & imgNewTexts = txts})
where
add_basic_attribute :: !BasicImgAttr !HostImg -> HostImg
add_basic_attribute attr (BasicHostImg img attrs) = BasicHostImg img ('Data.Set'.insert attr attrs)
add_basic_attribute attr (BasicHostImg img attrs) = BasicHostImg img ('Data.SetBy'.insertBy smallerBasicImgAttr attr attrs)
add_basic_attribute _ host = host
attr` (LineMarkerAttr` {LineMarkerAttr | markerImg,markerPos}) image p font_spans text_spans imgTables
#! (mark,imgTables) = toImg markerImg [ViaAttr :p] font_spans text_spans imgTables
......@@ -676,8 +680,6 @@ ImgEventhandler`ConsName ImgEventhandlerOnMouseMoveAttr` = "ImgEventhandlerOnM
ImgEventhandler`ConsName ImgEventhandlerOnMouseOutAttr` = "ImgEventhandlerOnMouseOutAttr`"
ImgEventhandler`ConsName ImgEventhandlerDraggableAttr` = "ImgEventhandlerDraggableAttr`"
instance < (ImgEventhandler m) where (<) a b = ImgEventhandlerConsName a < ImgEventhandlerConsName b
instance == (ImgEventhandler m) where (==) a b = ImgEventhandlerConsName a == ImgEventhandlerConsName b
instance == DefuncImgEventhandler` where (==) a b = ImgEventhandler`ConsName a == ImgEventhandler`ConsName b
ImgAttrConsName :: !BasicImgAttr -> String
......@@ -690,8 +692,8 @@ ImgAttrConsName (BasicImgFillOpacityAttr _) = "BasicImgFillOpacityAttr"
ImgAttrConsName (BasicImgFillAttr _) = "BasicImgFillAttr"
ImgAttrConsName (BasicImgDashAttr _) = "BasicImgDashAttr"
instance < BasicImgAttr where (<) a b = ImgAttrConsName a < ImgAttrConsName b
instance == BasicImgAttr where (==) a b = ImgAttrConsName a == ImgAttrConsName b
smallerBasicImgAttr :: !BasicImgAttr !BasicImgAttr -> Bool
smallerBasicImgAttr a b = ImgAttrConsName a < ImgAttrConsName b
tag` :: !ImageTag !(Image` m) !ImgNodePath !FontSpans !TextSpans !ImgTables -> (!Img,!ImgTables)
tag` t=:(ImageTagUser no label) image p font_spans txt_spans imgTables
......@@ -907,12 +909,12 @@ where
resolveHostImg user_tags font_spans text_spans host spans
= (Ok host,spans)
resolveImgAttrs :: !ImgTags !FontSpans !TextSpans !(Set BasicImgAttr) !*(!ImgPaths,!ImgSpans,!GridSpans) -> (!MaybeError SpanResolveError (Set BasicImgAttr),!*(!ImgPaths,!ImgSpans,!GridSpans))
resolveImgAttrs :: !ImgTags !FontSpans !TextSpans !(SetBy BasicImgAttr) !*(!ImgPaths,!ImgSpans,!GridSpans) -> (!MaybeError SpanResolveError (SetBy BasicImgAttr),!*(!ImgPaths,!ImgSpans,!GridSpans))
resolveImgAttrs user_tags font_spans text_spans attrs spans
#! (m_attrs`,spans) = strictTRMapSt (resolveImgAttr user_tags font_spans text_spans) ('Data.Set'.toList attrs) spans
#! (m_attrs`,spans) = strictTRMapSt (resolveImgAttr user_tags font_spans text_spans) ('Data.SetBy'.toList attrs) spans
= case [e \\ Error e <- m_attrs`] of
[e : _] = (Error e,spans)
_ = (Ok ('Data.Set'.fromList (map fromOk m_attrs`)),spans)
_ = (Ok ('Data.SetBy'.fromListBy smallerBasicImgAttr (map fromOk m_attrs`)),spans)
resolveImgAttr :: !ImgTags !FontSpans !TextSpans !BasicImgAttr !*(!ImgPaths,!ImgSpans,!GridSpans) -> (!MaybeError SpanResolveError BasicImgAttr,!*(!ImgPaths,!ImgSpans,!GridSpans))
resolveImgAttr user_tags font_spans text_spans (BasicImgStrokeWidthAttr span) spans
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment