Split off Attributes from Actor.

gcross · Oct 10, 2015 · 54f8159 · 54f8159
1 parent f1c5b2d
commit 54f8159
Show file tree

Hide file tree

Showing 2 changed files with 45 additions and 29 deletions.
diff --git a/example.hs b/example.hs
@@ -1,11 +1,12 @@
 {-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE UnicodeSyntax #-}
 
 module Main where
 
-import Control.Lens ((^.),(.=),makeLenses)
+import Control.Lens (Lens',(^.),(.=),makeLenses)
 
 import Data.Default (def)
 import qualified Data.Map as Map
@@ -20,19 +21,25 @@ import Slick.SVG
 import Slick.Transition
 
 data LogoState = LogoState
-    {   _logo_the :: Actor
-    ,   _logo_uantum :: Actor
-    ,   _logo_mechanic :: Actor
-    ,   _logo_gear :: Actor
-    ,   _logo_gear_tail :: Actor
+    {   _actor_logo_the :: Actor
+    ,   _actor_logo_uantum :: Actor
+    ,   _actor_logo_mechanic :: Actor
+    ,   _actor_logo_gear :: Actor
+    ,   _actor_logo_gear_tail :: Actor
     } deriving (Eq,Ord,Show)
 makeLenses ''LogoState
 
+logo_the = actor_logo_the . attributes
+logo_uantum = actor_logo_uantum . attributes
+logo_mechanic = actor_logo_mechanic . attributes
+logo_gear = actor_logo_gear . attributes
+logo_gear_tail = actor_logo_gear_tail . attributes
+
 main = do
     let filename = "quantum-mechanic.svg"
     document ← XML.readFile def filename
     let defs = mkDefsFromSVG document
-        uses = extractElementsForUse document . Set.fromList $
+        actor = extractActors document . Set.fromList $
             ["logo_the"
             ,"logo_gear"
             ,"logo_uantum"
@@ -41,22 +48,23 @@ main = do
             ,"logo_gear_tail"
             ]
         initial_logo_state = LogoState
-            (fromJust $ Map.lookup "logo_the" uses)
-            (fromJust $ Map.lookup "logo_uantum" uses)
-            (fromJust $ Map.lookup "logo_mechanic" uses)
-            (fromJust $ Map.lookup "logo_gear" uses)
-            (fromJust $ Map.lookup "logo_gear_tail" uses)
+            (fromJust $ Map.lookup "logo_the" actor)
+            (fromJust $ Map.lookup "logo_uantum" actor)
+            (fromJust $ Map.lookup "logo_mechanic" actor)
+            (fromJust $ Map.lookup "logo_gear" actor)
+            (fromJust $ Map.lookup "logo_gear_tail" actor)
         renderToDocument logo_state =
             svg (document ^. header)
+                1
                 [defs
-                ,renderUse $ logo_state ^. logo_the
-                ,renderUse $ logo_state ^. logo_uantum
-                ,renderUse $ logo_state ^. logo_mechanic
-                ,renderUse $ logo_state ^. logo_gear
-                ,renderUse $ logo_state ^. logo_gear_tail
+                ,renderActor $ logo_state ^. actor_logo_the
+                ,renderActor $ logo_state ^. actor_logo_uantum
+                ,renderActor $ logo_state ^. actor_logo_mechanic
+                ,renderActor $ logo_state ^. actor_logo_gear
+                ,renderActor $ logo_state ^. actor_logo_gear_tail
                 ]
     viewPresentation Serial initial_logo_state renderToDocument $ do
-        logo_the . x .= -380
+        actor_logo_the . attributes . x .= -380
         logo_uantum . x .= 540
         logo_mechanic . y .= 280
         logo_gear . y .= -314

diff --git a/src/Slick/SVG.hs b/src/Slick/SVG.hs
@@ -161,35 +161,43 @@ instance Interpolatable Double Scale where
     interpolateUnitInterval (NonPropScale _ _) (PropScale _) _ =
         error "Must interpolate between the same kind of scale.  (Not from NonPropScale to PropScale.)"
 
-data Actor = Actor
-    {   useId
-    ,   useParentTransform :: Text
-    ,   _rotation_angle :: Double
+data Attributes = Attributes
+    {   _rotation_angle :: Double
     ,   _rotation_x :: Double
     ,   _rotation_y :: Double
     ,   _scale :: Scale
     ,   _x :: Double
     ,   _y :: Double
     } deriving (Eq,Ord,Read,Show)
+makeLenses ''Attributes
 
+data Actor = Actor
+    {   actorId
+    ,   actorParentTransform :: Text
+    ,   _attributes :: Attributes
+    } deriving (Eq,Ord,Read,Show)
 makeLenses ''Actor
 
+instance Default Attributes where
+    def = Attributes 0 0 0 def 0 0
+
 mkActor :: Text → Text → Actor
-mkActor use_id parent_transform = Actor use_id parent_transform 0 0 0 (PropScale 1) 0 0
+mkActor actor_id parent_transform = Actor actor_id parent_transform def
 
-renderUse :: Actor → Element
-renderUse Actor{..} =
+renderActor :: Actor → Element
+renderActor Actor{..} =
     Element
         (mkName "use")
         (Map.fromList
             [(mkName "transform",transform)
-            ,("xlink:href","#" <> useId)
+            ,("xlink:href","#" <> actorId)
             ]
         )
         []
   where
+    Attributes{..} = _attributes
     transform =
-        useParentTransform
+        actorParentTransform
         <>
         (pack $
             "scale(" ++ (
@@ -201,8 +209,8 @@ renderUse Actor{..} =
              "rotate(" ++ show _rotation_angle ++ " " ++ show _rotation_x ++ " " ++ show _rotation_y ++ ")"
         )
 
-extractElementsForUse :: Document → Set Text → Map Text Actor
-extractElementsForUse Document{..} id_set =
+extractActors :: Document → Set Text → Map Text Actor
+extractActors Document{..} id_set =
     if not (Set.null remaining_id_set)
     then error $ "Some ids were not found: " ++ show (Set.toList remaining_id_set)
     else id_map