penrose-0.1.0.2: src/Runtime.hs
{-# 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