penrose 0.1.0.0 → 0.1.0.1
raw patch · 6 files changed
+1450/−2 lines, 6 files
Files
- penrose.cabal +2/−2
- src/Compiler.hs +491/−0
- src/Functions.hs +335/−0
- src/Server.hs +110/−0
- src/StyAst.hs +421/−0
- src/Utils.hs +91/−0
penrose.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: penrose-version: 0.1.0.0+version: 0.1.0.1 synopsis: A system that automatically visualize mathematics -- description: homepage: http://penrose.ink@@ -18,7 +18,7 @@ executable penrose main-is: Main.hs- -- other-modules: + other-modules: Utils Server StyAst Compiler Functions other-extensions: AllowAmbiguousTypes, RankNTypes, UnicodeSyntax, NoMonomorphismRestriction, OverloadedStrings, DeriveGeneric, DuplicateRecordFields build-depends: base >=4.9 && <4.10, random >=1.1 && <1.2, containers >=0.5 && <0.6, gloss >=1.11 && <1.12, megaparsec >=5.3 && <5.4, ad >=4.3 && <4.4, aeson >=1.2 && <1.3, text >=1.2 && <1.3, websockets >=0.11 && <0.12, old-time >=1.1 && <1.2 hs-source-dirs: src
+ src/Compiler.hs view
@@ -0,0 +1,491 @@+ 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
+ src/Functions.hs view
@@ -0,0 +1,335 @@+{-# LANGUAGE AllowAmbiguousTypes, RankNTypes, UnicodeSyntax, NoMonomorphismRestriction #-}+module Functions where+import Shapes+import Utils+import qualified Data.Map.Strict as M++----------------------- Sample objective functions that operate on objects (given names)+-- TODO write about expectations for the objective function writer++-- type ObjFnOn a = forall a. (Floating a, Real a, Show a, Ord a) => [Name] -> M.Map Name (Obj' a) -> a+type ObjFnOn a = forall a. (Floating a, Real a, Show a, Ord a) => [Obj' a] -> a+-- illegal polymorphic or qualified type--can't return a forall?+type ObjFnNamed a = forall a. (Floating a, Real a, Show a, Ord a) => M.Map Name (Obj' a) -> a+type Weight a = a++-- TODO deal with lists in a more principled way+-- maybe the typechecking should be done elsewhere...+-- shouldn't these two be parametric over objects?+centerCirc :: ObjFnOn a+centerCirc [C' c] = (xc' c)^2 + (yc' c)^2+centerCirc [L' _] = error "misnamed label"++-- distanceOf :: ObjFnOn a+-- toLeft [fromname, toname] dict =+-- case (M.lookup fromname dict, M.lookup toname dict) of+-- -- (Just (A' a), Just (S' s), Just (S' e)) ->+-- -- (Just (A' a), Just (S' s), Just (C' e)) ->+-- -- (Just (A' a), Just (C' s), Just (S' e)) ->+-- (Just (C' s), Just (C' e)) ->+-- -- (fromx - sx)^2 + (fromy - sy)^2 + (tox - ex)^2 + (toy - ey)^2+-- (xc' s - xc' e + 400)^2++onTop :: ObjFnOn a+onTop [L' s, L' e] = (yl' s - yl' e - 100)^2++sameHeight :: ObjFnOn a+sameHeight [C' s, S' e] = (yc' s - ys' e)^2+sameHeight [S' s, C' e] = (ys' s - yc' e)^2+sameHeight [C' s, C' e] = (yc' s - yc' e)^2+sameHeight [S' s, S' e] = (ys' s - ys' e)^2+sameHeight [L' s, L' e] = (yl' s - yl' e)^2++sameX :: ObjFnOn a+sameX [C' s, S' e] = (xc' s - xs' e)^2+sameX [S' s, C' e] = (xs' s - xc' e)^2+sameX [C' s, C' e] = (xc' s - xc' e)^2+sameX [S' s, S' e] = (xs' s - xs' e)^2+sameX [L' s, L' e] = (xl' s - xl' e)^2++sameCenter :: ObjFnOn a+sameCenter [C' s, S' e] = (yc' s - ys' e)^2 + (xc' s - xs' e)^2+sameCenter [S' s, C' e] = (ys' s - yc' e)^2 + (xs' s - xc' e)^2+sameCenter [C' s, C' e] = (yc' s - yc' e)^2 + (xc' s - xc' e)^2+sameCenter [S' s, S' e] = (ys' s - ys' e)^2 + (xs' s - xs' e)^2+sameCenter [L' s, L' e] = (yl' s - yl' e)^2 + (xl' s - xl' e)^2++toLeft :: ObjFnOn a+toLeft [C' s, S' e] = (xc' s - xs' e + 400)^2+toLeft [S' s, C' e] = (xs' s - xc' e + 400)^2+-- toLeft [C' s, C' e] = (xc' s - xc' e + r' s + r' e + 200)^2+toLeft [C' s, C' e] = (xc' s - xc' e + 400)^2+toLeft [S' s, S' e] = (xs' s - xs' e + 400)^2+toLeft [L' s, L' e] = (xl' s - xl' e + 100)^2+++centerMap :: ObjFnOn a+centerMap [A' a, S' s, S' e] = _centerMap a [xs' s, ys' s] [xs' e, ys' e]+ [spacing + (halfDiagonal . side') s, negate $ spacing + (halfDiagonal . side') e]+centerMap [A' a, S' s, C' e] = _centerMap a [xs' s, ys' s] [xc' e, yc' e]+ [spacing + (halfDiagonal . side') s, negate $ spacing + r' e]+centerMap [A' a, C' s, S' e] = _centerMap a [xc' s, yc' s] [xs' e, ys' e]+ [spacing + r' s, negate $ spacing + (halfDiagonal . side') e]+centerMap [A' a, C' s, C' e] = _centerMap a [xc' s, yc' s] [xc' e, yc' e]+ [ spacing * r' s, negate $ spacing * r' e]+centerMap [A' a, L' s, L' e] = _centerMap a [xl' s, yl' s] [xl' e, yl' e]+ [spacing * hl' s, negate $ spacing * hl' e]+centerMap [A' a, L' s, C' e] = _centerMap a [xl' s, yl' s] [xc' e, yc' e]+ [spacing, negate $ spacing + r' e]+centerMap o = error ("CenterMap: unsupported arguments: " ++ show o)+spacing = 1.1 -- TODO: arbitrary++_centerMap :: forall a. (Floating a, Real a, Show a, Ord a) =>+ SolidArrow' a -> [a] -> [a] -> [a] -> a+_centerMap a s1@[x1, y1] s2@[x2, y2] [o1, o2] =+ let vec = [x2 - x1, y2 - y1] -- direction the arrow should point to+ dir = normalize vec -- direction the arrow should point to+ [sx, sy, ex, ey] = if norm vec > o1 + abs o2+ then (s1 +. o1 *. dir) ++ (s2 +. o2 *. dir) else s1 ++ s2+ [fromx, fromy, tox, toy] = [startx' a, starty' a, endx' a, endy' a] in+ (fromx - sx)^2 + (fromy - sy)^2 + (tox - ex)^2 + (toy - ey)^2++repel :: ObjFnOn a+repel [C' c, S' d] = 1 / distsq (xc' c, yc' c) (xs' d, ys' d) - r' c - side' d + epsd+repel [S' c, C' d] = 1 / distsq (xc' d, yc' d) (xs' c, ys' c) - r' d - side' c + epsd+repel [C' c, C' d] = 1 / distsq (xc' c, yc' c) (xc' d, yc' d) - r' c - r' d + epsd+repel [L' c, L' d] =+ if c == d then 0 else 1 / distsq (xl' c, yl' c) (xl' d, yl' d)+repel [L' c, C' d] = if labelName (namec' d) == namel' c then 0 else 1 / distsq (xl' c, yl' c) (xc' d, yc' d)+repel [C' c, L' d] = 1 / distsq (xc' c, yc' c) (xl' d, yl' d)+repel [L' c, S' d] = if labelName (names' d) == namel' c then 0 else 1 / distsq (xl' c, yl' c) (xs' d, ys' d)+repel [S' c, L' d] = 1 / distsq (xs' c, ys' c) (xl' d, yl' d)+repel [A' c, L' d] = repel' (startx' c, starty' c) (xl' d, yl' d) ++ repel' (endx' c, endy' c) (xl' d, yl' d)+repel [A' c, C' d] = repel' (startx' c, starty' c) (xc' d, yc' d) ++ repel' (endx' c, endy' c) (xc' d, yc' d)+repel _ = error "invalid selectors in repel"++repel' x y = 1 / distsq x y + epsd++centerLabel :: ObjFnOn a+centerLabel [C' c, L' l] =+ let [cx, cy, lx, ly] = [xc' c, yc' c, xl' l, yl' l] in+ -- if dist (cx, cy) (lx, ly) > r' c then (cx - lx)^2 + (cy - ly)^2 else 0.3 *+ (cx - lx)^2 + (cy - ly)^2+centerLabel [S' s, L' l] =+ let [cx, cy, lx, ly] = [xs' s, ys' s, xl' l, yl' l] in+ (cx - lx)^2 + (cy - ly)^2+centerLabel [P' p, L' l] =+ let [px, py, lx, ly] = [xp' p, yp' p, xl' l, yl' l] in+ (px + 10 - lx)^2 + (py + 20 - ly)^2 -- Top right from the point+centerLabel [A' a, L' l] =+ let (sx, sy, ex, ey) = (startx' a, starty' a, endx' a, endy' a)+ (mx, my) = midpoint (sx, sy) (ex, ey)+ (lx, ly) = (xl' l, yl' l) in+ (mx - lx)^2 + (my + 1.1 * hl' l - ly)^2 -- Top right from the point+centerLabel o = error ("centerLabel not called with 1 arg" ++ show o)++outside :: ObjFnOn a+outside [L' o, C' i] =+ -- let d = dist (xl' o, yl' o) (xc' i, yc' i) in+ -- if d > r' i then 0 else+ -- (dist (xl' o, yl' o) (xc' i, yc' i) - (1.2 * r' i))^2+ (dist (xl' o, yl' o) (xc' i, yc' i) - (1.2 * r' i))^2+ -- (dist (xl' o, yl' o) (xc' i, yc' i) - (2 * r' i))^2+outside [L' o, S' i] =+ (dist (xl' o, yl' o) (xs' i, ys' i) - 2 * (halfDiagonal . side') i)^2++------- Ambient objective functions++-- -- no names specified; can apply to any combination of objects in M.Map+-- type AmbientObjFn a = forall a. (Floating a, Real a, Show a, Ord a) => M.Map Name (Obj' a) -> a+--+-- -- if there are no circles, doesn't do anything+-- -- TODO fix in case there's only 1 circle?+-- circParams :: (Floating a, Real a, Show a, Ord a) => M.Map Name (Obj' a) -> ([a], [a])+-- circParams m = unpackSplit $ filter isCirc $ M.elems m+-- where isCirc (C' _) = True+-- isCirc _ = False+--+-- -- reuse existing objective function+-- circlesCenterAndRepel :: AmbientObjFn a+-- circlesCenterAndRepel objMap = let (fix, vary) = circParams objMap in+-- centerAndRepel_dist fix vary+--+-- circlesCenter :: AmbientObjFn a+-- circlesCenter objMap = let (fix, vary) = circParams objMap in+-- centerObjs fix vary++-- pairwiseRepel :: [Obj] -> Float+-- pairwiseRepel objs = sumMap pairRepel $ allPairs objs++-- pairRepel :: Obj -> Obj -> Float+-- pairRepel c d = 1 / (distsq c d)+-- where distsq c d = (getX c - getX d)^2 + (getY c - getY c)^2++-- -- returns a list of ambient constraint fns--4 for each object+-- -- i guess i don’t NEED to weight each individually. just sum them and weight the whole thing+-- allInBbox :: [Obj] -> Float+-- allInBbox objs = sum $ concatMap inBbox objs+-- where inBbox o = [boxleft o, boxright o, boxup o, boxdown o]+-- boxleft o = getX o - leftline -- magnitude of violation++------- Constraints+-- Constraints are written WRT magnitude of violation+-- TODO metaprogramming for boolean constraints+-- TODO use these types?+-- type ConstraintFn a = forall a. (Floating a, Real a, Show a, Ord a) => [Name] -> M.Map Name (Obj' a) -> a++defaultCWeight :: Floating a => a+defaultCWeight = 1++-- TODO: should points also have a weight of 1?+defaultPWeight :: Floating a => a+defaultPWeight = 1+++--------------------------------------------------------------------------------+-- Constraint functions+-- List: smallerThan, contains, outsideOf, overlapping, nonOverlapping, samesize, maxsize, minsize+type ConstraintFn = forall a. (Floating a, Real a, Show a, Ord a) => [Obj' a] -> a++sameSize :: ConstraintFn+sameSize [S' s1, S' s2] = (side' s1 - side' s2)**2+sameSize [C' s1, C' s2] = (r' s1 - r' s2)**2++maxSize :: ConstraintFn+limit = max (fromIntegral 700) (fromIntegral 900)+maxSize [C' c] = r' c - limit / 3+maxSize [S' s] = side' s - limit / 3++minSize :: ConstraintFn+minSize [C' c] = 20 - r' c+minSize [S' s] = 20 - side' s++smallerThan :: ConstraintFn+-- smallerThan [C' inc, C' outc] = (r' outc) - (r' inc) - 0.4 * r' outc -- TODO: taking this as a parameter?+smallerThan [C' inc, C' outc] = (r' inc) - (r' outc)+smallerThan [S' inc, S' outc] = (side' outc) - (side' inc) - subsetSizeDiff+smallerThan [C' c, S' s] = 0.5 * side' s - r' c+smallerThan [S' s, C' c] = r' c - (halfDiagonal . side') s++contains :: ConstraintFn+contains [C' outc, C' inc] =+ -- tr (namec' outc ++ " contains " ++ namec' inc ++ " val: ") $+ -- strictSubset [[xc' inc, yc' inc, r' inc], [xc' outc, yc' outc, r' outc]]+ let res = dist (xc' inc, yc' inc) (xc' outc, yc' outc) - (r' outc - r' inc) in+ if res > 0 then res else 0+contains [S' outc, S' inc] = strictSubset+ [[xs' inc, ys' inc, 0.5 * side' inc], [xs' outc, ys' outc, 0.5 * side' outc]]+contains [S' outc, C' inc] = strictSubset+ [[xc' inc, yc' inc, r' inc], [xs' outc, ys' outc, 0.5 * side' outc]]+contains [C' outc, S' inc] = strictSubset+ [[xs' inc, ys' inc, (halfDiagonal . side') inc], [xc' outc, yc' outc, r' outc]]+contains [C' set, P' pt] =+ dist (xp' pt, yp' pt) (xc' set, yc' set) - 0.5 * r' set+contains [S' set, P' pt] =+ dist (xp' pt, yp' pt) (xs' set, ys' set) - 0.4 * side' set+contains [C' set, L' label] =+ let res = dist (xl' label, yl' label) (xc' set, yc' set) - 0.5 * r' set in+ if res < 0 then 0 else res+contains [S' set, L' label] =+ dist (xl' label, yl' label) (xs' set, ys' set) - (side' set) / 2 + wl' label+contains _ = error "subset not called with 2 args"++outsideOf :: ConstraintFn+outsideOf [C' inc, C' outc] =+ noSubset [[xc' inc, yc' inc, r' inc], [xc' outc, yc' outc, r' outc]]+outsideOf [S' inc, S' outc] =+ noSubset [[xs' inc, ys' inc, (halfDiagonal . side') inc],+ [xs' outc, ys' outc, (halfDiagonal . side') outc]]+outsideOf [C' inc, S' outs] =+ noSubset [[xc' inc, yc' inc, r' inc], [xs' outs, ys' outs, (halfDiagonal . side') outs]]+outsideOf [S' inc, C' outc] =+ noSubset [[xs' inc, ys' inc, (halfDiagonal . side') inc], [xc' outc, yc' outc, r' outc]]+outsideOf [P' pt, C' set] =+ -dist (xp' pt, yp' pt) (xc' set, yc' set) + r' set+outsideOf [P' pt, S' set] =+ -dist (xp' pt, yp' pt) (xs' set, ys' set) + (halfDiagonal . side') set+outsideOf [L' lout, C' inset] =+ let labelR = max (wl' lout) (hl' lout)+ res = - dist (xl' lout, yl' lout) (xc' inset, yc' inset) + r' inset + labelR in+ if namel' lout == (labelName $ namec' inset) then 0 else res+ -- if res <= 0 then 1 / res else res+ -- - dist (xl' lout, yl' lout) (xc' inset, yc' inset) + r' inset+outsideOf [L' lout, S' inset] =+ - dist (xl' lout, yl' lout) (xs' inset, ys' inset) + (halfDiagonal . side') inset+outsideOf _ = error "noSubset not called with 2 args"++overlapping :: ConstraintFn+overlapping [C' xset, C' yset] =+ looseIntersect [[xc' xset, yc' xset, r' xset], [xc' yset, yc' yset, r' yset]]+overlapping [S' xset, C' yset] =+ looseIntersect [[xs' xset, ys' xset, 0.5 * side' xset], [xc' yset, yc' yset, r' yset]]+overlapping [C' xset, S' yset] =+ looseIntersect [[xc' xset, yc' xset, r' xset], [xs' yset, ys' yset, 0.5 * side' yset]]+overlapping [S' xset, S' yset] =+ looseIntersect [[xs' xset, ys' xset, 0.5 * side' xset], [xs' yset, ys' yset, 0.5 * side' yset]]+overlapping _ = error "intersect not called with 2 args"++nonOverlapping :: ConstraintFn+nonOverlapping [C' xset, C' yset] =+ noIntersectExt [[xc' xset, yc' xset, r' xset], [xc' yset, yc' yset, r' yset]]+nonOverlapping [S' xset, C' yset] =+ noIntersectExt [[xs' xset, ys' xset, (halfDiagonal . side') xset], [xc' yset, yc' yset, r' yset]]+nonOverlapping [C' xset, S' yset] =+ noIntersectExt [[xc' xset, yc' xset, r' xset], [xs' yset, ys' yset, (halfDiagonal . side') yset]]+nonOverlapping [S' xset, S' yset] =+ noIntersectExt [[xs' xset, ys' xset, (halfDiagonal . side') xset],+ [xs' yset, ys' yset, (halfDiagonal . side') yset]]+nonOverlapping [A' arr, L' label] =+ let (sx, sy, ex, ey, t) = (startx' arr, starty' arr, endx' arr, endy' arr, thickness' arr)+ (x1, y1, x2, y2) = (sx, sy - t, ex, ey + t)+ dx = maximum [x1 - xl' label, 0, xl' label - x2]+ dy = maximum [y1 - yl' label, 0, yl' label - y2] in+ tr "labelvsArr: " $ -sqrt(dx**2 + dy**2) - wl' label+nonOverlapping _ = error "no intersect not called with 2 args"++type PairConstrV a = forall a . (Floating a, Ord a, Show a) => [[a]] -> a -- takes pairs of "packed" objs+++noConstraint :: PairConstrV a+noConstraint _ = 0++-- To convert your inequality constraint into a violation to be penalized:+-- it needs to be in the form "c < 0" and c is the violation penalized if > 0+-- so e.g. if you want "x < -100" then you would convert it to "x + 100 < 0" with c = x + 100+-- if you want "f x > -100" then you would convert it to "-(f x + 100) < 0" with c = -(f x + 100)"++-- all sets must pairwise-strict-intersect+-- plus an offset so they overlap by a visible amount (perhaps this should be an optimization parameter?)+looseIntersect :: PairConstrV a+looseIntersect [[x1, y1, s1], [x2, y2, s2]] = let offset = 10 in+ -- if s1 + s2 < offset then error "radii too small" --TODO: make it const+ -- else+ dist (x1, y1) (x2, y2) - (s1 + s2 - offset)++-- the energy actually increases so it always settles around the offset+-- that's because i am centering all of them--test w/objective off+-- TODO flatten energy afterward, or get it to be *far* from the other set+-- offset so the sets differ by a visible amount+noSubset :: PairConstrV a+noSubset [[x1, y1, s1], [x2, y2, s2]] = let offset = 10 in -- max/min dealing with s1 > s2 or s2 < s1+ -(dist (x1, y1) (x2, y2)) + max s2 s1 - min s2 s1 + offset++-- the first set is the subset of the second, and thus smaller than the second in size.+-- TODO: test for equal sets+-- TODO: for two primitives we have 4 functions, which is not sustainable. NOT NEEDED, remove them.+strictSubset :: PairConstrV a+strictSubset [[x1, y1, s1], [x2, y2, s2]] = dist (x1, y1) (x2, y2) - (s2 - s1)++-- exterior point method constraint: no intersection (meaning also no subset)+noIntersectExt :: PairConstrV a+noIntersectExt [[x1, y1, s1], [x2, y2, s2]] = -(dist (x1, y1) (x2, y2)) + s1 + s2 + offset where offset = 10++pointInExt :: PairConstrV a+pointInExt [[x1, y1], [x2, y2, r]] = dist (x1, y1) (x2, y2) - 0.5 * r++pointNotInExt :: PairConstrV a+pointNotInExt [[x1, y1], [x2, y2, r]] = - dist (x1, y1) (x2, y2) + r++-- exterior point method: penalty function+penalty :: (Ord a, Floating a, Show a) => a -> a+penalty x = (max x 0) ^ q -- weights should get progressively larger in cr_dist+ where q = 2 -- also, may need to sample OUTSIDE feasible set+ -- where q = 3 -- also, may need to sample OUTSIDE feasible set
+ src/Server.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}++module Server where+import Shapes+import GHC.Generics+import Data.Monoid (mappend)+import Data.Text (Text)+import Control.Monad (forM_, forever)+import Control.Monad.IO.Class (liftIO)+import Control.Concurrent (MVar, newMVar, modifyMVar_, modifyMVar, readMVar)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Runtime as R+import qualified Network.WebSockets as WS+import GHC.Float (float2Double)+import Control.Exception+import System.Time+-- import System.Posix.Unistd(usleep)+import Data.Char (isPunctuation, isSpace)+import Data.Aeson+import Data.Maybe (fromMaybe)+++type ServerState = R.State+data FeedBack = Cmd Command | Drag DragEvent | Update UpdateShapes deriving (Show, Generic)+data Command = Command { command :: String } deriving (Show, Generic)+data DragEvent = DragEvent { name :: String, xm :: Float, ym :: Float } deriving (Show, Generic)+data UpdateShapes = UpdateShapes { objs :: [Obj] } deriving (Show, Generic)+instance FromJSON FeedBack+instance FromJSON Command+instance FromJSON DragEvent+instance FromJSON UpdateShapes+++wsSendJSON :: ToJSON j => WS.Connection -> j -> IO ()+wsSendJSON conn obj = WS.sendTextData conn $ encode obj++-- wsReceiveJSON :: (WS.TextProtocol p, FromJSON j) => WS.WebSockets p (Maybe j)+-- wsReceiveJSON = fmap decode WS.receiveData++servePenrose :: String -> Int -> R.State -> IO ()+servePenrose domain port initState = do+ putStrLn "Starting Server..."+ WS.runServer domain port $ application initState++application :: ServerState -> WS.ServerApp+application s pending = do+ conn <- WS.acceptRequest pending+ WS.forkPingThread conn 30 -- To keep the connection alive+ wsSendJSON conn (R.objs s)+ loop conn (step s)++loop :: WS.Connection -> R.State -> IO ()+loop conn s+ | R.optStatus ( R.params s) == R.EPConverged = do+ putStrLn "Optimization completed."+ -- wsSendJSON conn (R.objs s) -- TODO: is this necessary?+ processCommand conn s+ | R.autostep s = stepAndSend conn s+ | otherwise = processCommand conn s++processCommand :: WS.Connection -> R.State -> IO ()+processCommand conn s = do+ -- putStrLn "Receiving Commands"+ msg_json <- WS.receiveData conn+ case decode msg_json of+ Just e -> case e of+ Cmd (Command cmd) -> executeCommand cmd conn s+ Drag (DragEvent name xm ym) -> dragUpdate name xm ym conn s+ Update (UpdateShapes objs) -> updateShapes objs conn s+ Nothing -> error "Error reading JSON"++updateShapes :: [Obj] -> WS.Connection -> R.State -> IO ()+updateShapes newObjs conn s = if R.autostep s then stepAndSend conn news else loop conn news+ where+ news = s { R.objs = newObjs, R.params = (R.params s) { R.weight = R.initWeight, R.optStatus = R.NewIter }}++dragUpdate :: String -> Float -> Float -> WS.Connection -> R.State -> IO ()+dragUpdate name xm ym conn s = if R.autostep s then stepAndSend conn news else loop conn news+ where+ newObjs = map (\x ->+ if getName x == name+ then setX (xm + getX x) $ setY (-ym + getY x) x+ else x)+ (R.objs s)+ news = s { R.objs = newObjs, R.params = (R.params s) { R.weight = R.initWeight, R.optStatus = R.NewIter }}++executeCommand :: String -> WS.Connection -> R.State -> IO ()+executeCommand cmd conn s+ | cmd == "resample" = resampleAndSend conn s+ | cmd == "step" = stepAndSend conn s+ | cmd == "autostep" = loop conn (s { R.autostep = not $ R.autostep s })+ | otherwise = putStrLn ("Can't recognize command " ++ cmd)+++resampleAndSend, stepAndSend :: WS.Connection -> R.State -> IO ()+resampleAndSend conn s = do+ let (objs', rng') = R.sampleConstrainedState (R.rng s) (R.objs s) (R.constrs s)+ let nexts = s { R.objs = objs', R.down = False, R.rng = rng', R.params = (R.params s) { R.weight = R.initWeight, R.optStatus = R.NewIter } }+ wsSendJSON conn (R.objs nexts)+ loop conn nexts+stepAndSend conn s = do+ let nexts = step s+ wsSendJSON conn (R.objs nexts)+ loop conn nexts++step :: R.State -> R.State+step s = s { R.objs = objs', R.params = params' }+ where (objs', params') = R.stepObjs (float2Double R.calcTimestep) (R.params s) (R.objs s)
+ src/StyAst.hs view
@@ -0,0 +1,421 @@+module StyAst where+-- module Main (main) where++import Control.Monad (void)+import Text.Megaparsec+import Text.Megaparsec.Expr+import Text.Megaparsec.String -- input stream is of the type ‘String’+import System.Environment+import qualified Data.Map.Strict as M+import qualified Text.Megaparsec.Lexer as L+++-- Style grammar (relies on the Substance grammar, specifically SubObj)++data SubType = Set | Pt | Map | Intersect | NoIntersect | NoSubset | Subset | PointIn | PointNotIn | AllTypes deriving (Show, Eq)++data StyObj = Circle | Box | Dot | Arrow | NoShape | Color | Text | Auto+ deriving (Show)++type StyObjInfo+ = (StyObj, M.Map String Expr)++data StySpec = StySpec {+ spType :: SubType,+ spId :: String,+ spArgs :: [String],+ spShape :: StyObjInfo,+ spShpMap :: M.Map String StyObjInfo+} deriving (Show)++type StyProg = [Block]++type Block = ([Selector], [Stmt])++data Selector = Selector+ { selTyp :: SubType+ , selPatterns :: [Pattern]+ -- , selIds :: [String]+ }+ deriving (Show)+data Pattern+ = RawID String+ | WildCard String+ deriving (Show)++data Stmt+ = Assign String Expr+ | ObjFn String [Expr]+ | ConstrFn String [Expr]+ | Avoid String [Expr]+ deriving (Show)++data Expr+ = IntLit Integer+ | FloatLit Float+ | Id String+ | BinOp BinaryOp Expr Expr+ | Cons StyObj [Stmt] -- Constructors for objects+ deriving (Show)++data BinaryOp = Access deriving (Show)++data Color = RndColor | Colo+ { r :: Float+ , g :: Float+ , b :: Float+ , a :: Float }+ deriving (Show)+--+-- data Shape+-- = Circle [(String, Expr)]+-- | Box [(String, Expr)]+-- | Dot [(String, Expr)]+-- | Arrow [(String, Expr)]+-- | NoShape+-- deriving (Show)++---- Style program+styleParser :: Parser [Block]+styleParser = between sc eof styProg++-- TODO: required global and/or style block or not?+-- TODO: How can I write something like noop???+-- NOTE: sequence matters here+styProg :: Parser [Block]+styProg = some block+-- globalBlock <|> typeBlock <|> objBlock+-- <|> emptyProg++---- Style blocks+block :: Parser Block+block = do+ sel <- selector `sepBy1` comma+ void (symbol "{")+ try newline'+ sc+ stmts <- try stmtSeq+ -- res <- try stmtSeq+ -- let stmts = case res of+ -- Just a -> a+ -- Nothing -> []+ void (symbol "}")+ newline'+ return (sel, stmts)+ -- return (sel, [])++globalSelect :: Parser Selector+globalSelect = do+ i <- WildCard <$> identifier+ -- return $ Selector AllTypes [] []+ return $ Selector AllTypes [i]++constructorSelect :: Parser Selector+constructorSelect = do+ typ <- subtype+ -- sc+ pat <- patterns+ -- void sc <|> void (symbol ":")+ -- ids <- many identifier+ -- res <- optional $ rword "as" *> some identifier+ -- let ids = case res of+ -- Just a -> a+ -- Nothing -> []+ -- return $ Selector typ pat ids+ return $ Selector typ pat++selector :: Parser Selector+selector = constructorSelect <|> globalSelect++subtype :: Parser SubType+subtype = do+ str <- symbol "Set"+ <|> symbol "Point"+ <|> symbol "Map"+ <|> symbol "Subset"+ <|> symbol "NoSubset"+ <|> symbol "Intersect"+ <|> symbol "NoIntersect"+ <|> symbol "PointIn"+ <|> symbol "PointNotIn"++ return (convert str)+ where convert s+ | s == "Set" = Set+ | s == "Point" = Pt+ | s == "Map" = Map+ | s == "Subset" = Subset+ | s == "NoSubset" = NoSubset+ | s == "Intersect" = Intersect+ | s == "NoIntersect" = NoIntersect+ | s == "PointIn" = PointIn+ | s == "PointNotIn" = PointNotIn++styObj :: Parser StyObj+styObj = do+ str <- symbol "Color"+ <|> symbol "None"+ <|> symbol "Arrow"+ <|> symbol "Text"+ <|> symbol "Circle"+ <|> symbol "Box"+ <|> symbol "Dot"+ return (convert str)+ where convert s+ | s == "Color" = Color+ | s == "Arrow" = Arrow+ | s == "None" = NoShape+ | s == "Text" = Text+ | s == "Circle" = Circle+ | s == "Box" = Box+ | s == "Dot" = Dot++patterns :: Parser [Pattern]+patterns = many pattern+ where pattern = (WildCard <$> identifier <|> RawID <$> backticks identifier)++ -- manyTill anyChar (symbol "{")+---- Statements+stmtSeq :: Parser [Stmt]+stmtSeq = endBy stmt newline'++stmt :: Parser Stmt+stmt =+ try objFn+ <|> try assignStmt+ <|> try avoidObjFn+ <|> try constrFn+--+assignStmt :: Parser Stmt+assignStmt = do+ var <- attribute+ sc+ void (symbol "=")+ e <- expr+ return (Assign var e)+--+objFn :: Parser Stmt+objFn = do+ rword "objective"+ fname <- identifier+ void (symbol "(")+ params <- expr `sepBy` comma+ void (symbol ")")+ -- params <- sepBy expr comma+ return (ObjFn fname params)++avoidObjFn :: Parser Stmt+avoidObjFn = do+ rword "avoid"+ fname <- identifier+ lbrac+ params <- expr `sepBy` comma+ rbrac+ return (Avoid fname params)++constrFn :: Parser Stmt+constrFn = do+ rword "constraint"+ fname <- identifier+ void (symbol "(")+ params <- expr `sepBy` comma+ void (symbol ")")+ -- params <- sepBy expr comma+ return (ConstrFn fname params)++expr :: Parser Expr+expr = try objConstructor+ <|> makeExprParser term operators+ <|> none+ <|> auto+ <|> number++term :: Parser Expr+term = Id <$> identifier++operators :: [[Operator Parser Expr]]+operators = [ [ InfixL (BinOp Access <$ symbol ".")] ]++none :: Parser Expr+none = do+ rword "None"+ return $ Cons NoShape []++auto :: Parser Expr+auto = do+ rword "Auto"+ return $ Cons Auto []++objConstructor :: Parser Expr+objConstructor = do+ typ <- styObj+ lbrac >> newline'+ stmts <- stmtSeq+ rbrac -- NOTE: not consuming the space because stmt already does+ return $ Cons typ stmts++number :: Parser Expr+number = FloatLit <$> try float <|> IntLit <$> integer++attribute :: Parser String+attribute = many alphaNumChar++--+--+--+-- typeBlock :: Parser Block+-- typeBlock = do+-- t <- typ+-- stmts <- braces stmtSeq+-- return $ TypeBlock t stmts+--+-- objBlock :: Parser Block+-- objBlock = do+-- i <- identifier+-- stmts <- braces stmtSeq+-- return $ ObjBlock i stmts+++---- Lexer functions+sc :: Parser ()+sc = L.space (void separatorChar) lineCmnt blockCmnt+ where lineCmnt = L.skipLineComment "--" >> newline'+ blockCmnt = L.skipBlockComment "/*" "*/" >> newline'++newline' :: Parser ()+newline' = void sc >> void (many newline) >> void sc++backticks :: Parser a -> Parser a+backticks = between (symbol "`") (symbol "`")++braces :: Parser a -> Parser a+braces = between (symbol "{") (symbol "}")++lparen, rparen, lbrac, rbrac :: Parser ()+lbrac = void (symbol "{")+rbrac = void (symbol "}")+lparen = void (symbol "(")+rparen = void (symbol ")")++parens :: Parser a -> Parser a+parens = between (symbol "(") (symbol ")")++lexeme :: Parser a -> Parser a+lexeme = L.lexeme sc++comma :: Parser String+comma = symbol ","++symbol :: String -> Parser String+symbol = L.symbol sc++integer :: Parser Integer+integer = lexeme L.integer++float :: Parser Float+float = realToFrac <$> lexeme L.float -- TODO: parsing without sign?++identifier :: Parser String+identifier = (lexeme . try) (p >>= check)+ where+ p = (:) <$> letterChar <*> many alphaNumChar+ check x = if x `elem` rws+ then fail $ "keyword " ++ show x ++ " cannot be an identifier"+ else return x++-- Reserved words+rword :: String -> Parser ()+rword w = string w *> notFollowedBy alphaNumChar *> sc++rws, attribs, attribVs, shapes, types :: [String] -- list of reserved words+rws = ["avoid", "global", "as"] ++ types ++ shapes+-- ++ types ++ attribs ++ shapes ++ colors++types = ["Set", "Map", "Point"]+attribs = ["shape", "color", "label", "scale", "position"]+attribVs = shapes ++ colors+shapes = ["Auto", "None", "Circle", "Box", "SolidArrow", "SolidDot", "HollowDot", "Cross"]+colors = ["Random", "Black", "Red", "Blue", "Yellow"]+--+-- getType :: String -> SubType+-- getType str = case str of+-- "Set" -> Set+-- "Map" -> Map+-- "Point" -> Pt+-- "Subset" -> Subset+--+--+-- getAttribute :: String -> Attribute+-- getAttribute str = case str of+-- "shape" -> Shape+-- "color" -> Color+-- "bordor" -> LineType+--+--+-- getAttributeV :: String -> AttributeV+-- getAttributeV str = case str of+-- "None" -> ShapeV NoShape+-- "Circle" -> ShapeV $ SS SetCircle+-- "Box" -> ShapeV $ SS Box+-- "SolidArrow" -> ShapeV $ SM SolidArrow+-- "SolidDot" -> ShapeV $ SP SolidDot+-- "HollowDot" -> ShapeV $ SP HollowDot+-- "Cross" -> ShapeV $ SP Cross+-- "Red" -> ColorV Red+-- "Yellow" -> ColorV Yellow+-- "Blue" -> ColorV Blue+-- "Black" -> ColorV Black+-- "Random" -> ColorV Random+--+-- attribute :: Parser Attribute+-- attribute = (lexeme . try) (p >>= check)+-- where+-- p = many letterChar+-- check x = if x `elem` attribs+-- then return (getAttribute x)+-- else fail $ "keyword " ++ show x ++ " cannot be an attribute"+--+-- attributeValue :: Parser AttributeV+-- attributeValue = (lexeme . try) (p >>= check)+-- where+-- p = many letterChar+-- check x = if x `elem` attribVs+-- then return (getAttributeV x)+-- else fail $ "keyword " ++ show x ++ " cannot be an attribute value"+--+-- typ :: Parser SubType+-- typ = (lexeme . try) (p >>= check)+-- where+-- p = some letterChar+-- check x = if x `elem` types+-- then return (getType x)+-- else fail $ "Type " ++ show x ++ " is not a valid type"+--+-- -- access :: Parser Expr+-- -- access = do+-- -- i <- identifier+-- -- void (symbol ".")+-- -- a <- attributeName+-- -- return (Access i a)+--+--+--+--++-- -- TODO+-- styPrettyPrint :: Block -> String+-- styPrettyPrint b = "HAHAHAHA"++parseFromFile p file = runParser p file <$> readFile file++main :: IO ()+main = do+ args <- getArgs+ let styFile = head args+ styIn <- readFile styFile+ -- putStrLn styIn+ -- parseTest styleParser styIn+ case runParser styleParser styFile styIn of+ Left err -> putStr (parseErrorPretty err)+ Right xs -> mapM_ print xs+ return ()
+ src/Utils.hs view
@@ -0,0 +1,91 @@+module Utils where+import Debug.Trace++debug = False+debugLineSearch = False+debugObj = False -- turn on/off output in obj fn or constraint++-- used when sampling the inital state, make sure sizes satisfy subset constraints+subsetSizeDiff :: Floating a => a+subsetSizeDiff = 10.0++epsd :: Floating a => a -- to prevent 1/0 (infinity). put it in the denominator+epsd = 10 ** (-10)++halfDiagonal :: (Floating a) => a -> a+halfDiagonal side = 0.5 * dist (0, 0) (side, side)++labelName :: String -> String+labelName name = "Label_" ++ name+++-- Some debugging functions. @@@+debugF :: (Show a) => a -> a+debugF x = if debug then traceShowId x else x+debugXY x1 x2 y1 y2 = if debug then trace (show x1 ++ " " ++ show x2 ++ " " ++ show y1 ++ " " ++ show y2 ++ "\n") else id++-- To send output to a file, do ./EXECUTABLE 2> FILE.txt+tr :: Show a => String -> a -> a+tr s x = if debug then trace "---" $ trace s $ traceShowId x else x -- prints in left to right order++trRaw :: Show a => String -> a -> a+trRaw s x = if debug then trace "---" $ trace s $ trace (show x ++ "\n") x else x-- prints in left to right order++trStr :: String -> a -> a+trStr s x = if debug then trace "---" $ trace s x else x -- prints in left to right order++tr' :: Show a => String -> a -> a+tr' s x = if debugLineSearch then trace "---" $ trace s $ traceShowId x else x -- prints in left to right order++tro :: Show a => String -> a -> a+tro s x = if debugObj then trace "---" $ trace s $ traceShowId x else x -- prints in left to right order++---- Lists-as-vectors utility functions, TODO split out of file++-- define operator precedence: higher precedence = evaluated earlier+infixl 6 +., -.+infixl 7 *. -- .*, /.++-- assumes lists are of the same length+dotL :: Floating a => [a] -> [a] -> a+dotL u v = if not $ length u == length v+ then error $ "can't dot-prod different-len lists: " ++ (show $ length u) ++ " " ++ (show $ length v)+ else sum $ zipWith (*) u v++(+.) :: Floating a => [a] -> [a] -> [a] -- add two vectors+(+.) u v = if not $ length u == length v+ then error $ "can't add different-len lists: " ++ (show $ length u) ++ " " ++ (show $ length v)+ else zipWith (+) u v++(-.) :: Floating a => [a] -> [a] -> [a] -- subtract two vectors+(-.) u v = if not $ length u == length v+ then error $ "can't subtract different-len lists: " ++ (show $ length u) ++ " " ++ (show $ length v)+ else zipWith (-) u v++negL :: Floating a => [a] -> [a]+negL = map negate++(*.) :: Floating a => a -> [a] -> [a] -- multiply by a constant+(*.) c v = map ((*) c) v++norm :: Floating a => [a] -> a+norm = sqrt . sum . map (^ 2)++normsq :: Floating a => [a] -> a+normsq = sum . map (^ 2)++normalize :: Floating a => [a] -> [a]+normalize v = (1 / norm v) *. v++-- Find the angle between x-axis and a line passing points, reporting in radians+findAngle :: Floating a => (a, a) -> (a, a) -> a+findAngle (x1, y1) (x2, y2) = atan $ (y2 - y1) / (x2 - x1)++midpoint :: Floating a => (a, a) -> (a, a) -> (a, a) -- mid point+midpoint (x1, y1) (x2, y2) = ((x1 + x2) / 2, (y1 + y2) / 2)++dist :: Floating a => (a, a) -> (a, a) -> a -- distance+dist (x1, y1) (x2, y2) = sqrt ((x1 - x2)^2 + (y1 - y2)^2)++distsq :: Floating a => (a, a) -> (a, a) -> a -- distance+distsq (x1, y1) (x2, y2) = (x1 - x2)^2 + (y1 - y2)^2