adding optional opacity (and sliders) to ColorNum

src/InterfaceView2.elm

@@ -407,6 +407,8 @@ cursorOfZone zone default = case LangSvg.realZoneOf zone of
   -- indirect manipulation zones
   LangSvg.Z "FillBall"        -> cursorStyle "pointer"
   LangSvg.Z "StrokeBall"      -> cursorStyle "pointer"
+  LangSvg.Z "FillOpacityBall"   -> cursorStyle "pointer"
+  LangSvg.Z "StrokeOpacityBall" -> cursorStyle "pointer"
   LangSvg.Z "StrokeWidthBall" -> cursorStyle "pointer"
   LangSvg.Z "RotateBall"      -> cursorStyle "pointer"
   LangSvg.Z "SliderBall"      -> cursorStyle "pointer"
@@ -417,6 +419,8 @@ isPrimaryZone zone =
   case zone of
     "FillBall"        -> False
     "StrokeBall"      -> False
+    "FillOpacityBall"   -> False
+    "StrokeOpacityBall" -> False
     "StrokeWidthBall" -> False
     "RotateBall"      -> False
     "SliderBall"      -> False
@@ -426,6 +430,8 @@ isFillStrokeZone zone =
   case zone of
     "FillBall"        -> True
     "StrokeBall"      -> True
+    "FillOpacityBall"   -> True
+    "StrokeOpacityBall" -> True
     "StrokeWidthBall" -> True
     _                 -> False
 
@@ -671,34 +677,44 @@ boundingBoxOfPoints pts =
 --------------------------------------------------------------------------------
 
 zonesStroke model id shape x y l =
-  let x' = x + wGradient + 5
-      y' = y
-  in
-  zoneStrokeColor model id shape x  y  (maybeColorNumAttr "stroke" l) ++
-  zoneStrokeWidth model id shape x' y' (maybeStrokeWidthNumAttr l)
+  let (maybeColor, maybeOpacity) = maybeColorNumAttr "stroke" l in
+  let maybeStrokeWidth = maybeStrokeWidthNumAttr l in
+  zoneStrokeOpacity model id shape (x - wOpacityBox - 5) y maybeOpacity ++
+  zoneStrokeColor model id shape x y maybeColor ++
+  zoneStrokeWidth model id shape (x + wGradient + 5) y maybeStrokeWidth
+
+zonesFill model id shape x y l =
+  let (maybeColor, maybeOpacity) = maybeColorNumAttr "fill" l in
+  zoneFillOpacity model id shape (x - wOpacityBox - 5) y maybeOpacity ++
+  zoneFillColor model id shape x y maybeColor
 
 zonesFillAndStroke model id shape x y l =
-  zoneFillColor model id shape x y (maybeColorNumAttr "fill" l) ++
-  zonesStroke model id shape x (y-20-5) l
+  zonesFill model id shape x y l ++
+  zonesStroke model id shape x (y - hZoneColor - 5) l
 
 zoneFillColor   = zoneColor "FillBall" LangSvg.shapeFill
 zoneStrokeColor = zoneColor "StrokeBall" LangSvg.shapeStroke
 
+zoneFillOpacity   = zoneOpacity "FillOpacityBall" LangSvg.shapeFillOpacity
+zoneStrokeOpacity = zoneOpacity "StrokeOpacityBall" LangSvg.shapeStrokeOpacity
+
 
 -- Stuff for Color Zones -------------------------------------------------------
 
 wGradient = 250
 scaleColorBall = 1 / (wGradient / LangSvg.maxColorNum)
 
+hZoneColor = 20
+
 numToColor = Utils.numToColor wGradient
 
-maybeColorNumAttr : String -> List LangSvg.Attr -> Maybe NumTr
+maybeColorNumAttr : String -> List LangSvg.Attr -> (Maybe NumTr, Maybe NumTr)
 maybeColorNumAttr k l =
   case Utils.maybeFind k l of
     Just aval -> case aval.av_ of
-      LangSvg.AColorNum n -> Just n
-      _                   -> Nothing
-    _                     -> Nothing
+      LangSvg.AColorNum (nt, maybeOpacity) -> (Just nt, maybeOpacity)
+      _                                    -> (Nothing, Nothing)
+    _                                      -> (Nothing, Nothing)
 
 zoneColor zoneName shapeFeature model id shape x y maybeColor =
   let pred z = isPrimaryZone z || isRotateZone z in
@@ -712,7 +728,7 @@ zoneColor_ : LangSvg.Zone -> LangSvg.ShapeFeature
           -> Model -> NodeId -> ShapeKind -> Num -> Num -> NumTr -> List Svg.Svg
 zoneColor_ zoneName shapeFeature model id shape x y (n, trace) =
   let (w, h, a, stroke, strokeWidth, rBall) =
