penrose-0.1.0.1: src/Compiler.hs
module Compiler where
-- TODO split this up + do selective export
import System.IO -- read/write to file
import System.Environment
import Control.Arrow ((>>>))
import System.Random
import Debug.Trace
import Data.List
-- Substance grammar
data SetType = Open | Closed | Unspecified
deriving (Show, Eq)
data Set = Set' String SetType
deriving (Show, Eq)
data Pt = Pt' String
deriving (Show, Eq)
-- Map <label> <from-set> <to-set>
data Map = Map' String String String -- TODO needs validation vs Set Set
deriving (Show, Eq)
data SubObj = OS Set | OP Pt | OM Map
deriving (Show, Eq)
-- TODO open sets?? they should inherit style characteristics from sets
data SubObjType = Set SetType | Pt | Map -- how to tie this to the types above
deriving (Show, Eq)
data SubDecl = Decl SubObj
deriving (Show, Eq)
-- TODO vs. Set Set. user only specifies names
-- TODO we assume that non-subset sets must not overlap (implicit constraint)
data SubConstr = Intersect String String
| NoIntersect String String
| Subset String String
| NoSubset String String
| PointIn String String
| PointNotIn String String
deriving (Show, Eq)
data SubLine = LD SubDecl | LC SubConstr
deriving (Show, Eq)
-- TODO do some program analysis to split the decls and constraints, which refer to things in the decls
-- and validate that the things they refer to are the right type (inline at some point??)
type SubSpec = [SubLine]
type SubSpecDiv = ([SubDecl], [SubConstr])
-- Sample Substance programs (more in file)
sub0 = "Set A"
sub1 = "OpenSet A"
sub2 = "Set A\nOpenSet B"
sub3 = "Set A\nOpenSet B\nSubset A B"
-- test
subSpecs = [sub0, sub1, sub2, sub3]
subTest = subValidateAll subSpecs
-- specs for 3 continuous map diagrams can be found in continuousmap1.sub, etc.
-- Substance parser
-- TODO divide into decls and constraints for typechecking and reference checking
-- parsing human-written programs: extra spaces ok (words removes them).
-- extra newlines ok (filter empty lines out). HOWEVER, this is not ok for validation, as
-- the pretty-printer does not add additional whitespace.
subParse :: String -> SubSpec
subParse = map (subToLine . words) . filter nonempty . lines
where nonempty x = (x /= "")
-- parses based on line length. should really tokenize and behave like DFA
-- TODO fix this or use lexer / parser generator
subToLine :: [String] -> SubLine
subToLine s@[x, y] = LD $ Decl $
if x == "Set" then OS (Set' y Unspecified)
else if x == "OpenSet" then OS (Set' y Open)
else if x == "ClosedSet" then OS (Set' y Closed)
else if x == "Point" then OP (Pt' y)
else error $ "Substance spec line: 2-token line '"
++ show s ++ "' does not begin with Set/OpenSet/ClosedSet"
-- TODO validate names exist in decls, are of type set
-- TODO auto-gen parser from grammar
subToLine s@[x, y, z] = LC $
if x == "Intersect" then Intersect y z
else if x == "NoIntersect" then NoIntersect y z
else if x == "Subset" then Subset y z
else if x == "NoSubset" then NoSubset y z
else if x == "In" then PointIn y z -- TODO ^
else if x == "NotIn" then PointNotIn y z
else error $ "Substance spec line: 3-token line '"
++ show s ++ "' does not begin with (No)Intersect/Subset/(Not)In"
subToLine s@[w, x, y, z] = LD $ Decl $
if w == "Map" then OM (Map' x y z)
else error $ "Substance spec line: 4-token line '"
++ show s ++ "' does not begin with Map"
subToLine s = error $ "Substance spec line '" ++ show s ++ "' is not 2, 3, or 4 tokens"
-- Pretty-printer for Substance AST
subPrettyPrintLine :: SubLine -> String
subPrettyPrintLine (LD (Decl decl)) = case decl of
OS (Set' name stype) -> case stype of
Open -> "OpenSet " ++ name
Closed -> "ClosedSet " ++ name
Unspecified -> "Set " ++ name
OP (Pt' name) -> "Point " ++ name
OM (Map' x y z) -> "Map " ++ x ++ " " ++ y ++ " " ++ z
subPrettyPrintLine (LC constr) = case constr of
Subset s1 s2 -> "Subset " ++ s1 ++ " " ++ s2
PointIn p s -> "In " ++ p ++ " " ++ s
PointNotIn p s -> "NotIn " ++ p ++ " " ++ s
subPrettyPrint :: SubSpec -> String
subPrettyPrint s = concat $ intersperse nl $ map subPrettyPrintLine s
-- Ugly pretty-printer for Substance
subPrettyPrintLine' :: SubLine -> String
subPrettyPrintLine' = show
subPrettyPrint' :: SubSpec -> String
subPrettyPrint' s = concat $ intersperse nl $ map subPrettyPrintLine' s
-- if a well-formed program is parsed, its output should equal the original
subValidate :: String -> Bool
subValidate s = (s == (subPrettyPrint $ subParse s))
subValidateAll :: [String] -> Bool
subValidateAll = all subValidate
-- Substance reference checker TODO
-- returns lines in same order as in program
subSeparate :: SubSpec -> SubSpecDiv
subSeparate = foldr separate ([], [])
where separate line (decls, constrs) =
case line of
(LD x) -> (x : decls, constrs)
(LC x) -> (decls, x : constrs)
-- Substance typechecker TODO
---------------------------------------
-- Style grammar (relies on the Substance grammar, specifically SubObj)
-- no styling for constraints
data SetShape = SetCircle | Box
deriving (Show, Eq)
data PtShape = SolidDot | HollowDot | Cross
deriving (Show, Eq)
-- data MapShape = LeftArr | RightArr | DoubleArr
data MapShape = SolidArrow
deriving (Show, Eq)
data Direction = Horiz | Vert | Angle Float
deriving (Show, Eq)
data SubShape = SS SetShape | SP PtShape | SM MapShape
deriving (Show, Eq)
data LineType = Solid | Dotted
deriving (Show, Eq, Read)
data Color = Red | Blue | Black | Yellow -- idk
deriving (Show, Eq, Read)
data M a = Auto | Override a -- short for Maybe (option type)
deriving (Show, Eq)
data StyLevel = SubVal String | LabelOfSubVal String | SubType SubObjType | Global
deriving (Show, Eq)
-- LabelOfSubObj is meant to allow styling of whatever label object A (originally named A) now has
-- e.g. it could be named "hello" with Label (SubValue "A") (Override "Hello"). (don't label labels)
-- then do (Position (LabelOfSubObj "A") 100 200)
type Opacity = Float -- 0 to 100%, TODO validate
type Priority' = Float -- higher = higher priority
-- There are three different layers of Style: global setting (over all types),
-- type setting (over all values of that type), and value setting.
-- The more specific ones implicitly override the more general ones.
-- If there are two conflicting ones at the same level, the more recent one will be used for "everything"
-- TODO more sophisticated system with scope
-- TODO if some aspect of style unspecified, then supplement with default
-- any setting is implicitly an override of the global default style
-- can choose to leave out an aspect (= implicitly auto), or explicitly specify auto; same thing
-- TODO need to validate that the shape specified matches that of the type
-- e.g. Shape Map Diamond is invalid
-- also, order does not matter between lines
data StyLine = Shape StyLevel (M SubShape) -- implicitly solid unless line is specified
| Line StyLevel (M LineType) (M Float) -- hollow shape; non-negative thickness
| Color StyLevel (M Color) (M Opacity)
| Priority StyLevel (M Priority') -- for line breaking
| Dir StyLevel (M Direction)
| Label StyLevel (M String) -- TODO add ability to turn off labeling
| Scale StyLevel (M Float) -- scale factor
| AbsPos StyLevel (M (Float, Float)) -- in pixels; TODO relative positions
deriving (Show, Eq)
type StySpec = [StyLine]
-- Sample Style programs and tests
-- TODO style is more complicated than substance; this doesn't test it fully
nl = "\n"
together = intercalate nl
sty0 = "Shape Global Circle"
sty1 = "Shape Set Box"
sty2 = "Shape A Circle"
sty3 = together [sty0, sty1, sty2] -- test overrides
sty4 = "Shape Set Circle\nShape Map RightArr\nLine Map Solid"
sty5 = "Line Map Dotted 5.01"
sty6 = "Color All Red 66.7"
sty7 = "Priority Label_AB 10.1"
sty8 = "Label All hithere"
sty9 = "Label Label_AB oh_no" -- TODO don't label labels. also allow spaces in labels (strings)
sty10 = "Direction Map Horizontal"
-- test all
sty_all = "Shape Set Circle\nShape Map RightArrow\nLine Map Solid Auto\nColor Global Blue 100\nPriority Map 100\nPriority Set 50\nDirection Map Horizontal\nDirection A Vertical\nLabel A NewA\nScale A 100\nPosition A -100 501\nColor Label_A Blue 100"
-- TODO deal with OpenSet, ClosedSet
-- TODO write tests of substance working *with* style
-- TODO add tests that should fail
styf1 = "Shape"
styf2 = "Shape Label_A"
styf3 = "Line Dotted 5.01"
-- TODO syntactically valid but semantically invalid programs
styfs1 = "Shape Map Circle"
-- Style parser
styParse :: String -> StySpec -- same as subParse
styParse = map (styToLine . words) . filter nonempty . lines
where nonempty x = (x /= "")
getLevel :: String -> StyLevel
getLevel s = if s == "All" then Global
-- TODO will need to update parsers whenever I add a new type...
else if s == "Set" then SubType (Set Unspecified)
else if s == "OpenSet" then SubType (Set Open)
else if s == "ClosedSet" then SubType (Set Closed)
else if s == "Point" then SubType Pt
else if s == "Map" then SubType Map
else if (take 6 s == "Label_")
then let res = drop 6 s in
if length res > 0 then LabelOfSubVal res
else error "Empty object name ('Label_') in style level"
else SubVal s -- sets could be named anything; later we validate that this ref exists
getShape :: [String] -> M SubShape
getShape [] = error "No Style shape param"
getShape [x] = if x == "Auto" then Auto
else if x == "Circle" then Override (SS SetCircle)
else if x == "Box" then Override (SS Box)
else if x == "SolidDot" then Override (SP SolidDot)
else if x == "HollowDot" then Override (SP HollowDot)
else if x == "Cross" then Override (SP Cross)
else if x == "SolidArrow" then Override (SM SolidArrow)
-- else if x == "LeftArrow" then Override (SM LeftArr)
-- else if x == "RightArrow" then Override (SM RightArr)
-- else if x == "DoubleArrow" then Override (SM DoubleArr)
else error $ "Invalid shape param '" ++ show x ++ "'"
getShape s = error $ "Too many style shape params in '" ++ show s ++ "'"
handleAuto :: String -> (String -> a) -> M a
handleAuto v f = if v == "Auto" then Auto else Override (f v)
readFloat :: String -> Float
readFloat x = read x :: Float
styToLine :: [String] -> StyLine
styToLine [] = error "Style spec line is empty"
styToLine s@[x] = error $ "Style spec line '" ++ show s ++ "' is only 1 token"
styToLine s@(x : y : xs) =
let level = getLevel y in -- throws its own errors
if x == "Shape" then
let shp = getShape xs in -- TODO handle Auto
Shape level shp
else if x == "Line" then
case xs of
[a, b] -> let ltype = handleAuto a (\x -> read x :: LineType) in -- TODO read is hacky, bad errorsn
let lthick = handleAuto b readFloat in
Line level ltype lthick
_ -> error $ "Incorrect number of params (not 3) for Line: '" ++ show xs ++ "'"
else if x == "Color" then
case xs of
[a, b] -> let ctype = handleAuto a (\x -> read x :: Color) in
let opacity = handleAuto b readFloat in
Color level ctype opacity
_ -> error $ "Incorrect # of params (not 3) for Color: '" ++ show xs ++ "'"
else if x == "Priority" then
case xs of
[a] -> let priority = handleAuto a readFloat in
Priority level priority
_ -> error $ "Incorrect number of params (not 2) for Priority: '" ++ show xs ++ "'"
else if x == "Direction" then
case xs of
[a] -> let dir = handleAuto a (\x -> if x == "Horizontal" then Horiz
else if x == "Vertical" then Vert
else Angle (read x :: Float)) in
Dir level dir
_ -> error $ "Incorrect number of params (not 2) for Direction: '" ++ show xs ++ "'"
else if x == "Label" then
case xs of
[a] -> Label level (handleAuto a id) -- label name is a string
_ -> error $ "Incorrect number of params (not 2) for Label: '" ++ show xs ++ "'"
else if x == "Scale" then
case xs of
[a] -> let scale = handleAuto a readFloat in
Scale level scale
_ -> error $ "Incorrect number of params (not 2) for Scale: '" ++ show xs ++ "'"
else if x == "Position" then
case xs of
[a] -> if a == "Auto" then AbsPos level Auto
else error $ "Only 1 param, but it is not Auto: '" ++ show a ++ "'"
[a, b] -> let x' = readFloat a in -- no Auto allowed if two params
let y' = readFloat b in
AbsPos level (Override (x', y'))
_ -> error $ "Incorrect number of params (not 2) for Position: '" ++ show xs ++ "'"
else error $ "Style spec line: '" ++ show s
++ "' does not begin with Shape/Line/Color/Priority/Direction/Label/Scale/Position"
-- Pretty-printer for Style AST
-- TODO write the full pretty-printer
styPrettyPrintLine :: StyLine -> String
styPrettyPrintLine = show
styPrettyPrint :: StySpec -> String
styPrettyPrint s = concat $ intersperse nl $ map styPrettyPrintLine s
-- Style validater
-- Style typechecker TODO
-- Style reference checker
---------------------------------------
-- Take a Substance and Style program, and produce the abstract layout representation
-- TODO try doing this w/o Style first? everything is compiled to a default style with default labels
-- write out applying Style on top: applying global overrides, then by type, then by name
-- going to need some kind of abstract intermediate type
-- figure out the intermediate subsets of the language I can support
-- e.g. map requires me to draw arrows, don't support direction and priority for now
-- how many objects I can support, e.g. A -> B -> C -> D requires scaling the size of each obj to fit on canvas
-- how the optimization code needs to scale up to meet the needs of multiple objects (labels only?)
-- also, optimization on multiple layouts
-- how to lay things out w/ constraints only (maybe)
-- how to apply optimization to the labels & what their obj functions should be
-- TODO finish parser for both, put into Slack tonight w/ description of override, continuousmap1.sub/sty
-- Substance only, circular sets only -> world state
-- then scale up optimization code to handle any number of sets
-- then support the Subset constraint only
-- then add labels and set styles
subt1 = "Set A"
subt2 = "Set A\nSet B"
subt2a = "Set A\nSet B\nSubset A B"
subt3 = "Set A\nSet B\nSet C"
subt4 = "Set A\nSet B\nSet C"
subt4a = "Set A\nSet B\nOpenSet C"
subt5 = "Set A\nSet B\nOpenSet C\nSubset B C"
styt1 = "Color Set Blue 50"
styt2 = "Color Set Blue 50\nLine OpenSet Dotted 1"
-- New type: inner join (?) of Decl with relevant constraint lines and relevant style lines
-- (only the ones that apply; not the ones that are overridden)
-- Type: Map Var (Decl, [SubConstr], [StyLine]) <-- the Var is the object's name (string) in Substance
-- does this include labels?? it includes overridden labels in StyLine but not labels like Set A -> "A"
-- for now, assume what about labels? -- are they separate? should they be linked? they all get default style
-- make a separate Map Label ObjName ? no, assuming no renaming for now
-- then we need to write a renderer type: Decl -> (Position, Size) -> [StyLine] -> Picture)
-- also (Label -> (Position, Size) -> [StyLine] -> Picture)
-- if we do a demo entirely w/o optimization... is that easier? and how would I do it?
-- layout algo (for initial state, at least): randomly place objs (sets, points) w/ no constraints
-- or place aligned horizontally so they don't intersect, choose radius as fn of # unconstrained objs?
-- for constraints: for any set that's a subset of another, pick a smaller radius & place it inside that set.
-- constraints: same for points (in fact, easier for points)--place it (at r/2, 45 degrees) inside that set
-- there's no validation... a point/set could be in multiple sets?? assume not
-- at this point we're almost hardcoding the diagram? not necessarily
-- TODO actually hardcode the diagram in gloss; seeing the final representation will help
-- add'l constraint: all other objects should not intersect. use optimization to maintain exclusion?
-- it seems likely that i'll get rid of the opt part for diagrams--might rewrite code instead of using opt code
-- BUT can I use opt for labels, given a fixed diagram state?
-- put all labels in center. set label is attracted to center or just-outside-or-inside border of set,
-- point label is attracted to just-outside-point, map label attracted to center
-- all labels repulsed from other objects and labels.
-- would hardcoding label locations be a bad thing to do?
-- creating unconstrained objective fn: f :: DiagramInfo -> LabelInfo -> Label Positions -> Label Positions
-- where f info pos = f_attract info pos + f_repel info pos, and each includes the pairwise interactions
-- can autodiff deal with this? does this preserve the (forall a. Floating a => [a] -> a) type?
-- is the function too complicated for autodiff?
-- TODO simple optimizer type, using state (Position and Size): ??
-- optimization fn: put all sets at the center, then use centerAndRepel. how to maintain subset?
-- the things the optimizer needs to know are Name, Position, Size, SubObjType (which includes names of other objects that this one is linked to, e.g. Map)... (later: needs to know Direction Label Scale AbsPos)
-- and it updates the Position and possibly the Size
-- TODO how to synthesize the objective functions and constraint functions and implicit constraints?
-- pairwise interactions? see above
-- Since the compiler and the runtime share the layout representation,
-- I'm going to re-type it here since the rep may change.
-- Runtime imports Compiler as qualified anyway, so I can just convert the types again there.
-- Here: removing selc / sell (selected). Don't forget they should satisfy Located typeclass
data Circ = Circ { namec :: String
, xc :: Float
, yc :: Float
, r :: Float }
deriving (Eq, Show)
data Label' = Label' { xl :: Float
, yl :: Float
, textl :: String
, scalel :: Float } -- calculate h,w from it
deriving (Eq, Show)
data Obj = C Circ | L Label' deriving (Eq, Show)
defaultRad = 100
-- TODO these functions are now unused
-- declToShape :: SubDecl -> [Obj]
-- declToShape (Decl (OS (Set' name setType))) =
-- case setType of
-- Open -> [C $ Circ { namec = name, xc = 0, yc = 0, r = defaultRad }, L $ Label' { xl = 0, yl = 0, textl = name, scalel = 1 }]
-- Closed -> [C $ Circ { namec = name, xc = 0, yc = 0, r = defaultRad }, L $ Label' { xl = 0, yl = 0, textl = name, scalel = 1 }]
-- Unspecified -> [C $ Circ { namec = name, xc = 0, yc = 0, r = defaultRad }, L $ Label' { xl = 0, yl = 0, textl = name, scalel = 1 }]
-- declToShape (Decl (OP (Pt' name))) = error "Substance -> Layout doesn't support points yet"
-- declToShape (Decl (OM (Map' mapName fromSet toSet))) = error "Substance -> Layout doesn't support maps yet"
-- toStateWithDefaultStyle :: [SubDecl] -> [Obj]
-- toStateWithDefaultStyle decls = concatMap declToShape decls -- should use style
-- subToLayoutRep :: SubSpec -> [Obj] -- this needs to know about the Obj type??
-- subToLayoutRep spec = let (decls, constrs) = subSeparate spec in
-- toStateWithDefaultStyle decls
-- Substance + Style typechecker
-- Substance + Style reference checker
-- Produce the constraints and objective function
-- Add rendering and interaction info to produce a world state for gloss
---------------------------------------
-- Runtime: layout algorithm picks a smart initial state
-- then tries to satisfy constraints and minimize objective function, live and interactively
-- TODO make module for this and optimization code
---------------------------------------
-- ghc compiler.hs; ./compiler <filename>.sub
parseSub = do
args <- getArgs
let fileIn = head args
program <- readFile fileIn
putStrLn $ show $ subParse program
putStrLn $ show $ subValidate program
-- ghc compiler.hs; ./compiler <filename>.sty
parseSty = do
args <- getArgs
let fileIn = head args
program <- readFile fileIn
putStrLn $ styPrettyPrint $ styParse program
-- ghc compiler.hs; ./compiler <filename>.sub <filename>.sty
subAndSty = do
args <- getArgs
let (subFile, styFile) = (head args, args !! 1) -- TODO usage
subIn <- readFile subFile
styIn <- readFile styFile
putStrLn $ subPrettyPrint $ subParse subIn
putStrLn "--------"
putStrLn $ styPrettyPrint $ styParse styIn
main = subAndSty