Add color schemes

app/Icons.hs

@@ -13,7 +13,9 @@ module Icons
     resultIcon,
     guardIcon,
     apply0NDia,
-    defaultLineWidth
+    defaultLineWidth,
+    ColorStyle(..),
+    colorScheme
     ) where
 
 import Diagrams.Prelude
@@ -22,6 +24,64 @@ import Data.Maybe (fromMaybe)
 
 import Types(Icon(..), Edge(..))
 
+-- COLO(U)RS --
+colorScheme :: (Floating a, Ord a) => ColorStyle a
+colorScheme = colorOnBlackScheme
+
+data ColorStyle a = ColorStyle {
+  backgroundC :: Colour a,
+  lineC :: Colour a,
+  textBoxTextC :: Colour a,
+  textBoxC :: Colour a,
+  apply0C :: Colour a,
+  apply1C :: Colour a,
+  boolC :: Colour a,
+  lamArgResC :: Colour a,
+  regionPerimC :: Colour a
+}
+
+colorOnBlackScheme :: (Floating a, Ord a) => ColorStyle a
+colorOnBlackScheme = ColorStyle {
+  backgroundC = black,
+  lineC = white,
+  textBoxTextC = white,
+  textBoxC = white,
+  apply0C = red,
+  apply1C = cyan,
+  boolC = orange,
+  lamArgResC = lime,
+  regionPerimC = white
+}
+
+whiteOnBlackScheme :: (Floating a, Ord a) => ColorStyle a
+whiteOnBlackScheme = ColorStyle {
+  backgroundC = black,
+  lineC = white,
+  textBoxTextC = white,
+  textBoxC = white,
+  apply0C = white,
+  apply1C = white,
+  boolC = white,
+  lamArgResC = white,
+  regionPerimC = white
+}
+
+-- Use this to test that all of the colors use the colorScheme
+randomColorScheme :: (Floating a, Ord a) => ColorStyle a
+randomColorScheme = ColorStyle {
+  backgroundC = darkorchid,
+  lineC = yellow,
+  textBoxTextC = blue,
+  textBoxC = magenta,
+  apply0C = orange,
+  apply1C = green,
+  boolC = lightpink,
+  lamArgResC = red,
+  regionPerimC = cyan
+}
+
+lineCol = lineC colorScheme
+
 -- FUNCTIONS --
 
 iconToDiagram Apply0Icon _ = apply0Dia
@@ -57,13 +117,13 @@ circleRadius = 0.5
 apply0LineWidth = defaultLineWidth
 
 --resultCircle :: Diagram B
-resultCircle = circle circleRadius # fc red # lw none
+resultCircle = circle circleRadius # fc (apply0C colorScheme) # lw none
 
 --apply0Triangle :: Diagram B
-apply0Triangle = eqTriangle (2 * circleRadius) # rotateBy (-1/12) # fc red # lw none
+apply0Triangle = eqTriangle (2 * circleRadius) # rotateBy (-1/12) # fc (apply0C colorScheme) # lw none
 
 --apply0Line :: Diagram B
-apply0Line = rect apply0LineWidth (2 * circleRadius) # fc white # lw none
+apply0Line = rect apply0LineWidth (2 * circleRadius) # fc lineCol # lw none
 
 --apply0Dia :: Diagram B
 apply0Dia = (resultCircle ||| apply0Line ||| apply0Triangle) <> makePortDiagrams apply0PortLocations # centerXY