-      (wGradient, 20, 20, "silver", "2", "7") in
+      (wGradient, hZoneColor, 20, "silver", "2", "7") in
   let yOff = a + rotZoneDelta in
   let typeAndNodeIdAndFeature = (InterfaceModel.selectedTypeShapeFeature, id, shapeFeature) in
   let ball =
@@ -757,6 +773,58 @@ zoneColor_ zoneName shapeFeature model id shape x y (n, trace) =
   ]
 
 
+-- Stuff for Color Opacity Zones -----------------------------------------------
+
+wOpacityBox = 20
+-- scaleOpacityBall = 1 / wOpacityBox
+
+-- TODO could abstract the zoneColor, zoneOpacity, and zoneStrokeWidth sliders
+
+zoneOpacity zoneName shapeFeature model id shape x y maybeOpacity =
+  let pred z = isPrimaryZone z || isRotateZone z in
+  case ( Set.member id model.selectedShapes
+       , objectZoneIsCurrentlyBeingManipulated model id pred
+       , maybeOpacity ) of
+    (True, False, Just nt) -> zoneOpacity_ zoneName shapeFeature model id shape x y nt
+    _                      -> []
+
+zoneOpacity_
+   : LangSvg.Zone -> LangSvg.ShapeFeature
+  -> Model -> NodeId -> ShapeKind -> Num -> Num -> NumTr -> List Svg.Svg
+zoneOpacity_ zoneName shapeFeature model id shape x y (n, trace) =
+  let (w, h, a, stroke, strokeWidth, rBall) =
+      (wOpacityBox, 20, 20, "silver", "2", "7") in
+  let yOff = a + rotZoneDelta in
+  let typeAndNodeIdAndFeature = (InterfaceModel.selectedTypeShapeFeature, id, shapeFeature) in
+  let ball =
+    let cx = x + n * wOpacityBox in
+    let cy = y - yOff + (h/2) in
+    flip Svg.circle [] <|
+      [ LangSvg.attr "stroke" "black" , LangSvg.attr "stroke-width" strokeWidth
+      , LangSvg.attr "fill" stroke
+      , LangSvg.attr "cx" (toString cx) , LangSvg.attr "cy" (toString cy)
+      , LangSvg.attr "r"  rBall
+      , cursorOfZone zoneName "default"
+      ] ++ zoneEvents id shape zoneName
+  in
+  let box =
+    flip Svg.rect [] <|
+      [ LangSvg.attr "fill" <|
+          if Set.member typeAndNodeIdAndFeature model.selectedFeatures
+            then colorPointSelected
+            else "white" -- colorPointNotSelected
+      , LangSvg.attr "stroke" stroke , LangSvg.attr "stroke-width" strokeWidth
+      , LangSvg.attr "x" (toString x) , LangSvg.attr "y" (toString (y - yOff))
+      , LangSvg.attr "width" (toString w) , LangSvg.attr "height" (toString h)
+      ]
+  in
+  [ Svg.g
+      [onMouseDownAndStop (toggleSelected [typeAndNodeIdAndFeature])]
+      ([box])
+  , ball
+  ]
+
+
 -- Stuff for Stroke Width Zones ------------------------------------------------
 
 wStrokeWidthBox = 60

src/LangSvg.elm

@@ -82,7 +82,7 @@ type AVal_
   | AString String
   | APoints (List Point)
   | ARgba Rgba
-  | AColorNum NumTr -- Utils.numToColor [0,500)
+  | AColorNum (NumTr, Maybe NumTr) -- Utils.numToColor [0,500), and opacity
   | APath2 (List PathCmd, PathCounts)
   | ATransform (List TransformCmd)
   | ABounds (NumTr, NumTr, NumTr, NumTr)
@@ -144,7 +144,8 @@ toNum a = case a.av_ of
 
 toNumTr a = case a.av_ of
   ANum (n,t) -> (n,t)
-  AColorNum (n,t) -> (n,t)
+  -- TODO add back in?
+  -- AColorNum (n,t) -> (n,t)
   AString s  ->
     case String.toFloat s of
       Ok n -> (n, dummyTrace)
