mirror of
https://github.com/rgleichman/glance.git
synced 2024-08-16 18:30:36 +03:00
Add color schemes
This commit is contained in:
parent
83780b8e0c
commit
e2e541a5dc
90
app/Icons.hs
90
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
|
||||
|
@ -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)
|
||||
|
||||
|
@ -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)
|
||||
|
Loading…
Reference in New Issue
Block a user