@@ -85,11 +145,11 @@ apply0NDia n = finalDia # centerXY where
   trianglePortsCircle = hcat [
     reflectX apply0Triangle,
     hcat $ take n $ map (\x -> makePort x <> strutX seperation) [2,3..],
-    makePort 1 <> alignR (circle circleRadius # fc red # lwG defaultLineWidth # lc red)
+    makePort 1 <> alignR (circle circleRadius # fc (apply0C colorScheme) # lwG defaultLineWidth # lc (apply0C colorScheme))
     ]
   allPorts = makePort 0 <> alignL trianglePortsCircle
   topAndBottomLineWidth = width allPorts - circleRadius
-  topAndBottomLine = hrule topAndBottomLineWidth # lc red # lwG defaultLineWidth # alignL
+  topAndBottomLine = hrule topAndBottomLineWidth # lc (apply0C colorScheme) # lwG defaultLineWidth # alignL
   finalDia = topAndBottomLine === allPorts === topAndBottomLine
 
 -- TEXT ICON --
@@ -98,7 +158,7 @@ monoLetterWidthToHeightFraction = 0.6
 textBoxHeightFactor = 1.1
 
 --textBox :: String -> Diagram B
-textBox = coloredTextBox white $ opaque white
+textBox = coloredTextBox (textBoxTextC colorScheme) $ opaque (textBoxC colorScheme)
 
 -- Since the normal SVG text has no size, some hackery is needed to determine
 -- the size of the text's bounding box.
@@ -111,12 +171,12 @@ coloredTextBox textColor boxColor t =
       + (textBoxFontSize * 0.2)
 
 -- ENCLOSING REGION --
-enclosure dia = dia <> boundingRect (dia # frame 0.5) # lc white # lwG defaultLineWidth
+enclosure dia = dia <> boundingRect (dia # frame 0.5) # lc (regionPerimC colorScheme) # lwG defaultLineWidth
 
 -- LAMBDA ICON --
 -- Don't use === here to put the port under the text box since mempty will stay
 -- at the origin of the text box.
-lambdaIcon x = coloredTextBox lime transparent "λ" # alignB <> makePort x
+lambdaIcon x = coloredTextBox (lamArgResC colorScheme) transparent "λ" # alignB <> makePort x
 
 -- LAMBDA REGION --
 
@@ -127,26 +187,26 @@ lambdaRegion n dia =
   where lambdaIcons = hsep 0.4 (take n (map lambdaIcon [0,1..]))
 
 -- RESULT ICON --
-resultIcon = unitSquare # lw none # fc lime
+resultIcon = unitSquare # lw none # fc (lamArgResC colorScheme)
 
 -- BRANCH ICON --
 branchIcon :: Diagram B
-branchIcon = circle 0.3 # fc white # lc white
+branchIcon = circle 0.3 # fc lineCol # lc lineCol
 
 -- GUARD ICON --
 guardSize = 0.7
 guardTriangle :: Int -> Diagram B
 guardTriangle x =
-  ((triangleAndPort ||| (hrule (guardSize * 0.8) # lc white # lwG defaultLineWidth)) # alignR) <> makePort x # alignL
+  ((triangleAndPort ||| (hrule (guardSize * 0.8) # lc lineCol # lwG defaultLineWidth)) # alignR) <> makePort x # alignL
   where
     triangleAndPort = polygon (with & polyType .~ PolySides [90 @@ deg, 45 @@ deg] [guardSize, guardSize])
-      # rotateBy (1/8)# lc white # lwG defaultLineWidth # alignT # alignR
+      # rotateBy (1/8)# lc lineCol # lwG defaultLineWidth # alignT # alignR
 
 guardLBracket :: Int -> Diagram B
 guardLBracket x = ell # alignT # alignL <> makePort x
   where
     ellShape = fromOffsets $ map r2 [(0, guardSize), (-guardSize,0)]
-    ell = ellShape # strokeLine # lc orange # lwG defaultLineWidth # lineJoin LineJoinRound
+    ell = ellShape # strokeLine # lc (boolC colorScheme) # lwG defaultLineWidth # lineJoin LineJoinRound
 
 -- | The ports of the guard icon are as follows:
 -- Port 0: The top port for the result
@@ -163,4 +223,4 @@ guardIcon n = centerXY $ makePort 1 <> alignB (vcat (take n trianglesAndBrackets
       zipWith zipper trianglesWithPorts lBrackets
     zipper tri lBrack = verticalLine === ((lBrack # extrudeRight guardSize) # alignR <> (tri # alignL))
       where
-        verticalLine = vrule 0.4 # lc white # lwG defaultLineWidth
+        verticalLine = vrule 0.4 # lc lineCol # lwG defaultLineWidth

app/Main.hs

@@ -14,18 +14,18 @@ import Data.Maybe (fromMaybe)
 import Data.Typeable(Typeable)
 
 import Lib
-import Icons(apply0Dia, apply0NDia, guardIcon)
+import Icons(apply0Dia, apply0NDia, guardIcon, colorScheme, ColorStyle(..))
 import Rendering(toNames, portToPort, iconToPort, iconToIcon,
   iconToIconEnds, iconHeadToPort, iconTailToPort, renderDrawing)
 import Types(Icon(..), Drawing(..), EdgeEnd(..))
 
 -- TODO Now --
--- todo: consolidate colors to one place
 -- todo: use constants for icon name strings in Main
 -- todo: figure out how to deal with the difference between arrow heads and arrow tails
 -- todo: consider moving portToPort etc. to a new file
 
 -- TODO Later --
+-- Add a small black border to lines to help distinguish line crossings.
 -- todo: Find out how to hide unqualified names such that recursive drawings are connected correctly
 -- todo: Find out and fix why connectinos to sub-icons need to be qualified twice (eg. "lam0" .> "arg" .> "arg")
 -- todo: Rotate based on difference from ideal tangent angle, not line distance.
@@ -217,7 +217,7 @@ factLam1Drawing = Drawing factLam0Icons factLam0Edges [(fact0Name, fact1Drawing)
 main1 :: IO ()
 main1 = do
   placedNodes <- renderDrawing factLam1Drawing
-  mainWith (placedNodes # bgFrame 1 black)
+  mainWith (placedNodes # bgFrame 1 (backgroundC colorScheme))
 
 main2 = mainWith (guardIcon 3 # bgFrame 0.1 black)
 

app/Rendering.hs

@@ -27,7 +27,7 @@ import Data.Function(on)
 import Data.Graph.Inductive.PatriciaTree (Gr)
 import Data.Typeable(Typeable)
 
-import Icons
+import Icons(colorScheme, Icon(..), iconToDiagram, nameDiagram, defaultLineWidth, ColorStyle(..))
 import Types(Edge(..), Connection, Drawing(..), EdgeEnd(..))
 
 
@@ -81,13 +81,13 @@ getArrowOpts (t, h) = arrowOptions
     lookupEnd :: (RealFloat n, Typeable n) => EdgeEnd -> ArrowOpts n -> ArrowOpts n
     lookupEnd EndNone = id
     lookupEnd EndAp1Arg = (arrowHead .~ arrowheadDart (0.4 @@ turn))
-      . (headTexture .~ solid black) . (headStyle %~ (lw thick . lc cyan ))
-    lookupEnd EndAp1Result = (arrowTail .~ arg1ResHT) . (tailTexture .~ solid cyan)
+      . (headTexture .~ solid (backgroundC colorScheme)) . (headStyle %~ (lw thick . lc (apply1C colorScheme) ))
+    lookupEnd EndAp1Result = (arrowTail .~ arg1ResHT) . (tailTexture .~ solid (apply1C colorScheme))
     arrowOptions =
       with & arrowHead .~ noHead
       & arrowTail .~ noTail
       & lengths .~ large
-      & shaftStyle %~ lwG defaultLineWidth . lc white
+      & shaftStyle %~ lwG defaultLineWidth . lc (lineC colorScheme)
       & lookupEnd t & lookupEnd h
 
 plainLine = getArrowOpts (EndNone, EndNone)