@@ -174,15 +175,31 @@ valToAttr v = case v.v_ of
      let (k',av_) =
       case (k, v2_) of
         ("points", VList vs)    -> (k, APoints <| List.map valToPoint vs)
-        ("fill", VList vs)      -> (k, ARgba <| valToRgba vs)
-        ("fill", VConst it)     -> (k, AColorNum it)
-        ("stroke", VList vs)    -> (k, ARgba <| valToRgba vs)
-        ("stroke", VConst it)   -> (k, AColorNum it)
+
+        ("fill"  , VList [v1,v2,v3,v4]) -> (k, ARgba <| valToRgba [v1,v2,v3,v4])
+        ("stroke", VList [v1,v2,v3,v4]) -> (k, ARgba <| valToRgba [v1,v2,v3,v4])
+
+        ("fill",   VConst it) -> (k, AColorNum (it, Nothing))
+        ("stroke", VConst it) -> (k, AColorNum (it, Nothing))
+
+        ("fill",   VList [v1,v2]) ->
+          case (v1.v_, v2.v_) of
+            (VConst it1, VConst it2) -> (k, AColorNum (it1, Just it2))
+            _                        -> Debug.crash "valToAttr: fill"
+        ("stroke", VList [v1,v2]) ->
+          case (v1.v_, v2.v_) of
+            (VConst it1, VConst it2) -> (k, AColorNum (it1, Just it2))
+            _                        -> Debug.crash "valToAttr: stroke"
+
         ("d", VList vs)         -> (k, APath2 (valsToPath2 vs))
+
         ("transform", VList vs) -> (k, ATransform (valsToTransform vs))
+
         ("BOUNDS", VList vs)    -> (k, ABounds <| valToBounds vs)
+
         (_, VConst it)          -> (k, ANum it)
         (_, VBase (String s))   -> (k, AString s)
+
         _                       -> Debug.crash "valToAttr"
      in
      (k', AVal av_ v2.vtrace)
@@ -225,11 +242,14 @@ strAVal a = case a.av_ of
   ARgba tup -> strRgba tup
   APath2 p  -> strAPath2 (fst p)
   ATransform l -> Utils.spaces (List.map strTransformCmd l)
-  AColorNum n ->
+  AColorNum (n, Nothing) ->
     -- slight optimization:
     strRgba_ (ColorNum.convert (fst n))
     -- let (r,g,b) = Utils.numToColor maxColorNum (fst n) in
     -- strRgba_ [r,g,b,1]
+  AColorNum (n, Just (opacity, _)) ->
+    let (r,g,b) = Utils.numToColor maxColorNum (fst n) in
+    strRgba_ [toFloat r, toFloat g, toFloat b, opacity]
   ABounds bounds -> strBounds bounds
 
 valOfAVal : AVal -> Val
@@ -239,7 +259,8 @@ valOfAVal a = flip Val a.vtrace <| case a.av_ of
   APoints l    -> VList (List.map pointToVal l)
   ARgba tup    -> VList (rgbaToVal tup)
   APath2 p     -> VList (List.concatMap valsOfPathCmd (fst p))
-  AColorNum nt -> VConst nt
+  AColorNum (nt, Nothing)   -> VConst nt
+  AColorNum (nt1, Just nt2) -> VList [vConst nt1, vConst nt2]
   _            -> Debug.crash "valOfAVal"
 
 valsOfPathCmd c =
@@ -569,6 +590,8 @@ edgeCrosshairs_ shape =
 -- So we can gather them back up into (X,Y) pairs again.
 shapeFill = "fill"
 shapeStroke = "stroke"
+shapeFillOpacity = "fillOpacity"
+shapeStrokeOpacity = "strokeOpacity"
 shapeStrokeWidth = "strokeWidth"
 shapeRotation = "rotation"
 rectTLX = "rectTLX"

src/Sync.elm

@@ -1278,6 +1278,22 @@ nodeToAttrLocs_ v (nextId,dShapes) = case v.v_ of
             let ee = ("stroke", ("StrokeBall", tr)) :: extraextra in
             (extra, ee, Dict.insert "stroke" tr dAttrs)
 
+          [VBase (String "fill"), VList [v1, v2]] ->
+            case (v1.v_, v2.v_) of
+              (VConst (_,tr1), VConst (_,tr2)) ->
+                let ee = ("fill", ("FillBall", tr1)) ::
+                         ("fillOpacity", ("FillOpacityBall", tr2)) :: extraextra in
+                (extra, ee, Dict.insert "fillOpacity" tr2 (Dict.insert "fill" tr1 dAttrs))
+              _ -> Debug.crash "nodeToAttrLocs_"
+
+          [VBase (String "stroke"), VList [v1, v2]] ->
+            case (v1.v_, v2.v_) of
+              (VConst (_,tr1), VConst (_,tr2)) ->
+                let ee = ("stroke", ("StrokeBall", tr1)) ::
+                         ("strokeOpacity", ("StrokeOpacityBall", tr2)) :: extraextra in
+                (extra, ee, Dict.insert "strokeOpacity" tr2 (Dict.insert "stroke" tr1 dAttrs))
+              _ -> Debug.crash "nodeToAttrLocs_"
+
           [VBase (String "stroke-width"), VConst (_,tr)] ->
             let ee = ("stroke-width", ("StrokeWidthBall", tr)) :: extraextra in
             (extra, ee, Dict.insert "stroke-width" tr dAttrs)
@@ -1446,6 +1462,8 @@ getZones kind extra ee =
 widgetZones = List.map <| \x -> case x of
   ("fill"         , ("FillBall"   , _)) -> ("FillBall"   , ["fill"])
   ("stroke"       , ("StrokeBall" , _)) -> ("StrokeBall" , ["stroke"])
+  ("fillOpacity"  , ("FillOpacityBall"   , _)) -> ("FillOpacityBall"   , ["fillOpacity"])
+  ("strokeOpacity", ("StrokeOpacityBall" , _)) -> ("StrokeOpacityBall" , ["strokeOpacity"])
   ("stroke-width" , ("StrokeWidthBall" , _)) -> ("StrokeWidthBall" , ["stroke-width"])
   ("transformRot" , ("RotateBall" , _)) -> ("RotateBall" , ["transformRot"])
   _                                     -> Debug.crash "widgetZones"
@@ -1723,6 +1741,18 @@ makeTrigger_ opts d0 d2 slate subst id kind zone =
         let n' = LangSvg.clampColorNum (n + scaleColorBall * toFloat dx) in
         solveOne "stroke" (n', t)
 
+    (_, "FillOpacityBall")   ->
+      \_ (dx,dy) ->
+        let (n,t) = getAColorNumOpacity slate id "fill" in
+        let n' = Utils.clamp 0.0 1.0 (n + scaleOpacityBall * toFloat dx) in
+        solveOne "fillOpacity" (n', t)
+
+    (_, "StrokeOpacityBall")   ->
+      \_ (dx,dy) ->
+        let (n,t) = getAColorNumOpacity slate id "stroke" in
+        let n' = Utils.clamp 0.0 1.0 (n + scaleOpacityBall * toFloat dx) in
+        solveOne "strokeOpacity" (n', t)
+
     (_, "StrokeWidthBall") ->
       \_ (dx,dy) ->
         let (n,t) = getANum slate id "stroke-width" in
@@ -2059,8 +2089,13 @@ getATransformRot = getAVal <| \aval ->
 
 getAColorNum = getAVal <| \aval ->
   case aval.av_ of
-    AColorNum nt -> nt
-    _            -> Debug.crash "getAColorNum"
+    AColorNum (nt, _) -> nt
+    _                 -> Debug.crash "getAColorNum"
+
+getAColorNumOpacity = getAVal <| \aval ->
+  case aval.av_ of
+    AColorNum (_, Just nt) -> nt
+    _                      -> Debug.crash "getAColorNumOpacity"
 
 getAVal foo slate i attrName =
   case Dict.get i slate of
@@ -2127,6 +2162,8 @@ scaleColorBall = 1 / (wGradient / LangSvg.maxColorNum)
 wStrokeWidthBox = 60
 scaleStrokeWidthBall = 1 / (wStrokeWidthBox / LangSvg.maxStrokeWidthNum)
 
+wOpacityBox = 20
+scaleOpacityBall = 1 / wOpacityBox
 
 ------------------------------------------------------------------------------
 

src/ValueBasedTransform.elm

@@ -1119,6 +1119,14 @@ featureEquation nodeId kind feature nodeAttrs =
   if feature == LangSvg.shapeFill then eqnVal "fill"
   else if feature == LangSvg.shapeStroke then eqnVal "stroke"
   else if feature == LangSvg.shapeStrokeWidth then eqnVal "stroke-width"
+  else if feature == LangSvg.shapeFillOpacity then
+    case (Utils.find_ nodeAttrs "fill").av_ of
+      LangSvg.AColorNum (_, Just opacity) -> EqnVal (vConst opacity)
+      _                                   -> Debug.crash "featureEquation: fillOpacity"
+  else if feature == LangSvg.shapeStrokeOpacity then
+    case (Utils.find_ nodeAttrs "stroke").av_ of
+      LangSvg.AColorNum (_, Just opacity) -> EqnVal (vConst opacity)
+      _                                   -> Debug.crash "featureEquation: strokeOpacity"
   else if feature == LangSvg.shapeRotation then
     let (rot,cx,cy) = LangSvg.toTransformRot <| Utils.find_ nodeAttrs "transform" in
     EqnVal (vConst rot)