penrose 0.1.0.1 → 0.1.0.2
raw patch · 3 files changed
+2244/−2 lines, 3 files
Files
- penrose.cabal +6/−2
- src/Runtime.hs +1828/−0
- src/Shapes.hs +410/−0
penrose.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: penrose-version: 0.1.0.1+version: 0.1.0.2 synopsis: A system that automatically visualize mathematics -- description: homepage: http://penrose.ink@@ -16,9 +16,13 @@ extra-source-files: ChangeLog.md, README.md cabal-version: >=1.10 +source-repository head+ type: git+ location: https://github.com/ghcjs/ghcjs.git+ executable penrose main-is: Main.hs- other-modules: Utils Server StyAst Compiler Functions+ other-modules: Utils Server StyAst Compiler Functions Runtime Shapes 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/Runtime.hs view
@@ -0,0 +1,1828 @@+{-# LANGUAGE AllowAmbiguousTypes, RankNTypes, UnicodeSyntax, NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+-- for autodiff, requires passing in a polymorphic fn++module Runtime where+import Shapes+import Functions+import Utils+import Graphics.Gloss.Data.Vector+import Graphics.Gloss.Interface.Pure.Game+import Data.Function+import System.Random+-- import Debug.Trace+import Numeric.AD+import GHC.Float -- float <-> double conversions+import System.IO+import System.Environment+import System.Exit+import Data.Set (fromList)+import Data.List+import Data.Maybe+import qualified Data.Map.Strict as M+import qualified Compiler as C+import qualified StyAst as SA+ -- (subPrettyPrint, styPrettyPrint, subParse, styParse)+ -- TODO limit export/import+-- For running the new style parser+import qualified Text.Megaparsec as MP (runParser, parseErrorPretty)+-- For porting to the web+import Data.Monoid ((<>))+import Data.Aeson++divLine = putStr "\n--------\n\n"++picWidth, picHeight :: Int+picWidth = 800+picHeight = 700++stepsPerSecond :: Int+stepsPerSecond = 100000++calcTimestep :: Float -- for use in forcing stepping in handler+calcTimestep = 1 / int2Float stepsPerSecond+++data LastEPstate = EPstate [Obj] deriving (Eq, Show)++data OptStatus = NewIter -- TODO should this be init with a state?+ | UnconstrainedRunning LastEPstate -- [Obj] stores last EP state+ | UnconstrainedConverged LastEPstate -- [Obj] stores last EP state+ | EPConverged+ deriving (Eq, Show)++data Params = Params { weight :: Double,+ optStatus :: OptStatus,+ objFn :: forall a. ObjFnPenaltyState a,+ annotations :: [[Annotation]]+ } -- deriving (Eq, Show) -- TODO derive Show instance++-- State of the world+data State = State { objs :: [Obj]+ -- , stys :: [C.StyLine]+ , constrs :: [C.SubConstr]+ , down :: Bool -- left mouse button is down (dragging)+ , rng :: StdGen -- random number generator+ , autostep :: Bool -- automatically step optimization or not+ , params :: Params+ } -- deriving (Show)++------++initRng :: StdGen+initRng = mkStdGen seed+ where seed = 11 -- deterministic RNG with seed++objFnNone :: ObjFnPenaltyState a+objFnNone objs w f v = 0+++initParams = Params { weight = initWeight, optStatus = NewIter, objFn = objFnNone, annotations = [] }++----------------------- Unpacking+data Annotation = Fix | Vary deriving (Eq, Show)+type Fixed a = [a]+type Varying a = [a]++-- make sure this matches circPack and labelPack+-- annotations are specified inline here. this is per type, not per value (i.e. all circles have the same fixed parameters). but you could generalize it to per-value by adding or overriding annotations globally after the unpacking+-- does not unpack names+unpackObj :: (Floating a, Real a, Show a, Ord a) => Obj' a -> [(a, Annotation)]+-- the location of a circle can vary, but not its radius+-- unpackObj (C' c) = [(xc' c, Vary), (yc' c, Vary), (r' c, Fix)]+unpackObj (C' c) = [(xc' c, Vary), (yc' c, Vary), (r' c, Vary)]+-- unpackObj (S' s) = [(xs' s, Vary), (ys' s, Vary), (side' s, Fix)]+unpackObj (S' s) = [(xs' s, Vary), (ys' s, Vary), (side' s, Vary)]+-- the location of a label can vary, but not its width or height (or other attributes)+unpackObj (L' l) = [(xl' l, Vary), (yl' l, Vary), (wl' l, Fix), (hl' l, Fix)]+-- the location of a point varies+unpackObj (P' p) = [(xp' p, Vary), (yp' p, Vary)]+unpackObj (A' a) = [(startx' a, Vary), (starty' a, Vary), (endx' a, Vary),+ (endy' a, Vary), (thickness' a, Fix)]++-- split out because pack needs this annotated list of lists+unpackAnnotate :: (Floating a, Real a, Show a, Ord a) => [Obj' a] -> [[(a, Annotation)]]+unpackAnnotate objs = map unpackObj objs++-- TODO check it preserves order+splitFV :: (Floating a, Real a, Show a, Ord a) => [(a, Annotation)] -> (Fixed a, Varying a)+splitFV annotated = foldr chooseList ([], []) annotated+ where chooseList :: (a, Annotation) -> (Fixed a, Varying a) -> (Fixed a, Varying a)+ chooseList (x, Fix) (f, v) = (x : f, v)+ chooseList (x, Vary) (f, v) = (f, x : v)++-- optimizer should use this unpack function+-- preserves the order of the objects’ parameters+-- e.g. unpackSplit [Circ {xc varying, r fixed}, Label {xl varying, h fixed} ] = ( [r, h], [xc, xl] )+-- crucially, this does NOT depend on the annotations, it can be used on any list of objects+unpackSplit :: (Floating a, Real a, Show a, Ord a) => [Obj' a] -> (Fixed a, Varying a)+unpackSplit objs = let annotatedList = concat $ unpackAnnotate objs in+ splitFV annotatedList++---------------------- Packing++-- We put `Floating a` into polymorphic objects for the autodiff.+-- (Maybe port all objects to polymorphic at some point, but would need to zero the gradient information.)+-- Can't use realToFrac here because it will zero the gradient information.+-- TODO use DuplicateRecordFields (also use `stack` and fix GLUT error)--need to upgrade GHC and gloss++++-- TODO comment packing these functions defining conventions+solidArrowPack :: (Real a, Floating a, Show a, Ord a) => SolidArrow -> [a] -> SolidArrow' a+solidArrowPack arr params = SolidArrow' { startx' = sx, starty' = sy, endx' = ex, endy' = ey, thickness' = t,+ namesa' = namesa arr, selsa' = selsa arr, colorsa' = colorsa arr }+ where (sx, sy, ex, ey, t) = if not $ length params == 5 then error "wrong # params to pack solid arrow"+ else (params !! 0, params !! 1, params !! 2, params !! 3, params !! 4)++circPack :: (Real a, Floating a, Show a, Ord a) => Circ -> [a] -> Circ' a+circPack cir params = Circ' { xc' = xc1, yc' = yc1, r' = r1, namec' = namec cir, selc' = selc cir, colorc' = colorc cir }+ where (xc1, yc1, r1) = if not $ length params == 3 then error "wrong # params to pack circle"+ else (params !! 0, params !! 1, params !! 2)++sqPack :: (Real a, Floating a, Show a, Ord a) => Square -> [a] -> Square' a+sqPack sq params = Square' { xs' = xs1, ys' = ys1, side' = side1, names' = names sq, sels' = sels sq, colors' = colors sq, ang' = ang sq}+ where (xs1, ys1, side1) = if not $ length params == 3 then error "wrong # params to pack square"+ else (params !! 0, params !! 1, params !! 2)++ptPack :: (Real a, Floating a, Show a, Ord a) => Pt -> [a] -> Pt' a+ptPack pt params = Pt' { xp' = xp1, yp' = yp1, namep' = namep pt, selp' = selp pt }+ where (xp1, yp1) = if not $ length params == 2 then error "Wrong # of params to pack point"+ else (params !! 0, params !! 1)++labelPack :: (Real a, Floating a, Show a, Ord a) => Label -> [a] -> Label' a+labelPack lab params = Label' { xl' = xl1, yl' = yl1, wl' = wl1, hl' = hl1,+ textl' = textl lab, sell' = sell lab, namel' = namel lab }+ where (xl1, yl1, wl1, hl1) = if not $ length params == 4 then error "wrong # params to pack label"+ else (params !! 0, params !! 1, params !! 2, params !! 3)++-- does a right fold on `annotations` to preserve order of output list+-- returns remaining (fixed, varying) that were not part of the object+-- e.g. yoink [Fixed, Varying, Fixed] [1, 2, 3] [4, 5] = ([1, 4, 2], [3], [5])+yoink :: (Show a) => [Annotation] -> Fixed a -> Varying a -> ([a], Fixed a, Varying a)+yoink annotations fixed varying = --trace ("yoink " ++ (show annotations) ++ (show fixed) ++ (show varying)) $+ case annotations of+ [] -> ([], fixed, varying)+ (Fix : annotations') -> let (params, fixed', varying') = yoink annotations' (tail fixed) varying in+ (head fixed : params, fixed', varying')+ (Vary : annotations') -> let (params, fixed', varying') = yoink annotations' fixed (tail varying) in+ (head varying : params, fixed', varying')++-- used inside overall objective fn to turn (fixed, varying) back into a list of objects+-- for inner objective fns to operate on+-- pack is partially applied with the annotations, which never change+-- (the annotations assume the state never changes size or order)+pack :: (Real a, Floating a, Show a, Ord a) => [[Annotation]] -> [Obj] -> Fixed a -> Varying a -> [Obj' a]+pack annotations objs = pack' (zip objs annotations)++pack' :: (Real a, Floating a, Show a, Ord a) => [(Obj, [Annotation])] -> Fixed a -> Varying a -> [Obj' a]+pack' zipped fixed varying =+ case zipped of+ [] -> []+ ((obj, annotations) : zips) -> res : pack' zips fixed' varying' -- preserve order+ -- use obj, annotations, fixed, and varying to create the object+ -- by yoinking the right params out of f/v in the right order+ where (flatParams, fixed', varying') = yoink annotations fixed varying+ -- is flatParams in the right order?+ res = case obj of+ -- pack objects using the names, text params carried from initial state+ -- assuming names do not change during opt+ C circ -> C' $ circPack circ flatParams+ L label -> L' $ labelPack label flatParams+ P pt -> P' $ ptPack pt flatParams+ S sq -> S' $ sqPack sq flatParams+ A ar -> A' $ solidArrowPack ar flatParams+++------- Style related functions++-- default shapes+defaultSolidArrow, defaultPt, defaultSquare, defaultLabel, defaultCirc, defaultText:: String -> Obj+defaultSolidArrow name = A SolidArrow { startx = 100, starty = 100, endx = 200, endy = 200, thickness = 10,+ selsa = False, namesa = name, colorsa = black }+defaultPt name = P Pt { xp = 100, yp = 100, selp = False, namep = name }+defaultSquare name = S Square { xs = 100, ys = 100, side = defaultRad,+ sels = False, names = name, colors = black, ang = 0.0}+defaultLabel text = L Label { xl = -100, yl = -100,+ wl = textWidth * fromIntegral (length text),+ hl = textHeight,+ textl = text, sell = False, namel = labelName text }+defaultText text = L Label { xl = -100, yl = -100,+ wl = textWidth * fromIntegral (length text),+ hl = textHeight,+ textl = text, sell = False, namel = text }+defaultCirc name = C Circ { xc = 100, yc = 100, r = defaultRad,+ selc = False, namec = name, colorc = black }++initSpec = SA.StySpec { SA.spType = SA.Pt, SA.spId = "", SA.spShape = (SA.NoShape, M.empty), SA.spArgs = [], SA.spShpMap = M.empty}++-- ------- Parsing for Old Style Design+--+-- dictOfStys :: [C.SubDecl] -> [C.StyLine] -> M.Map Name [C.StyLine]+-- dictOfStys objs stys = foldr (processLine objs) dict stys+-- where dict = foldr addObj M.empty objs+-- addObj (C.Decl (C.OM (C.Map' name _ _))) = M.insert name []+-- addObj (C.Decl (C.OS (C.Set' name _))) = M.insert name []+-- addObj (C.Decl (C.OP (C.Pt' name))) = M.insert name []+--+-- -- If there is no spec associated with an obj, we should insert this obj in the dict+-- insertSty :: Name -> C.StyLine -> M.Map Name [C.StyLine] -> M.Map Name [C.StyLine]+-- insertSty name line dict = case (M.lookup name dict) of+-- Nothing -> M.insert name [line] dict+-- _ -> M.adjust ([line] ++) name dict+--+-- processLine :: [C.SubDecl] -> C.StyLine -> M.Map Name [C.StyLine] -> M.Map Name [C.StyLine]+-- processLine objs s dict =+-- case s of+-- (C.Shape (C.SubVal v) _) -> insertSty v s dict+-- (C.Shape C.Global _) -> M.mapWithKey (\k stys -> s:stys) dict+-- (C.Shape (C.SubType t) _) -> M.mapWithKey (\k stys -> s:stys) dict+-- otherwise -> error "shape not known"+--+-- -- Find all lines specifying shape+-- shapeLines :: [C.StyLine] -> [C.StyLine]+-- shapeLines stys = filter isShape $ stys+-- where isShape (C.Shape _ _) = True+-- isShape _ = False+--+-- -- Given a list of sty settings, find the most specific one+-- -- The order from most specific to general: individual -> type -> global+-- prioritize :: [C.StyLine] -> C.StyLine+-- prioritize stys = stys !! maxIdx+-- where prios = map getPrio stys+-- Just maxIdx = elemIndex (maximum prios) prios+-- getPrio (C.Shape (C.SubVal _) _) = 3+-- getPrio (C.Shape C.Global _) = 2+-- getPrio (C.Shape (C.SubType _) _) = 1+-- Generates an object depending on the style specification++----- Parser for the new style design+-- -- Given a list of IDs, translate a raw AST of a Style program+-- -- to a object-wise record+-- getStyDict :: [C.SubDecl] -> SA.StyProg -> M.Map Name SA.StySpec+-- getStyDict decls prog = foldl loadObjConfig tConfig oBlk+-- where+-- ids = getSubTuples decls+-- dict = foldl (\m (t, n) ->+-- M.insert n (dummySpec { SA.spId = n, SA.spType = t }) m) M.empty ids+-- [gBlk, tBlk, oBlk] = getBlocks prog+-- gConfig = foldl loadGlobalConfig dict gBlk+-- tConfig = foldl loadTypeConfig gConfig tBlk+-- -- applyConfig f d = foldl f d prog+--+-- getSubTuples :: [C.SubDecl] -> [(SA.SubType, String)]+-- getSubTuples decls = map getType decls+-- where+-- getType (C.Decl d) = case d of+-- C.OS (C.Set' n _) -> (SA.Set, n)+-- C.OP (C.Pt' n) -> (SA.Pt, n)+-- C.OM (C.Map' n _ _) -> (SA.Map, n)+--+--+--+-- -- NOTE: assuming we process global settings FIRST. All other fields will get wiped out+-- loadGlobalConfig :: M.Map Name SA.StySpec -> SA.Block -> M.Map Name SA.StySpec+-- loadGlobalConfig dict (SA.GlobalBlock stmts) = M.mapWithKey (\_ oldSpec -> newSpec { SA.spType = SA.spType oldSpec, SA.spId = SA.spId oldSpec}) dict+-- where+-- newSpec = foldl procStmt dummySpec stmts+-- loadGlobalConfig dict _ = dict -- ignore all other blocks+--+-- loadTypeConfig :: M.Map Name SA.StySpec -> SA.Block -> M.Map Name SA.StySpec+-- loadTypeConfig dict (SA.TypeBlock typ stmts) = M.mapWithKey (\_ s -> procSpec s) dict+-- where+-- procSpec s = if SA.spType s == typ then getSpec s else s+-- getSpec s = foldl procStmt s stmts+-- loadTypeConfig dict _ = dict -- ignore all other blocks+--+-- loadObjConfig :: M.Map Name SA.StySpec -> SA.Block -> M.Map Name SA.StySpec+-- loadObjConfig dict (SA.ObjBlock name stmts) = M.mapWithKey (\_ s -> procSpec s) dict+-- where+-- procSpec s = if SA.spId s == name then getSpec s else s+-- getSpec s = foldl procStmt s stmts+-- loadObjConfig dict _ = dict -- ignore all other blocks+--+-- procStmt :: SA.StySpec -> SA.Stmt -> SA.StySpec+-- procStmt spec (SA.Assign _ (SA.Color c)) = spec { SA.spColor = c }+-- procStmt spec (SA.Assign _ (SA.Shape s)) = spec { SA.spShape = s }+--+-- getBlocks :: SA.StyProg -> [[SA.Block]]+-- getBlocks p = map (\f -> f p) filters+-- where filters = map filter [isGlobalBlock, isTypeBlock, isObjBlock]+--+-- isGlobalBlock, isTypeBlock, isObjBlock :: SA.Block -> Bool+-- isGlobalBlock (SA.GlobalBlock _) = True+-- isGlobalBlock _ = False+--+-- isTypeBlock (SA.TypeBlock _ _) = True+-- isTypeBlock _ = False+--+-- isObjBlock (SA.ObjBlock _ _) = True+-- isObjBlock _ = False++----- Parser for Style design++-- Type aliases for readability in this section+type StyDict = M.Map Name SA.StySpec+-- type ObjFn a = M.Map Name (Obj' a) -> a+type ConstrFn a = [Obj' a] -> a+type ObjFn a = [Obj' a] -> a+-- A VarMap matches lambda ids in the selector to the actual selected id+type VarMap = M.Map Name Name++getDictAndFns :: (Floating a, Real a, Show a, Ord a) =>+ ([C.SubDecl], [C.SubConstr]) -> SA.StyProg+ -> (StyDict, [(ObjFn a, Weight a, [Name])], [(ConstrFn a, Weight a, [Name])])+getDictAndFns (decls, constrs) blocks = foldl procBlock (initDict, [], []) blocks+ where+ res = getSubTuples decls ++ getConstrTuples constrs+ ids = map (\(x, y, z) -> (x, y)) res+ -- args = map (\(_, _, z) -> z) res+ initDict = foldl (\m (t, n, a) ->+ M.insert n (initSpec { SA.spId = n, SA.spType = t, SA.spArgs = a }) m) M.empty res+ -- applyConfig f d = foldl f d prog++procBlock :: (Floating a, Real a, Show a, Ord a) =>+ (StyDict, [(ObjFn a, Weight a, [Name])], [(ConstrFn a, Weight a, [Name])])+ -> SA.Block+ -> (StyDict, [(ObjFn a, Weight a, [Name])], [(ConstrFn a, Weight a, [Name])])+procBlock (dict, objFns, constrFns) (selectors, stmts) = (newDict, objFns ++ newObjFns, constrFns ++ newConstrFns)+ where+ select s = M.elems $ M.filter (match s) dict+ selectedSpecs :: [[(VarMap, SA.StySpec)]]+ selectedSpecs = map+ (\s -> let xs = select s+ vs = map (allOtherVars . getVarMap s) xs in zip vs xs) selectors+ -- TODO: scoping - now every block has access to everyone else+ allOtherVars = M.union (M.fromList $ zip k k) where k = M.keys dict+ -- Combination of all selected (spec. varmap)+ allCombs = filter (\x -> length x == length selectedSpecs) $ cartesianProduct (map (map fst) selectedSpecs)+ mergedMaps =+ -- let allMaps = map (map fst) allCombs in+ -- map M.unions (tr "allMaps: " allMaps)+ -- tr "allmaps: " $+ map M.unions allCombs+ -- Only process assignment statements on matched specs, not the cartesion product of them+ updateSpec d (vm, sp) =+ let newSpec = foldl (procAssign vm) sp stmts in+ M.insert (SA.spId newSpec) newSpec d+ newDict = foldl updateSpec dict $ concat selectedSpecs+ -- (zip varMaps selected)+ genFns f vm = foldl (f vm) [] stmts+ newObjFns = concatMap (genFns procObjFn) mergedMaps+ newConstrFns = concatMap (genFns procConstrFn) mergedMaps++cartesianProduct = foldr f [[]] where f l a = [ x:xs | x <- l, xs <- a ]++-- Returns a map from placeholder ids to actual matched ids+getVarMap :: SA.Selector -> SA.StySpec -> VarMap+getVarMap sel spec = foldl add M.empty patternNamePairs+ where+ patternNamePairs = zip (SA.selPatterns sel) (SA.spArgs spec)+ add d (p, n) = case p of+ SA.RawID _ -> d+ SA.WildCard i -> M.insert i n d+++-- Returns true of an object matches the selector+match :: SA.Selector -> SA.StySpec -> Bool+match sel spec = all test (zip args patterns) &&+ SA.selTyp sel == SA.spType spec &&+ length args == length patterns+ where+ patterns = SA.selPatterns sel+ args = SA.spArgs spec+ -- dummies = SA.selIds sel+ test (a, p) = case p of+ SA.RawID i -> a == i+ SA.WildCard _ -> True++procConstrFn :: (Floating a, Real a, Show a, Ord a) =>+ VarMap -> [(ConstrFn a, Weight a, [Name])] -> SA.Stmt+ -> [(ConstrFn a, Weight a, [Name])]+procConstrFn varMap fns (SA.ConstrFn fname es) =+ -- trStr ("New Constraint function: " ++ fname ++ " " ++ (show names)) $+ fns ++ [(func, defaultWeight, names)]+ where+ (func, names) = case M.lookup fname constrFuncDict of+ Just f -> (f, map (getIdByExpr varMap) es)+ Nothing -> error "procConstrFn: constraint function not known"+procConstrFn varMap fns _ = fns -- TODO: avoid functions++procObjFn :: (Floating a, Real a, Show a, Ord a) =>+ VarMap -> [(ObjFn a, Weight a, [Name])] -> SA.Stmt+ -> [(ObjFn a, Weight a, [Name])]+procObjFn varMap fns (SA.ObjFn fname es) =+ trStr ("New Objective function: " ++ fname ++ " " ++ (show names)) $+ fns ++ [(func, defaultWeight, names)]+ where+ (func, names) = case M.lookup fname objFuncDict of+ Just f -> (f, tr "Args: " args)+ Nothing -> error "procObjFn: objective function not known"+ args = map (getIdByExpr varMap) es+procObjFn varMap fns (SA.Avoid fname es) = fns -- TODO: avoid functions+procObjFn varMap fns _ = fns -- TODO: avoid functions++-- TODO: Have a more principled expr look up routine+lookupVarMap s varMap= case M.lookup s varMap of+ Just s -> s+ Nothing -> (error $ "lookupVarMap: incorrect variable mapping from " ++ s)+getIdByExpr d (SA.Id s) = lookupVarMap s d+-- TODO: properly resolve access by doing lookups+getIdByExpr d (SA.BinOp SA.Access (SA.Id i) (SA.Id "label")) = labelName $ lookupVarMap i d+getIdByExpr d (SA.BinOp SA.Access (SA.Id i) (SA.Id "shape")) = lookupVarMap i d+getIdByExpr _ _ = error "getIdByExpr: argument unsupported!"++procAssign :: VarMap -> SA.StySpec -> SA.Stmt -> SA.StySpec+procAssign varMap spec (SA.Assign n (SA.Cons typ stmts)) =+ if n == "shape" then spec { SA.spShape = (typ, configs) } -- primary shape+ else spec { SA.spShpMap = M.insert n (typ, configs) $ SA.spShpMap spec } -- secondary shapes+ where+ configs = foldl addSpec M.empty stmts+ -- FIXME: this is incorrect, we should resolve the variables earlier+ addSpec dict (SA.Assign s e@(SA.Cons SA.NoShape _)) = M.insert s (SA.Id "None") dict+ addSpec dict (SA.Assign s e@(SA.Cons SA.Auto _)) = M.insert s (SA.Id "Auto") dict+ addSpec dict (SA.Assign s e) = M.insert s (SA.Id (getIdByExpr varMap e)) dict+ addSpec _ _ = error "procAssign: only support assignments in constructors!"+procAssign _ spec _ = spec -- TODO: ignoring assignment for all others++getConstrTuples :: [C.SubConstr] -> [(SA.SubType, String, [String])]+getConstrTuples = map getType+ where getType c = case c of+ C.Intersect a b -> (SA.Intersect, "Intersect" ++ a ++ b, [a, b])+ C.NoIntersect a b -> (SA.NoIntersect, "NoIntersect" ++ a ++ b, [a, b])+ C.Subset a b -> (SA.Subset, "Subset" ++ a ++ b, [a, b])+ C.NoSubset a b -> (SA.NoSubset, "NoSubset" ++ a ++ b, [a, b])+ C.PointIn a b -> (SA.PointIn, "PointIn" ++ a ++ b, [a, b])+ C.PointNotIn a b -> (SA.PointNotIn, "PointNotIn" ++ a ++ b, [a, b])++getSubTuples :: [C.SubDecl] -> [(SA.SubType, String, [String])]+getSubTuples = map getType+ where getType (C.Decl d) = case d of+ C.OS (C.Set' n _) -> (SA.Set, n, [n])+ C.OP (C.Pt' n) -> (SA.Pt, n, [n])+ C.OM (C.Map' n a b) -> (SA.Map, n, [n, a, b])++getAllIds :: ([C.SubDecl], [C.SubConstr]) -> [String]+getAllIds (decls, constrs) = map (\(_, x, _) -> x) $ getSubTuples decls ++ getConstrTuples constrs++shapeAndFn :: (Floating a, Real a, Show a, Ord a) => StyDict -> String -> ([Obj], [(ObjFn a, Weight a, [Name])], [(ConstrFn a, Weight a, [Name])])+shapeAndFn dict name =+ case M.lookup name dict of+ Nothing -> error ("Cannot find style info for " ++ name)+ Just s -> concat3 $ map getShape $ (name, SA.spShape s) : map addPrefix (M.toList $ SA.spShpMap s)+ where+ concat3 x = (concatMap fst3 x, concatMap snd3 x, concatMap thd3 x)+ addPrefix (s, o) = (name ++ "_" ++ s, o)+ fst3 (a, _, _) = a+ snd3 (_, a, _) = a+ thd3 (_, _, a) = a+ getShape (n, (SA.Text, config)) = initText n config+ getShape (n, (SA.Arrow, config)) = initArrow n config+ getShape (n, (SA.Circle, config)) = initCircle n config+ getShape (n, (SA.Box, config)) = initSquare n config+ getShape (n, (SA.NoShape, _)) = ([], [], [])+ getShape (_, (t, _)) = error ("ShapeOf: Unknown shape " ++ show t ++ " for " ++ name)++initText, initArrow, initCircle, initSquare ::+ (Floating a, Real a, Show a, Ord a) =>+ String -> M.Map String SA.Expr+ -> ([Obj], [(ObjFn a, Weight a, [Name])], [(ConstrFn a, Weight a, [Name])])+initText n config = ([defaultText n], [], [])+initArrow n config =+ -- ([defaultSolidArrow n, defaultLabel n], [(centerMap, defaultWeight, [n, from, to])], [])+ -- ([defaultSolidArrow n], [(centerMap, defaultWeight, [n, from, to])], [])+ if lab == "None" then+ ([defaultSolidArrow n], [(centerMap, defaultWeight, [n, from, to])], [])+ else+ ([defaultSolidArrow n, defaultLabel n], [(centerMap, defaultWeight, [n, from, to])], [])+ where+ from = queryConfig "start" config+ to = queryConfig "end" config+ lab = queryConfig "label" config+initCircle n config = ([defaultCirc n, defaultLabel n], [], [(penalty . maxSize, defaultWeight, [n]), (penalty . minSize, defaultWeight, [n])])+initSquare n config = ([defaultSquare n, defaultLabel n], [], [(penalty . maxSize, defaultWeight, [n])])++queryConfig key dict = case M.lookup key dict of+ Just (SA.Id i) -> i+ -- FIXME: get dot access to work for arbitrary input+ Just (SA.BinOp SA.Access (SA.Id i) (SA.Id "shape")) -> i+ Nothing -> error ("queryConfig: Key " ++ key ++ " does not exist!")++------- Generate objective functions++defaultWeight :: Floating a => a+defaultWeight = 1++defaultRad :: Floating a => a+defaultRad = 100++objFnOnNone :: ObjFnOn a+objFnOnNone _ = 0++-- Parameters to change+declSetObjfn :: ObjFnOn a+declSetObjfn = objFnOnNone -- centerCirc++declPtObjfn :: ObjFnOn a+declPtObjfn = objFnOnNone -- centerCirc++declLabelObjfn :: ObjFnOn a+declLabelObjfn = centerLabel -- objFnOnNone++declMapObjfn :: ObjFnOn a+declMapObjfn = centerMap+++constrFuncDict :: forall a. (Floating a, Real a, Show a, Ord a) =>+ M.Map String (ConstrFn a)+constrFuncDict = M.fromSet mapping allFns+ where+ allFns = fromList ["sameSizeAs", "smallerThan", "contains", "nonOverlapping", "overlapping", "outsideOf"]+ mapping f = case f of+ "sameSizeAs" -> penalty . sameSize+ "contains" -> penalty . contains+ "overlapping" -> penalty . overlapping+ "nonOverlapping" -> penalty . nonOverlapping+ "outsideOf" -> penalty . outsideOf+ "smallerThan" -> penalty . smallerThan -- TODO: should this be an objective?+ -- "avoidSubsets" -> penalty . avoidSubsets+ _ -> error ("constrFuncDict: unknown function " ++ f)++objFuncDict :: forall a. (Floating a, Real a, Show a, Ord a) => M.Map String (ObjFn a)+objFuncDict = M.fromSet mapping allFns+ where+ allFns = fromList ["sameX", "sameCenter", "sameHeight", "repel", "onTop", "toLeft", "centerLabel", "outside"]+ mapping f = case f of+ "centerLabel" -> centerLabel+ "toLeft" -> toLeft+ "onTop" -> onTop+ "sameHeight" -> sameHeight+ "sameX" -> (*) 0.2 . sameX+ "sameCenter" -> (*) 0.01 . sameCenter+ -- "repel" -> penalty . repel+ -- "repel" -> (*) 100000000 . repel+ -- "repel" -> (*) 9000 . repel+ "repel" -> (*) 900000 . repel+ -- "repel" -> repe l+ -- "repel" -> repel+ "outside" -> outside+ _ -> error ("objFuncDict: unknown function " ++ f)++genAllObjs :: (Floating a, Real a, Show a, Ord a) =>+ ([C.SubDecl], [C.SubConstr]) -> StyDict+ -> ([Obj], [(ObjFn a, Weight a, [Name])], [(ConstrFn a, Weight a, [Name])])+-- TODO figure out how the types work. also add weights+genAllObjs (decls, constrs) stys = (concat objss, concat objFnss, concat constrFnss)+ where+ (objss, objFnss, constrFnss) = unzip3 $ map (shapeAndFn stys) $ getAllIds (decls, constrs)++-- genObjsAndFns :: (Floating a, Real a, Show a, Ord a) =>+-- M.Map String SA.StySpec -> C.SubDecl -> ([Obj], [(M.Map Name (Obj' a) -> a, Weight a)])+-- genObjsAndFns stys line@(C.Decl (C.OS (C.Set' sname stype))) = (objs, weightedFns)+-- where+-- c1 = shapeOf sname stys+-- -- TODO proper dimensions for labels+-- l1 = defaultLabel sname+-- objs = [c1, l1]+-- weightedFns = [ (declSetObjfn [sname], defaultWeight),+-- (declLabelObjfn [sname, labelName sname], defaultWeight) ]+-- genObjsAndFns stys (C.Decl (C.OP (C.Pt' pname))) = (objs, weightedFns)+-- where+-- p1 = defaultPt pname+-- l1 = defaultLabel pname+-- objs = [p1, l1]+-- weightedFns = [ (declPtObjfn [pname], defaultWeight),+-- (declLabelObjfn [pname, labelName pname], defaultWeight) ]+-- genObjsAndFns stys (C.Decl (C.OM (C.Map' name from to))) = (objs, weightedFns)+-- where+-- a = defaultSolidArrow name+-- l1 = defaultLabel name+-- objs = [a, l1]+-- weightedFns = [+-- (toLeft [from, to], defaultWeight),+-- (sameY [from, to], defaultWeight),+-- (declMapObjfn [name, from, to], defaultWeight), -- TODO: a different obj function+-- (declLabelObjfn [name, labelName name], defaultWeight)]+--++-- genAllObjsAndFns :: (Floating a, Real a, Show a, Ord a) =>+-- [C.SubDecl] -> M.Map String SA.StySpec -> ([Obj], [(M.Map Name (Obj' a) -> a, Weight a)])+-- -- TODO figure out how the types work. also add weights+-- genAllObjsAndFns decls stys = let (objss, fnss) = unzip $ map (genObjsAndFns stys) decls in+-- (concat objss, concat fnss)++dictOf :: (Real a, Floating a, Show a, Ord a) => [Obj' a] -> M.Map Name (Obj' a)+dictOf = foldr addObj M.empty+ where addObj o dict = M.insert (getName o) o dict++dictOfObjs :: [Obj] -> M.Map Name Obj+dictOfObjs = foldr addObj M.empty+ where addObj o dict = M.insert (getName o) o dict++-- constant b/c ambient fn value seems to be 10^4 and constr value seems to reach only 10, 10^2+constrWeight :: Floating a => a+constrWeight = 10 ^ 4++lookupNames :: (Real a, Floating a, Show a, Ord a) => M.Map Name (Obj' a) -> [Name] -> [Obj' a]+lookupNames dict ns = map check res+ where+ res = map (`M.lookup` dict) ns+ check x = case x of+ Just x -> x+ _ -> error "lookupNames: at least one of the arguments don't exist!"+++-- TODO should take list of current objects as parameter, and be partially applied with that+-- first param: list of parameter annotations for each object in the state+-- assumes that the state's SIZE and ORDER never change+-- note: CANNOT do dict -> list because that destroys the order+genObjFn :: (Real a, Floating a, Show a, Ord a) =>+ [[Annotation]]+ -> [(ObjFn a, Weight a, [Name])]+ -> [(M.Map Name (Obj' a) -> a, Weight a)]+ -> [(ConstrFn a, Weight a, [Name])]+ -> [Obj] -> a -> [a] -> [a] -> a+genObjFn annotations objFns ambientObjFns constrObjFns =+ \currObjs penaltyWeight fixed varying ->+ let newObjs = pack annotations currObjs fixed varying in+ let objDict = dictOf newObjs in+ sumMap (\(f, w, n) -> w * f (lookupNames objDict n)) objFns+ + (tr "ambient fn value: " (sumMap (\(f, w) -> w * f objDict) ambientObjFns))+ + (tr "constr fn value: "+ (constrWeight * penaltyWeight * sumMap (\(f, w, n) -> w * f (lookupNames objDict n)) constrObjFns))+ -- (sumMap (\(f, w) -> w * f objDict) objFns) ++ -- (sumMap (\(f, w) -> w * f objDict) ambientObjFns) ++ -- (constrWeight * penaltyWeight *+ -- sumMap (\(f, w, n) -> w * f (lookupNames objDict n)) constrObjFns)+ -- factor out weight application?+++-- TODO: **must** manually change this constraint if you change the constr function for EP+-- needs constr to be violated+constraint :: [C.SubConstr] -> [Obj] -> Bool+constraint constrs = if constraintFlag then \x ->+ let res = [consistentSizes constrs x] in and res+ else \x -> True++-- generate all objects and the overall objective function+-- style program is currently unused+-- TODO adjust weights of all functions+genInitState :: ([C.SubDecl], [C.SubConstr]) -> SA.StyProg -> State+genInitState (decls, constrs) stys =+ -- objects and objectives (without ambient objfns or constrs)+ let (dict, userObjFns, userConstrFns) = getDictAndFns (decls, constrs) stys in+ let (initObjs, initObjFns, initConstrFns) = genAllObjs (decls, constrs) dict in+ let objFns = userObjFns ++ initObjFns in+ -- let (initState, objFns) = genAllObjsAndFns decls (getStyDict decls stys) in+ -- let objFns = [] in -- TODO removed only for debugging constraints++ -- ambient objectives+ -- be careful with how the ambient objectives interact with the per-declaration objectives!+ -- e.g. the repel objective conflicts with a subset/intersect constraint -> nonconvergence!+ -- let ambientObjFns = [(circlesCenter, defaultWeight)] in+ let ambientObjFns = [] in++ -- constraints+ -- let constrFns = genConstrFns constrs in+ -- let constrFns = [] in+ let ambientConstrFns = [] in -- TODO add+ let constrObjFns = initConstrFns ++ userConstrFns ++ ambientConstrFns in++ -- resample state w/ constrs. TODO how to deal with `Subset A B` -> `r A < r B`?+ -- let boolConstr = \x -> True in // TODO needs to take this as a param+ let (initStateConstr, initRng') = sampleConstrainedState initRng initObjs constrs in++ -- unpackAnnotate :: [Obj] -> [ [(Float, Annotation)] ]+ let flatObjsAnnotated = unpackAnnotate (addGrads initStateConstr) in+ let annotationsCalc = map (map snd) flatObjsAnnotated in -- `map snd` throws away initial floats++ -- overall objective function+ let objFnOverall = genObjFn annotationsCalc objFns ambientObjFns constrObjFns in++ State { objs = initStateConstr,+ constrs = constrs,+ params = initParams { objFn = objFnOverall, annotations = annotationsCalc },+ down = False, rng = initRng', autostep = False }++--------------- end object / objfn generation++rad :: Floating a => a+rad = 200 -- TODO don't hardcode into constant+clamp1D y = if clampflag then 0 else y++rad1 :: Floating a => a+rad1 = rad-100++rad2 :: Floating a => a+rad2 = rad+50++-- Initial state of the world, reading from Substance/Style input+initState :: State+initState = State { objs = objsInit, constrs = [], down = False, rng = initRng, autostep = False, params = initParams }++-- divide two integers to obtain a float+divf :: Int -> Int -> Float+divf a b = (fromIntegral a) / (fromIntegral b)++pw2 :: Float+pw2 = picWidth `divf` 2++pw2' :: Floating a => a+pw2' = realToFrac pw2++ph2 :: Float+ph2 = picHeight `divf` 2++ph2' :: Floating a => a+ph2' = realToFrac ph2++-- avoid having black and white to ensure the visibility of objects+opacity, cmax, cmin :: Float+opacity = 0.5+cmax = 0.1+cmin = 0.9++-- radiusRange, sideRange :: Floating a => (a, a )+widthRange = (-pw2, pw2)+heightRange = (-ph2, ph2)+radiusRange = (20, picWidth `divf` 6)+sideRange = (20, picWidth `divf` 3)+colorRange = (cmin, cmax)++------------- The "Style" layer: render the state of the world.+renderCirc :: Circ -> Picture+renderCirc c = if selected c+ then let (r', g', b', a') = rgbaOfColor $ colorc c in+ color (makeColor r' g' b' (a' / 2)) $ translate (xc c) (yc c) $+ circleSolid (r c)+ else color (colorc c) $ translate (xc c) (yc c) $+ circleSolid (r c)++-- fix to the centering problem of labels, assumeing:+-- (1) monospaced font; (2) at least a chracter of max height is in the label string+labelScale, textWidth, textHeight :: Floating a => a+textWidth = 104.76 -- Half of that of the monospaced version+textHeight = 119.05+labelScale = 0.2++label_offset_x, label_offset_y :: String -> Float -> Float+label_offset_x str x = x - (textWidth * labelScale * 0.5 * (fromIntegral (length str)))+label_offset_y str y = y - labelScale * textHeight * 0.5++renderLabel :: Label -> Picture+renderLabel l =+ pictures $ [+ color scolor $+ translate+ (label_offset_x (textl l) (xl l))+ (label_offset_y (textl l) (yl l)) $+ scale labelScale labelScale $+ text (textl l)+ -- ,+ -- line [(x, y), (x + labelScale * w, y), (x + labelScale * w, y + labelScale * h),+ -- (x, y + labelScale * h), (x, y)]+ ]+ where scolor = if selected l then red else light black+ w = textWidth * (fromIntegral (length $ textl l))+ h = textHeight+ x = (label_offset_x (textl l) (xl l))+ y = (label_offset_y (textl l) (yl l))+++renderPt :: Pt -> Picture+renderPt p = color scalar $ translate (xp p) (yp p)+ $ circleSolid ptRadius+ where scalar = if selected p then red else black+-- renderPt p = color scalar $ translate (xp p) (yp p)+-- $ circle ptRadius+-- where scalar = if selected p then red else black+-- renderPt p = let l1 = line [(-ptRadius, -ptRadius), (ptRadius, ptRadius)]+-- l2 = line [(-ptRadius, ptRadius), (ptRadius, -ptRadius)]+-- in color scalar $ translate (xp p) (yp p) $ Pictures [l1, l2]+-- where scalar = if selected p then red else black++renderSquare :: Square -> Picture+renderSquare s = if selected s+ then let (r', g', b', a') = rgbaOfColor $ colors s in+ color (makeColor r' g' b' (a' / 2)) $ translate (xs s) (ys s) $+ rectangleSolid (side s) (side s)+ else color (colors s) $ translate (xs s) (ys s) $+ rectangleSolid (side s) (side s)++renderArrow :: SolidArrow -> Picture+-- renderArrow sa = color black $ line [(startx sa, starty sa), (endx sa, endy sa)]+renderArrow sa = color scalar $ translate sx sy $ rotate (negate $ toDegree $ argV dir) $ pictures $+ map polygon [ head_path, body_path ]+ where+ scalar = if selected sa then red else black+ (sx, sy, ex, ey, t) = (startx sa, starty sa, endx sa, endy sa, thickness sa / 6)+ dir = (ex - sx, ey - sy) -- direction the arrow should point to+ len = magV dir+ body_path = [ (0, 0 + t), (len - 5*t, t),+ (len - 5*t, -1*t), (0, -1*t) ]+ head_path = [(len - 5*t, 3*t), (len, 0),+ (len - 5*t, -3*t)]++toDegree, toRadian :: Floating a => a -> a+toDegree rad = rad * 180 / pi+toRadian deg = deg * pi / 180++renderObj :: Obj -> Picture+renderObj (C circ) = renderCirc circ+renderObj (L label) = renderLabel label+renderObj (P pt) = renderPt pt+renderObj (S sq) = renderSquare sq+renderObj (A ar) = renderArrow ar++isLabel :: Obj -> Bool+isLabel (L l) = True+isLabel _ = False++splitLabels :: [Obj] -> ([Obj], [Obj])+splitLabels objs = (filter isLabel objs, filter (not . isLabel) objs)++picOfState :: State -> Picture+picOfState s =+ let (labels, others) = splitLabels (objs s)+ in+ -- currently not putting labels at the top level because the control is not ready+ -- Pictures $ map renderObj others ++ map renderObj labels+ Pictures $ map renderObj (objs s)++picOf :: State -> Picture+picOf s = Pictures [picOfState s, objectiveText, constraintText, stateText, paramText, optText]+ -- lineXbot, lineXtop, lineYbot, lineYtop]+ where -- TODO display constraint instead of hardcoding+ -- (picture for bounding box for bound constraints)+ -- constraints are currently global params+ lineXbot = color red $ Line [(leftb, botb), (rightb, botb)]+ lineXtop = color red $ Line [(leftb, topb), (rightb, topb)]+ lineYbot = color red $ Line [(leftb, botb), (leftb, topb)]+ lineYtop = color red $ Line [(rightb, botb), (rightb, topb)]++ -- TODO generate this text more programmatically+ objectiveText = translate xInit yInit $ scale sc sc+ $ text objText+ constraintText = translate xInit (yInit - yConst) $ scale sc sc+ $ text constrText+ stateText = let res = if autostep s then "on" else "off" in+ translate xInit (yInit - 2 * yConst) $ scale sc sc+ $ text ("autostep: " ++ res)+ paramText = translate xInit (yInit - 3 * yConst) $ scale sc sc+ $ text ("penalty function weight: " ++ show (weight $ params s))+ optText = translate xInit (yInit - 4 * yConst) $ scale sc sc+ $ text ("optimization status: " ++ (statusTextOf $ optStatus $ params s))+ statusTextOf val = case val of+ NewIter -> "opt started; new iteration"+ UnconstrainedRunning lastState -> "unconstrained running"+ UnconstrainedConverged lastState -> "unconstrained converged"+ EPConverged -> "EP converged" -- TODO record num iterations+ xInit = -pw2+50+ yInit = ph2-50+ yConst = 30+ sc = 0.1++------- Sampling the state subject to a constraint. Currently not used since we are doing unconstrained optimization.++-- generate an infinite list of sampled elements+-- keep the last generator for the "good" element+genMany :: RandomGen g => g -> (g -> (a, g)) -> [(a, g)]+genMany gen genOne = iterate (\(c, g) -> genOne g) (genOne gen)++-- take the first element that satisfies the condition+-- not the most efficient impl. also assumes infinite list s.t. head always exists+crop :: RandomGen g => (a -> Bool) -> [(a, g)] -> (a, g)+crop cond xs = --(takeWhile (not . cond) (map fst xs), -- drops gens+ head $ dropWhile (\(x, _) -> not $ cond x) xs -- drops while top-level condition true. keeps good's gen++-- randomly sample location (for circles and labels) and radius (for circles)+sampleCoord :: RandomGen g => g -> Obj -> (Obj, g)+sampleCoord gen o = let o_loc = setX x' $ setY (clamp1D y') o in+ case o_loc of+ C circ -> let (r', gen3) = randomR radiusRange gen2+ (cr', gen4) = randomR colorRange gen3+ (cg', gen5) = randomR colorRange gen4+ (cb', gen6) = randomR colorRange gen5+ in+ (C $ circ { r = r', colorc = makeColor cr' cg' cb' opacity }, gen6)+ S sq -> let (side', gen3) = randomR sideRange gen2+ (cr', gen4) = randomR colorRange gen3+ (cg', gen5) = randomR colorRange gen4+ (cb', gen6) = randomR colorRange gen5+ in+ (S $ sq { side = side', colors = makeColor cr' cg' cb' opacity }, gen6)+ L lab -> (o_loc, gen2) -- only sample location+ P pt -> (o_loc, gen2)+ A a -> (o_loc, gen2) -- TODO++ where (x', gen1) = randomR widthRange gen+ (y', gen2) = randomR heightRange gen1++-- sample each object independently, threading thru gen+stateMap :: RandomGen g => g -> (g -> a -> (b, g)) -> [a] -> ([b], g)+stateMap gen f [] = ([], gen)+stateMap gen f (x:xs) = let (x', gen') = f gen x in+ let (xs', gen'') = stateMap gen' f xs in+ (x' : xs', gen'')++-- sample a state+genState :: RandomGen g => [Obj] -> g -> ([Obj], g)+genState shapes gen = stateMap gen sampleCoord shapes++-- sample entire state at once until constraint is satisfied+-- TODO doesn't take into account pairwise constraints or results from objects sampled first, sequentially+sampleConstrainedState :: RandomGen g => g -> [Obj] -> [C.SubConstr] -> ([Obj], g)+sampleConstrainedState gen shapes constrs = (state', gen')+ where (state', gen') = crop (constraint constrs) states+ states = genMany gen (genState shapes)+ -- init state params are ignored; we just need to know what kinds of objects are in it++--------------- Handle user input. "handler" is the main function here.+-- Whenever the library receives an input event, it calls "handler" with that event+-- and the current state of the world to handle it.++ptRadius = 4 -- The size of a point on canvas+bbox = 60 -- TODO put all flags and consts together+-- hacky bounding box of label++-- -- 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++-- Hardcode bbox of label at the center+-- TODO properly get bbox; rn text is centered at bottom left+inObj :: (Float, Float) -> Obj -> Bool++-- TODO: this is NOT an accurate BBox at all. Good for selection though+inObj (xm, ym) (L o) =+ abs (xm - (xl o)) <= 0.1 * (wl o) &&+ abs (ym - (yl o)) <= 0.1 * (hl o) -- is label+ -- abs (xm - (label_offset_x (textl o) (xl o))) <= 0.25 * (wl o) &&+ -- abs (ym - (label_offset_y (textl o) (yl o))) <= 0.25 * (hl o) -- is label+inObj (xm, ym) (C o) = dist (xm, ym) (xc o, yc o) <= r o -- is circle+inObj (xm, ym) (S o) = abs (xm - xs o) <= 0.5 * side o && abs (ym - ys o) <= 0.5 * side o -- is squar e+inObj (xm, ym) (P o) = dist (xm, ym) (xp o, yp o) <= ptRadius -- is Point, where we arbitrarily define the "radius" of a point+-- TODO: due to the way Located is defined, we can only drag the starting pt here+inObj (xm, ym) (A a) =+ let (sx, sy, ex, ey, t) = (startx a, starty a, endx a, endy a, thickness a)+ (x, y) = midpoint (sx, sy) (ex, ey)+ len = 0.5 * dist (sx, sy) (ex, ey)+ in abs (x - xm) <= len && abs (y - ym) <= t+++-- check convergence of EP method+epDone :: State -> Bool+epDone s = ((optStatus $ params s) == EPConverged) || ((optStatus $ params s) == NewIter)++-- UI so far: pressing and releasing 'r' will re-sample all objects' sizes and positions within some preset range+-- if autostep is set, then dragging will move an object while optimization continues+-- if autostep is not set, then optimization will only step when 's' is pressed. dragging will move an object while optimization is not happening++-- for more on these constructors, see docs: https://hackage.haskell.org/package/gloss-1.10.2.3/docs/Graphics-Gloss-Interface-Pure-Game.html+-- pattern matches not fully fuzzed--assume that user only performs one action at once+-- (e.g. not left-clicking while stepping the optimization)+-- TODO "in object" tests+-- prevents user from manipulating objects until EP is done, unless objects are re-sampled++handler :: Event -> State -> State+handler (EventKey (MouseButton LeftButton) Down _ (xm, ym)) s =+ if epDone s then s { objs = objsFirstSelected, down = True } else s+ -- so that clicking doesn't select all overlapping objects in bbox+ -- foldl will reverse the list each time, so a diff obj can be selected+ -- foldr will preserve the list order, so objects are stepped consistently+ where (objsFirstSelected, _) = foldr (flip $ selectFirstIfContains (xm, ym)) ([], False) (objs s)+ selectFirstIfContains (x, y) (xs, alreadySelected) o =+ if alreadySelected || (not $ inObj (x, y) o) then (o : xs, alreadySelected)+ else (select (setX xm $ setY ym o) : xs, True)+-- dragging mouse when down+-- if an object is selected, then if the collection of objects with the object moved satisfies the constraint,+-- then move the object to mouse position+-- TODO there's probably a better way to implement that+handler (EventMotion (xm, ym)) s =+ if down s && epDone s then s { objs = map (ifSelectedMoveTo (xm, ym)) (objs s), down = down s } else s+ where ifSelectedMoveTo (xm, ym) o = if selected o then setX xm $ setY (clamp1D ym) o else o++-- button released, so deselect all objects AND restart the optimization+-- keep the annotations and obj fn, otherwise state will be erased+handler (EventKey (MouseButton LeftButton) Up _ _) s =+ s { objs = map deselect $ objs s, down = False,+ params = (params s) { weight = initWeight, optStatus = NewIter } }++-- if you press a key while down, then the handler resets the entire state (then Up will just reset again)+handler (EventKey (Char 'r') Up _ _) s =+ s { objs = objs', down = False, rng = rng',+ params = (params s) { weight = initWeight, optStatus = NewIter } }+ where (objs', rng') = sampleConstrainedState (rng s) (objs s) (constrs s)++-- turn autostep on or off (press same button to turn on or off)+handler (EventKey (Char 'a') Up _ _) s = if autostep s then s { autostep = False }+ else s { autostep = True }++-- pressing 's' (down) while autostep is off will step the optimization once, overriding the step function+-- (which doesn't step if autostep is off). this is the same code as the step function but with reverse condition+-- if autostep is on, this does nothing+-- also overrides EP done: forces a step (might want this to test if there substantial steps left after convergence, e.g. if magnitude of gradient is still large)+handler (EventKey (Char 's') Down _ _) s =+ if not $ autostep s then s { objs = objs', params = params' } else s+ where (objs', params') = stepObjs (float2Double calcTimestep) (params s) (objs s)++-- change the weights in the barrier/penalty method (scale by 10). don't step objects+-- only allow the user to change the weights if EP has converged (just make the constraints sharper)+-- (doesn't seem to make a difference, though...)+-- in that case, start re-running UO with the last EP state as the current (converged) EP state+handler (EventKey (SpecialKey KeyUp) Down _ _) s =+ if epDone s then s { params = (params s) { weight = weight', optStatus = status' }} else s+ where currWeight = weight (params s)+ weight' = currWeight * weightGrowth+ status' = UnconstrainedRunning $ EPstate (objs s)++handler (EventKey (SpecialKey KeyDown) Down _ _) s =+ if epDone s then s { params = (params s) { weight = weight', optStatus = status' }} else s+ where currWeight = weight (params s)+ weight' = currWeight / weightGrowth+ status' = UnconstrainedRunning $ EPstate (objs s)++handler _ s = s++----------- Stepping the state the world via gradient descent.+ -- First, miscellaneous helper functions.++-- Clamp objects' positions so they don't go offscreen.+-- TODO clamp needs to take into account bbox of object+clampX :: Float -> Float+clampX x = if x < -pw2 then -pw2 else if x > pw2 then pw2 else x++clampY :: Float -> Float+clampY y = if y < -ph2 then -ph2 else if y > ph2 then ph2 else y++-- minSize :: Float+-- minSize = 5++-- clampSize :: Float -> Float -- TODO assumes the size is a radius+-- clampSize s = if s < minSize then minSize+-- else if s > ph2 || s > pw2 then min pw2 ph2 else s++-- -- 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++noOverlapPair :: Obj -> Obj -> Bool+noOverlapPair (C c1) (C c) = dist (xc c1, yc c1) (xc c, yc c) > r c1 + r c+noOverlapPair (S s1) (S s2) = dist (xs s1, ys s1) (xs s2, ys s2) > side s1 + side s2+-- TODO: factor out this+noOverlapPair (C c) (S s) = dist (xc c, yc c) (xs s, ys s) > (halfDiagonal . side) s + r c+noOverlapPair (S s) (C c) = dist (xs s, ys s) (xc c, yc c) > (halfDiagonal . side) s + r c+noOverlapPair _ _ = True -- TODO, ignores labels++-- return true iff satisfied+-- TODO deal with labels and more than two objects+noneOverlap :: [Obj] -> Bool+noneOverlap objs = let allPairs = filter (\x -> length x == 2) $ subsequences objs in -- TODO factor out+ all id $ map (\[o1, o2] -> noOverlapPair o1 o2) allPairs+-- noOverlap (c1 : c : []) = noOverlapPair c1 c+-- noOverlap (c1 : c : c3 : _) = noOverlapPair c1 c && noOverlapPair c c3 && noOverlapPair c1 c3 -- TODO+-- noOverlap _ _ = True++-- allOverlap vs. not noOverlap--they're different!+allOverlap :: [Obj] -> Bool+allOverlap objs = let allPairs = filter (\x -> length x == 2) $ subsequences objs in -- TODO factor out+ all id $ map (\[o1, o2] -> not $ noOverlapPair o1 o2) allPairs++-- -- used when sampling the inital state, make sure sizes satisfy subset constraints+-- subsetSizeDiff :: Floating a => a+-- subsetSizeDiff = 10.0++-- halfDiagonal :: (Floating a) => a -> a+-- halfDiagonal side = 0.5 * dist (0, 0) (side, side)++-- TODO: do we want strict subset or loose subset here? Now it is strict+consistentSizes :: [C.SubConstr] -> [Obj] -> Bool+consistentSizes constrs objs = all id $ map (checkSubsetSize dict) constrs+ where dict = dictOfObjs objs+checkSubsetSize dict constr@(C.Subset inName outName) =+ case (M.lookup inName dict, M.lookup outName dict) of+ (Just (C inc), Just (C outc)) ->+ -- (r outc) (r inc) > subsetSizeDiff -- TODO: taking this as a parameter?+ 0.7 * (r outc) > (r inc)+ (Just (S inc), Just (S outc)) -> (side outc) - (side inc) > subsetSizeDiff+ -- TODO: this does not scale, general way?+ (Just (C c), Just (S s)) -> r c < 0.5 * side s+ (Just (S s), Just (C c)) -> (halfDiagonal . side) s < r c+ (_, _) -> True+checkSubsetSize _ _ = True+++-- Type aliases for shorter type signatures.+type TimeInit = Float+type Time = Double+type ObjFn1 a = forall a . (Show a, Ord a, Floating a, Real a) => [a] -> a+type GradFn a = forall a . (Show a, Ord a, Floating a, Real a) => [a] -> [a]+type Constraints = [(Int, (Double, Double))]+ -- TODO: convert lists to lists of type-level length, and define an interface for object state (pos, size)+ -- also need to check the input length matches obj fn lengths, e.g. in awlinesearch++-- old code for bound constraints+-- does not project onto an arbitrary set, only intervals+-- projCoordInterval :: (Double, Double) -> Double -> Double+-- projCoordInterval (lower, upper) x = (sort [lower, upper, x]) !! 1 -- median of the list++-- for each element, if there's a constraint on it (by index), project it onto the interval+-- lookInAndProj :: Constraints -> (Int, Double) -> [Double] -> [Double]+-- lookInAndProj constraints (index, x) acc =+-- case (Map.lookup index constraintsMap) of+-- Just bounds -> projCoordInterval bounds x : acc+-- Nothing -> x : acc+-- where constraintsMap = Map.fromList constraints++-- don't change the order of elements in the state!! use foldr, not foldl+-- projectOnto :: Constraints -> [Double] -> [Double]+-- projectOnto constraints state =+-- let indexedState = zip [0..] state in+-- foldr (lookInAndProj constraints) [] indexedState++-------- Step the world by one timestep (provided by the library).+-- this function actually ignores the input timestep, because line search calculates the appropriate timestep to use,+-- but it's left in, in case we want to debug the line search.+-- gloss operates on floats, but the optimization code should be done with doubles, so we+-- convert float to double for the input and convert double to float for the output.+step :: TimeInit -> State -> State+step t s = -- if down s then s -- don't step when dragging+ if autostep s then s { objs = objs', params = params' } else s+ where (objs', params') = stepObjs (float2Double t) (params s) (objs s)++-- Utility functions for getting object info (currently unused)+objInfo :: Obj -> [Float]+objInfo o = [getX o, getY o, getSize o] -- TODO deal with labels, also do stuff at type level++stateSize :: Int+stateSize = 3++chunksOf :: Int -> [a] -> [[a]]+chunksOf _ [] = []+chunksOf n l = take n l : chunksOf n (drop n l)++objsInfo :: [a] -> [[a]]+objsInfo = chunksOf stateSize++-- from [x,y,s] over all objs, return [x,y] over all+objsCoords :: [a] -> [a]+objsCoords = concatMap (\[x, y, s] -> [x, y]) . objsInfo -- from [x,y,s] over all objs, return [s] over all+objsSizes :: [a] -> [a]+objsSizes = map (\[x, y, s] -> s) . objsInfo+----++-- convergence criterion for EP+-- if you want to use it for UO, needs a different epsilon+epStopCond :: (Floating a, Ord a, Show a) => [a] -> [a] -> a -> a -> Bool+epStopCond x x' fx fx' =+ trStr ("EP: \n||x' - x||: " ++ (show $ norm (x -. x'))+ ++ "\n|f(x') - f(x)|: " ++ (show $ abs (fx - fx'))) $+ (norm (x -. x') <= epStop) || (abs (fx - fx') <= epStop)++-- just for unconstrained opt, not EP+-- stopEps large bc UO doesn't seem to strongly converge...+optStopCond :: (Floating a, Ord a, Show a) => [a] -> Bool+optStopCond gradEval = trStr ("||gradEval||: " ++ (show $ norm gradEval)+ ++ "\nstopEps: " ++ (show stopEps)) $+ (norm gradEval <= stopEps)++-- unpacks all objects into a big state vector, steps that state, and repacks the new state into the objects+-- NOTE: all downstream functions (objective functions, line search, etc.) expect a state in the form of+-- a big list of floats with the object parameters grouped together: [x1, y1, size1, ... xn, yn, sizen]++-- don't use r2f outside of zeroGrad or addGrad, since it doesn't interact well w/ autodiff+r2f :: (Fractional b, Real a) => a -> b+r2f = realToFrac++-- Going from `Floating a` to Float discards the autodiff dual gradient info (I think)+zeroGrad :: (Real a, Floating a, Show a, Ord a) => Obj' a -> Obj+zeroGrad (C' c) = C $ Circ { xc = r2f $ xc' c, yc = r2f $ yc' c, r = r2f $ r' c,+ selc = selc' c, namec = namec' c, colorc = colorc' c }+zeroGrad (S' s) = S $ Square { xs = r2f $ xs' s, ys = r2f $ ys' s, side = r2f $ side' s, sels = sels' s, names = names' s, colors = colors' s, ang = ang' s }++zeroGrad (L' l) = L $ Label { xl = r2f $ xl' l, yl = r2f $ yl' l, wl = r2f $ wl' l, hl = r2f $ hl' l,+ textl = textl' l, sell = sell' l, namel = namel' l }+zeroGrad (P' p) = P $ Pt { xp = r2f $ xp' p, yp = r2f $ yp' p, selp = selp' p,+ namep = namep' p }+zeroGrad (A' a) = A $ SolidArrow { startx = r2f $ startx' a, starty = r2f $ starty' a,+ endx = r2f $ endx' a, endy = r2f $ endy' a, thickness = r2f $ thickness' a,+ selsa = selsa' a, namesa = namesa' a, colorsa = colorsa' a }++zeroGrads :: (Real a, Floating a, Show a, Ord a) => [Obj' a] -> [Obj]+zeroGrads = map zeroGrad++-- Add the grad info by generalizing Obj (on Floats) to polymorphic objects (for autodiff to use)+addGrad :: (Real a, Floating a, Show a, Ord a) => Obj -> Obj' a+addGrad (C c) = C' $ Circ' { xc' = r2f $ xc c, yc' = r2f $ yc c, r' = r2f $ r c,+ selc' = selc c, namec' = namec c, colorc' = colorc c }+addGrad (S s) = S' $ Square' { xs' = r2f $ xs s, ys' = r2f $ ys s, side' = r2f $ side s, sels' = sels s,+ names' = names s, colors' = colors s, ang' = ang s }+addGrad (L l) = L' $ Label' { xl' = r2f $ xl l, yl' = r2f $ yl l, wl' = r2f $ wl l, hl' = r2f $ hl l,+ textl' = textl l, sell' = sell l, namel' = namel l }+addGrad (P p) = P' $ Pt' { xp' = r2f $ xp p, yp' = r2f $ yp p, selp' = selp p,+ namep' = namep p }+addGrad (A a) = A' $ SolidArrow' { startx' = r2f $ startx a, starty' = r2f $ starty a,+ endx' = r2f $ endx a, endy' = r2f $ endy a, thickness' = r2f $ thickness a,+ selsa' = selsa a, namesa' = namesa a, colorsa' = colorsa a }+++addGrads :: (Real a, Floating a, Show a, Ord a) => [Obj] -> [Obj' a]+addGrads = map addGrad++-- implements exterior point algo as described on page 6 here:+-- https://www.me.utexas.edu/~jensen/ORMM/supplements/units/nlp_methods/const_opt.pdf+-- the initial state (WRT violating constraints), initial weight, params, constraint normalization, etc.+-- have all been initialized or set earlier+stepObjs :: (Real a, Floating a, Show a, Ord a) => a -> Params -> [Obj] -> ([Obj], Params)+stepObjs t sParams objs =+ let (epWeight, epStatus) = (weight sParams, optStatus sParams) in+ case epStatus of++ -- start the outer EP optimization and the inner unconstrained optimization, recording initial EPstate+ NewIter -> let status' = UnconstrainedRunning $ EPstate objs in+ (objs', sParams { weight = initWeight, optStatus = status'} )++ -- check *weak* convergence of inner unconstrained opt.+ -- if UO converged, set opt state to converged and update UO state (NOT EP state)+ -- if not, keep running UO (inner state implicitly stored)+ -- note convergence checks are only on the varying part of the state+ UnconstrainedRunning lastEPstate -> -- doesn't use last EP state+ -- let unconstrConverged = optStopCond gradEval in+ let unconstrConverged = epStopCond stateVarying stateVarying'+ (objFnApplied stateVarying) (objFnApplied stateVarying') in+ if unconstrConverged then+ let status' = UnconstrainedConverged lastEPstate in -- update UO state only!+ (objs', sParams { optStatus = status'}) -- note objs' (UO converged), not objs+ else (objs', sParams) -- update UO state but not EP state; UO still running++ -- check EP convergence. if converged then stop, else increase weight, update states, and run UO again+ -- TODO some trickiness about whether unconstrained-converged has updated the correct state+ -- and whether i should check WRT the updated state or not+ UnconstrainedConverged (EPstate lastEPstate) ->+ let (_, epStateVarying) = tupMap (map float2Double) $ unpackSplit+ $ addGrads lastEPstate in -- TODO factor out+ let epConverged = epStopCond epStateVarying stateVarying -- stateV is last state for converged UO+ (objFnApplied epStateVarying) (objFnApplied stateVarying) in+ if epConverged then+ let status' = EPConverged in -- no more EP state+ (objs, sParams { optStatus = status'}) -- do not update UO state+ -- update EP state: to be the converged state from the most recent UO+ else let status' = UnconstrainedRunning $ EPstate objs in -- increase weight+ (objs, sParams { weight = weightGrowth * epWeight, optStatus = status' })++ -- done; don't update obj state or params; user can now manipulate+ EPConverged -> (objs, sParams)++ -- TODO: implement EPConvergedOverride (for when the magnitude of the gradient is still large)++ -- TODO factor out--only unconstrainedRunning needs to run stepObjective, but EPconverged needs objfn+ where (fixed, stateVarying) = tupMap (map float2Double) $ unpackSplit $ addGrads objs+ -- realToFrac used because `t` output is a Float? I don't really know why this works+ (stateVarying', objFnApplied, gradEval) = stepWithObjective objs fixed sParams+ (realToFrac t) stateVarying+ -- re-pack each object's state list into object+ objs' = zeroGrads $ pack (annotations sParams) objs fixed stateVarying'++-- Given the time, state, and evaluated gradient (or other search direction) at the point,+-- return the new state. Note that the time is treated as `Floating a` (which is internally a Double)+-- not gloss's `Float`+stepT :: Floating a => a -> a -> a -> a+stepT dt x dfdx = x - dt * dfdx++-- Calculates the new state by calculating the directional derivatives (via autodiff)+-- and timestep (via line search), then using them to step the current state.+-- Also partially applies the objective function.+stepWithObjective :: (RealFloat a, Real a, Floating a, Ord a, Show a) =>+ [Obj] -> [a] -> Params -> a -> [a] -> ([a], [a] -> a, [a])+stepWithObjective objs fixed stateParams t state = (steppedState, objFnApplied, gradEval)+ where (t', gradEval) = timeAndGrad objFnApplied t state+ -- get timestep via line search, and evaluated gradient at the state+ -- step each parameter of the state with the time and gradient+ -- gradEval :: [Double]; gradEval = [dfdx1, dfdy1, dfdsize1, ...]+ steppedState = let state' = map (\(v, dfdv) -> stepT t' v dfdv) (zip state gradEval) in+ trStr ("||x' - x||: " ++ (show $ norm (state -. state'))+ ++ "\n|f(x') - f(x)|: " +++ (show $ abs (objFnApplied state - objFnApplied state')))+ state'+ objFnApplied :: ObjFn1 a -- i'm not clear on why realToFrac is needed here either+ -- since everything should already be polymorphic+ -- here, objFn is a function that gets the objective function from stateParams+ -- note that the objective function is partially applied w/ current list of objects+ objFnApplied = (objFn stateParams) objs (realToFrac cWeight) (map realToFrac fixed)+ cWeight = weight stateParams++-- a version of grad with a clearer type signature+appGrad :: (Show a, Ord a, Floating a, Real a) =>+ (forall a . (Show a, Ord a, Floating a, Real a) => [a] -> a) -> [a] -> [a]+appGrad f l = grad f l++nanSub :: (RealFloat a, Floating a) => a+nanSub = 0++removeNaN' :: (RealFloat a, Floating a) => a -> a+removeNaN' x = if isNaN x then nanSub else x++removeNaN :: (RealFloat a, Floating a) => [a] -> [a]+removeNaN = map removeNaN'++removeInf' :: (RealFloat a, Floating a) => a -> a+removeInf' x = if isInfinity x then bignum else if isNegInfinity x then (-bignum) else x+ where bignum = 10**10++removeInf :: (RealFloat a, Floating a) => [a] -> [a]+removeInf = map removeInf'++tupMap :: (a -> b) -> (a, a) -> (b, b)+tupMap f (a, b) = (f a, f b)++-- ----- 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++-----++-- Given the objective function, gradient function, timestep, and current state,+-- return the timestep (found via line search) and evaluated gradient at the current state.+-- TODO change stepWithGradFn(s) to use this fn and its type+-- note: continue to use floats throughout the code, since gloss uses floats+-- the autodiff library requires that objective functions be polymorphic with Floating a+-- M-^ = delete indentation+timeAndGrad :: (Show b, Ord b, RealFloat b, Floating b, Real b) => ObjFn1 a -> b -> [b] -> (b, [b])+timeAndGrad f t state = tr "timeAndGrad: " (timestep, gradEval)+ where gradF :: GradFn a+ gradF = appGrad f+ gradEval = gradF state+ -- Use line search to find a good timestep.+ -- Redo if it's NaN, defaulting to 0 if all NaNs. TODO+ descentDir = negL gradEval+ -- timestep :: Floating c => c+ timestep = if not linesearch then t else -- use a fixed timestep for debugging+ let resT = awLineSearch f duf descentDir state in+ if isNaN resT then tr "returned timestep is NaN" nanSub else resT+ -- directional derivative at u, where u is the negated gradient in awLineSearch+ -- descent direction need not have unit norm+ -- we could also use a different descent direction if desired+ duf :: (Show a, Ord a, Floating a, Real a) => [a] -> [a] -> a+ duf u x = gradF x `dotL` u++-- Parameters for Armijo-Wolfe line search+-- NOTE: must maintain 0 < c1 < c2 < 1+c1 :: Floating a => a+c1 = 0.4 -- for Armijo, corresponds to alpha in backtracking line search (see below for explanation)+-- smaller c1 = shallower slope = less of a decrease in fn value needed = easier to satisfy+-- turn Armijo off: c1 = 0++c2 :: Floating a => a+c2 = 0.2 -- for Wolfe, is the factor decrease needed in derivative value+-- new directional derivative value / old DD value <= c2+-- smaller c2 = smaller new derivative value = harder to satisfy+-- turn Wolfe off: c1 = 1 (basically backatracking line search onlyl++infinity :: Floating a => a+infinity = 1/0 -- x/0 == Infinity for any x > 0 (x = 0 -> Nan, x < 0 -> -Infinity)+-- all numbers are smaller than infinity except infinity, to which it's equal++negInfinity :: Floating a => a+negInfinity = -infinity++isInfinity x = (x == infinity)+isNegInfinity x = (x == negInfinity)++-- Implements Armijo-Wolfe line search as specified in Keenan's notes, converges on nonconvex fns as well+-- based off Lewis & Overton, "Nonsmooth optimization via quasi-Newton methods", page TODO+-- duf = D_u(f), the directional derivative of f at descent direction u+-- D_u(x) = <gradF(x), u>. If u = -gradF(x) (as it is here), then D_u(x) = -||gradF(x)||^2+-- TODO summarize algorithm+-- TODO what happens if there are NaNs in awLineSearch? or infinities+awLineSearch :: (Floating b, Ord b, Show b, Real b) => ObjFn1 a -> ObjFn2 a -> [b] -> [b] -> b+awLineSearch f duf_noU descentDir x0 =+ -- results after a&w are satisfied are junk and can be discarded+ -- drop while a&w are not satisfied OR the interval is large enough+ let (af, bf, tf) = head $ dropWhile intervalOK_or_notArmijoAndWolfe+ $ iterate update (a0, b0, t0) in tf+ where (a0, b0, t0) = (0, infinity, 1)+ duf = duf_noU descentDir+ update (a, b, t) =+ let (a', b', sat) = if not $ armijo t then tr' "not armijo" (a, t, False)+ else if not $ weakWolfe t then tr' "not wolfe" (t, b, False)+ -- remember to change both wolfes+ else (a, b, True) in+ if sat then (a, b, t) -- if armijo and wolfe, then we use (a, b, t) as-is+ else if b' < infinity then tr' "b' < infinity" (a', b', (a' + b') / 2)+ else tr' "b' = infinity" (a', b', 2 * a')+ intervalOK_or_notArmijoAndWolfe (a, b, t) = not $+ if armijo t && weakWolfe t then -- takes precedence+ tr ("stop: both sat. |-gradf(x0)| = " ++ show (norm descentDir)) True+ else if abs (b - a) < minInterval then+ tr ("stop: interval too small. |-gradf(x0)| = " ++ show (norm descentDir)) True+ else False -- could be shorter; long for debugging purposes+ armijo t = (f ((tr' "** x0" x0) +. t *. (tr' "descentDir" descentDir))) <= ((tr' "fAtX0"fAtx0) + c1 * t * (tr' "dufAtX0" dufAtx0))+ strongWolfe t = abs (duf (x0 +. t *. descentDir)) <= c2 * abs dufAtx0+ weakWolfe t = duf_x_tu >= (c2 * dufAtx0) -- split up for debugging purposes+ where duf_x_tu = tr' "Duf(x + tu)" (duf (x0 +. t' *. descentDir'))+ t' = tr' "t" t+ descentDir' = descentDir --tr' "descentDir" descentDir+ dufAtx0 = duf x0 -- cache some results, can cache more if needed+ fAtx0 =f x0 -- TODO debug why NaN. even using removeNaN' didn't help+ minInterval = if intervalMin then 10 ** (-10) else 0+ -- stop if the interval gets too small; might not terminate++------------------------ ### frequently-changed params for debugging++objsInit = []++-- Flags for debugging the surrounding functions.+clampflag = False+-- debug = True+-- debug = False+-- debugLineSearch = False+-- debugObj = False -- turn on/off output in obj fn or constraint+constraintFlag = False+objFnOn = True -- turns obj function on or off in exterior pt method (for debugging constraints only)+constraintFnOn = True -- TODO need to implement constraint fn synthesis++type ObjFnPenalty a = forall a . (Show a, Floating a, Ord a, Real a) => a -> [a] -> [a] -> a+-- needs to be partially applied with the current list of objects+-- this type is only for the TOP-LEVEL synthesized objective function, not for any of the ones that people write+type ObjFnPenaltyState a = forall a . (Show a, Floating a, Ord a, Real a) => [Obj] -> a -> [a] -> [a] -> a++-- TODO should use objFn as a parameter+objFnPenalty :: ObjFnPenalty a+objFnPenalty weight = combineObjfns objFnUnconstrained weight+ where objFnUnconstrained :: Floating a => ObjFn2 a+ -- objFnUnconstrained = centerObjs -- centerAndRepel+ objFnUnconstrained = centerAndRepel++-- if the list of constraints is empty, it behaves as unconstrained optimization+boundConstraints :: Constraints+boundConstraints = [] -- first_two_objs_box++weightGrowth :: Floating a => a -- for EP weight+weightGrowth = 10++epStop :: Floating a => a -- for EP diff+epStop = 10 ** (-3)+-- epStop = 60 ** (-3)+-- epStop = 0.01+-- epStop = 0.1++-- for use in barrier/penalty method (interior/exterior point method)+-- seems if the point starts in interior + weight starts v small and increases, then it converges+-- not quite... if the weight is too small then the constraint will be violated+initWeight :: Floating a => a+initWeight = 10 ** (-5)+-- initWeight = 10 ** (-3)+++stopEps :: Floating a => a+stopEps = 10 ** (-1)++------------ Various constants and helper functions related to objective functions++-- epsd :: Floating a => a -- to prevent 1/0 (infinity). put it in the denominator+-- epsd = 10 ** (-10)++objText = "objective: center all sets; center all labels in set"+constrText = "constraint: satisfy constraints specified in Substance program"++-- separates fixed parameters (here, size) from varying parameters (here, location)+-- ObjFn2 has two parameters, ObjFn1 has one (partially applied)+type ObjFn2 a = forall a . (Show a, Ord a, Floating a, Real a) => [a] -> [a] -> a++linesearch = True -- TODO move these parameters back+intervalMin = True -- true = force linesearch halt if interval gets too small; false = no forced halt++sumMap :: Floating b => (a -> b) -> [a] -> b -- common pattern in objective functions+sumMap f l = sum $ map f l++-------------- Sample bound constraints++-- TODO test bound constraints with EP, keep separate and formally build in if it doesn't work+-- TODO add more constraints for testing++-- x-coord of first object's center in [-300,-200], y-coord of first object's center in [0, 200]+first_two_objs_box :: Constraints+first_two_objs_box = [(0, (-300, -100)), (1, (0, 200)), (4, (100, 300)), (5, (-100, -400))]++-------------- Objective functions++-- simple test function+minx1 :: ObjFn2 a -- timestep t+minx1 _ xs = if length xs == 0 then error "minx1 empty list" else (head xs)^2++-- only center the first object (for debugging). NOTE: need to pass in parameters in the right order+centerObjNoSqrt :: ObjFn2 a+centerObjNoSqrt _ (x1 : y1 : _) = x1^2 + y1^2 -- sum $++-- center both objects without sqrt+centerObjsNoSqrt :: ObjFn2 a+centerObjsNoSqrt _ = sumMap (^2)++centerx1Sqrt :: ObjFn2 a -- discontinuous, timestep = 100 * t. autodiff behaves differently for this vs abs+centerx1Sqrt _ (x1 : _) = sqrt $ x1^2++-- lot of "interval too small"s happening with the objfns on lists now+centerObjs :: ObjFn2 a -- with sqrt+centerObjs fixed = sqrt . (centerObjsNoSqrt fixed)++-- Repel two objects+repel2 :: ObjFn2 a+repel2 _ [x1, y1, x2, y2] = 1 / ((x1 - x2)^2 + (y1 - y2)^2 + epsd)++-- pairwise repel on a list of objects (by distance b/t their centers)+repelCenter :: ObjFn2 a+repelCenter _ locs = sumMap (\x -> 1 / (x + epsd)) denoms+ where denoms = map diffSq allPairs+ diffSq [[x1, y1], [x2, y2]] = (x1 - x2)^2 + (y1 - y2)^2+ allPairs = filter (\x -> length x == 2) $ subsequences objs+ -- TODO implement more efficient version. also, subseq only returns *unique* subseqs+ objs = chunksOf 2 locs++-- does not deal with labels+centerAndRepel :: ObjFn2 a -- timestep t+centerAndRepel fixed varying = centerObjsNoSqrt fixed varying + weight * repelCenter fixed varying+ where weight = 10 ** (9.8) -- TODO calculate this weight as a function of radii and bbox++-- pairwise repel on a list of objects (by distance b/t their centers)+-- TODO: version of above function that separates fixed parameters (size) from varying parameters (location)+-- assuming 1 size for each two locs, and s1 corresponds to x1, y1 (and so on)+repelDist :: ObjFn2 a+repelDist sizes locs = sumMap (\x -> 1 / (x + epsd)) denoms+ where denoms = map diffSq allPairs+ diffSq [[x1, y1, s1], [x2, y2, s2]] = (x1 - x2)^2 + (y1 - y2)^2 - s1 - s2+ allPairs = filter (\x -> length x == 2) $ subsequences objs+ objs = zipWith (++) locPairs sizes'+ (sizes', locPairs) = (map (\x -> [x]) sizes, chunksOf 2 locs)++-- attempts to account for the radii of the objects+-- currently, they repel each other "too much"--want them to be as centered as possible+-- not sure whether to use sqrt or not+-- try multiple objects?+centerAndRepel_dist :: ObjFn2 a+centerAndRepel_dist fixed varying = centerObjsNoSqrt fixed varying + weight * (repelDist fixed varying)+ where weight = 10 ** 10++-----++doNothing :: ObjFn2 a -- for debugging+doNothing _ _ = 0++nonDifferentiable :: ObjFn2 a+nonDifferentiable sizes locs = let q = head locs in+ -- max q 0+ abs q -- actually works fine with the line search++-- TODO these need separate pack/unpack functions because they change the sizes. these don't currently work+grow2 :: ObjFn2 a+grow2 _ [_, _, s1, _, _, s2] = 1 / (s1 + epsd) + 1 / (s2 + epsd)++grow :: ObjFn2 a+grow _ varying = sumMap (\x -> 1 / (x + epsd)) $ varying++-- TODO this needs to use the set size info. hardcode radii for now+-- TODO to use "min rad rad1" we need to add "Ord a" to the type signatures everywhere+-- we want the distance between the sets to be <overlap> less than having them just touch+-- this isn't working? and isn't resampling?+-- also i'm getting interval shrinking problems just with this function (using 'distance' only)+setsIntersect2 :: ObjFn2 a+setsIntersect2 sizes [x1, y1, x2, y2] = (dist (x1, y1) (x2, y2) - overlap)^2+ where overlap = rad + rad1 - 0.5 * rad1 -- should be "min rad rad1"++------ Objective function to place a label either inside of or right outside of a set++eps' :: Floating a => a+eps' = 60 -- why is this 100??++-- two parabolas, one at f(d) = d^2 and one at f(d) = (d-c)^2, intersecting at c/2+-- (i could try making the first one bigger and solving for the new intersection pt if i want the threshold+-- to be greater than (r + margin)/2++-- note: whenever an objective function has a partial derivative that might be fractional,+-- and vary in the denominator, need to add epsilon to denominator to avoid 1/0, or avoid it altogether+-- e.g. f(x) = sqrt(x) -> f'(x) = 1/(2sqrt(x))+-- in the first branch, we square the distance, because the objective there is to minimize the distance (resulting in 1/0).+-- in the second branch, the objective is to keep the distance at (r_set + margin), not at 0--so there’s no NaN in the denominator+centerOrRadParabola2 :: Bool -> ObjFn2 a+centerOrRadParabola2 inSet [r_set, _] [x1, y1, x2, y2] =+ if dsq <= r_set^2 then dsq+ else (if inSet then dsq else coeff * (d - const)^2) -- false -> can lay it outside as well+ where d = dist (x1, y1) (x2, y2) -- + epsd+ dsq = distsq (x1, y1) (x2, y2) -- + epsd+ coeff = r_set^2 / (r_set - const)^2 -- chosen s.t. parabolas intersect at r+ const = r_set + margin -- second parabola's zero+ margin = if r_set <= 30 then 30 else 60 -- distance from edge of set (as a fn of r)+ -- we want r to be close to r_set+margin, otherwise if r is small it converges slowly?++-- NOTE: assumes that object and label are exactly contiguous in list: sizes of [o1, l1, o2, l2...]+-- and locs: [x_o1, y_o1, x_l1, y_l1, x_o2, y_o2, x_l2, y_l2...]+-- TODO abstract out repelDist / labelSum pattern+labelSum :: Bool -> ObjFn2 a+labelSum inSet objLabelSizes objLabelLocs =+ let objLabelSizes' = chunksOf 2 objLabelSizes in+ let objLabelLocs' = chunksOf 4 objLabelLocs in+ sumMap (\(sizes, locs) -> centerOrRadParabola2 inSet sizes locs) (zip objLabelSizes' objLabelLocs')++------++-- TODO: label-only obj fns don't work out-of-the-box with set-only obj fns since they do unpacking differently++-- Start composing set-wise functions (centerAndRepel) with set-label functions (labelSum)+-- Sets repel each other, labels repel each other, and sets are labeled+-- TODO non-label sets should repel those labels+-- TODO resample initial state s.t. labels start inside the set (the centerOrRad is mostly useful if there are other objects inside the set that might repel the label)+-- TODO abstract out the unpacking functions here and factor out the weights+centerRepelLabel :: ObjFn2 a+centerRepelLabel olSizes olLocs =+ centerAndRepel oSizes oLocs + weight * repelCenter lSizes lLocs + labelSum inSet olSizes olLocs+ where (oSizes, lSizes) = (map fst zippedSizes, map snd zippedSizes)+ zippedSizes = map (\[obj, lab] -> (obj, lab)) $ chunksOf 2 olSizes+ (oLocs, lLocs) = (concatMap fst zippedLocs, concatMap snd zippedLocs)+ zippedLocs = map (\[xo, yo, xl, yl] -> ([xo, yo], [xl, yl])) $ chunksOf 4 olLocs+ weight = 10 ** 6+ inSet = True -- label only in set vs. in or at radius+++---------------- Exterior point method functions+-- Given an objective function and a list of constraints (phrased in terms of violations on a list of floats),+-- combines them using the penalty method (parametrized by a constraint weight over the sum of the constraints,+-- & individual normalizing weights on each constraint). Returns the corresponding unconstrained objective fn,+-- for use in unconstrained opt with line search.++-- PAIRWISE constraint functions that return the magnitude of violation+-- same type as ObjFn2; more general than PairConstrV+type StateConstrV a = forall a . (Floating a, Ord a, Show a) => [a] -> [a] -> a+-- 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++-- for each pair, for each constraint on that pair, compose w/ penalty function and sum+-- TODO add vector of normalization constants for each constraint+pairToPenalties :: PairConstrV a+pairToPenalties pair = sum $ map (\((f, w), p) -> w * (penalty $ f p)) $ zip pairConstrVs (repeat pair)++-- sum penalized violations of each constraint on the whole state+stateConstrsToObjfn :: ObjFn2 a+stateConstrsToObjfn fixed varying = sum $ map (\((f, w), (fix, vary)) -> w * (penalty $ f fix vary))+ $ zip stateConstrVs (repeat (fixed, varying))++-- the overall penalty function is the sum m (unweighted)+-- generate all unique pairs of objs and sum the penalized violation on each pair+pairConstrsToObjfn :: ObjFn2 a+pairConstrsToObjfn sizes locs = sumMap pairToPenalties allPairs+ where -- generates all *unique* pairs (does not generate e.g. (o1, o2) and (o2, o1))+ allPairs = filter (\x -> length x == 2) $ subsequences objs+ objs = zipWith (++) locPairs sizes'+ (sizes', locPairs) = (map (\x -> [x]) sizes, chunksOf 2 locs)++-- add the obj fn value to all penalized violations of constraints+-- note that a high weight may result in an "ill-conditioned hessian" with high differences b/t eigenvalues+-- with which the line search and stopping conditions may have trouble+-- https://www.researchgate.net/post/What_is_stopping_criteria_of_any_optimization_algorithm+combineObjfns :: ObjFn2 a -> ObjFnPenalty a+combineObjfns objfn weight fixed varying = -- input objfn is unconstrained+ (if objFnOn then tro "obj val" $ objWeight * objfn fixed varying else 0)+ + (if constraintFnOn then tro "penalty val" $+ weight * (pairConstrsToObjfn fixed varying + stateConstrsToObjfn fixed varying)+ else 0)+ where objWeight = 1++-- constraint functions that act on the entire state+-- this one just acts on the first object and ignores the fixed params+firstObjInBbox :: (Floating a, Ord a, Show a) => (a, a, a, a) -> [([a] -> [a] -> a, a)]+firstObjInBbox (l, r, b, t) = [(leftBound, 1), (rightBound, 1), (botBound, 1), (topBound, 1)]+ where leftBound fixed (x1 : _ : _) = -(x1 - l)+ leftBound _ _ = error "not enough floats in state to apply constr function firstObjInBbox"+ rightBound fixed (x1 : _ : _) = x1 - r+ botBound fixed (_ : y1 : _) = -(y1 - b)+ topBound fixed (_ : y1 : _) = y1 - t++stateConstrVs :: (Floating a, Ord a, Show a) => [([a] -> [a] -> a, a)] -- constr, constr weight+stateConstrVs = -- firstObjInBbox (leftb, rightb, botb, topb)+ -- ++ firstObjInBbox (-pw2', pw2', -ph2', ph2') -- first object in viewport, TODO for all objs+ [] -- TODO add more++-- Parameter to modify (TODO move it to other section)+-- [PairConstrV a] is not allowed b/c impredicative types+pairConstrVs :: (Floating a, Ord a, Show a) => [([[a]] -> a, a)] -- constr, constr weight+pairConstrVs = [(noSubset, 1)]++-- It's not clear what happens with contradictory constraints like these:+-- It looks like one pair satisfies strict subset, and the other pairs all intersect+-- pairConstrVs = [(strictSubset, 1), (noIntersectExt, 1)]++-- Corners for hard-coded bounding box constraint.+leftb :: Floating a => a+leftb = -200++rightb :: Floating a => a+rightb = 100++botb :: Floating a => a+botb = 0++topb :: Floating a => a+topb = 200
+ src/Shapes.hs view
@@ -0,0 +1,410 @@+--------------------------------------------------------------------------------+-- Geometry module in Penrose+-- Currently supporting:+-- Circle+-- Square+-- Point+-- Arrow+-- Label+--------------------------------------------------------------------------------+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DuplicateRecordFields #-}++module Shapes where+-- module Shapes (Obj, Obj') where+import Data.Aeson+import Data.Monoid ((<>))+import GHC.Generics+import Graphics.Gloss++type Name = String++class Located a where+ getX :: a -> Float+ getY :: a -> Float+ setX :: Float -> a -> a+ setY :: Float -> a -> a++class Selectable a where+ select :: a -> a+ deselect :: a -> a+ selected :: a -> Bool++class Sized a where+ getSize :: a -> Float+ setSize :: Float -> a -> a++class Named a where+ getName :: a -> Name+ setName :: Name -> a -> a++-- data BBox = BBox {+-- cx :: Float,+-- cy :: Float,+-- h :: Float,+-- w :: Float+-- } deriving (Show, Eq, Generic)+-- instance ToJSON BBox+-- instance FromJSON BBox++-------+data SolidArrow = SolidArrow { startx :: Float+ , starty :: Float+ , endx :: Float+ , endy :: Float+ , thickness :: Float -- the maximum thickness, i.e. the thickness of the head+ , selsa :: Bool -- is the circle currently selected? (mouse is dragging it)+ , namesa :: String+ , colorsa :: Color+ -- , bbox :: BBox+ }+ deriving (Eq, Show, Generic)++instance Located SolidArrow where+ -- getX a = endx a - startx a+ -- getY a = endy a - starty a+ getX a = startx a+ getY a = starty a+ setX x c = c { startx = x } -- TODO+ setY y c = c { starty = y }++instance Selectable SolidArrow where+ select x = x { selsa = True }+ deselect x = x { selsa = False }+ selected x = selsa x++instance Named SolidArrow where+ getName a = namesa a+ setName x a = a { namesa = x }++instance ToJSON SolidArrow+instance FromJSON SolidArrow++-------++data Circ = Circ { xc :: Float+ , yc :: Float+ , r :: Float+ , selc :: Bool -- is the circle currently selected? (mouse is dragging it)+ , namec :: String+ , colorc :: Color }+ deriving (Eq, Show, Generic)++instance Located Circ where+ getX c = xc c+ getY c = yc c+ setX x c = c { xc = x }+ setY y c = c { yc = y }++instance Selectable Circ where+ select x = x { selc = True }+ deselect x = x { selc = False }+ selected x = selc x++instance Sized Circ where+ getSize x = r x+ setSize size x = x { r = size }++instance Named Circ where+ getName c = namec c+ setName x c = c { namec = x }++instance ToJSON Circ+instance FromJSON Circ++----------------------++data Square = Square { xs :: Float+ , ys :: Float+ , side :: Float+ , ang :: Float -- angle for which the obj is rotated+ , sels :: Bool -- is the circle currently selected? (mouse is dragging it)+ , names :: String+ , colors :: Color }+ deriving (Eq, Show, Generic)++instance Located Square where+ getX s = xs s+ getY s = ys s+ setX x s = s { xs = x }+ setY y s = s { ys = y }++instance Selectable Square where+ select x = x { sels = True }+ deselect x = x { sels = False }+ selected x = sels x++instance Sized Square where+ getSize x = side x+ setSize size x = x { side = size }++instance Named Square where+ getName s = names s+ setName x s = s { names = x }++instance ToJSON Square+instance FromJSON Square+-------++data Label = Label { xl :: Float+ , yl :: Float+ , wl :: Float+ , hl :: Float+ , textl :: String+ -- , scalel :: Float -- calculate h,w from it+ , sell :: Bool -- selected label+ , namel :: String }+ deriving (Eq, Show, Generic)++instance Located Label where+ getX l = xl l+ getY l = yl l+ setX x l = l { xl = x }+ setY y l = l { yl = y }++instance Selectable Label where+ select x = x { sell = True }+ deselect x = x { sell = False }+ selected x = sell x++instance Sized Label where+ getSize x = xl x -- TODO generalize label size, distance to corner? ignores scale+ setSize size x = x { xl = size, yl = size } -- TODO currently sets both of them, ignores scale+ -- changing a label's size doesn't actually do anything right now, but should use the scale+ -- and the base font size++instance Named Label where+ getName l = namel l+ setName x l = l { namel = x }++instance ToJSON Label+instance FromJSON Label+------++data Pt = Pt { xp :: Float+ , yp :: Float+ , selp :: Bool+ , namep :: String }+ deriving (Eq, Show, Generic)++instance Located Pt where+ getX p = xp p+ getY p = yp p+ setX x p = p { xp = x }+ setY y p = p { yp = y }++instance Selectable Pt where+ select x = x { selp = True }+ deselect x = x { selp = False }+ selected x = selp x++instance Named Pt where+ getName p = namep p+ setName x p = p { namep = x }++instance ToJSON Pt+instance FromJSON Pt++data Obj = S Square+ | C Circ+ | L Label+ | P Pt+ | A SolidArrow+ deriving (Eq, Show, Generic)++instance ToJSON Obj+instance FromJSON Obj++instance FromJSON Color where+ parseJSON = withObject "Color" $ \v -> makeColor+ <$> v .: "r"+ <*> v .: "g"+ <*> v .: "b"+ <*> v .: "a"++instance ToJSON Color where+ -- this generates a Value+ toJSON c =+ let (r, g, b, a) = rgbaOfColor c in+ object ["r" .= r, "g" .= g, "b" .= b, "a" .= a]+ toEncoding c =+ let (r, g, b, a) = rgbaOfColor c in+ pairs ("r" .= r <> "g" .= g <> "b" .= b <> "a" .= a)++-- TODO: is there some way to reduce the top-level boilerplate?+instance Located Obj where+ getX o = case o of+ C c -> getX c+ L l -> getX l+ P p -> getX p+ S s -> getX s+ A a -> getX a+ getY o = case o of+ C c -> getY c+ L l -> getY l+ P p -> getY p+ S s -> getY s+ A a -> getY a+ setX x o = case o of+ C c -> C $ setX x c+ L l -> L $ setX x l+ P p -> P $ setX x p+ S s -> S $ setX x s+ A a -> A $ setX x a+ setY y o = case o of+ C c -> C $ setY y c+ L l -> L $ setY y l+ P p -> P $ setY y p+ S s -> S $ setY y s+ A a -> A $ setY y a++instance Selectable Obj where+ select x = case x of+ C c -> C $ select c+ L l -> L $ select l+ P p -> P $ select p+ S s -> S $ select s+ A a -> A $ select a+ deselect x = case x of+ C c -> C $ deselect c+ L l -> L $ deselect l+ P p -> P $ deselect p+ S s -> S $ deselect s+ A a -> A $ deselect a+ selected x = case x of+ C c -> selected c+ L l -> selected l+ P p -> selected p+ S s -> selected s+ A a -> selected a++instance Sized Obj where+ getSize o = case o of+ C c -> getSize c+ S s -> getSize s+ L l -> getSize l+ setSize x o = case o of+ C c -> C $ setSize x c+ L l -> L $ setSize x l+ S s -> S $ setSize x s++instance Named Obj where+ getName o = case o of+ C c -> getName c+ L l -> getName l+ P p -> getName p+ S s -> getName s+ A a -> getName a+ setName x o = case o of+ C c -> C $ setName x c+ L l -> L $ setName x l+ P p -> P $ setName x p+ S s -> S $ setName x s+ A a -> A $ setName x a++data SolidArrow' a = SolidArrow' { startx' :: a+ , starty' :: a+ , endx' :: a+ , endy' :: a+ , thickness' :: a -- the maximum thickness, i.e. the thickness of the head+ , selsa' :: Bool -- is the circle currently selected? (mouse is dragging it)+ , namesa' :: String+ , colorsa' :: Color }+ deriving (Eq, Show)++data Circ' a = Circ' { xc' :: a+ , yc' :: a+ , r' :: a+ , selc' :: Bool -- is the circle currently selected? (mouse is dragging it)+ , namec' :: String+ , colorc' :: Color }+ deriving (Eq, Show)++data Label' a = Label' { xl' :: a+ , yl' :: a+ , wl' :: a+ , hl' :: a+ , textl' :: String+ , sell' :: Bool -- selected label+ , namel' :: String }+ deriving (Eq, Show)++data Pt' a = Pt' { xp' :: a+ , yp' :: a+ , selp' :: Bool+ , namep' :: String }+ deriving (Eq, Show)++data Square' a = Square' { xs' :: a+ , ys' :: a+ , side' :: a+ , ang' :: Float -- angle for which the obj is rotated+ , sels' :: Bool+ , names' :: String+ , colors' :: Color }+ deriving (Eq, Show)++instance Named (SolidArrow' a) where+ getName sa = namesa' sa+ setName x sa = sa { namesa' = x }++instance Named (Circ' a) where+ getName c = namec' c+ setName x c = c { namec' = x }++instance Named (Square' a) where+ getName s = names' s+ setName x s = s { names' = x }++instance Named (Label' a) where+ getName l = namel' l+ setName x l = l { namel' = x }++instance Named (Pt' a) where+ getName p = namep' p+ setName x p = p { namep' = x }++instance Named (Obj' a) where+ getName o = case o of+ C' c -> getName c+ L' l -> getName l+ P' p -> getName p+ S' s -> getName s+ A' a -> getName a+ setName x o = case o of+ C' c -> C' $ setName x c+ S' s -> S' $ setName x s+ L' l -> L' $ setName x l+ P' p -> P' $ setName x p+ A' a -> A' $ setName x a++-- instance Located (Obj' a) where+-- getX o = case o of+-- C' c -> xc' c+-- L' l -> xl' l+-- P' p -> xp' p+-- S' s -> xs' s+-- A' a -> startx' a+-- getY o = case o of+-- C' c -> yc' c+-- L' l -> yl' l+-- P' p -> yp' p+-- S' s -> ys' s+-- A' a -> starty' a+ -- setX x o = case o of+ -- C' c -> C $ setX' x c+ -- L' l -> L $ setX' x l+ -- P' p -> P $ setX' x p+ -- S' s -> S $ setX' x s+ -- A' a -> A $ setX' x a+ -- setY y o = case o of+ -- C' c -> C' $ setY' y c+ -- L' l -> L' $ setY' y l+ -- P' p -> P' $ setY' y p+ -- S' s -> S' $ setY' y s+ -- A' a -> A' $ setY' y a+++data Obj' a = C' (Circ' a) | L' (Label' a) | P' (Pt' a) | S' (Square' a)+ | A' (SolidArrow' a) deriving (Eq, Show)