From e2e541a5dc72ec16a5c07a7ea7fe9ac54492ed10 Mon Sep 17 00:00:00 2001 From: Robbie Gleichman Date: Thu, 21 Jan 2016 13:35:34 -0800 Subject: [PATCH] Add color schemes --- app/Icons.hs | 90 ++++++++++++++++++++++++++++++++++++++++-------- app/Main.hs | 6 ++-- app/Rendering.hs | 8 ++--- 3 files changed, 82 insertions(+), 22 deletions(-) diff --git a/app/Icons.hs b/app/Icons.hs index 2cf6503..3bcaad5 100644 --- a/app/Icons.hs +++ b/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 diff --git a/app/Main.hs b/app/Main.hs index ca23b79..65655b7 100644 --- a/app/Main.hs +++ b/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) diff --git a/app/Rendering.hs b/app/Rendering.hs index 06dd3d5..f79e4ef 100644 --- a/app/Rendering.hs +++ b/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)