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